{-# 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 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) String
formatstr 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 Type
typ = case Type
typ of
      TyForall X
_ Maybe [TyVarBind X]
b Maybe (Context X)
c 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 X
_ Type
t1 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 X
_ Boxed
b [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 X
_ 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 X
_ Type
t1 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 X
_ 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 X
_ 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 X
_ Type
t1 MaybePromotedName X
q 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 X
_ Type
t 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 X
_ 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 X
_ Type
t1 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 X
_ BangType X
bt Unpackedness X
unp 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 String
"TyWildCard not supported"
      TyQuasiQuote {}   -> String -> Compile Type
forall a. HasCallStack => String -> a
error String
"TyQuasiQuote not supported"
      TyUnboxedSum {}   -> String -> Compile Type
forall a. HasCallStack => String -> a
error String
"TyUnboxedSum not supported"

    compileFFI' :: N.Type -> Compile JsExp
    compileFFI' :: Type -> Compile JsExp
compileFFI' Type
sig = do
      let name :: Name ()
name = Name () -> Maybe (Name ()) -> Name ()
forall a. a -> Maybe a -> a
fromMaybe Name ()
"<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 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 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 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 JsName
pname 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 [Int
1..Type -> Int
forall a. Type a -> Int
typeArity Type
sig]
        wrapReturn :: String -> JsExp
        wrapReturn :: String -> JsExp
wrapReturn 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:
            Maybe FundamentalType
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 String
string 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]
++ String
":\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 Expression SourcePos
x = case Expression SourcePos
x of
      DotRef SourcePos
_ (VarRef SourcePos
_ (Id SourcePos
_ String
name)) Id SourcePos
_
         | String
name String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
globalNames -> Bool
False
      DotRef{}                     -> Bool
True
      Expression SourcePos
_                            -> Bool
False

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

    globalNames :: [String]
globalNames = [String
"Math",String
"console",String
"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 QName
"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 [(String
"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 ((Int
i,(Name (), Type)
fieldType):[(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
$ String
"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)
        (String
d, JsExp
field) = Int -> (Name (), Type) -> (String, JsExp)
declField Int
i (Name (), Type)
fieldType

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

    -- Declare/encode Fay→JS field
    declField :: Int -> (N.Name,N.Type) -> (String,JsExp)
    declField :: Int -> (Name (), Type) -> (String, JsExp)
declField Int
i (Name ()
fname,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 QName
"obj"

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

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

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

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

-- | Generate a user-defined type.
userDefined :: [N.Type] -> FundamentalType
userDefined :: [Type] -> FundamentalType
userDefined (TyCon ()
_ (UnQual ()
_ Name ()
name):[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 [Type]
_ = FundamentalType
UnknownType

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

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

  where flat :: String -> JsExp
flat 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 -> 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 FundamentalType
ty' =
          JsName -> [JsExp] -> JsExp
JsNew (Name () -> JsName
JsBuiltIn Name ()
"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 SerializeContext
context FundamentalType
typ = case FundamentalType
typ of
  FunctionType [FundamentalType]
xs     -> [JsExp] -> JsExp
JsList [JsLit -> JsExp
JsLit (JsLit -> JsExp) -> JsLit -> JsExp
forall a b. (a -> b) -> a -> b
$ String -> JsLit
JsStr String
"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 FundamentalType
x            -> [JsExp] -> JsExp
JsList [JsLit -> JsExp
JsLit (JsLit -> JsExp) -> JsLit -> JsExp
forall a b. (a -> b) -> a -> b
$ String -> JsLit
JsStr String
"action",[JsExp] -> JsExp
JsList [SerializeContext -> FundamentalType -> JsExp
typeRep SerializeContext
context FundamentalType
x]]
  ListType FundamentalType
x          -> [JsExp] -> JsExp
JsList [JsLit -> JsExp
JsLit (JsLit -> JsExp) -> JsLit -> JsExp
forall a b. (a -> b) -> a -> b
$ String -> JsLit
JsStr String
"list",[JsExp] -> JsExp
JsList [SerializeContext -> FundamentalType -> JsExp
typeRep SerializeContext
context FundamentalType
x]]
  TupleType [FundamentalType]
xs        -> [JsExp] -> JsExp
JsList [JsLit -> JsExp
JsLit (JsLit -> JsExp) -> JsLit -> JsExp
forall a b. (a -> b) -> a -> b
$ String -> JsLit
JsStr String
"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 [FundamentalType]
xs -> [JsExp] -> JsExp
JsList [JsLit -> JsExp
JsLit (JsLit -> JsExp) -> JsLit -> JsExp
forall a b. (a -> b) -> a -> b
$ String -> JsLit
JsStr String
"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 (\FundamentalType
t Int
i -> SerializeContext -> FundamentalType -> JsExp
typeRep (Int -> SerializeContext -> SerializeContext
setArg Int
i SerializeContext
context) FundamentalType
t) [FundamentalType]
xs [Int
0..])]
  Defined FundamentalType
x           -> [JsExp] -> JsExp
JsList [JsLit -> JsExp
JsLit (JsLit -> JsExp) -> JsLit -> JsExp
forall a b. (a -> b) -> a -> b
$ String -> JsLit
JsStr String
"defined",[JsExp] -> JsExp
JsList [SerializeContext -> FundamentalType -> JsExp
typeRep SerializeContext
context FundamentalType
x]]
  Nullable FundamentalType
x          -> [JsExp] -> JsExp
JsList [JsLit -> JsExp
JsLit (JsLit -> JsExp) -> JsLit -> JsExp
forall a b. (a -> b) -> a -> b
$ String -> JsLit
JsStr String
"nullable",[JsExp] -> JsExp
JsList [SerializeContext -> FundamentalType -> JsExp
typeRep SerializeContext
context FundamentalType
x]]
  FundamentalType
_ -> JsExp
nom

  where
    setArg :: Int -> SerializeContext -> SerializeContext
setArg Int
i SerializeUserArg{}   = Int -> SerializeContext
SerializeUserArg Int
i
    setArg Int
_ 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
      FundamentalType
StringType -> String -> JsExp
ret String
"string"
      FundamentalType
DoubleType -> String -> JsExp
ret String
"double"
      FundamentalType
PtrType    -> String -> JsExp
ret String
"ptr"
      FundamentalType
Automatic  -> String -> JsExp
ret String
"automatic"
      FundamentalType
IntType    -> String -> JsExp
ret String
"int"
      FundamentalType
BoolType   -> String -> JsExp
ret String
"bool"
      FundamentalType
DateType   -> String -> JsExp
ret String
"date"
      FundamentalType
_          ->
        case SerializeContext
context of
          SerializeContext
SerializeAnywhere -> String -> JsExp
ret String
"unknown"
          SerializeUserArg Int
i ->
            let args :: JsExp
args = JsName -> JsExp
JsName JsName
argTypes
                automatic :: JsExp
automatic = Int -> JsExp -> JsExp
JsIndex Int
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 String
"&&" JsExp
args JsExp
thisArg)
                           JsExp
thisArg
                           (JsExp -> JsExp -> JsExp -> JsExp
JsTernaryIf (JsExp -> JsExp -> JsExp
JsEq JsExp
automatic (JsLit -> JsExp
JsLit JsLit
"automatic"))
                                        (String -> JsExp
ret String
"automatic")
                                        (String -> JsExp
ret String
"unknown"))

-- | Get the arity of a type.
typeArity :: Type a -> Int
typeArity :: Type a -> Int
typeArity Type a
t = case Type a
t of
  TyForall a
_ Maybe [TyVarBind a]
_ Maybe (Context a)
_ Type a
i -> Type a -> Int
forall a. Type a -> Int
typeArity Type a
i
  TyFun a
_ Type a
_ Type a
b      -> Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Type a -> Int
forall a. Type a -> Int
typeArity Type a
b
  TyParen a
_ Type a
st     -> Type a -> Int
forall a. Type a -> Int
typeArity Type a
st
  Type a
_              -> Int
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 SrcSpanInfo
loc String
formatstr [(JsName, FundamentalType)]
args = String -> Compile String
forall (m :: * -> *).
MonadError CompileError m =>
String -> m String
go String
formatstr where
  go :: String -> m String
go (Char
'%':Char
'*':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 [Int
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
"," [String]
these String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rest)
  go (Char
'%':Char
'%':String
xs) = do
    String
rest <- String -> m String
go String
xs
    String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'%' Char -> String -> String
forall a. a -> [a] -> [a]
: String
rest)
  go [Char
'%'] = CompileError -> m String
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SrcSpanInfo -> CompileError
FfiFormatIncompleteArg SrcSpanInfo
loc)
  go (Char
'%':((Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit -> (String
op,String
xs))) =
    case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMay String
op of
     Maybe Int
Nothing -> CompileError -> m String
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SrcSpanInfo -> String -> CompileError
FfiFormatBadChars SrcSpanInfo
loc String
op)
     Just 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 (Char
x: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 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
-Int
1) [(JsName, FundamentalType)]
args) of
      Maybe (JsName, FundamentalType)
Nothing -> CompileError -> m String
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SrcSpanInfo -> Int -> CompileError
FfiFormatNoSuchArg SrcSpanInfo
loc Int
n)
      Just (JsName
arg,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
$ \([a]
names,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 [(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 Name ()
"objConcat") [JsName -> JsExp
JsName (JsName -> JsExp) -> JsName -> JsExp
forall a b. (a -> b) -> a -> b
$ Name () -> JsName
JsBuiltIn Name ()
"fayToJsHash", [(String, JsExp)] -> JsExp
JsObj [(String, JsExp)]
cases]]

-- | Generate JS→Fay decoding.
jsToFayHash :: [(String, JsExp)] -> [JsStmt]
jsToFayHash :: [(String, JsExp)] -> [JsStmt]
jsToFayHash [(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 Name ()
"objConcat") [JsName -> JsExp
JsName (JsName -> JsExp) -> JsName -> JsExp
forall a b. (a -> b) -> a -> b
$ Name () -> JsName
JsBuiltIn Name ()
"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 =
      Maybe JsName -> [JsName] -> [JsStmt] -> Maybe JsExp -> JsExp
JsFun Maybe JsName
forall a. Maybe a
Nothing [QName -> JsName
JsNameVar QName
"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 (Int
i,(Name ()
fname,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 QName
"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 ()
_ 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
      Maybe Int
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
$ String
"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]
++
                         String
" 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 -> 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 -> String
forall a. [a] -> [a] -> [a]
++
                         String
" 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]
++ String
", rest: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [TyVarBind ()] -> String
forall a. Show a => a -> String
show [TyVarBind ()]
tyvars
      Just Int
i -> (Int
i,(Name ()
sname,Type
ty))
    Type
_ -> (Int
0,(Name ()
sname,Type
ty))

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