module Language.Fay.Compiler
(runCompile
,compileViaStr
,compileForDocs
,compileToAst
,compileModule
,compileExp
,compileDecl
,printCompile
,printTestCompile
,compileToplevelModule)
where
import Language.Fay.Compiler.FFI
import Language.Fay.Compiler.Misc
import Language.Fay.Compiler.Optimizer
import Language.Fay.ModuleScope (bindAsLocals, findTopLevelNames, moduleLocals)
import Language.Fay.Print (printJSString)
import qualified Language.Fay.Stdlib as Stdlib
import Language.Fay.Types
import Control.Applicative
import Control.Monad.Error
import Control.Monad.IO
import Control.Monad.State
import Control.Monad.RWS
import Data.Default (def)
import Data.List
import Data.List.Extra
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Maybe
import qualified GHC.Paths as GHCPaths
import Language.Haskell.Exts
import System.Directory (doesFileExist)
import System.FilePath ((</>))
import System.Process.Extra
runCompile :: CompileReader -> CompileState
-> Compile a
-> IO (Either CompileError (a,CompileState))
runCompile reader state m =
fmap (fmap dropWriter)
(runErrorT (runRWST (unCompile m) reader state))
where dropWriter (a,s,_w) = (a,s)
compileViaStr :: (Show from,Show to,CompilesTo from to)
=> FilePath
-> CompileConfig
-> (from -> Compile to)
-> String
-> IO (Either CompileError (PrintState,CompileState))
compileViaStr filepath config with from = do
cs <- defaultCompileState
rs <- defaultCompileReader config
runCompile rs
(cs { stateFilePath = filepath })
(parseResult (throwError . uncurry ParseError)
(fmap (\x -> execState (runPrinter (printJS x)) printConfig) . with)
(parseFay filepath from))
where printConfig = def { psPretty = configPrettyPrint config }
compileToAst :: (Show from,Show to,CompilesTo from to)
=> FilePath
-> CompileReader
-> CompileState
-> (from -> Compile to)
-> String
-> IO (Either CompileError (to,CompileState))
compileToAst filepath reader state with from =
runCompile reader
state
(parseResult (throwError . uncurry ParseError)
with
(parseFay filepath from))
parseFay :: Parseable ast => FilePath -> String -> ParseResult ast
parseFay filepath = parseWithMode parseMode { parseFilename = filepath } . applyCPP
applyCPP :: String -> String
applyCPP =
unlines . loop NoCPP . lines
where
loop _ [] = []
loop state ("#if FAY":rest) = "" : loop (CPPIf True state) rest
loop state ("#ifdef FAY":rest) = "" : loop (CPPIf True state) rest
loop state ("#ifndef FAY":rest) = "" : loop (CPPIf False state) rest
loop (CPPIf b oldState) ("#else":rest) = "" : loop (CPPElse (not b) oldState) rest
loop (CPPIf _ oldState) ("#endif":rest) = "" : loop oldState rest
loop (CPPElse _ oldState) ("#endif":rest) = "" : loop oldState rest
loop state (x:rest) = (if toInclude state then x else "") : loop state rest
toInclude NoCPP = True
toInclude (CPPIf x state) = x && toInclude state
toInclude (CPPElse x state) = x && toInclude state
data CPPState = NoCPP
| CPPIf Bool CPPState
| CPPElse Bool CPPState
parseMode :: ParseMode
parseMode = defaultParseMode { extensions =
[GADTs,StandaloneDeriving,PackageImports,EmptyDataDecls,TypeOperators,RecordWildCards,NamedFieldPuns] }
printCompile :: (Show from,Show to,CompilesTo from to)
=> CompileConfig
-> (from -> Compile to)
-> String
-> IO ()
printCompile config with from = do
result <- compileViaStr "<interactive>" config { configPrettyPrint = True } with from
case result of
Left err -> print err
Right (PrintState{..},_) -> do
putStrLn (concat (reverse (psOutput)))
printTestCompile :: String -> IO ()
printTestCompile = printCompile def { configWarn = False } compileModule
compileForDocs :: Module -> Compile [JsStmt]
compileForDocs mod = do
initialPass mod
compileModule mod
compileToplevelModule :: Module -> Compile [JsStmt]
compileToplevelModule mod@(Module _ (ModuleName modulename) _ _ _ _ _) = do
cfg <- config id
faydir <- io faySourceDir
let includeDirs = filter (/= faydir) (configDirectoryIncludes cfg)
when (configTypecheck cfg) $
typecheck (configPackageConf cfg) includeDirs [] (configWall cfg) $
fromMaybe modulename $ configFilePath cfg
initialPass mod
cs <- io defaultCompileState
modify $ \s -> s { stateImported = stateImported cs }
stmts <- compileModule mod
fay2js <- do syms <- gets stateFayToJs
return $ if null syms then [] else [fayToJsDispatcher syms]
js2fay <- do syms <- gets stateJsToFay
return $ if null syms then [] else [jsToFayDispatcher syms]
let maybeOptimize = if configOptimize cfg then runOptimizer optimizeToplevel else id
return (maybeOptimize (stmts ++ fay2js ++ js2fay))
initialPass :: Module -> Compile ()
initialPass (Module _ _ _ Nothing _ imports decls) = do
mapM_ initialPass_import imports
mapM_ initialPass_decl decls
initialPass mod = throwError (UnsupportedModuleSyntax mod)
initialPass_import :: ImportDecl -> Compile ()
initialPass_import (ImportDecl _ _ _ _ Just{} _ _) = do
return ()
initialPass_import (ImportDecl _ name False _ Nothing Nothing _) = do
void $ initialPass_unlessImported name $ \filepath contents -> do
state <- get
reader <- ask
result <- liftIO $ initialPass_records filepath reader state initialPass contents
case result of
Right ((),st) -> do
modify $ \s -> s { stateRecords = stateRecords st
, stateRecordTypes = stateRecordTypes st
, stateImported = stateImported st
}
Left err -> throwError err
return ()
initialPass_import i = throwError $ UnsupportedImport i
initialPass_unlessImported :: ModuleName
-> (FilePath -> String -> Compile ())
-> Compile ()
initialPass_unlessImported name importIt = do
imported <- gets stateImported
case lookup name imported of
Just _ -> return ()
Nothing -> do
dirs <- configDirectoryIncludes <$> config id
(filepath,contents) <- findImport dirs name
modify $ \s -> s { stateImported = (name,filepath) : imported }
importIt filepath contents
initialPass_records :: (Show from,Parseable from)
=> FilePath
-> CompileReader
-> CompileState
-> (from -> Compile ())
-> String
-> IO (Either CompileError ((),CompileState))
initialPass_records filepath compileReader compileState with from =
runCompile compileReader
compileState
(parseResult (throwError . uncurry ParseError)
with
(parseFay filepath from))
initialPass_decl :: Decl -> Compile ()
initialPass_decl decl = do
case decl of
DataDecl _loc DataType _ctx name _tyvarb qualcondecls _deriv -> do
let ns = flip map qualcondecls (\(QualConDecl _loc' _tyvarbinds _ctx' condecl) -> conDeclName condecl)
addRecordTypeState name ns
_ -> return ()
case decl of
DataDecl _ DataType _ _ _ constructors _ -> initialPass_dataDecl constructors
GDataDecl _ DataType _l _i _v _n decls _ -> initialPass_dataDecl (map convertGADT decls)
_ -> return ()
where
addRecordTypeState name cons = modify $ \s -> s
{ stateRecordTypes = (UnQual name, map UnQual cons) : stateRecordTypes s }
conDeclName (ConDecl n _) = n
conDeclName (InfixConDecl _ n _) = n
conDeclName (RecDecl n _) = n
initialPass_dataDecl :: [QualConDecl] -> Compile ()
initialPass_dataDecl constructors = do
forM_ constructors $ \(QualConDecl _ _ _ condecl) ->
case condecl of
ConDecl name types -> do
let fields = map (Ident . ("slot"++) . show . fst) . zip [1 :: Integer ..] $ types
addRecordState name fields
InfixConDecl _t1 name _t2 ->
addRecordState name ["slot1", "slot2"]
RecDecl name fields' -> do
let fields = concatMap fst fields'
addRecordState name fields
where
addRecordState :: Name -> [Name] -> Compile ()
addRecordState name fields = modify $ \s -> s
{ stateRecords = (UnQual name,map UnQual fields) : stateRecords s }
typecheck :: Maybe FilePath -> [FilePath] -> [String] -> Bool -> String -> Compile ()
typecheck packageConf includeDirs ghcFlags wall fp = do
ghcPackageDbArgs <-
case packageConf of
Nothing -> return []
Just pk -> do
flag <- liftIO getGhcPackageDbFlag
return [flag ++ '=' : pk]
res <- liftIO $ readAllFromProcess GHCPaths.ghc (
["-fno-code"
,"-package fay"
,"-main-is"
,"Language.Fay.DummyMain"
,fp]
++ ghcPackageDbArgs
++ map ("-i" ++) includeDirs ++ ghcFlags ++ wallF) ""
either error (warn . fst) res
where
wallF | wall = ["-Wall"]
| otherwise = []
compileModule :: Module -> Compile [JsStmt]
compileModule (Module _ modulename _pragmas Nothing exports imports decls) =
withModuleScope $ do
modify $ \s -> s { stateModuleName = modulename
, stateExports = []
, stateModuleScope = findTopLevelNames modulename decls
}
imported <- fmap concat (mapM compileImport imports)
current <- compileDecls True decls
case exports of
Just exps -> mapM_ emitExport exps
Nothing -> do
exps <- moduleLocals modulename <$> gets stateModuleScope
modify $ \s -> s { stateExports = exps ++ stateExports s }
return (imported ++ current)
compileModule mod = throwError (UnsupportedModuleSyntax mod)
instance CompilesTo Module [JsStmt] where compileTo = compileModule
findImport :: [FilePath] -> ModuleName -> Compile (FilePath,String)
findImport alldirs mname = go alldirs mname where
go (dir:dirs) name = do
exists <- io (doesFileExist path)
if exists
then fmap (path,) (fmap stdlibHack (io (readFile path)))
else go dirs name
where
path = dir </> replace '.' '/' (prettyPrint name) ++ ".hs"
replace c r = map (\x -> if x == c then r else x)
go [] name =
throwError $ Couldn'tFindImport name alldirs
stdlibHack
| mname == ModuleName "Language.Fay.Stdlib" = \s -> s ++ "\n\ndata Maybe a = Just a | Nothing"
| mname == ModuleName "Language.Fay.FFI" = const "module Language.Fay.FFI where\n\ndata Nullable a = Nullable a | Null\n\ndata Defined a = Defined a | Undefined"
| otherwise = id
compileImport :: ImportDecl -> Compile [JsStmt]
compileImport (ImportDecl _ _ _ _ Just{} _ _) = do
return []
compileImport (ImportDecl _ name False _ Nothing Nothing Nothing) =
compileImportWithFilter name (const $ return True)
compileImport (ImportDecl _ name False _ Nothing Nothing (Just (True, specs))) =
compileImportWithFilter name (fmap not . imported specs)
compileImport (ImportDecl _ name False _ Nothing Nothing (Just (False, specs))) =
compileImportWithFilter name (imported specs)
compileImport i =
throwError $ UnsupportedImport i
imported :: [ImportSpec] -> QName -> Compile Bool
imported is qn = anyM (matching qn) is
where
matching :: QName -> ImportSpec -> Compile Bool
matching (Qual _ _) (IAbs _) = return True
matching (Qual _ name) (IVar var) = return $ name == var
matching (Qual _ name) (IThingAll typ) = do
recs <- typeToRecs $ UnQual typ
if UnQual name `elem` recs
then return True
else do
fields <- typeToFields $ UnQual typ
return $ UnQual name `elem` fields
matching (Qual _ name) (IThingWith typ cns) =
flip anyM cns $ \cn -> case cn of
ConName _ -> do
recs <- typeToRecs $ UnQual typ
return $ UnQual name `elem` recs
VarName _ -> do
fields <- typeToFields $ UnQual typ
return $ UnQual name `elem` fields
matching q is = error $ "compileImport: Unsupported QName ImportSpec combination " ++ show (q, is) ++ ", this is a bug!"
compileImportWithFilter :: ModuleName -> (QName -> Compile Bool) -> Compile [JsStmt]
compileImportWithFilter name importFilter =
unlessImported name importFilter $ \filepath contents -> do
state <- get
reader <- ask
result <- liftIO $ compileToAst filepath reader state compileModule contents
case result of
Right (stmts,state) -> do
imports <- filterM importFilter $ stateExports state
modify $ \s -> s { stateFayToJs = stateFayToJs state
, stateJsToFay = stateJsToFay state
, stateImported = stateImported state
, stateLocalScope = S.empty
, stateModuleScope = bindAsLocals imports (stateModuleScope s)
}
return stmts
Left err -> throwError err
unlessImported :: ModuleName
-> (QName -> Compile Bool)
-> (FilePath -> String -> Compile [JsStmt])
-> Compile [JsStmt]
unlessImported "Language.Fay.Types" _ _ = return []
unlessImported name importFilter importIt = do
imported <- gets stateImported
case lookup name imported of
Just _ -> do
sec <- gets stateExportsCache
case M.lookup name sec of
Nothing -> throwError $ UnableResolveCachedImport name
Just exports -> do
imports <- filterM importFilter exports
modify $ \s -> s { stateModuleScope = bindAsLocals imports (stateModuleScope s) }
return []
Nothing -> do
dirs <- configDirectoryIncludes <$> config id
(filepath,contents) <- findImport dirs name
res <- importIt filepath contents
exportsCache <- gets stateExports
modify $ \s -> s { stateImported = (name,filepath) : imported
, stateExportsCache = M.insert name exportsCache (stateExportsCache s)
}
return res
compileDecls :: Bool -> [Decl] -> Compile [JsStmt]
compileDecls toplevel decls =
case decls of
[] -> return []
(TypeSig _ _ sig:bind@PatBind{}:decls) -> appendM (scoped (compilePatBind toplevel (Just sig) bind))
(compileDecls toplevel decls)
(decl:decls) -> appendM (scoped (compileDecl toplevel decl))
(compileDecls toplevel decls)
where appendM m n = do x <- m
xs <- n
return (x ++ xs)
scoped = if toplevel then withScope else id
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
GDataDecl _ DataType _l _i _v _n decls _ -> compileDataDecl toplevel decl (map convertGADT decls)
TypeDecl{} -> return []
TypeSig{} -> return []
InfixDecl{} -> return []
ClassDecl{} -> return []
InstDecl{} -> return []
DerivDecl{} -> return []
_ -> throwError (UnsupportedDeclaration decl)
instance CompilesTo Decl [JsStmt] where compileTo = compileDecl True
compilePatBind :: Bool -> Maybe Type -> Decl -> Compile [JsStmt]
compilePatBind toplevel sig pat =
case pat of
PatBind srcloc (PVar ident) Nothing (UnGuardedRhs rhs) (BDecls []) ->
case ffiExp rhs of
Just formatstr -> case sig of
Just sig -> compileFFI srcloc ident formatstr sig
Nothing -> throwError (FfiNeedsTypeSig pat)
_ -> compileUnguardedRhs srcloc toplevel ident rhs
PatBind srcloc (PVar ident) Nothing (UnGuardedRhs rhs) bdecls -> do
compileUnguardedRhs srcloc toplevel ident (Let bdecls rhs)
_ -> throwError (UnsupportedDeclaration pat)
where ffiExp (App (Var (UnQual (Ident "ffi"))) (Lit (String formatstr))) = Just formatstr
ffiExp _ = Nothing
compileUnguardedRhs :: SrcLoc -> Bool -> Name -> Exp -> Compile [JsStmt]
compileUnguardedRhs srcloc toplevel ident rhs = do
unless toplevel $ bindVar ident
withScope $ do
body <- compileExp rhs
bind <- bindToplevel srcloc toplevel ident (thunk body)
return [bind]
convertGADT :: GadtDecl -> QualConDecl
convertGADT d =
case d of
GadtDecl srcloc name typ -> QualConDecl srcloc tyvars context
(ConDecl name (convertFunc typ))
where tyvars = []
context = []
convertFunc (TyCon _) = []
convertFunc (TyFun x xs) = UnBangedTy x : convertFunc xs
convertFunc (TyParen x) = convertFunc x
convertFunc _ = []
compileDataDecl :: Bool -> Decl -> [QualConDecl] -> Compile [JsStmt]
compileDataDecl toplevel _decl constructors =
fmap concat $
forM constructors $ \(QualConDecl srcloc _ _ condecl) ->
case condecl of
ConDecl name types -> do
let fields = map (Ident . ("slot"++) . show . fst) . zip [1 :: Integer ..] $ types
fields' = (zip (map return fields) types)
cons <- makeConstructor name fields
func <- makeFunc name fields
emitFayToJs name fields'
emitJsToFay name fields'
return [cons, func]
InfixConDecl t1 name t2 -> do
let slots = ["slot1","slot2"]
fields = zip (map return slots) [t1, t2]
cons <- makeConstructor name slots
func <- makeFunc name slots
emitFayToJs name fields
emitJsToFay name fields
return [cons, func]
RecDecl name fields' -> do
let fields = concatMap fst fields'
cons <- makeConstructor name fields
func <- makeFunc name fields
funs <- makeAccessors srcloc fields
emitFayToJs name fields'
emitJsToFay name fields'
return (cons : func : funs)
where
makeConstructor :: Name -> [Name] -> Compile JsStmt
makeConstructor name (map (JsNameVar . UnQual) -> fields) = do
qname <- qualify name
emitExport (EVar qname)
return $
JsVar (JsConstructor qname) $
JsFun fields (for fields $ \field -> JsSetProp JsThis field (JsName field))
Nothing
makeFunc :: Name -> [Name] -> Compile JsStmt
makeFunc name (map (JsNameVar . UnQual) -> fields) = do
let fieldExps = map JsName fields
qname <- qualify name
return $ JsVar (JsNameVar qname) $
foldr (\slot inner -> JsFun [slot] [] (Just inner))
(thunk $ JsNew (JsConstructor qname) fieldExps)
fields
makeAccessors :: SrcLoc -> [Name] -> Compile [JsStmt]
makeAccessors srcloc fields =
forM fields $ \name ->
bindToplevel srcloc
toplevel
name
(JsFun [JsNameVar "x"]
[]
(Just (thunk (JsGetProp (force (JsName (JsNameVar "x")))
(JsNameVar (UnQual name))))))
compileFunCase :: Bool -> [Match] -> Compile [JsStmt]
compileFunCase _toplevel [] = return []
compileFunCase toplevel matches@(Match srcloc name argslen _ _ _:_) = do
pats <- fmap optimizePatConditions (mapM compileCase matches)
bindVar name
bind <- bindToplevel srcloc
toplevel
name
(foldr (\arg inner -> JsFun [arg] [] (Just inner))
(stmtsThunk (concat pats ++ basecase))
args)
return [bind]
where args = zipWith const uniqueNames argslen
isWildCardMatch (Match _ _ pats _ _ _) = all isWildCardPat pats
compileCase :: Match -> Compile [JsStmt]
compileCase match@(Match _ _ pats _ rhs _) = do
withScope $ do
whereDecls' <- whereDecls match
generateScope $ zipWithM (\arg pat -> compilePat (JsName arg) pat []) args pats
generateScope $ mapM compileLetDecl whereDecls'
rhsform <- compileRhs rhs
body <- if null whereDecls'
then return $ either id JsEarlyReturn rhsform
else do
binds <- mapM compileLetDecl whereDecls'
return $ case rhsform of
Right exp ->
(JsEarlyReturn (JsApp (JsFun [] (concat binds) (Just exp)) []))
Left stmt ->
(JsEarlyReturn (JsApp (JsFun [] (concat binds ++ [stmt]) Nothing) []))
foldM (\inner (arg,pat) ->
compilePat (JsName arg) pat inner)
[body]
(zip args pats)
whereDecls :: Match -> Compile [Decl]
whereDecls (Match _ _ _ _ _ (BDecls decls)) = return decls
whereDecls match = throwError (UnsupportedWhereInMatch match)
basecase :: [JsStmt]
basecase = if any isWildCardMatch matches
then []
else [throw ("unhandled case in " ++ prettyPrint name)
(JsList (map JsName args))]
compileRhs :: Rhs -> Compile (Either JsStmt JsExp)
compileRhs (UnGuardedRhs exp) = Right <$> compileExp exp
compileRhs (GuardedRhss rhss) = Left <$> compileGuards rhss
compileGuards :: [GuardedRhs] -> Compile JsStmt
compileGuards ((GuardedRhs _ (Qualifier (Var (UnQual (Ident "otherwise"))):_) exp):_) =
(\e -> JsIf (JsLit (JsBool True)) [JsEarlyReturn e] []) <$> compileExp exp
compileGuards (GuardedRhs _ (Qualifier guard:_) exp : rest) =
makeIf <$> fmap force (compileExp guard)
<*> compileExp exp
<*> if null rest then (return []) else do
gs' <- compileGuards rest
return [gs']
where makeIf gs e gss = JsIf gs [JsEarlyReturn e] gss
compileGuards rhss = throwError . UnsupportedRhs . GuardedRhss $ rhss
compileExp :: Exp -> Compile JsExp
compileExp exp =
case exp of
Paren exp -> compileExp exp
Var qname -> compileVar qname
Lit lit -> compileLit lit
App exp1 exp2 -> compileApp exp1 exp2
NegApp exp -> compileNegApp exp
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 (JsLit (JsBool True))
Con (UnQual (Ident "False")) -> return (JsLit (JsBool False))
Con qname -> compileVar qname
Do stmts -> compileDoBlock stmts
Lambda _ pats exp -> compileLambda pats exp
LeftSection e o -> compileExp =<< desugarLeftSection e o
RightSection o e -> compileExp =<< desugarRightSection o e
EnumFrom i -> compileEnumFrom i
EnumFromTo i i' -> compileEnumFromTo i i'
EnumFromThen a b -> compileEnumFromThen a b
EnumFromThenTo a b z -> compileEnumFromThenTo a b z
RecConstr name fieldUpdates -> compileRecConstr name fieldUpdates
RecUpdate rec fieldUpdates -> updateRec rec fieldUpdates
ListComp exp stmts -> compileExp =<< desugarListComp exp stmts
ExpTypeSig _ e _ -> compileExp e
exp -> throwError (UnsupportedExpression exp)
instance CompilesTo Exp JsExp where compileTo = compileExp
compileVar :: QName -> Compile JsExp
compileVar qname = do
qname <- resolveName qname
return (JsName (JsNameVar qname))
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 JsForce) [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 JsApply) (op : args)
flatten x = x
compileNegApp :: Exp -> Compile JsExp
compileNegApp e = JsNegApp . force <$> compileExp e
compileInfixApp :: Exp -> QOp -> Exp -> Compile JsExp
compileInfixApp exp1 ap exp2 = do
qname <- resolveName op
case qname of
Qual "Fay$" _
| prettyPrint ap `elem` words "* + - / < > || &&" -> do
e1 <- compileExp exp1
e2 <- compileExp exp2
fn <- compileExp (Var op)
return $ JsApp (JsApp (force fn) [force e1]) [force e2]
_ -> compileExp (App (App (Var op) exp1) exp2)
where op = getOp ap
getOp (QVarOp op) = op
getOp (QConOp op) = op
compileList :: [Exp] -> Compile JsExp
compileList xs = do
exps <- mapM compileExp xs
return (makeList exps)
makeList :: [JsExp] -> JsExp
makeList exps = (JsApp (JsName (JsBuiltIn "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
withScope $ do
generateScope $ generateStatements JsNull
exp <- compileExp exp
stmts <- generateStatements exp
case stmts of
[JsEarlyReturn fun@JsFun{}] -> return fun
_ -> error "Unexpected statements in compileLambda"
where unhandledcase = throw "unhandled case" . JsName
allfree = all isWildCardPat pats
generateStatements exp =
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))
desugarListComp :: Exp -> [QualStmt] -> Compile Exp
desugarListComp e [] =
return (List [ e ])
desugarListComp e (QualStmt (Generator loc p e2) : stmts) = do
nested <- desugarListComp e stmts
withScopedTmpName $ \f ->
return (Let (BDecls [ FunBind [
Match loc f [ p ] Nothing (UnGuardedRhs nested) (BDecls []),
Match loc f [ PWildCard ] Nothing (UnGuardedRhs (List [])) (BDecls [])
]]) (App (App (Var (UnQual (Ident "concatMap"))) (Var (UnQual f))) e2))
desugarListComp e (QualStmt (Qualifier e2) : stmts) = do
nested <- desugarListComp e stmts
return (If e2 nested (List []))
desugarListComp e (QualStmt (LetStmt bs) : stmts) = do
nested <- desugarListComp e stmts
return (Let bs nested)
desugarListComp _ (s : _ ) =
throwError (UnsupportedQualStmt s)
desugarLeftSection :: Exp -> QOp -> Compile Exp
desugarLeftSection e o = withScopedTmpName $ \tmp ->
return (Lambda undefined [PVar tmp] (InfixApp e o (Var (UnQual tmp))))
desugarRightSection :: QOp -> Exp -> Compile Exp
desugarRightSection o e = withScopedTmpName $ \tmp ->
return (Lambda undefined [PVar tmp] (InfixApp (Var (UnQual tmp)) o e))
compileCase :: Exp -> [Alt] -> Compile JsExp
compileCase exp alts = do
exp <- compileExp exp
withScopedTmpJsName $ \tmpName -> do
pats <- fmap optimizePatConditions $ mapM (compilePatAlt (JsName tmpName)) alts
return $
JsApp (JsFun [tmpName]
(concat pats)
(if any isWildCardAlt alts
then Nothing
else Just (throwExp "unhandled case" (JsName tmpName))))
[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 (BDecls binds) -> return (Just (Let (BDecls binds) 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@(Alt _ pat rhs wheres) = case wheres of
BDecls (_ : _) -> throwError (UnsupportedWhereInAlt alt)
IPBinds (_ : _) -> throwError (UnsupportedWhereInAlt alt)
_ -> withScope $ do
generateScope $ compilePat exp pat []
alt <- compileGuardedAlt rhs
compilePat exp pat [alt]
compilePat :: JsExp -> Pat -> [JsStmt] -> Compile [JsStmt]
compilePat exp pat body =
case pat of
PVar name -> compilePVar 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
PAsPat name pat -> compilePAsPat exp name pat body
PRec name pats -> compilePatFields exp name pats body
pat -> throwError (UnsupportedPattern pat)
compilePVar :: Name -> JsExp -> [JsStmt] -> Compile [JsStmt]
compilePVar name exp body = do
bindVar name
return $ JsVar (JsNameVar (UnQual name)) exp : body
compilePatFields :: JsExp -> QName -> [PatField] -> [JsStmt] -> Compile [JsStmt]
compilePatFields exp name pats body = do
c <- liftM (++ body) (compilePats' [] pats)
qname <- resolveName name
return [JsIf (force exp `JsInstanceOf` JsConstructor qname) c []]
where
compilePats' :: [QName] -> [PatField] -> Compile [JsStmt]
compilePats' names (PFieldPun name:xs) =
compilePats' names (PFieldPat (UnQual name) (PVar name):xs)
compilePats' names (PFieldPat fieldname (PVar varName):xs) = do
r <- compilePats' (fieldname : names) xs
bindVar varName
return $ JsVar (JsNameVar (UnQual varName))
(JsGetProp (force exp) (JsNameVar fieldname))
: r
compilePats' names (PFieldWildcard:xs) = do
records <- liftM stateRecords get
let fields = fromJust (lookup name records)
fields' = fields \\ names
f <- mapM (\fieldName -> do bindVar (unQual fieldName)
return (JsVar (JsNameVar fieldName)
(JsGetProp (force exp) (JsNameVar fieldName))))
fields'
r <- compilePats' names xs
return $ f ++ r
compilePats' _ [] = return []
compilePats' _ (pat:_) = throwError (UnsupportedFieldPattern pat)
unQual (Qual _ n) = n
unQual (UnQual n) = n
unQual Special{} = error "Trying to unqualify a Special..."
compilePLit :: JsExp -> Literal -> [JsStmt] -> Compile [JsStmt]
compilePLit exp literal body = do
lit <- compileLit literal
return [JsIf (equalExps exp lit)
body
[]]
where
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 (JsBuiltIn "equal")) [a,b]
compilePAsPat :: JsExp -> Name -> Pat -> [JsStmt] -> Compile [JsStmt]
compilePAsPat exp name pat body = do
bindVar name
x <- compilePat exp pat body
return ([JsVar (JsNameVar (UnQual name)) exp] ++ x)
compileRecConstr :: QName -> [FieldUpdate] -> Compile JsExp
compileRecConstr name fieldUpdates = do
qname <- resolveName name
let record = JsVar (JsNameVar name) (JsNew (JsConstructor qname) [])
setFields <- liftM concat (forM fieldUpdates (updateStmt name))
return $ JsApp (JsFun [] (record:setFields) (Just (JsName (JsNameVar name)))) []
where updateStmt :: QName -> FieldUpdate -> Compile [JsStmt]
updateStmt o (FieldUpdate field value) = do
exp <- compileExp value
return [JsSetProp (JsNameVar o) (JsNameVar field) exp]
updateStmt name FieldWildcard = do
records <- liftM stateRecords get
let fields = fromJust (lookup name records)
return (map (\fieldName -> JsSetProp (JsNameVar name)
(JsNameVar fieldName)
(JsName (JsNameVar fieldName)))
fields)
updateStmt _ u = error ("updateStmt: " ++ show u)
updateRec :: Exp -> [FieldUpdate] -> Compile JsExp
updateRec rec fieldUpdates = do
record <- force <$> compileExp rec
let copyName = UnQual (Ident "$_record_to_update")
copy = JsVar (JsNameVar copyName)
(JsRawExp ("Object.create(" ++ printJSString record ++ ")"))
setFields <- forM fieldUpdates (updateExp copyName)
return $ JsApp (JsFun [] (copy:setFields) (Just (JsName (JsNameVar copyName)))) []
where updateExp :: QName -> FieldUpdate -> Compile JsStmt
updateExp copyName (FieldUpdate field value) =
JsSetProp (JsNameVar copyName) (JsNameVar field) <$> compileExp value
updateExp copyName (FieldPun name) =
return $ JsSetProp (JsNameVar copyName)
(JsNameVar (UnQual name))
(JsName (JsNameVar (UnQual name)))
updateExp _ FieldWildcard = error "unsupported update: FieldWildcard"
compilePApp :: QName -> [Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt]
compilePApp cons pats exp body = do
let forcedExp = force exp
let boolIf b = return [JsIf (JsEq forcedExp (JsLit (JsBool b))) body []]
case cons of
"True" -> boolIf True
"False" -> boolIf False
_ -> do
rf <- fmap (lookup cons) (gets stateRecords)
let recordFields =
fromMaybe
(error $ "Constructor '" ++ prettyPrint cons ++
"' was not found in stateRecords, did you try running this through GHC first?")
rf
substmts <- foldM (\body (field,pat) ->
compilePat (JsGetProp forcedExp (JsNameVar field)) pat body)
body
(reverse (zip recordFields pats))
qcons <- resolveName cons
return [JsIf (forcedExp `JsInstanceOf` JsConstructor qcons)
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
stmts <- foldM (\body (i,pat) -> compilePat (JsApp (JsName (JsBuiltIn "index"))
[JsLit (JsInt i),forcedExp])
pat
body)
body
(reverse (zip [0..] pats))
let patsLen = JsLit (JsInt (length pats))
return [JsIf (JsApp (JsName (JsBuiltIn "listLen")) [forcedExp,patsLen])
stmts
[]]
compileInfixPat :: JsExp -> Pat -> [JsStmt] -> Compile [JsStmt]
compileInfixPat exp pat@(PInfixApp left (Special cons) right) body =
case cons of
Cons -> do
withScopedTmpJsName $ \tmpName -> do
let forcedExp = JsName tmpName
x = JsGetProp forcedExp (JsNameVar "car")
xs = JsGetProp forcedExp (JsNameVar "cdr")
rightMatch <- compilePat xs right body
leftMatch <- compilePat x left rightMatch
return [JsVar tmpName (force exp)
,JsIf (JsInstanceOf forcedExp (JsBuiltIn "Cons"))
leftMatch
[]]
_ -> throwError (UnsupportedPattern pat)
compileInfixPat _ pat _ = throwError (UnsupportedPattern pat)
compileGuardedAlt :: GuardedAlts -> Compile JsStmt
compileGuardedAlt alt =
case alt of
UnGuardedAlt exp -> JsEarlyReturn <$> compileExp exp
GuardedAlts alts -> compileGuards (map altToRhs alts)
where
altToRhs (GuardedAlt l s e) = GuardedRhs l s e
compileLet :: [Decl] -> Exp -> Compile JsExp
compileLet decls exp = do
withScope $ do
generateScope $ mapM compileLetDecl decls
binds <- mapM compileLetDecl decls
body <- compileExp exp
return (JsApp (JsFun [] (concat binds) (Just body)) [])
compileLetDecl :: Decl -> Compile [JsStmt]
compileLetDecl decl = do
v <- case decl of
decl@PatBind{} -> compileDecls False [decl]
decl@FunBind{} -> compileDecls False [decl]
TypeSig{} -> return []
_ -> throwError (UnsupportedLetBinding decl)
return v
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 (JsBuiltIn "list"))
[JsLit (JsStr string)])
lit -> throwError (UnsupportedLiteral lit)
maxStrictASLen :: Int
maxStrictASLen = 10
compileEnumFrom :: Exp -> Compile JsExp
compileEnumFrom i = do
e <- compileExp i
name <- resolveName "enumFrom"
return (JsApp (JsName (JsNameVar name)) [e])
compileEnumFromTo :: Exp -> Exp -> Compile JsExp
compileEnumFromTo i i' = do
f <- compileExp i
t <- compileExp i'
name <- resolveName "enumFromTo"
cfg <- config id
return $ case optEnumFromTo cfg f t of
Just s -> s
_ -> JsApp (JsApp (JsName (JsNameVar name)) [f]) [t]
optEnumFromTo :: CompileConfig -> JsExp -> JsExp -> Maybe JsExp
optEnumFromTo cfg (JsLit f) (JsLit t) =
if configOptimize cfg
then case (f,t) of
(JsInt fl, JsInt tl) -> strict JsInt fl tl
(JsFloating fl, JsFloating tl) -> strict JsFloating fl tl
_ -> Nothing
else Nothing
where strict :: (Enum a, Ord a, Num a) => (a -> JsLit) -> a -> a -> Maybe JsExp
strict litfn f t =
if fromEnum t fromEnum f < maxStrictASLen
then Just . makeList . map (JsLit . litfn) $ Stdlib.enumFromTo f t
else Nothing
optEnumFromTo _ _ _ = Nothing
compileEnumFromThen :: Exp -> Exp -> Compile JsExp
compileEnumFromThen a b = do
fr <- compileExp a
th <- compileExp b
name <- resolveName "enumFromThen"
return (JsApp (JsApp (JsName (JsNameVar name)) [fr]) [th])
compileEnumFromThenTo :: Exp -> Exp -> Exp -> Compile JsExp
compileEnumFromThenTo a b z = do
fr <- compileExp a
th <- compileExp b
to <- compileExp z
name <- resolveName "enumFromThenTo"
cfg <- config id
return $ case optEnumFromThenTo cfg fr th to of
Just s -> s
_ -> JsApp (JsApp (JsApp (JsName (JsNameVar name)) [fr]) [th]) [to]
optEnumFromThenTo :: CompileConfig -> JsExp -> JsExp -> JsExp -> Maybe JsExp
optEnumFromThenTo cfg (JsLit fr) (JsLit th) (JsLit to) =
if configOptimize cfg
then case (fr,th,to) of
(JsInt frl, JsInt thl, JsInt tol) -> strict JsInt frl thl tol
(JsFloating frl, JsFloating thl, JsFloating tol) -> strict JsFloating frl thl tol
_ -> Nothing
else Nothing
where strict :: (Enum a, Ord a, Num a) => (a -> JsLit) -> a -> a -> a -> Maybe JsExp
strict litfn fr th to =
if (fromEnum to fromEnum fr) `div`
(fromEnum th fromEnum fr) + 1 < maxStrictASLen
then Just . makeList . map (JsLit . litfn) $ Stdlib.enumFromThenTo fr th to
else Nothing
optEnumFromThenTo _ _ _ _ = Nothing