{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE ViewPatterns      #-}

-- | Compile FFI definitions.

module Fay.Compiler.FFI
  (emitFayToJs
  ,emitJsToFay
  ,compileFFIExp
  ,jsToFayHash
  ,fayToJsHash
  ,typeArity
  ) where

import           Fay.Compiler.Prelude

import           Fay.Compiler.Misc
import           Fay.Compiler.Print           (printJSString)
import           Fay.Compiler.QName
import           Fay.Exts.NoAnnotation        (unAnn)
import qualified Fay.Exts.NoAnnotation        as N
import qualified Fay.Exts.Scoped              as S
import           Fay.Types

import           Control.Monad.Except         (throwError)
import           Control.Monad.Writer         (tell)
import           Data.Generics.Schemes
import           Language.ECMAScript3.Parser  as JS
import           Language.ECMAScript3.Syntax
import           Language.Haskell.Exts        (SrcSpanInfo, prettyPrint)
import           Language.Haskell.Exts.Syntax

-- | Compile an FFI expression (also used when compiling top level definitions).
compileFFIExp :: SrcSpanInfo -> Maybe (Name a) -> String -> S.Type -> Compile JsExp
compileFFIExp :: SrcSpanInfo -> Maybe (Name a) -> String -> Type -> Compile JsExp
compileFFIExp loc :: SrcSpanInfo
loc ((Name a -> Name ()) -> Maybe (Name a) -> Maybe (Name ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name a -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> Maybe (Name ())
nameopt) formatstr :: String
formatstr sig' :: Type
sig' =
  -- substitute newtypes with their child types before calling
  -- real compileFFI
  Type -> Compile JsExp
compileFFI' (Type -> Compile JsExp) -> (Type -> Type) -> Type -> Compile JsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn (Type -> Compile JsExp) -> Compile Type -> Compile JsExp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> Compile Type
rmNewtys Type
sig'
  where
    rmNewtys :: S.Type -> Compile N.Type
    rmNewtys :: Type -> Compile Type
rmNewtys typ :: Type
typ = case Type
typ of
      TyForall _ b :: Maybe [TyVarBind X]
b c :: Maybe (Context X)
c t :: Type
t  -> () -> Maybe [TyVarBind ()] -> Maybe (Context ()) -> Type -> Type
forall l.
l -> Maybe [TyVarBind l] -> Maybe (Context l) -> Type l -> Type l
TyForall () (([TyVarBind X] -> [TyVarBind ()])
-> Maybe [TyVarBind X] -> Maybe [TyVarBind ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TyVarBind X -> TyVarBind ()) -> [TyVarBind X] -> [TyVarBind ()]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBind X -> TyVarBind ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn) Maybe [TyVarBind X]
b) ((Context X -> Context ())
-> Maybe (Context X) -> Maybe (Context ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Context X -> Context ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn Maybe (Context X)
c) (Type -> Type) -> Compile Type -> Compile Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Compile Type
rmNewtys Type
t
      TyFun _ t1 :: Type
t1 t2 :: Type
t2     -> () -> Type -> Type -> Type
forall l. l -> Type l -> Type l -> Type l
TyFun () (Type -> Type -> Type) -> Compile Type -> Compile (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Compile Type
rmNewtys Type
t1 Compile (Type -> Type) -> Compile Type -> Compile Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Compile Type
rmNewtys Type
t2
      TyTuple _ b :: Boxed
b tl :: [Type]
tl    -> () -> Boxed -> [Type] -> Type
forall l. l -> Boxed -> [Type l] -> Type l
TyTuple () Boxed
b ([Type] -> Type) -> Compile [Type] -> Compile Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Compile Type) -> [Type] -> Compile [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Compile Type
rmNewtys [Type]
tl
      TyList _ t :: Type
t        -> () -> Type -> Type
forall l. l -> Type l -> Type l
TyList () (Type -> Type) -> Compile Type -> Compile Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Compile Type
rmNewtys Type
t
      TyApp _ t1 :: Type
t1 t2 :: Type
t2     -> () -> Type -> Type -> Type
forall l. l -> Type l -> Type l -> Type l
TyApp () (Type -> Type -> Type) -> Compile Type -> Compile (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Compile Type
rmNewtys Type
t1 Compile (Type -> Type) -> Compile Type -> Compile Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Compile Type
rmNewtys Type
t2
      t :: Type
t@TyVar{}         -> Type -> Compile Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Compile Type) -> Type -> Compile Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn Type
t
      TyCon _ qname :: QName X
qname     -> Type
-> ((Maybe QName, Type) -> Type)
-> Maybe (Maybe QName, Type)
-> Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> QName -> Type
forall l. l -> QName l -> Type l
TyCon () (QName X -> QName
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn QName X
qname)) (Maybe QName, Type) -> Type
forall a b. (a, b) -> b
snd (Maybe (Maybe QName, Type) -> Type)
-> Compile (Maybe (Maybe QName, Type)) -> Compile Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName X -> Compile (Maybe (Maybe QName, Type))
lookupNewtypeConst QName X
qname
      TyParen _ t :: Type
t       -> () -> Type -> Type
forall l. l -> Type l -> Type l
TyParen () (Type -> Type) -> Compile Type -> Compile Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Compile Type
rmNewtys Type
t
      TyInfix _ t1 :: Type
t1 q :: MaybePromotedName X
q t2 :: Type
t2 -> (Type -> MaybePromotedName () -> Type -> Type)
-> MaybePromotedName () -> Type -> Type -> Type
forall a b c. (a -> b -> c) -> b -> a -> c
flip (() -> Type -> MaybePromotedName () -> Type -> Type
forall l. l -> Type l -> MaybePromotedName l -> Type l -> Type l
TyInfix ()) (MaybePromotedName X -> MaybePromotedName ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn MaybePromotedName X
q) (Type -> Type -> Type) -> Compile Type -> Compile (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Compile Type
rmNewtys Type
t1 Compile (Type -> Type) -> Compile Type -> Compile Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Compile Type
rmNewtys Type
t2
      TyKind _ t :: Type
t k :: Type
k      -> (Type -> Type -> Type) -> Type -> Type -> Type
forall a b c. (a -> b -> c) -> b -> a -> c
flip (() -> Type -> Type -> Type
forall l. l -> Type l -> Type l -> Type l
TyKind ()) (Type -> Type
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn Type
k) (Type -> Type) -> Compile Type -> Compile Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Compile Type
rmNewtys Type
t
      TyPromoted {}     -> Type -> Compile Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Compile Type) -> Type -> Compile Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn Type
typ
      TyParArray _ t :: Type
t    -> () -> Type -> Type
forall l. l -> Type l -> Type l
TyParArray () (Type -> Type) -> Compile Type -> Compile Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Compile Type
rmNewtys Type
t
      TyEquals _ t1 :: Type
t1 t2 :: Type
t2  -> () -> Type -> Type -> Type
forall l. l -> Type l -> Type l -> Type l
TyEquals () (Type -> Type -> Type) -> Compile Type -> Compile (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Compile Type
rmNewtys Type
t1 Compile (Type -> Type) -> Compile Type -> Compile Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Compile Type
rmNewtys Type
t2
      TySplice {}       -> Type -> Compile Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Compile Type) -> Type -> Compile Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn Type
typ
      TyBang _ bt :: BangType X
bt unp :: Unpackedness X
unp t :: Type
t -> () -> BangType () -> Unpackedness () -> Type -> Type
forall l. l -> BangType l -> Unpackedness l -> Type l -> Type l
TyBang () (BangType X -> BangType ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn BangType X
bt) (Unpackedness X -> Unpackedness ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn Unpackedness X
unp) (Type -> Type) -> Compile Type -> Compile Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Compile Type
rmNewtys Type
t
      TyWildCard {}     -> String -> Compile Type
forall a. HasCallStack => String -> a
error "TyWildCard not supported"
      TyQuasiQuote {}   -> String -> Compile Type
forall a. HasCallStack => String -> a
error "TyQuasiQuote not supported"
      TyUnboxedSum {}   -> String -> Compile Type
forall a. HasCallStack => String -> a
error "TyUnboxedSum not supported"

    compileFFI' :: N.Type -> Compile JsExp
    compileFFI' :: Type -> Compile JsExp
compileFFI' sig :: Type
sig = do
      let name :: Name ()
name = Name () -> Maybe (Name ()) -> Name ()
forall a. a -> Maybe a -> a
fromMaybe "<exp>" Maybe (Name ())
nameopt
      String
inner <- SrcSpanInfo
-> String -> [(JsName, FundamentalType)] -> Compile String
formatFFI SrcSpanInfo
loc String
formatstr ([JsName] -> [FundamentalType] -> [(JsName, FundamentalType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [JsName]
params [FundamentalType]
funcFundamentalTypes)
      case Parser String (Expression SourcePos)
-> String -> String -> Either ParseError (Expression SourcePos)
forall s a.
Stream s Identity Char =>
Parser s a -> String -> s -> Either ParseError a
JS.parse Parser String (Expression SourcePos)
forall s. Stream s Identity Char => Parser s (Expression SourcePos)
JS.expression (Name () -> String
forall a. Pretty a => a -> String
prettyPrint Name ()
name) (JsExp -> String
forall a. Printable a => a -> String
printJSString (String -> JsExp
wrapReturn String
inner)) of
        Left err :: ParseError
err -> CompileError -> Compile JsExp
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SrcSpanInfo -> String -> String -> CompileError
FfiFormatInvalidJavaScript SrcSpanInfo
loc String
inner (ParseError -> String
forall a. Show a => a -> String
show ParseError
err))
        Right exp :: Expression SourcePos
exp  -> do
          Config
config' <- (Config -> Config) -> Compile Config
forall a. (Config -> a) -> Compile a
config Config -> Config
forall a. a -> a
id
          Bool -> Compile () -> Compile ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
configGClosure Config
config') (Compile () -> Compile ()) -> Compile () -> Compile ()
forall a b. (a -> b) -> a -> b
$ SrcSpanInfo -> String -> Expression SourcePos -> Compile ()
warnDotUses SrcSpanInfo
loc String
inner Expression SourcePos
exp
          JsExp -> Compile JsExp
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> JsExp
body String
inner)
      where
        body :: String -> JsExp
body inner :: String
inner = (JsName -> JsExp -> JsExp) -> JsExp -> [JsName] -> JsExp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr JsName -> JsExp -> JsExp
wrapParam (String -> JsExp
wrapReturn String
inner) [JsName]
params
        wrapParam :: JsName -> JsExp -> JsExp
wrapParam pname :: JsName
pname inner :: JsExp
inner = Maybe JsName -> [JsName] -> [JsStmt] -> Maybe JsExp -> JsExp
JsFun Maybe JsName
forall a. Maybe a
Nothing [JsName
pname] [] (JsExp -> Maybe JsExp
forall a. a -> Maybe a
Just JsExp
inner)
        params :: [JsName]
params = (JsName -> Int -> JsName) -> [JsName] -> [Int] -> [JsName]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith JsName -> Int -> JsName
forall a b. a -> b -> a
const [JsName]
uniqueNames [1..Type -> Int
forall a. Type a -> Int
typeArity Type
sig]
        wrapReturn :: String -> JsExp
        wrapReturn :: String -> JsExp
wrapReturn inner :: String
inner = JsExp -> JsExp
thunk (JsExp -> JsExp) -> JsExp -> JsExp
forall a b. (a -> b) -> a -> b
$
          case [FundamentalType] -> Maybe FundamentalType
forall a. [a] -> Maybe a
lastMay [FundamentalType]
funcFundamentalTypes of
            -- Returns a “pure” value;
            Just{} -> SerializeContext -> FundamentalType -> JsExp -> JsExp
jsToFay SerializeContext
SerializeAnywhere FundamentalType
returnType (String -> JsExp
JsRawExp String
inner)
            -- Base case:
            Nothing -> String -> JsExp
JsRawExp String
inner
        funcFundamentalTypes :: [FundamentalType]
funcFundamentalTypes = Type -> [FundamentalType]
functionTypeArgs Type
sig
        returnType :: FundamentalType
returnType = [FundamentalType] -> FundamentalType
forall a. [a] -> a
last [FundamentalType]
funcFundamentalTypes

-- | Warn about uses of naked x.y which will not play nicely with Google Closure.
warnDotUses :: SrcSpanInfo -> String -> Expression SourcePos -> Compile ()
warnDotUses :: SrcSpanInfo -> String -> Expression SourcePos -> Compile ()
warnDotUses srcSpanInfo :: SrcSpanInfo
srcSpanInfo string :: String
string expr :: Expression SourcePos
expr =
  Bool -> Compile () -> Compile ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
anyrefs (Compile () -> Compile ()) -> Compile () -> Compile ()
forall a b. (a -> b) -> a -> b
$
    String -> Compile ()
warn (String -> Compile ()) -> String -> Compile ()
forall a b. (a -> b) -> a -> b
$ SrcSpanInfo -> String
printSrcSpanInfo SrcSpanInfo
srcSpanInfo String -> String -> String
forall a. [a] -> [a] -> [a]
++ ":\nDot ref syntax used in FFI JS code: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
string

  where
    anyrefs :: Bool
anyrefs = Bool -> Bool
not ([Expression SourcePos] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ((Expression SourcePos -> Bool)
-> Expression SourcePos -> [Expression SourcePos]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify Expression SourcePos -> Bool
dotref Expression SourcePos
expr)) Bool -> Bool -> Bool
||
                  Bool -> Bool
not ([LValue SourcePos] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ((LValue SourcePos -> Bool)
-> Expression SourcePos -> [LValue SourcePos]
forall r. Typeable r => (r -> Bool) -> GenericQ [r]
listify LValue SourcePos -> Bool
ldot Expression SourcePos
expr))

    dotref :: Expression SourcePos -> Bool
    dotref :: Expression SourcePos -> Bool
dotref x :: Expression SourcePos
x = case Expression SourcePos
x of
      DotRef _ (VarRef _ (Id _ name :: String
name)) _
         | String
name String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
globalNames -> Bool
False
      DotRef{}                     -> Bool
True
      _                            -> Bool
False

    ldot :: LValue SourcePos -> Bool
    ldot :: LValue SourcePos -> Bool
ldot x :: LValue SourcePos
x =
      case LValue SourcePos
x of
        LDot _ (VarRef _ (Id _ name :: String
name)) _
         | String
name String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
globalNames -> Bool
False
        LDot{}                     -> Bool
True
        _                          -> Bool
False

    globalNames :: [String]
globalNames = ["Math","console","JSON"]

-- | Make a Fay→JS encoder.
emitFayToJs :: Name a -> [TyVarBind b] -> [([Name c], Type d)] -> Compile ()
emitFayToJs :: Name a -> [TyVarBind b] -> [([Name c], Type d)] -> Compile ()
emitFayToJs (Name a -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> Name ()
name) ((TyVarBind b -> TyVarBind ()) -> [TyVarBind b] -> [TyVarBind ()]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBind b -> TyVarBind ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> [TyVarBind ()]
tyvars) ([([Name c], Type d)] -> [(Name c, Type d)]
forall a t. [([a], t)] -> [(a, t)]
explodeFields -> [(Name c, Type d)]
fieldTypes) = do
  QName
qname <- Name () -> Compile QName
forall a. Name a -> Compile QName
qualify Name ()
name
  let ctrName :: String
ctrName = Name () -> String
forall a. Printable a => a -> String
printJSString (Name () -> String) -> Name () -> String
forall a b. (a -> b) -> a -> b
$ QName -> Name ()
forall a. QName a -> Name a
unQual QName
qname
  CompileWriter -> Compile ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (CompileWriter -> Compile ()) -> CompileWriter -> Compile ()
forall a b. (a -> b) -> a -> b
$ CompileWriter
forall a. Monoid a => a
mempty { writerFayToJs :: [(String, JsExp)]
writerFayToJs = [(String
ctrName, JsExp
translator)] }

  where
    translator :: JsExp
translator =
      Maybe JsName -> [JsName] -> [JsStmt] -> Maybe JsExp -> JsExp
JsFun Maybe JsName
forall a. Maybe a
Nothing
            [QName -> JsName
JsNameVar "type", JsName
argTypes, JsName
transcodingObjForced]
            (JsStmt
obj JsStmt -> [JsStmt] -> [JsStmt]
forall a. a -> [a] -> [a]
: [(Int, (Name (), Type))] -> [JsStmt]
fieldStmts (((Name c, Type d) -> (Int, (Name (), Type)))
-> [(Name c, Type d)] -> [(Int, (Name (), Type))]
forall a b. (a -> b) -> [a] -> [b]
map (Name ()
-> [TyVarBind ()] -> (Name c, Type d) -> (Int, (Name (), Type))
forall a b c d.
Name a
-> [TyVarBind b] -> (Name c, Type d) -> (Int, (Name (), Type))
getIndex Name ()
name [TyVarBind ()]
tyvars) [(Name c, Type d)]
fieldTypes))
            (JsExp -> Maybe JsExp
forall a. a -> Maybe a
Just (JsExp -> Maybe JsExp) -> JsExp -> Maybe JsExp
forall a b. (a -> b) -> a -> b
$ JsName -> JsExp
JsName JsName
obj_)

    obj :: JsStmt
    obj :: JsStmt
obj = JsName -> JsExp -> JsStmt
JsVar JsName
obj_ (JsExp -> JsStmt) -> JsExp -> JsStmt
forall a b. (a -> b) -> a -> b
$
      [(String, JsExp)] -> JsExp
JsObj [("instance",JsLit -> JsExp
JsLit (String -> JsLit
JsStr (Name () -> String
forall a. Printable a => a -> String
printJSString (Name () -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn Name ()
name))))]

    fieldStmts :: [(Int,(N.Name,N.Type))] -> [JsStmt]
    fieldStmts :: [(Int, (Name (), Type))] -> [JsStmt]
fieldStmts [] = []
    fieldStmts ((i :: Int
i,fieldType :: (Name (), Type)
fieldType):fts :: [(Int, (Name (), Type))]
fts) =
      JsName -> JsExp -> JsStmt
JsVar JsName
obj_v JsExp
field JsStmt -> [JsStmt] -> [JsStmt]
forall a. a -> [a] -> [a]
:
        JsExp -> [JsStmt] -> [JsStmt] -> JsStmt
JsIf (JsExp -> JsExp -> JsExp
JsNeq JsExp
JsUndefined (JsName -> JsExp
JsName JsName
obj_v))
          [JsName -> JsName -> JsExp -> JsStmt
JsSetPropExtern JsName
obj_ JsName
decl (JsName -> JsExp
JsName JsName
obj_v)]
          [] JsStmt -> [JsStmt] -> [JsStmt]
forall a. a -> [a] -> [a]
:
        [(Int, (Name (), Type))] -> [JsStmt]
fieldStmts [(Int, (Name (), Type))]
fts
      where
        obj_v :: JsName
obj_v = QName -> JsName
JsNameVar (QName -> JsName) -> QName -> JsName
forall a b. (a -> b) -> a -> b
$ () -> Name () -> QName
forall l. l -> Name l -> QName l
UnQual () (() -> String -> Name ()
forall l. l -> String -> Name l
Ident () (String -> Name ()) -> String -> Name ()
forall a b. (a -> b) -> a -> b
$ "obj_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
d)
        decl :: JsName
decl = QName -> JsName
JsNameVar (QName -> JsName) -> QName -> JsName
forall a b. (a -> b) -> a -> b
$ () -> Name () -> QName
forall l. l -> Name l -> QName l
UnQual () (() -> String -> Name ()
forall l. l -> String -> Name l
Ident () String
d)
        (d :: String
d, field :: JsExp
field) = Int -> (Name (), Type) -> (String, JsExp)
declField Int
i (Name (), Type)
fieldType

    obj_ :: JsName
obj_ = QName -> JsName
JsNameVar "obj_"

    -- Declare/encode Fay→JS field
    declField :: Int -> (N.Name,N.Type) -> (String,JsExp)
    declField :: Int -> (Name (), Type) -> (String, JsExp)
declField i :: Int
i (fname :: Name ()
fname,typ :: Type
typ) =
      (Name () -> String
forall a. Pretty a => a -> String
prettyPrint Name ()
fname
      ,SerializeContext -> FundamentalType -> JsExp -> JsExp
fayToJs (Int -> SerializeContext
SerializeUserArg Int
i)
               (Type -> FundamentalType
argType Type
typ)
               (JsExp -> JsName -> JsExp
JsGetProp (JsName -> JsExp
JsName JsName
transcodingObjForced)
                          (QName -> JsName
JsNameVar (() -> Name () -> QName
forall l. l -> Name l -> QName l
UnQual () Name ()
fname))))

-- | A name used for transcoding.
transcodingObj :: JsName
transcodingObj :: JsName
transcodingObj = QName -> JsName
JsNameVar "obj"

-- | The name used for the forced version of a transcoding variable.
transcodingObjForced :: JsName
transcodingObjForced :: JsName
transcodingObjForced = QName -> JsName
JsNameVar "_obj"

-- | Get arg types of a function type.
functionTypeArgs :: N.Type -> [FundamentalType]
functionTypeArgs :: Type -> [FundamentalType]
functionTypeArgs t :: Type
t = case Type
t of
  TyForall _ _ _ i :: Type
i -> Type -> [FundamentalType]
functionTypeArgs Type
i
  TyFun _ a :: Type
a b :: Type
b      -> Type -> FundamentalType
argType Type
a FundamentalType -> [FundamentalType] -> [FundamentalType]
forall a. a -> [a] -> [a]
: Type -> [FundamentalType]
functionTypeArgs Type
b
  TyParen _ st :: Type
st     -> Type -> [FundamentalType]
functionTypeArgs Type
st
  r :: Type
r                -> [Type -> FundamentalType
argType Type
r]

-- | Convert a Haskell type to an internal FFI representation.
argType :: N.Type -> FundamentalType
argType :: Type -> FundamentalType
argType t :: Type
t = case Type
t of
  TyCon _ (UnQual _ (Ident _ "String"))                -> FundamentalType
StringType
  TyCon _ (UnQual _ (Ident _ "Double"))                -> FundamentalType
DoubleType
  TyCon _ (UnQual _ (Ident _ "Int"))                   -> FundamentalType
IntType
  TyCon _ (UnQual _ (Ident _ "Bool"))                  -> FundamentalType
BoolType
  TyApp _ (TyCon _ (UnQual _ (Ident _ "Ptr"))) _       -> FundamentalType
PtrType
  TyApp _ (TyCon _ (UnQual _ (Ident _ "Automatic"))) _ -> FundamentalType
Automatic
  TyApp _ (TyCon _ (UnQual _ (Ident _ "Defined"))) a :: Type
a   -> FundamentalType -> FundamentalType
Defined (Type -> FundamentalType
argType Type
a)
  TyApp _ (TyCon _ (UnQual _ (Ident _ "Nullable"))) a :: Type
a  -> FundamentalType -> FundamentalType
Nullable (Type -> FundamentalType
argType Type
a)
  TyApp _ (TyCon _ (UnQual _ (Ident _ "Fay"))) a :: Type
a       -> FundamentalType -> FundamentalType
JsType (Type -> FundamentalType
argType Type
a)
  TyFun _ x :: Type
x xs :: Type
xs                  -> [FundamentalType] -> FundamentalType
FunctionType (Type -> FundamentalType
argType Type
x FundamentalType -> [FundamentalType] -> [FundamentalType]
forall a. a -> [a] -> [a]
: Type -> [FundamentalType]
functionTypeArgs Type
xs)
  TyList _ x :: Type
x                    -> FundamentalType -> FundamentalType
ListType (Type -> FundamentalType
argType Type
x)
  TyTuple _ _ xs :: [Type]
xs                -> [FundamentalType] -> FundamentalType
TupleType ((Type -> FundamentalType) -> [Type] -> [FundamentalType]
forall a b. (a -> b) -> [a] -> [b]
map Type -> FundamentalType
argType [Type]
xs)
  TyParen _ st :: Type
st                  -> Type -> FundamentalType
argType Type
st
  TyApp _ op :: Type
op arg :: Type
arg                -> [Type] -> FundamentalType
userDefined ([Type] -> [Type]
forall a. [a] -> [a]
reverse (Type
arg Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> [Type]
expandApp Type
op))
  _                     ->
    -- No semantic point to this, merely to avoid GHC's broken
    -- warning.
    case Type
t of
      TyCon _ (UnQual _ user :: Name ()
user)   -> Name () -> [FundamentalType] -> FundamentalType
UserDefined Name ()
user []
      _ -> FundamentalType
UnknownType

-- | Expand a type application.
expandApp :: N.Type -> [N.Type]
expandApp :: Type -> [Type]
expandApp (TyParen _ t :: Type
t) = Type -> [Type]
expandApp Type
t
expandApp (TyApp _ op :: Type
op arg :: Type
arg) = Type
arg Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> [Type]
expandApp Type
op
expandApp x :: Type
x = [Type
x]

-- | Generate a user-defined type.
userDefined :: [N.Type] -> FundamentalType
userDefined :: [Type] -> FundamentalType
userDefined (TyCon _ (UnQual _ name :: Name ()
name):typs :: [Type]
typs) = Name () -> [FundamentalType] -> FundamentalType
UserDefined Name ()
name ((Type -> FundamentalType) -> [Type] -> [FundamentalType]
forall a b. (a -> b) -> [a] -> [b]
map Type -> FundamentalType
argType [Type]
typs)
userDefined _ = FundamentalType
UnknownType

-- | Translate: JS → Fay.
jsToFay :: SerializeContext -> FundamentalType -> JsExp -> JsExp
jsToFay :: SerializeContext -> FundamentalType -> JsExp -> JsExp
jsToFay = String -> SerializeContext -> FundamentalType -> JsExp -> JsExp
translate "jsToFay"
-- | Translate: Fay → JS.
fayToJs :: SerializeContext -> FundamentalType -> JsExp -> JsExp
fayToJs :: SerializeContext -> FundamentalType -> JsExp -> JsExp
fayToJs = String -> SerializeContext -> FundamentalType -> JsExp -> JsExp
translate "fayToJs"

-- | Make a translator.
translate :: String -> SerializeContext -> FundamentalType -> JsExp -> JsExp
translate :: String -> SerializeContext -> FundamentalType -> JsExp -> JsExp
translate method :: String
method context :: SerializeContext
context typ :: FundamentalType
typ exp :: JsExp
exp = case FundamentalType
typ of
  -- Unserialized types
  PtrType     -> JsExp
exp
  -- Flat types
  StringType -> String -> JsExp
flat "string"
  DoubleType -> String -> JsExp
flat "double"
  IntType    -> String -> JsExp
flat "int"
  BoolType   -> String -> JsExp
flat "bool"
  -- Collapse monad
  JsType x :: FundamentalType
x | String
method String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "jsToFay" -> FundamentalType -> JsExp
js FundamentalType
x
  -- Otherwise recursive stuff needs the big guns
  _ -> JsExp
recursive

  where flat :: String -> JsExp
flat specialize :: String
specialize =
          JsExp -> [JsExp] -> JsExp
JsApp (JsName -> JsExp
JsName (Name () -> JsName
JsBuiltIn (() -> String -> Name ()
forall l. l -> String -> Name l
Ident () (String
method String -> String -> String
forall a. [a] -> [a] -> [a]
++ "_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
specialize))))
                [JsExp
exp]
        recursive :: JsExp
recursive =
          JsExp -> [JsExp] -> JsExp
JsApp (JsName -> JsExp
JsName (Name () -> JsName
JsBuiltIn (() -> String -> Name ()
forall l. l -> String -> Name l
Ident () String
method)))
                [SerializeContext -> FundamentalType -> JsExp
typeRep SerializeContext
context FundamentalType
typ
                ,JsExp
exp]
        js :: FundamentalType -> JsExp
js ty' :: FundamentalType
ty' =
          JsName -> [JsExp] -> JsExp
JsNew (Name () -> JsName
JsBuiltIn "Monad")
                [String -> SerializeContext -> FundamentalType -> JsExp -> JsExp
translate String
method SerializeContext
context FundamentalType
ty' JsExp
exp]

-- | Get a JS-representation of a fundamental type for encoding/decoding.
typeRep :: SerializeContext -> FundamentalType -> JsExp
typeRep :: SerializeContext -> FundamentalType -> JsExp
typeRep context :: SerializeContext
context typ :: FundamentalType
typ = case FundamentalType
typ of
  FunctionType xs :: [FundamentalType]
xs     -> [JsExp] -> JsExp
JsList [JsLit -> JsExp
JsLit (JsLit -> JsExp) -> JsLit -> JsExp
forall a b. (a -> b) -> a -> b
$ String -> JsLit
JsStr "function",[JsExp] -> JsExp
JsList ((FundamentalType -> JsExp) -> [FundamentalType] -> [JsExp]
forall a b. (a -> b) -> [a] -> [b]
map (SerializeContext -> FundamentalType -> JsExp
typeRep SerializeContext
context) [FundamentalType]
xs)]
  JsType x :: FundamentalType
x            -> [JsExp] -> JsExp
JsList [JsLit -> JsExp
JsLit (JsLit -> JsExp) -> JsLit -> JsExp
forall a b. (a -> b) -> a -> b
$ String -> JsLit
JsStr "action",[JsExp] -> JsExp
JsList [SerializeContext -> FundamentalType -> JsExp
typeRep SerializeContext
context FundamentalType
x]]
  ListType x :: FundamentalType
x          -> [JsExp] -> JsExp
JsList [JsLit -> JsExp
JsLit (JsLit -> JsExp) -> JsLit -> JsExp
forall a b. (a -> b) -> a -> b
$ String -> JsLit
JsStr "list",[JsExp] -> JsExp
JsList [SerializeContext -> FundamentalType -> JsExp
typeRep SerializeContext
context FundamentalType
x]]
  TupleType xs :: [FundamentalType]
xs        -> [JsExp] -> JsExp
JsList [JsLit -> JsExp
JsLit (JsLit -> JsExp) -> JsLit -> JsExp
forall a b. (a -> b) -> a -> b
$ String -> JsLit
JsStr "tuple",[JsExp] -> JsExp
JsList ((FundamentalType -> JsExp) -> [FundamentalType] -> [JsExp]
forall a b. (a -> b) -> [a] -> [b]
map (SerializeContext -> FundamentalType -> JsExp
typeRep SerializeContext
context) [FundamentalType]
xs)]
  UserDefined name :: Name ()
name xs :: [FundamentalType]
xs -> [JsExp] -> JsExp
JsList [JsLit -> JsExp
JsLit (JsLit -> JsExp) -> JsLit -> JsExp
forall a b. (a -> b) -> a -> b
$ String -> JsLit
JsStr "user"
                                ,JsLit -> JsExp
JsLit (JsLit -> JsExp) -> JsLit -> JsExp
forall a b. (a -> b) -> a -> b
$ String -> JsLit
JsStr (Name () -> String
forall a. Name a -> String
unname Name ()
name)
                                ,[JsExp] -> JsExp
JsList ((FundamentalType -> Int -> JsExp)
-> [FundamentalType] -> [Int] -> [JsExp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\t :: FundamentalType
t i :: Int
i -> SerializeContext -> FundamentalType -> JsExp
typeRep (Int -> SerializeContext -> SerializeContext
setArg Int
i SerializeContext
context) FundamentalType
t) [FundamentalType]
xs [0..])]
  Defined x :: FundamentalType
x           -> [JsExp] -> JsExp
JsList [JsLit -> JsExp
JsLit (JsLit -> JsExp) -> JsLit -> JsExp
forall a b. (a -> b) -> a -> b
$ String -> JsLit
JsStr "defined",[JsExp] -> JsExp
JsList [SerializeContext -> FundamentalType -> JsExp
typeRep SerializeContext
context FundamentalType
x]]
  Nullable x :: FundamentalType
x          -> [JsExp] -> JsExp
JsList [JsLit -> JsExp
JsLit (JsLit -> JsExp) -> JsLit -> JsExp
forall a b. (a -> b) -> a -> b
$ String -> JsLit
JsStr "nullable",[JsExp] -> JsExp
JsList [SerializeContext -> FundamentalType -> JsExp
typeRep SerializeContext
context FundamentalType
x]]
  _ -> JsExp
nom

  where
    setArg :: Int -> SerializeContext -> SerializeContext
setArg i :: Int
i SerializeUserArg{}   = Int -> SerializeContext
SerializeUserArg Int
i
    setArg _ c :: SerializeContext
c = SerializeContext
c
    ret :: String -> JsExp
ret = [JsExp] -> JsExp
JsList ([JsExp] -> JsExp) -> (String -> [JsExp]) -> String -> JsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsExp -> [JsExp]
forall (m :: * -> *) a. Monad m => a -> m a
return (JsExp -> [JsExp]) -> (String -> JsExp) -> String -> [JsExp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsLit -> JsExp
JsLit (JsLit -> JsExp) -> (String -> JsLit) -> String -> JsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> JsLit
JsStr
    nom :: JsExp
nom = case FundamentalType
typ of
      StringType -> String -> JsExp
ret "string"
      DoubleType -> String -> JsExp
ret "double"
      PtrType    -> String -> JsExp
ret "ptr"
      Automatic  -> String -> JsExp
ret "automatic"
      IntType    -> String -> JsExp
ret "int"
      BoolType   -> String -> JsExp
ret "bool"
      DateType   -> String -> JsExp
ret "date"
      _          ->
        case SerializeContext
context of
          SerializeAnywhere -> String -> JsExp
ret "unknown"
          SerializeUserArg i :: Int
i ->
            let args :: JsExp
args = JsName -> JsExp
JsName JsName
argTypes
                automatic :: JsExp
automatic = Int -> JsExp -> JsExp
JsIndex 0 (JsName -> JsExp
JsName JsName
JsParametrizedType)
                thisArg :: JsExp
thisArg = Int -> JsExp -> JsExp
JsIndex Int
i JsExp
args
            in JsExp -> JsExp -> JsExp -> JsExp
JsTernaryIf (String -> JsExp -> JsExp -> JsExp
JsInfix "&&" JsExp
args JsExp
thisArg)
                           JsExp
thisArg
                           (JsExp -> JsExp -> JsExp -> JsExp
JsTernaryIf (JsExp -> JsExp -> JsExp
JsEq JsExp
automatic (JsLit -> JsExp
JsLit "automatic"))
                                        (String -> JsExp
ret "automatic")
                                        (String -> JsExp
ret "unknown"))

-- | Get the arity of a type.
typeArity :: Type a -> Int
typeArity :: Type a -> Int
typeArity t :: Type a
t = case Type a
t of
  TyForall _ _ _ i :: Type a
i -> Type a -> Int
forall a. Type a -> Int
typeArity Type a
i
  TyFun _ _ b :: Type a
b      -> 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Type a -> Int
forall a. Type a -> Int
typeArity Type a
b
  TyParen _ st :: Type a
st     -> Type a -> Int
forall a. Type a -> Int
typeArity Type a
st
  _              -> 0

-- | Format the FFI  format string with the given arguments.
formatFFI :: SrcSpanInfo                -- ^ Source Location.
          -> String                     -- ^ The format string.
          -> [(JsName,FundamentalType)] -- ^ Arguments.
          -> Compile String             -- ^ The JS code.
formatFFI :: SrcSpanInfo
-> String -> [(JsName, FundamentalType)] -> Compile String
formatFFI loc :: SrcSpanInfo
loc formatstr :: String
formatstr args :: [(JsName, FundamentalType)]
args = String -> Compile String
forall (m :: * -> *).
MonadError CompileError m =>
String -> m String
go String
formatstr where
  go :: String -> m String
go ('%':'*':xs :: String
xs) = do
    [String]
these <- (Int -> m String) -> [Int] -> m [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Int -> m String
forall (m :: * -> *). MonadError CompileError m => Int -> m String
inject ((Int -> (JsName, FundamentalType) -> Int)
-> [Int] -> [(JsName, FundamentalType)] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> (JsName, FundamentalType) -> Int
forall a b. a -> b -> a
const [1..] [(JsName, FundamentalType)]
args)
    String
rest <- String -> m String
go String
xs
    String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "," [String]
these String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rest)
  go ('%':'%':xs :: String
xs) = do
    String
rest <- String -> m String
go String
xs
    String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return ('%' Char -> String -> String
forall a. a -> [a] -> [a]
: String
rest)
  go ['%'] = CompileError -> m String
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SrcSpanInfo -> CompileError
FfiFormatIncompleteArg SrcSpanInfo
loc)
  go ('%':((Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit -> (op :: String
op,xs :: String
xs))) =
    case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMay String
op of
     Nothing -> CompileError -> m String
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SrcSpanInfo -> String -> CompileError
FfiFormatBadChars SrcSpanInfo
loc String
op)
     Just n :: Int
n -> do
       String
this <- Int -> m String
forall (m :: * -> *). MonadError CompileError m => Int -> m String
inject Int
n
       String
rest <- String -> m String
go String
xs
       String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
this String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rest)
  go (x :: Char
x:xs :: String
xs) = do String
rest <- String -> m String
go String
xs
                 String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
rest)
  go [] = String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return []

  inject :: Int -> m String
inject n :: Int
n =
    case [(JsName, FundamentalType)] -> Maybe (JsName, FundamentalType)
forall a. [a] -> Maybe a
listToMaybe (Int -> [(JsName, FundamentalType)] -> [(JsName, FundamentalType)]
forall a. Int -> [a] -> [a]
drop (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) [(JsName, FundamentalType)]
args) of
      Nothing -> CompileError -> m String
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SrcSpanInfo -> Int -> CompileError
FfiFormatNoSuchArg SrcSpanInfo
loc Int
n)
      Just (arg :: JsName
arg,typ :: FundamentalType
typ) ->
        String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (JsExp -> String
forall a. Printable a => a -> String
printJSString (SerializeContext -> FundamentalType -> JsExp -> JsExp
fayToJs SerializeContext
SerializeAnywhere FundamentalType
typ (JsName -> JsExp
JsName JsName
arg)))

-- | Generate n name-typ pairs from the given list.
explodeFields :: [([a], t)] -> [(a, t)]
explodeFields :: [([a], t)] -> [(a, t)]
explodeFields = (([a], t) -> [(a, t)]) -> [([a], t)] -> [(a, t)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((([a], t) -> [(a, t)]) -> [([a], t)] -> [(a, t)])
-> (([a], t) -> [(a, t)]) -> [([a], t)] -> [(a, t)]
forall a b. (a -> b) -> a -> b
$ \(names :: [a]
names,typ :: t
typ) -> (a -> (a, t)) -> [a] -> [(a, t)]
forall a b. (a -> b) -> [a] -> [b]
map (,t
typ) [a]
names

-- | Generate Fay→JS encoding.
fayToJsHash :: [(String, JsExp)] -> [JsStmt]
fayToJsHash :: [(String, JsExp)] -> [JsStmt]
fayToJsHash cases :: [(String, JsExp)]
cases = [JsExp -> JsStmt
JsExpStmt (JsExp -> JsStmt) -> JsExp -> JsStmt
forall a b. (a -> b) -> a -> b
$ JsExp -> [JsExp] -> JsExp
JsApp (JsName -> JsExp
JsName (JsName -> JsExp) -> JsName -> JsExp
forall a b. (a -> b) -> a -> b
$ Name () -> JsName
JsBuiltIn "objConcat") [JsName -> JsExp
JsName (JsName -> JsExp) -> JsName -> JsExp
forall a b. (a -> b) -> a -> b
$ Name () -> JsName
JsBuiltIn "fayToJsHash", [(String, JsExp)] -> JsExp
JsObj [(String, JsExp)]
cases]]

-- | Generate JS→Fay decoding.
jsToFayHash :: [(String, JsExp)] -> [JsStmt]
jsToFayHash :: [(String, JsExp)] -> [JsStmt]
jsToFayHash cases :: [(String, JsExp)]
cases = [JsExp -> JsStmt
JsExpStmt (JsExp -> JsStmt) -> JsExp -> JsStmt
forall a b. (a -> b) -> a -> b
$ JsExp -> [JsExp] -> JsExp
JsApp (JsName -> JsExp
JsName (JsName -> JsExp) -> JsName -> JsExp
forall a b. (a -> b) -> a -> b
$ Name () -> JsName
JsBuiltIn "objConcat") [JsName -> JsExp
JsName (JsName -> JsExp) -> JsName -> JsExp
forall a b. (a -> b) -> a -> b
$ Name () -> JsName
JsBuiltIn "jsToFayHash", [(String, JsExp)] -> JsExp
JsObj [(String, JsExp)]
cases]]

-- | Make a JS→Fay decoder.
emitJsToFay :: Name a -> [TyVarBind b] -> [([Name c],Type d)] -> Compile ()
emitJsToFay :: Name a -> [TyVarBind b] -> [([Name c], Type d)] -> Compile ()
emitJsToFay (Name a -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> Name ()
name) ((TyVarBind b -> TyVarBind ()) -> [TyVarBind b] -> [TyVarBind ()]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBind b -> TyVarBind ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> [TyVarBind ()]
tyvars) (((Name c, Type d) -> (Name (), Type))
-> [(Name c, Type d)] -> [(Name (), Type)]
forall a b. (a -> b) -> [a] -> [b]
map (Name c -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn (Name c -> Name ())
-> (Type d -> Type) -> (Name c, Type d) -> (Name (), Type)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Type d -> Type
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn) ([(Name c, Type d)] -> [(Name (), Type)])
-> ([([Name c], Type d)] -> [(Name c, Type d)])
-> [([Name c], Type d)]
-> [(Name (), Type)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([Name c], Type d)] -> [(Name c, Type d)]
forall a t. [([a], t)] -> [(a, t)]
explodeFields -> [(Name (), Type)]
fieldTypes) = do
  QName
qname <- Name () -> Compile QName
forall a. Name a -> Compile QName
qualify Name ()
name
  CompileWriter -> Compile ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (CompileWriter
forall a. Monoid a => a
mempty { writerJsToFay :: [(String, JsExp)]
writerJsToFay = [(Name () -> String
forall a. Printable a => a -> String
printJSString (Name () -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn Name ()
name), QName -> JsExp
translator QName
qname)] })

  where
    translator :: QName -> JsExp
translator qname :: QName
qname =
      Maybe JsName -> [JsName] -> [JsStmt] -> Maybe JsExp -> JsExp
JsFun Maybe JsName
forall a. Maybe a
Nothing [QName -> JsName
JsNameVar "type", JsName
argTypes, JsName
transcodingObj] []
            (JsExp -> Maybe JsExp
forall a. a -> Maybe a
Just (JsExp -> Maybe JsExp) -> JsExp -> Maybe JsExp
forall a b. (a -> b) -> a -> b
$ JsName -> [JsExp] -> JsExp
JsNew (QName -> JsName
JsConstructor QName
qname)
                          (((Name (), Type) -> JsExp) -> [(Name (), Type)] -> [JsExp]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, (Name (), Type)) -> JsExp
decodeField ((Int, (Name (), Type)) -> JsExp)
-> ((Name (), Type) -> (Int, (Name (), Type)))
-> (Name (), Type)
-> JsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name ()
-> [TyVarBind ()] -> (Name (), Type) -> (Int, (Name (), Type))
forall a b c d.
Name a
-> [TyVarBind b] -> (Name c, Type d) -> (Int, (Name (), Type))
getIndex Name ()
name [TyVarBind ()]
tyvars) [(Name (), Type)]
fieldTypes))
    -- Decode JS→Fay field
    decodeField :: (Int,(N.Name,N.Type)) -> JsExp
    decodeField :: (Int, (Name (), Type)) -> JsExp
decodeField (i :: Int
i,(fname :: Name ()
fname,typ :: Type
typ)) =
      SerializeContext -> FundamentalType -> JsExp -> JsExp
jsToFay (Int -> SerializeContext
SerializeUserArg Int
i)
              (Type -> FundamentalType
argType Type
typ)
              (JsExp -> String -> JsExp
JsGetPropExtern (JsName -> JsExp
JsName JsName
transcodingObj)
                               (Name () -> String
forall a. Pretty a => a -> String
prettyPrint Name ()
fname))

-- | The argument types used in serialization of parametrized user-defined types.
argTypes :: JsName
argTypes :: JsName
argTypes = QName -> JsName
JsNameVar "argTypes"

-- | Get the index of a name from the set of type variables bindings.
getIndex :: Name a -> [TyVarBind b] -> (Name c,Type d) -> (Int,(N.Name,N.Type))
getIndex :: Name a
-> [TyVarBind b] -> (Name c, Type d) -> (Int, (Name (), Type))
getIndex (Name a -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> Name ()
name) ((TyVarBind b -> TyVarBind ()) -> [TyVarBind b] -> [TyVarBind ()]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBind b -> TyVarBind ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> [TyVarBind ()]
tyvars) (Name c -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> Name ()
sname,Type d -> Type
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> Type
ty) =
  case Type
ty of
    TyVar _ tyname :: Name ()
tyname -> case Name () -> [Name ()] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Name ()
tyname ((TyVarBind () -> Name ()) -> [TyVarBind ()] -> [Name ()]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBind () -> Name ()
tyvar [TyVarBind ()]
tyvars) of
      Nothing -> String -> (Int, (Name (), Type))
forall a. HasCallStack => String -> a
error (String -> (Int, (Name (), Type)))
-> String -> (Int, (Name (), Type))
forall a b. (a -> b) -> a -> b
$ "unknown type variable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name () -> String
forall a. Pretty a => a -> String
prettyPrint Name ()
tyname String -> String -> String
forall a. [a] -> [a] -> [a]
++
                         " for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name () -> String
forall a. Pretty a => a -> String
prettyPrint Name ()
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ "." String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name () -> String
forall a. Pretty a => a -> String
prettyPrint Name ()
sname String -> String -> String
forall a. [a] -> [a] -> [a]
++ "," String -> String -> String
forall a. [a] -> [a] -> [a]
++
                         " vars were: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ((TyVarBind () -> String) -> [TyVarBind ()] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBind () -> String
forall a. Pretty a => a -> String
prettyPrint [TyVarBind ()]
tyvars) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", rest: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [TyVarBind ()] -> String
forall a. Show a => a -> String
show [TyVarBind ()]
tyvars
      Just i :: Int
i -> (Int
i,(Name ()
sname,Type
ty))
    _ -> (0,(Name ()
sname,Type
ty))

-- | Extract the name from a possibly-kinded tyvar.
tyvar :: N.TyVarBind -> N.Name
tyvar :: TyVarBind () -> Name ()
tyvar (UnkindedVar _ v :: Name ()
v) = Name ()
v
tyvar (KindedVar _ v :: Name ()
v _) = Name ()
v