{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Foreign.JavaScript.Marshal
    ( ToJS(..)
    , FromJS
    , FFI, JSFunction, toCode, marshalResult, ffi
    , IsHandler, convertArguments, handle

    , NewJSObject, wrapImposeStablePtr
    ) where

import           Data.List                        (intercalate)
import qualified Data.Text              as T

import Foreign.JavaScript.CallJavaScript
    ( fromJSStablePtr, newJSObjectFromCoupon )
import Foreign.JavaScript.Types
    ( HsEvent, JSObject, NewJSObject(..), Window(Window,wJSObjects) )
import qualified Foreign.JavaScript.JSON as JSON
import qualified Foreign.RemotePtr as RemotePtr

{-----------------------------------------------------------------------------
    Convert Haskell values to JavaScript values
------------------------------------------------------------------------------}
-- | JavaScript code snippet.
newtype JSCode = JSCode { unJSCode :: String }
    deriving (Eq, Ord, Show)

-- | Helper class for rendering Haskell values as JavaScript expressions.
class ToJS a where
    render     :: a   -> IO JSCode
    renderList :: [a] -> IO JSCode

    renderList xs = do
        ys <- mapM render xs
        jsCode $ "[" ++ intercalate "," (map unJSCode ys) ++ "]"

jsCode :: String -> IO JSCode
jsCode = pure . JSCode

instance ToJS Float      where render   = render . JSON.toJSON
instance ToJS Double     where render   = render . JSON.toJSON
instance ToJS Int        where render   = jsCode . show
instance ToJS Bool       where render b = jsCode $ if b then "true" else "false"
instance ToJS JSON.Value where render   = jsCode . JSON.showJSON
instance ToJS T.Text     where render   = render . JSON.string
instance ToJS Char       where
    render x   = renderList [x]
    renderList = render . JSON.string . T.pack

instance ToJS a => ToJS [a] where
    render = renderList

instance ToJS HsEvent    where
    render x = render =<< RemotePtr.unprotectedGetCoupon x
instance ToJS JSObject   where
    render x =
        apply1 "Haskell.deRefStablePtr(%1)"
            <$> (render =<< RemotePtr.unprotectedGetCoupon x)

{-----------------------------------------------------------------------------
    Convert JavaScript values to Haskell values
------------------------------------------------------------------------------}
data FromJS' a = FromJS'
    { wrapCode :: (JSCode -> JSCode)
    , marshal  :: Window -> JSON.Value -> IO a
    }

-- | Helper class for converting JavaScript values to Haskell values.
class FromJS a where
    fromJS   :: FromJS' a

-- | Marshal a simple type to Haskell.
simple :: JSON.FromJSON a => (JSCode -> JSCode) -> FromJS' a
simple f =
    FromJS' { wrapCode = f , marshal = \_ -> fromSuccessIO . JSON.fromJSON }
    where
    fromSuccessIO (JSON.Success a) = pure a

instance FromJS Double     where fromJS = simple id
instance FromJS Float      where fromJS = simple id
instance FromJS Int        where fromJS = simple id
instance FromJS String     where fromJS = simple $ apply1 "%1.toString()"
instance FromJS T.Text     where fromJS = simple $ apply1 "%1.toString()"
instance FromJS JSON.Value where fromJS = simple id

instance FromJS ()         where
    fromJS = FromJS' { wrapCode = id, marshal = \_ _ -> pure () }

instance FromJS JSObject   where
    fromJS = FromJS'
        { wrapCode = apply1 "Haskell.getStablePtr(%1)"
        , marshal  = \w v -> fromJSStablePtr v w
        }

-- FIXME: Not sure whether this instance is really a good idea.
instance FromJS [JSObject] where
    fromJS = FromJS'
        { wrapCode = apply1 "Haskell.map(Haskell.getStablePtr, %1)"
        , marshal  = \w vs -> do
            mapM (\v -> fromJSStablePtr v w) (JSON.fromArray vs)
        }

instance FromJS NewJSObject where
    fromJS = FromJS' { wrapCode = id, marshal = \_ _ -> pure NewJSObject }

-- | Impose a JS stable pointer upon a newly created JavaScript object.
--   In this way, JSObject can be created without waiting for the browser
--   to return a result.
wrapImposeStablePtr :: Window -> JSFunction NewJSObject -> IO (JSFunction JSObject)
wrapImposeStablePtr (Window{wJSObjects}) f = do
    coupon  <- RemotePtr.newCoupon wJSObjects
    rcoupon <- render coupon
    rcode   <- code f
    pure $ JSFunction
        { code = pure $ apply "Haskell.imposeStablePtr(%1,%2)" [rcode, rcoupon]
        , marshalResult = \w _ -> newJSObjectFromCoupon w coupon
        }

{-----------------------------------------------------------------------------
    Variable argument JavaScript functions
------------------------------------------------------------------------------}
-- | A JavaScript function with a given output type @a@.
data JSFunction a = JSFunction
    { code          :: IO JSCode
      -- ^ Code snippet that implements the function.
    , marshalResult :: Window -> JSON.Value -> IO a
      -- ^ Marshal the function result to a Haskell value.
    }

-- | Change the output type of a 'JSFunction'.
instance Functor JSFunction where
    fmap f (JSFunction c m) = JSFunction c (\w v -> fmap f $ m w v)

-- | Render function to a textual representation using JavaScript syntax.
toCode :: JSFunction a -> IO String
toCode = fmap unJSCode . code


-- | Helper class for making 'ffi' a variable argument function.
class FFI a where
    fancy :: ([JSCode] -> IO JSCode) -> a

instance (ToJS a, FFI b) => FFI (a -> b) where
    fancy f a = fancy $ \xs -> do
        x <- render a
        f (x:xs)

instance FromJS b        => FFI (JSFunction b) where
    fancy f   = JSFunction
        { code          = wrapCode b <$> f []
        , marshalResult = marshal b
        }
        where b = fromJS

-- | Simple JavaScript FFI with string substitution.
--
-- Inspired by the Fay language. <https://github.com/faylang/fay/wiki>
--
-- > example :: String -> Int -> JSFunction String
-- > example = ffi "$(%1).prop('checked',%2)"
--
-- The 'ffi' function takes a string argument representing the JavaScript
-- code to be executed on the client.
-- Occurrences of the substrings @%1@ to @%9@ will be replaced by
-- subequent arguments.
-- The substring @%%@ in the original will be replaced by @%@ (character escape).
--
-- Note: Always specify a type signature! The types automate
-- how values are marshalled between Haskell and JavaScript.
-- The class instances for the 'FFI' class show which conversions are supported.
--
ffi :: FFI a => String -> a
ffi macro = fancy (pure . apply macro)

testFFI :: String -> Int -> JSFunction String
testFFI = ffi "$(%1).prop('checked',%2)"

{-----------------------------------------------------------------------------
    Type classes
------------------------------------------------------------------------------}
-- | Helper class for exporting Haskell functions to JavaScript
-- as event handlers.
class IsHandler a where
    convertArgs :: a -> Int -> [JSCode]
    handle      :: a -> Window -> [JSON.Value] -> IO ()

instance (FromJS a, IsHandler b) => IsHandler (a -> b) where
    convertArgs = convertArgs'
    handle f = \w (a:as) -> do
        x <- marshal fromJS w a
        handle (f x) w as

convertArgs' :: forall a b. (FromJS a, IsHandler b) => (a -> b) -> Int -> [JSCode]
convertArgs' f n = wrap arg : convertArgs (f x) (n+1)
    where
    x    = undefined :: a
    wrap = wrapCode (fromJS :: FromJS' a)
    arg  = JSCode $ "arguments[" ++ show n ++ "]"

instance IsHandler (IO ()) where
    convertArgs _ _ = []
    handle      m   = \_ _ -> m

-- | Code needed to preconvert arguments on the JavaScript side.
convertArguments :: IsHandler a => a -> String
convertArguments f =
    "[" ++ intercalate "," (map unJSCode $ convertArgs f 0) ++ "]"


{-----------------------------------------------------------------------------
    String utilities
------------------------------------------------------------------------------}
-- | String substitution.
-- Substitute occurences of %1, %2 up to %9 with the argument strings.
-- The types ensure that the % character has no meaning in the generated output.
--
-- > apply "%1 and %2" [x,y] = x ++ " and " ++ y
apply :: String -> [JSCode] -> JSCode
apply code args = JSCode $ go code
    where
    at xs i = maybe (error err) id $ atMay xs i
    err     = "Graphics.UI.Threepenny.FFI: Too few arguments in FFI call!"
    argument i = unJSCode (args `at` i)

    go []           = []
    go ('%':'%':cs) = '%' : go cs
    go ('%':c  :cs) = argument index ++ go cs
        where index = fromEnum c - fromEnum '1'
    go (c:cs)       = c : go cs

-- | Apply string substitution that expects a single argument.
apply1 :: String -> JSCode -> JSCode
apply1 s x = apply s [x]

-- | Helper function, inlined here. Index a list, return 'Maybe'.
atMay :: [a] -> Int -> Maybe a
atMay xs o
    | o < 0 = Nothing
    | otherwise = f o xs
  where
    f 0 (x:xs) = Just x
    f i (x:xs) = f (i-1) xs
    f i []     = Nothing
