module Language.Fay
where
import Language.Fay.Print ()
import Language.Fay.Types
import Control.Applicative
import Control.Monad.Error
import Control.Monad.IO
import Control.Monad.State
import Data.List
import Data.Maybe
import Data.String
import Language.Haskell.Exts
import System.Process.Extra
compile :: CompilesTo from to => CompileConfig -> from -> IO (Either CompileError (to,CompileState))
compile config = runCompile config . compileTo
runCompile :: CompileConfig -> Compile a -> IO (Either CompileError (a,CompileState))
runCompile config m = runErrorT (runStateT (unCompile m) state) where
state = CompileState { stateConfig = config
, stateExports = []
, stateModuleName = "Main"
, stateExportAll = True
}
compileViaStr :: (Show from,Show to,CompilesTo from to)
=> CompileConfig
-> (from -> Compile to)
-> String
-> IO (Either CompileError (String,CompileState))
compileViaStr config with from =
runCompile config
(parseResult (throwError . uncurry ParseError)
(fmap printJS . with)
(parse from))
compileToAst :: (Show from,Show to,CompilesTo from to)
=> CompileConfig
-> (from -> Compile to)
-> String
-> IO (Either CompileError (to,CompileState))
compileToAst config with from =
runCompile config
(parseResult (throwError . uncurry ParseError)
with
(parse from))
compileFromStr :: (Parseable a, MonadError CompileError m) => (a -> m a1) -> String -> m a1
compileFromStr with from =
parseResult (throwError . uncurry ParseError)
(with)
(parse from)
printCompile :: (Show from,Show to,CompilesTo from to)
=> CompileConfig
-> (from -> Compile to)
-> String
-> IO ()
printCompile config with from = do
result <- compileViaStr config with from
case result of
Left err -> putStrLn $ show err
Right (ok,_) -> do writeFile "/tmp/x.js" ok
prettyPrintFile "/tmp/x.js" >>= putStr
compileModule :: Module -> Compile [JsStmt]
compileModule (Module _ modulename _pragmas Nothing exports imports decls) = do
modify $ \s -> s { stateModuleName = modulename
, stateExportAll = isNothing exports
}
mapM_ emitExport (fromMaybe [] exports)
imported <- fmap concat (mapM compileImport imports)
current <- compileDecls True decls
return (imported ++ current)
compileModule mod = throwError (UnsupportedModuleSyntax mod)
instance CompilesTo Module [JsStmt] where compileTo = compileModule
compileImport :: ImportDecl -> Compile [JsStmt]
compileImport (ImportDecl _ (ModuleName name) _ _ _ _ _)
| isPrefixOf "Language.Fay." name || name == "Prelude" = return []
compileImport (ImportDecl _ (ModuleName name) False _ Nothing Nothing Nothing) = do
contents <- io (readFile (replace '.' '/' name ++ ".hs"))
compileFromStr compileModule contents
where replace c r = map (\x -> if x == c then r else x)
compileImport i =
error $ "Import syntax not supported. " ++
"The compiler writer was too lazy to support that.\n" ++
"It was: " ++ show i
compileDecls :: Bool -> [Decl] -> Compile [JsStmt]
compileDecls toplevel decls = do
case decls of
[] -> return []
(TypeSig _ _ sig:bind@PatBind{}:decls) -> appendM (compilePatBind toplevel (Just sig) bind)
(compileDecls toplevel decls)
(decl:decls) -> appendM (compileDecl toplevel decl)
(compileDecls toplevel decls)
where appendM m n = do x <- m
xs <- n
return (x ++ xs)
compileDecl :: Bool -> Decl -> Compile [JsStmt]
compileDecl toplevel decl =
case decl of
pat@PatBind{} -> compilePatBind toplevel Nothing pat
FunBind matches -> compileFunCase toplevel matches
DataDecl _ DataType _ _ _ constructors _ -> compileDataDecl toplevel decl constructors
TypeDecl{} -> return []
TypeSig{} -> return []
InfixDecl{} -> return []
ClassDecl{} -> return []
InstDecl{} -> return []
_ -> throwError (UnsupportedDeclaration decl)
compilePatBind :: Bool -> Maybe Type -> Decl -> Compile [JsStmt]
compilePatBind toplevel sig pat = do
case pat of
PatBind _ (PVar ident) Nothing (UnGuardedRhs rhs) (BDecls []) ->
case ffiExp rhs <|> ffiProp rhs of
Just detail@(binding,_,_) ->
case sig of
Nothing -> compileNormalPatBind toplevel ident rhs
Just sig -> case () of
() | func binding -> compileFFIFunc sig ident detail
| method binding -> compileFFIMethod sig ident detail
| setprop binding -> compileFFISetProp sig ident detail
| otherwise -> throwError (FfiNeedsTypeSig pat)
_ -> compileNormalPatBind toplevel ident rhs
_ -> throwError (UnsupportedDeclaration pat)
where func = flip elem ["foreignFay","foreignPure","foreignValue"]
method = flip elem ["foreignMethodFay","foreignProp","foreignPropFay","foreignMethod"]
setprop = flip elem ["foreignSetProp"]
ffiExp (App (App (Var (UnQual (Ident ident)))
(Lit (String name)))
(Con (UnQual (Ident (reads -> [(typ,"")])))))
| func ident || method ident || setprop ident = Just (ident,name,typ)
ffiExp _ = Nothing
ffiProp (App (Var (UnQual (Ident ident)))
(Lit (String name)))
| func ident || method ident || setprop ident = Just (ident,name,FayNone)
ffiProp _ = Nothing
compileNormalPatBind :: Bool -> Name -> Exp -> Compile [JsStmt]
compileNormalPatBind toplevel ident rhs = do
body <- compileExp rhs
bind <- bindToplevel toplevel (UnQual ident) (thunk body)
return [bind]
compileFFIFunc :: Type -> Name -> (String,String,FayReturnType) -> Compile [JsStmt]
compileFFIFunc sig ident detail@(_,name,_) = do
let args = zipWith const uniqueNames [1..typeArity sig]
compileFFI sig ident detail (JsRawName name) args args
compileFFIMethod :: Type -> Name -> (String,String,FayReturnType) -> Compile [JsStmt]
compileFFIMethod sig ident detail@(_,name,_) = do
let args = zipWith const uniqueNames [1..typeArity sig]
jsargs = drop 1 args
obj = head args
compileFFI sig ident detail (JsGetPropExtern (force (JsName obj)) (fromString name)) args jsargs
compileFFISetProp :: Type -> Name -> (String,String,FayReturnType) -> Compile [JsStmt]
compileFFISetProp sig ident detail@(_,name,_) = do
let args = zipWith const uniqueNames [1..typeArity sig]
jsargs = drop 1 args
obj = head args
compileFFI sig
ident
detail
(JsUpdatePropExtern (force (JsName obj))
(fromString name)
(serialize (head (tail funcTypes))
(JsName (head jsargs))))
args
[]
where funcTypes = functionTypeArgs sig
compileFFI :: Type
-> Name
-> (String,String,FayReturnType)
-> JsExp
-> [JsName]
-> [JsName]
-> Compile [JsStmt]
compileFFI sig ident (binding,_,typ) exp params args = do
let innerexp
| length args == 0 && elem binding ["foreignProp","foreignPropFay","foreignValue"] = exp
| binding == "foreignSetProp" = exp
| otherwise = JsApp exp
(map (\(typ,name) -> serialize typ (JsName name))
(zip types args))
bind <- bindToplevel True
(UnQual ident)
(foldr (\name inner -> JsFun [name] [] (Just inner))
(thunk
(maybeMonad
(if binding == "foreignSetProp"
then innerexp
else unserialize typ innerexp)))
params)
return [bind]
where (maybeMonad,types) | binding == "foreignFay" = (monad,funcTypes)
| binding == "foreignProp" = (id,drop 1 funcTypes)
| binding == "foreignMethodFay" = (monad,drop 1 funcTypes)
| binding == "foreignPropFay" = (monad,drop 1 funcTypes)
| binding == "foreignMethod" = (id,drop 1 funcTypes)
| binding == "foreignSetProp" = (monad,[])
| otherwise = (id,funcTypes)
funcTypes = functionTypeArgs sig
data ArgType = FunctionType | JsType | StringType | DoubleType | ListType | BoolType | UnknownType
deriving (Show,Eq)
serialize :: ArgType -> JsExp -> JsExp
serialize typ exp =
JsApp (JsName (hjIdent "serialize"))
[JsName (fromString (show typ)),exp]
functionTypeArgs :: Type -> [ArgType]
functionTypeArgs t =
case t of
TyForall _ _ i -> functionTypeArgs i
TyFun a b -> argType a : functionTypeArgs b
TyParen st -> functionTypeArgs st
_ -> []
where argType t =
case t of
TyApp (TyCon "Fay") _ -> JsType
TyCon "String" -> StringType
TyCon "Double" -> DoubleType
TyCon "Bool" -> BoolType
TyFun{} -> FunctionType
TyList _ -> ListType
_ -> UnknownType
typeArity :: Type -> Integer
typeArity t =
case t of
TyForall _ _ i -> typeArity i
TyFun _ b -> 1 + typeArity b
TyParen st -> typeArity st
_ -> 0
compileDataDecl :: Bool -> Decl -> [QualConDecl] -> Compile [JsStmt]
compileDataDecl toplevel decl constructors = do
fmap concat $
forM constructors $ \(QualConDecl _ _ _ condecl) ->
case condecl of
ConDecl (UnQual -> name) types -> fmap return (makeDataCons name types [])
RecDecl (UnQual -> name) fields -> do
cons <- makeDataCons name (map snd fields) (map fst fields)
funs <- makeAccessors (zip [1..] (map fst fields))
return (cons : funs)
_ -> throwError (UnsupportedDeclaration decl)
where makeDataCons name types fields = do
let slots = (map (fromString . ("slot"++) . show . fst)
(zip [1 :: Integer ..] types))
return $
JsVar name
(foldr (\slot inner -> JsFun [slot] [] (Just inner))
(thunk (JsList ((JsNew (hjIdent "Constructor")
(JsLit (JsStr (qname name)) :
concat (map (map (JsLit . JsStr . unname)) fields)))
: map JsName slots)))
slots)
makeAccessors fields = do
fmap concat $
forM fields $ \(i,field) ->
forM field $ \name ->
bindToplevel toplevel
(UnQual name)
(JsFun ["x"]
[]
(Just (thunk (JsIndex i (force (JsName "x"))))))
qname :: QName -> String
qname (UnQual (Ident str)) = str
qname _ = error "qname: Expected unqualified ident."
unname :: Name -> String
unname (Ident str) = str
unname _ = error "Expected ident from uname."
compileFunCase :: Bool -> [Match] -> Compile [JsStmt]
compileFunCase _toplevel [] = return []
compileFunCase toplevel matches@(Match _ name argslen _ _ _:_) = do
tco <- config configTCO
pats <- fmap optimizePatConditions $ forM matches $ \match@(Match _ _ pats _ rhs wheres) -> do
unless (noBinds wheres) $ do _ <- throwError (UnsupportedWhereInMatch match)
return ()
exp <- compileRhs rhs
foldM (\inner (arg,pat) -> do
compilePat (JsName arg) pat inner)
[JsEarlyReturn exp]
(zip args pats)
bind <- bindToplevel toplevel
(UnQual name)
(foldr (\arg inner -> JsFun [arg] [] (Just inner))
(stmtsThunk (let stmts = (concat pats ++ basecase)
in if tco
then optimizeTailCalls args name stmts
else stmts))
args)
return [bind]
where args = zipWith const uniqueNames argslen
basecase = if any isWildCardMatch matches
then []
else [throw ("unhandled case in " ++ show name)
(JsList (map JsName args))]
isWildCardMatch (Match _ _ pats _ _ _) = all isWildCardPat pats
noBinds (BDecls []) = True
noBinds (IPBinds []) = True
noBinds _ = False
optimizeTailCalls :: [JsParam]
-> Name
-> [JsStmt]
-> [JsStmt]
optimizeTailCalls params name stmts = abandonIfNoChange $
JsWhile (JsLit (JsBool True))
(concatMap replaceTailStmt
(reverse (zip (reverse stmts) [0::Integer ..])))
where replaceTailStmt (JsIf cond sothen orelse,i) = [JsIf cond (concatMap (replaceTailStmt . (,i)) sothen)
(concatMap (replaceTailStmt . (,i)) orelse)]
replaceTailStmt (JsEarlyReturn exp,i) = expTailReplace i exp
replaceTailStmt (x,_) = [x]
expTailReplace i (flatten -> Just (JsName (UnQual call):args@(_:_)))
| call == name = updateParamsInstead i args
expTailReplace _i original = [JsEarlyReturn original]
updateParamsInstead i args = zipWith JsUpdate params args ++
[JsContinue | i /= 0]
abandonIfNoChange (JsWhile _ newstmts)
| newstmts == stmts = stmts
abandonIfNoChange new = [new]
flatten :: JsExp -> Maybe [JsExp]
flatten (JsApp op@JsApp{} arg) = do
inner <- expand op
return (inner ++ arg)
flatten name@JsName{} = return [name]
flatten _ = Nothing
expand :: JsExp -> Maybe [JsExp]
expand (JsApp (JsName (UnQual (Ident "_"))) xs) = do
fmap concat (mapM flatten xs)
expand _ = Nothing
prettyPrintFile :: String -> IO String
prettyPrintFile file = fmap (either id id) (readAllFromProcess "js-beautify" file)
compileRhs :: Rhs -> Compile JsExp
compileRhs (UnGuardedRhs exp) = compileExp exp
compileRhs rhs = throwError (UnsupportedRhs rhs)
compileFunMatch :: Bool -> Match -> Compile [JsStmt]
compileFunMatch toplevel match =
case match of
(Match _ name args Nothing (UnGuardedRhs rhs) _) -> do
body <- compileExp rhs
args <- mapM patToArg args
bind <- bindToplevel toplevel
(UnQual name)
(foldr (\arg inner -> JsFun [arg] [] (Just inner))
(thunk body)
args)
return [bind]
match -> throwError (UnsupportedMatchSyntax match)
where patToArg (PVar name) = return (UnQual name)
patToArg _ = throwError (UnsupportedMatchSyntax match)
instance CompilesTo Decl [JsStmt] where compileTo = compileDecl False
compileExp :: Exp -> Compile JsExp
compileExp exp =
case exp of
Paren exp -> compileExp exp
Var (UnQual (Ident "return")) -> return (JsName (hjIdent "return"))
Var qname -> return (JsName qname)
Lit lit -> compileLit lit
App exp1 exp2 -> compileApp exp1 exp2
InfixApp exp1 op exp2 -> compileInfixApp exp1 op exp2
Let (BDecls decls) exp -> compileLet decls exp
List [] -> return JsNull
List xs -> compileList xs
Tuple xs -> compileList xs
If cond conseq alt -> compileIf cond conseq alt
Case exp alts -> compileCase exp alts
Con (UnQual (Ident "True")) -> return (JsName "true")
Con (UnQual (Ident "False")) -> return (JsName "false")
Con exp -> return (JsName exp)
Do stmts -> compileDoBlock stmts
Lambda _ pats exp -> compileLambda pats exp
EnumFrom i -> do e <- compileExp i
return (JsApp (JsName "enumFrom") [e])
EnumFromTo i i' -> do f <- compileExp i
t <- compileExp i'
return (JsApp (JsApp (JsName "enumFromTo") [f])
[t])
ExpTypeSig _ e _ -> compileExp e
exp -> throwError (UnsupportedExpression exp)
instance CompilesTo Exp JsExp where compileTo = compileExp
compileApp :: Exp -> Exp -> Compile JsExp
compileApp exp1 exp2 = do
flattenApps <- config configFlattenApps
if flattenApps then method2 else method1
where
method1 =
JsApp <$> (forceFlatName <$> compileExp exp1)
<*> fmap return (compileExp exp2)
forceFlatName name = JsApp (JsName "_") [name]
method2 = fmap flatten $
JsApp <$> compileExp exp1
<*> fmap return (compileExp exp2)
flatten (JsApp op args) =
case op of
JsApp l r -> JsApp l (r ++ args)
_ -> JsApp (JsName "__") (op : args)
flatten x = x
compileInfixApp :: Exp -> QOp -> Exp -> Compile JsExp
compileInfixApp exp1 op exp2 = do
config <- config id
case getOp op of
UnQual (Symbol symbol)
| symbol `elem` words "* + - / < > || &&" -> do
e1 <- compileExp exp1
e2 <- compileExp exp2
return (JsInfix symbol (forceInlinable config e1) (forceInlinable config e2))
_ -> do
var <- resolveOpToVar op
compileExp (App (App var exp1) exp2)
where getOp (QVarOp op) = op
getOp (QConOp op) = op
compileList :: [Exp] -> Compile JsExp
compileList xs = do
exps <- mapM compileExp xs
return (JsApp (JsName (hjIdent "list")) [JsList exps])
compileIf :: Exp -> Exp -> Exp -> Compile JsExp
compileIf cond conseq alt =
JsTernaryIf <$> fmap force (compileExp cond)
<*> compileExp conseq
<*> compileExp alt
compileLambda :: [Pat] -> Exp -> Compile JsExp
compileLambda pats exp = do
exp <- compileExp exp
stmts <- foldM (\inner (param,pat) -> do
stmts <- compilePat (JsName param) pat inner
return [JsEarlyReturn (JsFun [param] (stmts ++ [unhandledcase param | not allfree]) Nothing)])
[JsEarlyReturn exp]
(reverse (zip uniqueNames pats))
case stmts of
[JsEarlyReturn fun@JsFun{}] -> return fun
_ -> error "Unexpected statements in compileLambda"
where unhandledcase = throw "unhandled case" . JsName
allfree = all isWildCardPat pats
compileCase :: Exp -> [Alt] -> Compile JsExp
compileCase exp alts = do
exp <- compileExp exp
pats <- fmap optimizePatConditions $ mapM (compilePatAlt (JsName (tmpName exp))) alts
return $
(JsApp (JsFun [tmpName exp]
(concat pats)
(if any isWildCardAlt alts
then Nothing
else Just (throwExp "unhandled case" (JsName (tmpName exp)))))
[exp])
compileDoBlock :: [Stmt] -> Compile JsExp
compileDoBlock stmts = do
doblock <- foldM compileStmt Nothing (reverse stmts)
maybe (throwError EmptyDoBlock) compileExp doblock
compileStmt :: Maybe Exp -> Stmt -> Compile (Maybe Exp)
compileStmt inner stmt =
case inner of
Nothing -> initStmt
Just inner -> subsequentStmt inner
where initStmt =
case stmt of
Qualifier exp -> return (Just exp)
LetStmt{} -> throwError LetUnsupported
_ -> throwError InvalidDoBlock
subsequentStmt inner =
case stmt of
Generator loc pat exp -> compileGenerator loc pat inner exp
Qualifier exp -> return (Just (InfixApp exp
(QVarOp (UnQual (Symbol ">>")))
inner))
LetStmt{} -> throwError LetUnsupported
RecStmt{} -> throwError RecursiveDoUnsupported
compileGenerator srcloc pat inner exp = do
let body = (Lambda srcloc [pat] inner)
return (Just (InfixApp exp
(QVarOp (UnQual (Symbol ">>=")))
body))
compilePatAlt :: JsExp -> Alt -> Compile [JsStmt]
compilePatAlt exp (Alt _ pat rhs _) = do
alt <- compileGuardedAlt rhs
compilePat exp pat [JsEarlyReturn alt]
compilePat :: JsExp -> Pat -> [JsStmt] -> Compile [JsStmt]
compilePat exp pat body = do
case pat of
PVar name -> return ([JsVar (UnQual name) exp] ++ body)
PApp cons pats -> compilePApp cons pats exp body
PLit literal -> compilePLit exp literal body
PParen pat -> compilePat exp pat body
PWildCard -> return body
pat@PInfixApp{} -> compileInfixPat exp pat body
PList pats -> compilePList pats body exp
PTuple pats -> compilePList pats body exp
pat -> throwError (UnsupportedPattern pat)
compilePLit :: JsExp -> Literal -> [JsStmt] -> Compile [JsStmt]
compilePLit exp literal body = do
lit <- compileLit literal
return [JsIf (equalExps exp lit)
body
[]]
equalExps :: JsExp -> JsExp -> JsExp
equalExps a b
| isConstant a && isConstant b = JsEq a b
| isConstant a = JsEq a (force b)
| isConstant b = JsEq (force a) b
| otherwise =
JsApp (JsName (hjIdent "equal")) [a,b]
isConstant :: JsExp -> Bool
isConstant JsLit{} = True
isConstant _ = False
compilePApp :: QName -> [Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt]
compilePApp cons pats exp body = do
let forcedExp = force exp
substmts <- foldM (\body (i,pat) -> compilePat (JsIndex i forcedExp) pat body)
body
(reverse (zip [1..] pats))
let constructor = JsIndex 0 forcedExp
compareConstructorNames
| cons == "True" = JsEq forcedExp (JsLit (JsBool True))
| cons == "False" = JsEq forcedExp (JsLit (JsBool False))
| otherwise =
JsEq (JsGetProp constructor "name")
(JsLit (JsStr (qname cons)))
return [JsIf compareConstructorNames
substmts
[]]
compilePList :: [Pat] -> [JsStmt] -> JsExp -> Compile [JsStmt]
compilePList [] body exp =
return [JsIf (JsEq (force exp) JsNull) body []]
compilePList pats body exp = do
let forcedExp = force exp
substmts <- foldM (\body (i,pat) -> compilePat (JsApp (JsApp (JsName (hjIdent "index"))
[JsLit (JsInt i)])
[forcedExp])
pat body)
body
(reverse (zip [0..] pats))
return substmts
compileInfixPat :: JsExp -> Pat -> [JsStmt] -> Compile [JsStmt]
compileInfixPat exp pat@(PInfixApp left (Special cons) right) body =
case cons of
Cons -> do
let forcedExp = JsName (tmpName exp)
x = (JsGetProp forcedExp "car")
xs = (JsGetProp forcedExp "cdr")
rightMatch <- compilePat xs right body
leftMatch <- compilePat x left rightMatch
return [JsVar (tmpName exp) (force exp)
,JsIf (JsInstanceOf forcedExp (hjIdent "Cons"))
leftMatch
[]]
_ -> throwError (UnsupportedPattern pat)
compileInfixPat _ pat _ = throwError (UnsupportedPattern pat)
compileGuardedAlt :: GuardedAlts -> Compile JsExp
compileGuardedAlt alt =
case alt of
UnGuardedAlt exp -> compileExp exp
alt -> throwError (UnsupportedGuardedAlts alt)
compileLet :: [Decl] -> Exp -> Compile JsExp
compileLet decls exp = do
body <- compileExp exp
binds <- mapM compileLetDecl decls
return (JsApp (JsFun [] (concat binds) (Just body)) [])
compileLetDecl :: Decl -> Compile [JsStmt]
compileLetDecl decl =
case decl of
decl@PatBind{} -> compileDecls False [decl]
decl@FunBind{} -> compileDecls False [decl]
_ -> throwError (UnsupportedLetBinding decl)
compileLit :: Literal -> Compile JsExp
compileLit lit =
case lit of
Char ch -> return (JsLit (JsChar ch))
Int integer -> return (JsLit (JsInt (fromIntegral integer)))
Frac rational -> return (JsLit (JsFloating (fromRational rational)))
String string -> return (JsApp (JsName (hjIdent "list"))
[JsLit (JsStr string)])
lit -> throwError (UnsupportedLiteral lit)
uniqueNames :: [JsParam]
uniqueNames = map (fromString . ("$_" ++))
$ map return "abcxyz" ++
zipWith (:) (cycle "v")
(map show [1 :: Integer ..])
optimizePatConditions :: [[JsStmt]] -> [[JsStmt]]
optimizePatConditions = concat . map merge . groupBy sameIf where
sameIf [JsIf cond1 _ _] [JsIf cond2 _ _] = cond1 == cond2
sameIf _ _ = False
merge xs@([JsIf cond _ _]:_) =
[[JsIf cond (concat (optimizePatConditions (map getIfConsequent xs))) []]]
merge noifs = noifs
getIfConsequent [JsIf _ cons _] = cons
getIfConsequent other = other
throw :: String -> JsExp -> JsStmt
throw msg exp = JsThrow (JsList [JsLit (JsStr msg),exp])
throwExp :: String -> JsExp -> JsExp
throwExp msg exp = JsThrowExp (JsList [JsLit (JsStr msg),exp])
isWildCardAlt :: Alt -> Bool
isWildCardAlt (Alt _ pat _ _) = isWildCardPat pat
isWildCardPat :: Pat -> Bool
isWildCardPat PWildCard{} = True
isWildCardPat PVar{} = True
isWildCardPat _ = False
tmpName :: JsExp -> JsName
tmpName exp =
fromString $
case exp of
JsName (qname -> x) -> "$_" ++ x
_ -> ":tmp"
thunk :: JsExp -> JsExp
thunk exp =
case exp of
JsLit{} -> exp
JsName "true" -> exp
JsName "false" -> exp
JsApp fun@JsFun{} [] -> JsNew ":thunk" [fun]
_ -> JsNew ":thunk" [JsFun [] [] (Just exp)]
monad :: JsExp -> JsExp
monad exp = JsNew (hjIdent "Monad") [exp]
stmtsThunk :: [JsStmt] -> JsExp
stmtsThunk stmts = JsNew ":thunk" [JsFun [] stmts Nothing]
unserialize :: FayReturnType -> JsExp -> JsExp
unserialize typ exp =
JsApp (JsName (hjIdent "unserialize"))
[JsLit (JsStr (showReturnType typ)),exp]
where showReturnType typ =
case typ of
FayArray -> "array"
FayList -> "list"
FayString -> "string"
FayBool -> "bool"
FayNone -> ""
force :: JsExp -> JsExp
force exp
| isConstant exp = exp
| otherwise = JsApp (JsName "_") [exp]
forceInlinable :: CompileConfig -> JsExp -> JsExp
forceInlinable config exp
| isConstant exp = exp
| configInlineForce config =
JsParen (JsTernaryIf (exp `JsInstanceOf` ":thunk")
(JsApp (JsName "_") [exp])
exp)
| otherwise = JsApp (JsName "_") [exp]
resolveOpToVar :: QOp -> Compile Exp
resolveOpToVar op =
case getOp op of
UnQual (Symbol symbol)
| symbol == "*" -> return (Var (hjIdent "mult"))
| symbol == "+" -> return (Var (hjIdent "add"))
| symbol == "-" -> return (Var (hjIdent "sub"))
| symbol == "/" -> return (Var (hjIdent "div"))
| symbol == "==" -> return (Var (hjIdent "eq"))
| symbol == "/=" -> return (Var (hjIdent "neq"))
| symbol == ">" -> return (Var (hjIdent "gt"))
| symbol == "<" -> return (Var (hjIdent "lt"))
| symbol == ">=" -> return (Var (hjIdent "gte"))
| symbol == "<=" -> return (Var (hjIdent "lte"))
| symbol == "&&" -> return (Var (hjIdent "and"))
| symbol == "||" -> return (Var (hjIdent "or"))
| symbol == ">>=" -> return (Var (hjIdent "bind"))
| symbol == ">>" -> return (Var (hjIdent "then"))
| otherwise -> return (Var (fromString symbol))
Special Cons -> return (Var (hjIdent "cons"))
_ -> throwError (UnsupportedOperator op)
where getOp (QVarOp op) = op
getOp (QConOp op) = op
hjIdent :: String -> QName
hjIdent = Qual (ModuleName "Fay") . Ident
bindToplevel :: Bool -> QName -> JsExp -> Compile JsStmt
bindToplevel toplevel name exp = do
exportAll <- gets stateExportAll
when (toplevel && exportAll) $ emitExport (EVar name)
return (JsVar name exp)
emitExport :: ExportSpec -> Compile ()
emitExport spec =
case spec of
EVar (UnQual name) -> modify $ \s -> s { stateExports = name : stateExports s }
EVar _ -> error "Emitted a qualifed export, not supported."
_ -> throwError (UnsupportedExportSpec spec)
parseResult :: ((SrcLoc,String) -> b) -> (a -> b) -> ParseResult a -> b
parseResult fail ok result =
case result of
ParseOk a -> ok a
ParseFailed srcloc msg -> fail (srcloc,msg)
config :: (CompileConfig -> a) -> Compile a
config f = gets (f . stateConfig)