392 lines
15 KiB
Haskell
392 lines
15 KiB
Haskell
{-# OPTIONS_GHC -W #-}
|
|
module Generate.JavaScript (generate) where
|
|
|
|
import Control.Applicative ((<$>),(<*>))
|
|
import Control.Arrow (first,(***))
|
|
import Control.Monad.State
|
|
import qualified Data.List as List
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
import Language.ECMAScript3.PrettyPrint
|
|
import Language.ECMAScript3.Syntax
|
|
|
|
import Generate.JavaScript.Helpers
|
|
import qualified Generate.Cases as Case
|
|
import qualified Generate.JavaScript.Ports as Port
|
|
import qualified Generate.Markdown as MD
|
|
import SourceSyntax.Annotation
|
|
import SourceSyntax.Expression
|
|
import qualified SourceSyntax.Helpers as Help
|
|
import SourceSyntax.Literal
|
|
import SourceSyntax.Module
|
|
import qualified SourceSyntax.Pattern as P
|
|
import SourceSyntax.PrettyPrint (renderPretty)
|
|
import qualified SourceSyntax.Variable as V
|
|
import qualified Transform.SafeNames as MakeSafe
|
|
|
|
varDecl :: String -> Expression () -> VarDecl ()
|
|
varDecl x expr =
|
|
VarDecl () (var x) (Just expr)
|
|
|
|
include :: String -> String -> VarDecl ()
|
|
include alias moduleName =
|
|
varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")
|
|
|
|
internalImports :: String -> Statement ()
|
|
internalImports name =
|
|
VarDeclStmt ()
|
|
[ varDecl "_N" (obj "Elm.Native")
|
|
, include "_U" "_N.Utils"
|
|
, include "_L" "_N.List"
|
|
, include "_E" "_N.Error"
|
|
, include "_J" "_N.JavaScript"
|
|
, varDecl "$moduleName" (string name)
|
|
]
|
|
|
|
literal :: Literal -> Expression ()
|
|
literal lit =
|
|
case lit of
|
|
Chr c -> obj "_U.chr" <| string [c]
|
|
Str s -> string s
|
|
IntNum n -> IntLit () n
|
|
FloatNum n -> NumLit () n
|
|
Boolean b -> BoolLit () b
|
|
|
|
expression :: Expr -> State Int (Expression ())
|
|
expression (A region expr) =
|
|
case expr of
|
|
Var (V.Raw x) -> return $ obj x
|
|
Literal lit -> return $ literal lit
|
|
|
|
Range lo hi ->
|
|
do lo' <- expression lo
|
|
hi' <- expression hi
|
|
return $ obj "_L.range" `call` [lo',hi']
|
|
|
|
Access e x ->
|
|
do e' <- expression e
|
|
return $ DotRef () e' (var x)
|
|
|
|
Remove e x ->
|
|
do e' <- expression e
|
|
return $ obj "_U.remove" `call` [string x, e']
|
|
|
|
Insert e x v ->
|
|
do v' <- expression v
|
|
e' <- expression e
|
|
return $ obj "_U.insert" `call` [string x, v', e']
|
|
|
|
Modify e fs ->
|
|
do e' <- expression e
|
|
fs' <- forM fs $ \(f,v) -> do
|
|
v' <- expression v
|
|
return $ ArrayLit () [string f, v']
|
|
return $ obj "_U.replace" `call` [ArrayLit () fs', e']
|
|
|
|
Record fields ->
|
|
do fields' <- forM fields $ \(f,e) -> do
|
|
(,) f <$> expression e
|
|
let fieldMap = List.foldl' combine Map.empty fields'
|
|
return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
|
|
where
|
|
combine r (k,v) = Map.insertWith (++) k [v] r
|
|
hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
|
|
Map.toList . Map.filter (not . null) $ Map.map tail fs
|
|
visible fs = map (first prop) . Map.toList $ Map.map head fs
|
|
|
|
Binop op e1 e2 -> binop region op e1 e2
|
|
|
|
Lambda p e@(A ann _) ->
|
|
do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
|
|
body' <- expression body
|
|
return $ case length args < 2 || length args > 9 of
|
|
True -> foldr (==>) body' (map (:[]) args)
|
|
False -> ref ("F" ++ show (length args)) <| (args ==> body')
|
|
where
|
|
depattern (args, body) pattern =
|
|
case pattern of
|
|
P.Var x -> return (args ++ [x], body)
|
|
_ -> do arg <- Case.newVar
|
|
return ( args ++ [arg]
|
|
, A ann (Case (A ann (rawVar arg)) [(pattern, body)]))
|
|
|
|
(patterns, innerBody) = collect [p] e
|
|
|
|
collect patterns lexpr@(A _ expr) =
|
|
case expr of
|
|
Lambda p e -> collect (p:patterns) e
|
|
_ -> (patterns, lexpr)
|
|
|
|
App e1 e2 ->
|
|
do func' <- expression func
|
|
args' <- mapM expression args
|
|
return $ case args' of
|
|
[arg] -> func' <| arg
|
|
_ | length args' <= 9 -> ref aN `call` (func':args')
|
|
| otherwise -> foldl1 (<|) (func':args')
|
|
where
|
|
aN = "A" ++ show (length args)
|
|
(func, args) = getArgs e1 [e2]
|
|
getArgs func args =
|
|
case func of
|
|
(A _ (App f arg)) -> getArgs f (arg : args)
|
|
_ -> (func, args)
|
|
|
|
Let defs e ->
|
|
do let (defs',e') = flattenLets defs e
|
|
stmts <- concat <$> mapM definition defs'
|
|
exp <- expression e'
|
|
return $ function [] (stmts ++ [ ret exp ]) `call` []
|
|
|
|
MultiIf branches ->
|
|
do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
|
|
return $ case last branches of
|
|
(A _ (Var (V.Raw "Basics.otherwise")), _) -> safeIfs branches'
|
|
(A _ (Literal (Boolean True)), _) -> safeIfs branches'
|
|
_ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ])
|
|
where
|
|
safeIfs branches = ifs (init branches) (snd (last branches))
|
|
ifs branches finally = foldr iff finally branches
|
|
iff (if', then') else' = CondExpr () if' then' else'
|
|
|
|
Case e cases ->
|
|
do (tempVar,initialMatch) <- Case.toMatch cases
|
|
(revisedMatch, stmt) <-
|
|
case e of
|
|
A _ (Var (V.Raw x)) ->
|
|
return (Case.matchSubst [(tempVar,x)] initialMatch, [])
|
|
_ ->
|
|
do e' <- expression e
|
|
return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
|
|
match' <- match region revisedMatch
|
|
return (function [] (stmt ++ match') `call` [])
|
|
|
|
ExplicitList es ->
|
|
do es' <- mapM expression es
|
|
return $ obj "_J.toList" <| ArrayLit () es'
|
|
|
|
Data name es ->
|
|
do es' <- mapM expression es
|
|
return $ ObjectLit () (ctor : fields es')
|
|
where
|
|
ctor = (prop "ctor", string name)
|
|
fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
|
|
|
|
Markdown uid doc es ->
|
|
do es' <- mapM expression es
|
|
return $ obj "Text.markdown" `call` (string md : string uid : es')
|
|
where
|
|
pad = "<div style=\"height:0;width:0;\"> </div>"
|
|
md = pad ++ MD.toHtml doc ++ pad
|
|
|
|
PortIn name tipe ->
|
|
return $ obj "Native.Ports.portIn" `call` [ string name, Port.incoming tipe ]
|
|
|
|
PortOut name tipe value ->
|
|
do value' <- expression value
|
|
return $ obj "Native.Ports.portOut" `call`
|
|
[ string name, Port.outgoing tipe, value' ]
|
|
|
|
definition :: Def -> State Int [Statement ()]
|
|
definition (Definition pattern expr@(A region _) _) = do
|
|
expr' <- expression expr
|
|
let assign x = varDecl x expr'
|
|
case pattern of
|
|
P.Var x
|
|
| Help.isOp x ->
|
|
let op = LBracket () (ref "_op") (string x) in
|
|
return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
|
|
| otherwise ->
|
|
return [ VarDeclStmt () [ assign x ] ]
|
|
|
|
P.Record fields ->
|
|
let setField f = varDecl f (dotSep ["$",f]) in
|
|
return [ VarDeclStmt () (assign "$" : map setField fields) ]
|
|
|
|
P.Data name patterns | vars /= Nothing ->
|
|
return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
|
|
where
|
|
vars = getVars patterns
|
|
getVars patterns =
|
|
case patterns of
|
|
P.Var x : rest -> (x:) `fmap` getVars rest
|
|
[] -> Just []
|
|
_ -> Nothing
|
|
|
|
decl x n = varDecl x (dotSep ["$","_" ++ show n])
|
|
setup vars
|
|
| Help.isTuple name = assign "$" : vars
|
|
| otherwise = assign "$raw" : safeAssign : vars
|
|
|
|
safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
|
|
if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)
|
|
exception = obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]
|
|
|
|
_ ->
|
|
do defs' <- concat <$> mapM toDef vars
|
|
return (VarDeclStmt () [assign "$"] : defs')
|
|
where
|
|
vars = P.boundVarList pattern
|
|
mkVar = A region . rawVar
|
|
toDef y = let expr = A region $ Case (mkVar "$") [(pattern, mkVar y)]
|
|
in definition $ Definition (P.Var y) expr Nothing
|
|
|
|
match :: Region -> Case.Match -> State Int [Statement ()]
|
|
match region mtch =
|
|
case mtch of
|
|
Case.Match name clauses mtch' ->
|
|
do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
|
|
mtch'' <- match region mtch'
|
|
return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
|
|
where
|
|
isLiteral p = case p of
|
|
Case.Clause (Right _) _ _ -> True
|
|
_ -> False
|
|
|
|
access name
|
|
| any isLiteral clauses = obj name
|
|
| otherwise = dotSep (split name ++ ["ctor"])
|
|
|
|
format isChars e
|
|
| or isChars = InfixExpr () OpAdd e (string "")
|
|
| otherwise = e
|
|
|
|
Case.Fail ->
|
|
return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]) ]
|
|
|
|
Case.Break -> return [BreakStmt () Nothing]
|
|
Case.Other e ->
|
|
do e' <- expression e
|
|
return [ ret e' ]
|
|
Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
|
|
where
|
|
dropEnd acc [] = acc
|
|
dropEnd acc (m:ms) =
|
|
case m of
|
|
Case.Other _ -> acc ++ [m]
|
|
_ -> dropEnd (acc ++ [m]) ms
|
|
|
|
clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
|
|
clause region variable (Case.Clause value vars mtch) =
|
|
(,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
|
|
where
|
|
vars' = map (\n -> variable ++ "._" ++ show n) [0..]
|
|
(isChar, pattern) =
|
|
case value of
|
|
Right (Chr c) -> (True, string [c])
|
|
_ -> (,) False $ case value of
|
|
Right (Boolean b) -> BoolLit () b
|
|
Right lit -> literal lit
|
|
Left name -> string $ case List.elemIndices '.' name of
|
|
[] -> name
|
|
is -> drop (last is + 1) name
|
|
|
|
flattenLets :: [Def] -> Expr -> ([Def], Expr)
|
|
flattenLets defs lexpr@(A _ expr) =
|
|
case expr of
|
|
Let ds body -> flattenLets (defs ++ ds) body
|
|
_ -> (defs, lexpr)
|
|
|
|
generate :: MetadataModule -> String
|
|
generate unsafeModule =
|
|
show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
|
|
[ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]
|
|
where
|
|
modul = MakeSafe.metadataModule unsafeModule
|
|
thisModule = dotSep ("_elm" : names modul ++ ["values"])
|
|
programStmts =
|
|
concat
|
|
[ [ ExprStmt () $ string "use strict" ]
|
|
, setup (Just "_elm") (names modul ++ ["values"])
|
|
, [ IfSingleStmt () thisModule (ret thisModule) ]
|
|
, [ internalImports (List.intercalate "." (names modul)) ]
|
|
, concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
|
|
, [ assign ["_op"] (ObjectLit () []) ]
|
|
, concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
|
|
, [ jsExports ]
|
|
, [ ret thisModule ]
|
|
]
|
|
|
|
jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
|
|
where
|
|
exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
|
|
entry x = (prop x, ref x)
|
|
|
|
assign path expr =
|
|
case path of
|
|
[x] -> VarDeclStmt () [ varDecl x expr ]
|
|
_ -> ExprStmt () $
|
|
AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
|
|
|
|
jsImport modul = setup Nothing path ++ [ include ]
|
|
where
|
|
path = Help.splitDots modul
|
|
include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
|
|
|
|
setup namespace path = map create paths
|
|
where
|
|
create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
|
|
paths = case namespace of
|
|
Nothing -> tail . init $ List.inits path
|
|
Just nmspc -> drop 2 . init . List.inits $ nmspc : path
|
|
|
|
binop :: Region -> String -> Expr -> Expr -> State Int (Expression ())
|
|
binop region op e1 e2 =
|
|
case op of
|
|
"Basics.." ->
|
|
do es <- mapM expression (e1 : collect [] e2)
|
|
return $ ["$"] ==> foldr (<|) (ref "$") es
|
|
"Basics.<|" ->
|
|
do e2' <- expression e2
|
|
es <- mapM expression (collect [] e1)
|
|
return $ foldr (<|) e2' es
|
|
"List.++" ->
|
|
do e1' <- expression e1
|
|
e2' <- expression e2
|
|
return $ obj "_L.append" `call` [e1', e2']
|
|
"::" -> expression (A region (Data "::" [e1,e2]))
|
|
_ ->
|
|
do e1' <- expression e1
|
|
e2' <- expression e2
|
|
return $ case Map.lookup op opDict of
|
|
Just f -> f e1' e2'
|
|
Nothing -> ref "A2" `call` [ func, e1', e2' ]
|
|
where
|
|
collect es e =
|
|
case e of
|
|
A _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
|
|
_ -> es ++ [e]
|
|
|
|
func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
|
|
| otherwise = dotSep parts
|
|
where
|
|
parts = Help.splitDots op
|
|
operator = last parts
|
|
|
|
opDict = Map.fromList (infixOps ++ specialOps)
|
|
|
|
specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
|
|
infixOp str op = specialOp str (InfixExpr () op)
|
|
|
|
infixOps = concat
|
|
[ infixOp "+" OpAdd
|
|
, infixOp "-" OpSub
|
|
, infixOp "*" OpMul
|
|
, infixOp "/" OpDiv
|
|
, infixOp "&&" OpLAnd
|
|
, infixOp "||" OpLOr
|
|
]
|
|
|
|
specialOps = concat
|
|
[ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
|
|
, specialOp "|>" $ flip (<|)
|
|
, specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]
|
|
, specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])
|
|
, specialOp "<" $ cmp OpLT 0
|
|
, specialOp ">" $ cmp OpGT 0
|
|
, specialOp "<=" $ cmp OpLT 1
|
|
, specialOp ">=" $ cmp OpGT (-1)
|
|
, specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
|
|
]
|
|
|
|
cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)
|