{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, DefaultSignatures,
             TypeOperators, TupleSections, FlexibleContexts, FlexibleInstances,
             LambdaCase
  #-}

module GHCJS.Marshal.Internal ( FromJSVal(..)
                              , ToJSVal(..)
                              , PToJSVal(..)
                              , PFromJSVal(..)
                              , Purity(..)
                              , toJSVal_generic
                              , fromJSVal_generic
                              , toJSVal_pure
                              , fromJSVal_pure
                              , fromJSValUnchecked_pure
                              ) where

import           Control.Applicative
import           Control.Monad

import           Data.Data
import           Data.Maybe
import           Data.Coerce (coerce)
import qualified Data.Text as T (pack)

import           GHC.Generics

import qualified GHCJS.Prim.Internal        as Prim
import qualified GHCJS.Foreign.Internal     as F
import           GHCJS.Types

import qualified Data.JSString.Internal.Type as JSS

import qualified JavaScript.Object.Internal as OI (Object(..), create, setProp, getProp)
import qualified JavaScript.Array.Internal as AI (SomeJSArray(..), create, push, read, fromListIO, toListIO)

import           Language.Javascript.JSaddle.Types (JSM, MutableJSArray, GHCJSPure(..), ghcjsPure, ghcjsPureMap, JSadddleHasCallStack)
import           Language.Javascript.JSaddle.String (textToStr)

data Purity = PureShared    -- ^ conversion is pure even if the original value is shared
            | PureExclusive -- ^ conversion is pure if the we only convert once
  deriving (Eq, Ord, Typeable, Data)

class PToJSVal a where
--  type PureOut a :: Purity
  pToJSVal :: a -> JSVal

class PFromJSVal a where
--  type PureIn a :: Purity
  pFromJSVal :: JSVal -> a

class ToJSVal a where
  toJSVal :: a -> JSM JSVal

  toJSValListOf :: [a] -> JSM JSVal
  toJSValListOf = fmap coerce . AI.fromListIO <=< mapM toJSVal

  -- default toJSVal :: PToJSVal a => a -> JSM (JSVal a)
  -- toJSVal x = return (pToJSVal x)

  default toJSVal :: (Generic a, GToJSVal (Rep a ())) => a -> JSM JSVal
  toJSVal = toJSVal_generic id

fromJustWithStack :: JSadddleHasCallStack => Maybe a -> a
fromJustWithStack Nothing = error "fromJSValUnchecked: fromJSVal result was Nothing"
fromJustWithStack (Just x) = x

class FromJSVal a where
  fromJSVal :: JSVal -> JSM (Maybe a)

#if MIN_VERSION_base(4,9,0) && defined(JSADDLE_HAS_CALL_STACK)
  fromJSValUnchecked :: JSadddleHasCallStack => JSVal -> JSM a
#ifdef CHECK_UNCHECKED
  fromJSValUnchecked v = fromJSVal v >>= \case
                             Nothing -> error "fromJSValUnchecked: fromJSVal result was Nothing"
                             Just x  -> return x
#else
  fromJSValUnchecked = fmap fromJustWithStack . fromJSVal
#endif
#else
  fromJSValUnchecked :: JSVal -> JSM a
  fromJSValUnchecked = fmap fromJust . fromJSVal
#endif
  {-# INLINE fromJSValUnchecked #-}

  fromJSValListOf :: JSVal -> JSM (Maybe [a])
  fromJSValListOf = fmap sequence . (mapM fromJSVal <=< AI.toListIO . coerce) -- fixme should check that it's an array

#if MIN_VERSION_base(4,9,0) && defined(JSADDLE_HAS_CALL_STACK)
  fromJSValUncheckedListOf :: JSadddleHasCallStack => JSVal -> JSM [a]
#else
  fromJSValUncheckedListOf :: JSVal -> JSM [a]
#endif
  fromJSValUncheckedListOf = mapM fromJSValUnchecked <=< AI.toListIO . coerce

  -- default fromJSVal :: PFromJSVal a => JSVal a -> JSM (Maybe a)
  -- fromJSVal x = return (Just (pFromJSVal x))

  default fromJSVal :: (Generic a, GFromJSVal (Rep a ())) => JSVal -> JSM (Maybe a)
  fromJSVal = fromJSVal_generic id

  -- default fromJSValUnchecked :: PFromJSVal a => a -> IO a
  -- fromJSValUnchecked x = return (pFromJSVal x)

-- -----------------------------------------------------------------------------

class GToJSVal a where
  gToJSVal :: (String -> String) -> Bool -> a -> JSM JSVal

class GToJSProp a where
  gToJSProp :: (String -> String) -> JSVal -> a -> JSM ()

class GToJSArr a where
  gToJSArr :: (String -> String) -> MutableJSArray -> a -> JSM ()

instance (ToJSVal b) => GToJSVal (K1 a b c) where
  gToJSVal _ _ (K1 x) = toJSVal x

instance GToJSVal p => GToJSVal (Par1 p) where
  gToJSVal f b (Par1 p) = gToJSVal f b p

instance GToJSVal (f p) => GToJSVal (Rec1 f p) where
  gToJSVal f b (Rec1 x) = gToJSVal f b x

instance (GToJSVal (a p), GToJSVal (b p)) => GToJSVal ((a :+: b) p) where
  gToJSVal f _ (L1 x) = gToJSVal f True x
  gToJSVal f _ (R1 x) = gToJSVal f True x

instance (Datatype c, GToJSVal (a p)) => GToJSVal (M1 D c a p) where
  gToJSVal f b m@(M1 x) = gToJSVal f b x

instance (Constructor c, GToJSVal (a p)) => GToJSVal (M1 C c a p) where
  gToJSVal f True m@(M1 x) = do
    obj@(OI.Object obj') <- OI.create
    v   <- gToJSVal f (conIsRecord m) x
    OI.setProp (packJSS . f $ conName m) v obj
    return obj'
  gToJSVal f _ m@(M1 x) = gToJSVal f (conIsRecord m) x

instance (GToJSArr (a p), GToJSArr (b p), GToJSProp (a p), GToJSProp (b p)) => GToJSVal ((a :*: b) p) where
  gToJSVal f True xy = do
    (OI.Object obj') <- OI.create
    gToJSProp f obj' xy
    return obj'
  gToJSVal f False xy = do
    arr@(AI.SomeJSArray arr') <- AI.create
    gToJSArr f arr xy
    return arr'

instance GToJSVal (a p) => GToJSVal (M1 S c a p) where
  gToJSVal f b (M1 x) = gToJSVal f b x

instance (GToJSProp (a p), GToJSProp (b p)) => GToJSProp ((a :*: b) p) where
  gToJSProp f o (x :*: y) = gToJSProp f o x >> gToJSProp f o y

instance (Selector c, GToJSVal (a p)) => GToJSProp (M1 S c a p) where
  gToJSProp f o m@(M1 x) = do
    r <- gToJSVal f False x
    OI.setProp (packJSS . f $ selName m) r (OI.Object o)

instance (GToJSArr (a p), GToJSArr (b p)) => GToJSArr ((a :*: b) p) where
  gToJSArr f a (x :*: y) = gToJSArr f a x >> gToJSArr f a y

instance GToJSVal (a p) => GToJSArr (M1 S c a p) where
  gToJSArr f a (M1 x) = do
    r <- gToJSVal f False x
    AI.push r a

instance GToJSVal (V1 p) where
  gToJSVal _ _ _ = return Prim.jsNull

instance GToJSVal (U1 p) where
  gToJSVal _ _ _ = return F.jsTrue

toJSVal_generic :: forall a . (Generic a, GToJSVal (Rep a ()))
                => (String -> String) -> a -> JSM JSVal
toJSVal_generic f x = gToJSVal f False (from x :: Rep a ())

-- -----------------------------------------------------------------------------

class GFromJSVal a where
  gFromJSVal :: (String -> String) -> Bool -> JSVal -> JSM (Maybe a)

class GFromJSProp a where
  gFromJSProp :: (String -> String) -> JSVal -> JSM (Maybe a)

class GFromJSArr a where
  gFromJSArr :: (String -> String) -> MutableJSArray -> Int -> JSM (Maybe (a,Int))

instance FromJSVal b => GFromJSVal (K1 a b c) where
  gFromJSVal _ _ r = fmap K1 <$> fromJSVal r

instance GFromJSVal p => GFromJSVal (Par1 p) where
  gFromJSVal f b r = gFromJSVal f b r

instance GFromJSVal (f p) => GFromJSVal (Rec1 f p) where
  gFromJSVal f b r = gFromJSVal f b r

instance (GFromJSVal (a p), GFromJSVal (b p)) => GFromJSVal ((a :+: b) p) where
  gFromJSVal f b r = do
    l <- gFromJSVal f True r
    case l of
      Just x  -> return (L1 <$> Just x)
      Nothing -> fmap R1 <$> gFromJSVal f True r

instance (Datatype c, GFromJSVal (a p)) => GFromJSVal (M1 D c a p) where
  gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r

instance forall c a p . (Constructor c, GFromJSVal (a p)) => GFromJSVal (M1 C c a p) where
  gFromJSVal f True r = do
    r' <- OI.getProp (packJSS . f $ conName (undefined :: M1 C c a p)) (OI.Object r)
    ghcjsPure (isUndefined r') >>= \case
      True -> return Nothing
      False -> fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r'
  gFromJSVal f _ r = fmap M1 <$> gFromJSVal f (conIsRecord (undefined :: M1 C c a p)) r

instance (GFromJSArr (a p), GFromJSArr (b p), GFromJSProp (a p), GFromJSProp (b p)) => GFromJSVal ((a :*: b) p) where
  gFromJSVal f True  r = gFromJSProp f r
  gFromJSVal f False r = fmap fst <$> gFromJSArr f (AI.SomeJSArray r) 0

instance GFromJSVal (a p) => GFromJSVal (M1 S c a p) where
  gFromJSVal f b r = fmap M1 <$> gFromJSVal f b r

instance (GFromJSProp (a p), GFromJSProp (b p)) => GFromJSProp ((a :*: b) p) where
  gFromJSProp f r = do
    a <- gFromJSProp f r
    case a of
      Nothing -> return Nothing
      Just a' -> fmap (a':*:) <$> gFromJSProp f r

instance forall c a p . (Selector c, GFromJSVal (a p)) => GFromJSProp (M1 S c a p) where
  gFromJSProp f o = do
    p <- OI.getProp (packJSS . f $ selName (undefined :: M1 S c a p)) (OI.Object o)
    ghcjsPure (isUndefined p) >>= \case
      True -> return Nothing
      False -> fmap M1 <$> gFromJSVal f False p

instance (GFromJSArr (a p), GFromJSArr (b p)) => GFromJSArr ((a :*: b) p) where
  gFromJSArr f r _n = do
    a <- gFromJSArr f r 0
    case a of
      Just (a',an) -> do
        b <- gFromJSArr f r an
        case b of
          Just (b',bn) -> return (Just (a' :*: b',bn))
          _            -> return Nothing

instance (GFromJSVal (a p)) => GFromJSArr (M1 S c a p) where
  gFromJSArr f o n = do
    r <- AI.read n o
    ghcjsPure (isUndefined r) >>= \case
      True -> return Nothing
      False -> fmap ((,n+1) . M1) <$> gFromJSVal f False r

instance GFromJSVal (V1 p) where
  gFromJSVal _ _ _ = return Nothing

instance GFromJSVal (U1 p) where
  gFromJSVal _ _ _ = return (Just U1)

fromJSVal_generic :: forall a . (Generic a, GFromJSVal (Rep a ()))
                => (String -> String) -> JSVal -> JSM (Maybe a)
fromJSVal_generic f x = fmap to <$> (gFromJSVal f False x :: JSM (Maybe (Rep a ())))

-- -----------------------------------------------------------------------------

fromJSVal_pure :: PFromJSVal a => JSVal -> JSM (Maybe a)
fromJSVal_pure = return . Just . pFromJSVal
{-# INLINE fromJSVal_pure #-}

fromJSValUnchecked_pure :: PFromJSVal a => JSVal -> JSM a
fromJSValUnchecked_pure = return . pFromJSVal
{-# INLINE fromJSValUnchecked_pure #-}

toJSVal_pure :: PToJSVal a => a -> JSM JSVal
toJSVal_pure = return . pToJSVal
{-# INLINE toJSVal_pure #-}

-- -----------------------------------------------------------------------------

packJSS :: String -> JSString
packJSS = textToStr . T.pack