module Language.Fay.Compiler.FFI
(emitFayToJs
,emitJsToFay
,compileFFI
,jsToFayDispatcher
,fayToJsDispatcher)
where
import Language.Fay.Compiler.Misc
import Language.Fay.Print (printJSString)
import Language.Fay.Types
import Control.Monad.Error
import Control.Monad.State
import Data.Char
import Data.List
import Data.Maybe
import Language.ECMAScript3.Parser as JS
import Language.ECMAScript3.Syntax
import Language.Haskell.Exts (prettyPrint)
import Language.Haskell.Exts.Syntax
import Prelude hiding (exp)
import Safe
compileFFI :: SrcLoc
-> Name
-> String
-> Type
-> Compile [JsStmt]
compileFFI srcloc name formatstr sig = do
inner <- formatFFI formatstr (zip params funcFundamentalTypes)
case JS.parse JS.parseExpression (prettyPrint name) (printJSString (wrapReturn inner)) of
Left err -> throwError (FfiFormatInvalidJavaScript srcloc inner (show err))
Right exp -> do
config' <- gets stateConfig
when (configGClosure config') $ warnDotUses srcloc inner exp
fmap return (bindToplevel srcloc True name (body inner))
where body inner = foldr wrapParam (wrapReturn inner) params
wrapParam pname inner = JsFun [pname] [] (Just inner)
params = zipWith const uniqueNames [1..typeArity sig]
wrapReturn inner = thunk $
case lastMay funcFundamentalTypes of
Just{} -> jsToFay SerializeAnywhere returnType (JsRawExp inner)
Nothing -> JsRawExp inner
funcFundamentalTypes = functionTypeArgs sig
returnType = last funcFundamentalTypes
warnDotUses :: SrcLoc -> String -> JS.ParsedExpression -> Compile ()
warnDotUses srcloc string = go where
gom = maybe (return ()) go
go exp = case exp of
DotRef _ (VarRef _ (Id _ name)) _
| elem name globalNames -> return ()
DotRef _ _ _ -> warn $ printSrcLoc srcloc ++ ":\nDot ref syntax used in FFI JS code: " ++ string
ArrayLit _ es -> mapM_ go es
ObjectLit _ pairs -> mapM_ go (map snd pairs)
BracketRef _ a b -> do go a; go b
NewExpr _ a xs -> do go a; mapM_ go xs
PrefixExpr _ _ e -> go e
UnaryAssignExpr _ _ lvalue -> golvalue lvalue
InfixExpr _ _ a b -> do go a; go b
CondExpr _ a b c -> do go a; go b; go c
AssignExpr _ _ lvalue e -> do golvalue lvalue; go e
ListExpr _ xs -> mapM_ go xs
CallExpr _ e xs -> do go e; mapM_ go xs
FuncExpr _ _ _ stmts -> mapM_ gostmt stmts
_ -> return ()
globalNames = ["Math","console","JSON"]
golvalue lvalue =
case lvalue of
LDot _ (VarRef _ (Id _ name)) _
| elem name globalNames -> return ()
LDot _ _ _ -> warn $ printSrcLoc srcloc ++ ":\nDot ref syntax used in FFI JS code: " ++ string
LBracket _ a b -> do go a; go b
_ -> return ()
gostmt stmt =
case stmt of
BlockStmt _ ss -> do mapM_ gostmt ss
ExprStmt _ e -> do go e
IfStmt _ e s s' -> do gostmt s; go e; gostmt s'
IfSingleStmt _ e s -> do gostmt s; go e; gostmt s
SwitchStmt _ e _ -> do go e
WhileStmt _ e s -> do gostmt s; go e; gostmt s
DoWhileStmt _ s e -> do gostmt s; go e; gostmt s
LabelledStmt _ _ s -> do gostmt s
ForInStmt _ (ForInLVal lvalue) e s -> do golvalue lvalue; gostmt s; go e; gostmt s
ForInStmt _ _ e s -> do gostmt s; go e; gostmt s
ForStmt _ _ me me' s -> do gostmt s; gostmt s; gom me; gom me'
TryStmt _ s cc ms -> do
maybe (return ()) gostmt ms
gostmt s
case cc of
Just (CatchClause _ _ s') -> gostmt s'
_ -> return ()
ThrowStmt _ e -> go e
WithStmt _ e s -> do gostmt s; go e; gostmt s
VarDeclStmt _ decls -> mapM_ godecl decls
FunctionStmt _ _ _ ss -> do mapM_ gostmt ss
ReturnStmt _ me -> gom me
_ -> return ()
godecl _ = return ()
emitFayToJs :: Name -> [([Name],BangType)] -> Compile ()
emitFayToJs name (explodeFields -> fieldTypes) = do
qname <- qualify name
modify $ \s -> s { stateFayToJs = translator qname : stateFayToJs s }
where
translator qname =
JsIf (JsInstanceOf (JsName transcodingObjForced) (JsConstructor qname))
(obj : fieldStmts (zip [0..] fieldTypes) ++ [ret])
[]
obj :: JsStmt
obj = JsVar obj_ $
JsObj [("instance",JsLit (JsStr (printJSString name)))]
fieldStmts :: [(Int,(Name,BangType))] -> [JsStmt]
fieldStmts [] = []
fieldStmts ((i,fieldType):fts) =
(JsVar obj_v field) :
(JsIf (JsNeq JsUndefined (JsName obj_v))
[JsSetPropExtern obj_ decl (JsName obj_v)]
[]) :
fieldStmts fts
where
obj_v = JsNameVar (UnQual (Ident $ "obj_" ++ d))
decl = JsNameVar (UnQual (Ident d))
(d, field) = declField i fieldType
obj_ = JsNameVar (UnQual (Ident "obj_"))
ret :: JsStmt
ret = JsEarlyReturn (JsName obj_)
declField :: Int -> (Name,BangType) -> (String,JsExp)
declField i (fname,typ) =
(prettyPrint fname
,fayToJs (case argType (bangType typ) of
known -> typeRep (SerializeUserArg i) known)
(force (JsGetProp (JsName transcodingObjForced)
(JsNameVar (UnQual fname)))))
transcodingObj :: JsName
transcodingObj = JsNameVar "obj"
transcodingObjForced :: JsName
transcodingObjForced = JsNameVar "_obj"
functionTypeArgs :: Type -> [FundamentalType]
functionTypeArgs t =
case t of
TyForall _ _ i -> functionTypeArgs i
TyFun a b -> argType a : functionTypeArgs b
TyParen st -> functionTypeArgs st
r -> [argType r]
argType :: Type -> FundamentalType
argType t =
case t of
TyCon "String" -> StringType
TyCon "Double" -> DoubleType
TyCon "Int" -> IntType
TyCon "Bool" -> BoolType
TyApp (TyCon "Defined") a -> Defined (argType a)
TyApp (TyCon "Nullable") a -> Nullable (argType a)
TyApp (TyCon "Fay") a -> JsType (argType a)
TyFun x xs -> FunctionType (argType x : functionTypeArgs xs)
TyList x -> ListType (argType x)
TyTuple _ xs -> TupleType (map argType xs)
TyParen st -> argType st
TyApp op arg -> userDefined (reverse (arg : expandApp op))
_ ->
case t of
TyCon (UnQual user) -> UserDefined user []
_ -> UnknownType
bangType :: BangType -> Type
bangType typ =
case typ of
BangedTy ty -> ty
UnBangedTy ty -> ty
UnpackedTy ty -> ty
expandApp :: Type -> [Type]
expandApp (TyParen t) = expandApp t
expandApp (TyApp op arg) = arg : expandApp op
expandApp x = [x]
userDefined :: [Type] -> FundamentalType
userDefined (TyCon (UnQual name):typs) = UserDefined name (map argType typs)
userDefined _ = UnknownType
jsToFay :: SerializeContext -> FundamentalType -> JsExp -> JsExp
jsToFay context typ exp =
JsApp (JsName (JsBuiltIn "jsToFay"))
[typeRep context typ,exp]
fayToJs :: JsExp -> JsExp -> JsExp
fayToJs typ exp = JsApp (JsName (JsBuiltIn "fayToJs"))
[typ,exp]
typeRep :: SerializeContext -> FundamentalType -> JsExp
typeRep context typ =
case typ of
FunctionType xs -> JsList [JsLit $ JsStr "function",JsList (map (typeRep context) xs)]
JsType x -> JsList [JsLit $ JsStr "action",JsList [typeRep context x]]
ListType x -> JsList [JsLit $ JsStr "list",JsList [typeRep context x]]
TupleType xs -> JsList [JsLit $ JsStr "tuple",JsList (map (typeRep context) xs)]
UserDefined name xs -> JsList [JsLit $ JsStr "user"
,JsLit $ JsStr (unname name)
,JsList (zipWith (\t i -> typeRep (setArg i context) t) xs [0..])]
Defined x -> JsList [JsLit $ JsStr "defined",JsList [typeRep context x]]
Nullable x -> JsList [JsLit $ JsStr "nullable",JsList [typeRep context x]]
_ -> nom
where setArg i SerializeUserArg{} = SerializeUserArg i
setArg _ c = c
ret = JsList . return . JsLit . JsStr
nom = case typ of
StringType -> ret "string"
DoubleType -> ret "double"
IntType -> ret "int"
BoolType -> ret "bool"
DateType -> ret "date"
_ ->
case context of
SerializeAnywhere -> ret "unknown"
SerializeUserArg i ->
let args = JsIndex 2 (JsName JsParametrizedType)
thisArg = JsIndex i args
unknown = ret "unknown"
in JsTernaryIf args
(JsTernaryIf thisArg
thisArg
unknown)
unknown
typeArity :: Type -> Int
typeArity t =
case t of
TyForall _ _ i -> typeArity i
TyFun _ b -> 1 + typeArity b
TyParen st -> typeArity st
_ -> 0
formatFFI :: String
-> [(JsName,FundamentalType)]
-> Compile String
formatFFI formatstr args = go formatstr where
go ('%':'*':xs) = do
these <- mapM inject (zipWith const [1..] args)
rest <- go xs
return (intercalate "," these ++ rest)
go ('%':'%':xs) = do
rest <- go xs
return ('%' : rest)
go ['%'] = throwError FfiFormatIncompleteArg
go ('%':(span isDigit -> (op,xs))) =
case readMay op of
Nothing -> throwError (FfiFormatBadChars op)
Just n -> do
this <- inject n
rest <- go xs
return (this ++ rest)
go (x:xs) = do rest <- go xs
return (x : rest)
go [] = return []
inject n =
case listToMaybe (drop (n1) args) of
Nothing -> throwError (FfiFormatNoSuchArg n)
Just (arg,typ) -> do
return (printJSString (fayToJs (typeRep SerializeAnywhere typ) (JsName arg)))
explodeFields :: [([a], t)] -> [(a, t)]
explodeFields = concatMap $ \(names,typ) -> map (,typ) names
fayToJsDispatcher :: [JsStmt] -> JsStmt
fayToJsDispatcher cases =
JsVar (JsBuiltIn "fayToJsUserDefined")
(JsFun [JsNameVar "type",transcodingObj]
(decl ++ cases ++ [baseCase])
Nothing)
where decl = [JsVar transcodingObjForced
(force (JsName transcodingObj))
,JsVar (JsNameVar "argTypes")
(JsLookup (JsName (JsNameVar "type"))
(JsLit (JsInt 2)))]
baseCase =
JsEarlyReturn (JsName transcodingObj)
jsToFayDispatcher :: [JsStmt] -> JsStmt
jsToFayDispatcher cases =
JsVar (JsBuiltIn "jsToFayUserDefined")
(JsFun [JsNameVar "type",transcodingObj]
(cases ++ [baseCase])
Nothing)
where baseCase =
JsEarlyReturn (JsName transcodingObj)
emitJsToFay :: Name -> [([Name], BangType)] -> Compile ()
emitJsToFay name (explodeFields -> fieldTypes) = do
qname <- qualify name
modify $ \s -> s { stateJsToFay = translator qname : stateJsToFay s }
where
translator qname =
JsIf (JsEq (JsGetPropExtern (JsName transcodingObj) "instance")
(JsLit (JsStr (printJSString name))))
[JsEarlyReturn (JsNew (JsConstructor qname)
(zipWith decodeField fieldTypes [0..]))]
[]
decodeField :: (Name,BangType) -> Int -> JsExp
decodeField (fname,typ) i =
jsToFay (SerializeUserArg i)
(argType (bangType typ))
(JsGetPropExtern (JsName transcodingObj)
(prettyPrint fname))