module Language.Fay
where
import Language.Fay.Print ()
import Language.Fay.Types
import Control.Applicative
import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.IO
import Data.List
import Data.String
import Language.Haskell.Exts
compile :: CompilesTo from to => Config -> from -> IO (Either CompileError to)
compile config = runCompile config . compileTo
runCompile :: Config -> Compile a -> IO (Either CompileError a)
runCompile config m = runErrorT (runReaderT m config)
compileViaStr :: (Show from,Show to,CompilesTo from to)
=> Config
-> (from -> Compile to)
-> String
-> IO (Either CompileError String)
compileViaStr config with from =
runCompile config
(parseResult (throwError . uncurry ParseError)
(fmap printJS . with)
(parse from))
compileToAst :: (Show from,Show to,CompilesTo from to)
=> Config
-> (from -> Compile to)
-> String
-> IO (Either CompileError to)
compileToAst config with from =
runCompile config
(parseResult (throwError . uncurry ParseError)
with
(parse from))
compileFromStr with from =
parseResult (throwError . uncurry ParseError)
(with)
(parse from)
compileModule :: Module -> Compile [JsStmt]
compileModule (Module _ modulename pragmas Nothing exports imports decls) = do
imported <- fmap concat (mapM compileImport imports)
current <- compileDecls 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 :: [Decl] -> Compile [JsStmt]
compileDecls decls = do
case decls of
[] -> return []
(TypeSig _ _ sig:bind@PatBind{}:decls) -> appendM (compilePatBind (Just sig) bind)
(compileDecls decls)
(decl:decls) -> appendM (compileDecl decl)
(compileDecls decls)
where appendM m n = do x <- m
xs <- n
return (x ++ xs)
compileDecl :: Decl -> Compile [JsStmt]
compileDecl decl =
case decl of
pat@PatBind{} -> compilePatBind Nothing pat
FunBind matches -> compileFunCase matches
DataDecl _ DataType _ _ _ constructors _ -> compileDataDecl decl constructors
TypeDecl{} -> return []
TypeSig{} -> return []
InfixDecl{} -> return []
ClassDecl{} -> return []
InstDecl{} -> return []
_ -> throwError (UnsupportedDeclaration decl)
compilePatBind :: Maybe Type -> Decl -> Compile [JsStmt]
compilePatBind sig pat =
case pat of
PatBind _ (PVar ident) Nothing (UnGuardedRhs rhs) (BDecls []) ->
case ffiExp rhs of
Just detail@(binding,_,_) ->
case sig of
Nothing -> compileNormalPatBind ident rhs
Just sig -> case () of
() | func binding -> compileFFIFunc sig ident detail
| method binding -> compileFFIMethod sig ident detail
| otherwise -> throwError (FfiNeedsTypeSig pat)
_ -> compileNormalPatBind ident rhs
_ -> throwError (UnsupportedDeclaration pat)
where func = flip elem ["foreignFay","foreignPure"]
method = flip elem ["foreignMethodFay","foreignMethod"]
ffiExp (App (App (Var (UnQual (Ident ident)))
(Lit (String name)))
(Lit (String typ)))
= Just (ident,name,typ)
ffiExp _ = Nothing
compileNormalPatBind :: Name -> Exp -> Compile [JsStmt]
compileNormalPatBind ident rhs = do
body <- compileExp rhs
return [JsVar (UnQual ident) (thunk body)]
compileFFIFunc :: Type -> Name -> (String,String,String) -> 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,String) -> 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 (JsGetProp (force (JsName obj)) (fromString name)) args jsargs
compileFFI :: Type
-> Name
-> (String,String,String)
-> JsExp
-> [JsName]
-> [JsName]
-> Compile [JsStmt]
compileFFI sig ident (binding,_,typ) exp params args = do
return [JsVar (UnQual ident)
(foldr (\name inner -> JsFun [name] [] (Just inner))
(thunk
(maybeMonad
(unserialize typ
(JsApp exp
(map (\(typ,name) -> serialize typ (JsName name))
(zip types args))))))
params)]
where (maybeMonad,types) | binding == "foreignFay" = (monad,funcTypes)
| binding == "foreignMethodFay" = (monad,drop 1 funcTypes)
| binding == "foreignMethod" = (id,drop 1 funcTypes)
| 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 :: Decl -> [QualConDecl] -> Compile [JsStmt]
compileDataDecl 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 ->
return (JsVar (UnQual name)
(JsFun ["x"]
[]
(Just (thunk (JsIndex i (force (JsName "x")))))))
qname (UnQual (Ident str)) = str
qname _ = error "qname: Expected unqualified ident."
unname (Ident str) = str
compileFunCase :: [Match] -> Compile [JsStmt]
compileFunCase [] = return []
compileFunCase matches@(Match _ name argslen _ _ _:_) = do
tco <- asks 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)
return [JsVar (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)]
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..])))
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 new@(JsWhile _ newstmts)
| newstmts == stmts = stmts
| otherwise = [new]
flatten :: JsExp -> Maybe [JsExp]
flatten (JsApp op@JsApp{} arg) = do
inner <- expand op
return (inner ++ arg)
flatten name@JsName{} = return [name]
flatten x = Nothing
expand (JsApp (JsName (UnQual (Ident "_"))) xs) = do
fmap concat (mapM flatten xs)
expand x = Nothing
compileRhs :: Rhs -> Compile JsExp
compileRhs (UnGuardedRhs exp) = compileExp exp
compileRhs rhs = throwError (UnsupportedRhs rhs)
compileFunMatch :: Match -> Compile [JsStmt]
compileFunMatch match =
case match of
(Match _ name args Nothing (UnGuardedRhs rhs) _) -> do
body <- compileExp rhs
args <- mapM patToArg args
return [JsVar (UnQual name)
(foldr (\arg inner -> JsFun [arg] [] (Just inner))
(thunk body)
args)]
match -> throwError (UnsupportedMatchSyntax match)
where patToArg (PVar name) = return (UnQual name)
patToArg _ = throwError (UnsupportedMatchSyntax match)
instance CompilesTo Decl [JsStmt] where compileTo = compileDecl
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 = fmap optimizeApp $
JsApp <$> (forceFlatName <$> compileExp exp1)
<*> fmap return (compileExp exp2)
where forceFlatName name = JsApp (JsName "_") [name]
optimizeApp :: JsExp -> JsExp
optimizeApp exp =
case exp of
exp -> exp
where name JsName{} = True
name _ = False
compileInfixApp :: Exp -> QOp -> Exp -> Compile JsExp
compileInfixApp exp1 op exp2 = do
config <- ask
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 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 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 [decl]
decl@FunBind{} -> compileDecls [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 ..])
thenm :: JsExp -> JsExp -> JsExp
thenm e inner =
JsApp (JsApp (JsName (hjIdent "then"))
[e])
[inner]
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 :: String -> JsExp -> JsExp
unserialize typ exp =
JsApp (JsName (hjIdent "unserialize")) [JsLit (JsStr typ),exp]
force :: JsExp -> JsExp
force exp
| isConstant exp = exp
| otherwise = JsApp (JsName "_") [exp]
forceInlinable :: Config -> 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
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)