git.iko.soy/elk
on e240f77 help sign in
elk/src/Generate/JavaScript.hs
552 lines 18 kB history raw
1module Generate.JavaScript (generate) where
3import Control.Applicative ((<$>),(<*>))
4import Control.Arrow (first,(***))
5import Control.Monad.State
6import qualified Data.List as List
7import qualified Data.Map as Map
8import qualified Data.Maybe as Maybe
9import qualified Data.Set as Set
10import Language.ECMAScript3.PrettyPrint
11import Language.ECMAScript3.Syntax
13import AST.Module
14import AST.Expression.General as Expr
15import qualified AST.Expression.Canonical as Canonical
16import qualified AST.Helpers as Help
17import AST.Literal
18import qualified AST.Module as Module
19import qualified AST.Pattern as P
20import qualified AST.Variable as Var
21import Elm.Utils ((|>))
22import Generate.JavaScript.Helpers as Help
23import qualified Generate.Cases as Case
24import qualified Generate.JavaScript.Port as Port
25import qualified Generate.JavaScript.Variable as Var
26import qualified Reporting.Annotation as A
27import qualified Reporting.Region as R
30internalImports :: Module.Name -> [VarDecl ()]
31internalImports name =
32 [ varDecl "_N" (obj ["Elm","Native"])
33 , include "_U" "Utils"
34 , include "_L" "List"
35 , varDecl Help.localModuleName (string (Module.nameToString name))
36 ]
37 where
38 include :: String -> String -> VarDecl ()
39 include alias modul =
40 varDecl alias (Help.make ["_N", modul])
43_Utils :: String -> Expression ()
44_Utils x =
45 obj ["_U", x]
48_List :: String -> Expression ()
49_List x =
50 obj ["_L", x]
53literal :: Literal -> Expression ()
54literal lit =
55 case lit of
56 Chr c -> _Utils "chr" <| string [c]
57 Str s -> string s
58 IntNum n -> IntLit () n
59 FloatNum n -> NumLit () n
60 Boolean b -> BoolLit () b
63-- EXPRESSIONS
65expression :: Canonical.Expr -> State Int (Expression ())
66expression annotatedExpr@(A.A region expr) =
67 case expr of
68 Var var ->
69 return $ Var.canonical var
71 Literal lit ->
72 return $ literal lit
74 Range lo hi ->
75 do lo' <- expression lo
76 hi' <- expression hi
77 return $ _List "range" `call` [lo',hi']
79 Access e field ->
80 do e' <- expression e
81 return $ DotRef () e' (var (Var.varName field))
83 Remove e field ->
84 do e' <- expression e
85 return $ _Utils "remove" `call` [ string (Var.varName field), e' ]
87 Insert e field value ->
88 do value' <- expression value
89 e' <- expression e
90 return $ _Utils "insert" `call` [ string (Var.varName field), value', e' ]
92 Modify e fields ->
93 do e' <- expression e
94 fields' <-
95 forM fields $ \(field, value) ->
96 do value' <- expression value
97 return $ ArrayLit () [ string (Var.varName field), value' ]
99 return $ _Utils "replace" `call` [ArrayLit () fields', e']
101 Record fields ->
102 do fields' <-
103 forM fields $ \(field, e) ->
104 (,) (Var.varName field) <$> expression e
106 let fieldMap =
107 List.foldl' combine Map.empty fields'
109 return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
110 where
111 combine record (field, value) =
112 Map.insertWith (++) field [value] record
114 hidden fs =
115 ObjectLit () . map (prop *** ArrayLit ()) $
116 Map.toList (Map.filter (not . null) (Map.map tail fs))
118 visible fs =
119 map (first prop) (Map.toList (Map.map head fs))
121 Binop op e1 e2 ->
122 binop region op e1 e2
124 Lambda _ _ ->
125 generateFunction (Expr.collectLambdas annotatedExpr)
127 App e1 e2 ->
128 do func' <- expression func
129 args' <- mapM expression args
130 return $
131 case args' of
132 [arg] -> func' <| arg
133 _ | length args' <= 9 -> ref aN `call` (func':args')
134 | otherwise -> foldl1 (<|) (func':args')
135 where
136 aN = "A" ++ show (length args)
137 (func, args) = getArgs e1 [e2]
138 getArgs func args =
139 case func of
140 (A.A _ (App f arg)) -> getArgs f (arg : args)
141 _ -> (func, args)
143 Let defs body ->
144 do (stmts, bodyExpr) <- generateLetPieces defs body
145 return $ function [] (stmts ++ [ ret bodyExpr ]) `call` []
148 MultiIf branches ->
149 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
150 return $
151 case last branches of
152 (A.A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) ->
153 safeIfs branches'
154 (A.A _ (Literal (Boolean True)), _) ->
155 safeIfs branches'
156 _ ->
157 ifs branches' (throw "badIf" region)
158 where
159 safeIfs branches = ifs (init branches) (snd (last branches))
160 ifs branches finally = foldr iff finally branches
161 iff (if', then') else' = CondExpr () if' then' else'
163 Case e cases ->
164 do (tempVar,initialMatch) <- Case.toMatch cases
165 (revisedMatch, stmt) <-
166 case e of
167 A.A _ (Var (Var.Canonical Var.Local x)) ->
168 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
169 _ ->
170 do e' <- expression e
171 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
172 match' <- match region revisedMatch
173 return (function [] (stmt ++ match') `call` [])
175 ExplicitList es ->
176 do es' <- mapM expression es
177 return $ _List "fromArray" <| ArrayLit () es'
179 Data name es ->
180 do es' <- mapM expression es
181 return $ ObjectLit () (ctor : fields es')
182 where
183 ctor = (prop "ctor", string name)
184 fields =
185 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
187 GLShader _uid src _tipe ->
188 return $ ObjectLit () [(PropString () "src", literal (Str src))]
190 Port impl ->
191 case impl of
192 In name portType ->
193 return (Port.inbound name portType)
195 Out name expr portType ->
196 do expr' <- expression expr
197 return (Port.outbound name expr' portType)
199 Task name expr portType ->
200 do expr' <- expression expr
201 return (Port.task name expr' portType)
204-- FUNCTIONS
206generateFunction
207 :: ([P.CanonicalPattern], Canonical.Expr)
208 -> State Int (Expression ())
209generateFunction (args, initialBody) =
210 do (argVars, patternDefs) <- destructuredArgs args
211 (stmts, expr) <- generateLetPieces patternDefs initialBody
212 return (generateFunctionWithArity argVars stmts expr)
215generateFunctionWithArity :: [String] -> [Statement ()] -> Expression () -> Expression ()
216generateFunctionWithArity args stmts expr =
217 let
218 arity = length args
219 in
220 if 2 <= arity && arity <= 9 then
221 let
222 fN = "F" ++ show arity
223 in
224 ref fN <| function args (stmts ++ [ret expr])
225 else
226 let
227 (lastArg:otherArgs) = reverse args
228 innerBody = function [lastArg] (stmts ++ [ret expr])
229 in
230 foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs
233destructuredArgs :: [P.CanonicalPattern] -> State Int ([String], [Canonical.Def])
234destructuredArgs args =
235 do (argVars, maybePatternDefs) <- unzip <$> mapM destructPattern args
236 return (argVars, Maybe.catMaybes maybePatternDefs)
239destructPattern :: P.CanonicalPattern -> State Int (String, Maybe Canonical.Def)
240destructPattern pattern@(A.A ann pat) =
241 case pat of
242 P.Var x ->
243 return (Var.varName x, Nothing)
245 _ ->
246 do arg <- Case.newVar
247 return
248 ( arg
249 , Just $ Canonical.Definition pattern (A.A ann (localVar arg)) Nothing
250 )
253-- LET EXPRESSIONS
255generateLetPieces
256 :: [Canonical.Def]
257 -> Canonical.Expr
258 -> State Int ([Statement ()], Expression ())
259generateLetPieces givenDefs givenBody =
260 do let (defs, body) = flattenLets givenDefs givenBody
261 stmts <- concat <$> mapM definition defs
262 expr <- expression body
263 return (stmts, expr)
266-- DEFINITIONS
268definition :: Canonical.Def -> State Int [Statement ()]
269definition (Canonical.Definition annPattern expr@(A.A region _) _) =
270 do expr' <- expression expr
271 let assign x = varDecl x expr'
272 let (A.A patternRegion pattern) = annPattern
273 case pattern of
274 P.Var x
275 | Help.isOp x ->
276 let op = LBracket () (ref "_op") (string x) in
277 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
279 | otherwise ->
280 return [ VarDeclStmt () [ assign (Var.varName x) ] ]
282 P.Record fields ->
283 let setField f = varDecl f (obj ["$",f]) in
284 return [ VarDeclStmt () (assign "$" : map setField fields) ]
286 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
287 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
288 where
289 vars = getVars patterns
290 getVars patterns =
291 case patterns of
292 A.A _ (P.Var x) : rest ->
293 (Var.varName x :) `fmap` getVars rest
294 [] ->
295 Just []
296 _ ->
297 Nothing
299 decl x n = varDecl x (obj ["$","_" ++ show n])
300 setup vars
301 | Help.isTuple name = assign "$" : vars
302 | otherwise = assign "_raw" : safeAssign : vars
304 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
305 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
306 exception = Help.throw "badCase" region
308 _ ->
309 do defs' <- concat <$> mapM toDef vars
310 return (VarDeclStmt () [assign "_"] : defs')
311 where
312 vars = P.boundVarList annPattern
313 mkVar = A.A region . localVar
314 toDef y =
315 let expr = A.A region $ Case (mkVar "_") [(annPattern, mkVar y)]
316 pat = A.A patternRegion (P.Var y)
317 in
318 definition (Canonical.Definition pat expr Nothing)
321match :: R.Region -> Case.Match -> State Int [Statement ()]
322match region mtch =
323 case mtch of
324 Case.Match name clauses mtch' ->
325 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
326 mtch'' <- match region mtch'
327 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
328 where
329 isLiteral p =
330 case p of
331 Case.Clause (Right _) _ _ -> True
332 _ -> False
334 access name
335 | any isLiteral clauses = obj [name]
336 | otherwise = obj (Help.splitDots name ++ ["ctor"])
338 format isChars e
339 | or isChars = InfixExpr () OpAdd e (string "")
340 | otherwise = e
342 Case.Fail ->
343 return [ ExprStmt () (Help.throw "badCase" region) ]
345 Case.Break ->
346 return [BreakStmt () Nothing]
348 Case.Other e ->
349 do e' <- expression e
350 return [ ret e' ]
352 Case.Seq ms ->
353 concat <$> mapM (match region) (dropEnd [] ms)
354 where
355 dropEnd acc [] = acc
356 dropEnd acc (m:ms) =
357 case m of
358 Case.Other _ -> acc ++ [m]
359 _ -> dropEnd (acc ++ [m]) ms
362clause :: R.Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
363clause region variable (Case.Clause value vars mtch) =
364 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
365 where
366 vars' =
367 map (\n -> variable ++ "._" ++ show n) [0..]
369 (isChar, pattern) =
370 case value of
371 Right (Chr c) -> (True, string [c])
372 _ ->
373 (,) False $
374 case value of
375 Right (Boolean b) -> BoolLit () b
376 Right lit -> literal lit
377 Left (Var.Canonical _ name) ->
378 string name
381flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
382flattenLets defs lexpr@(A.A _ expr) =
383 case expr of
384 Let ds body -> flattenLets (defs ++ ds) body
385 _ -> (defs, lexpr)
388generate :: Module.CanonicalModule -> String
389generate modul =
390 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
391 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]
392 where
393 names :: [String]
394 names = Module.names modul
396 thisModule :: Expression ()
397 thisModule = obj (localRuntime : names ++ ["values"])
399 programStmts :: [Statement ()]
400 programStmts =
401 concat
402 [ [ ExprStmt () (string "use strict") ]
403 , setup localRuntime (names ++ ["values"])
404 , [ IfSingleStmt () thisModule (ret thisModule) ]
405 , [ VarDeclStmt () localVars ]
406 , body
407 , [ jsExports ]
408 , [ ret thisModule ]
409 ]
411 localVars :: [VarDecl ()]
412 localVars =
413 varDecl "_op" (ObjectLit () [])
414 : internalImports (Module.names modul)
415 ++ explicitImports
416 where
417 explicitImports :: [VarDecl ()]
418 explicitImports =
419 Module.imports modul
420 |> Set.fromList
421 |> Set.toList
422 |> map jsImport
424 jsImport :: Module.Name -> VarDecl ()
425 jsImport name =
426 varDecl (Var.moduleName name) $
427 obj ("Elm" : name ++ ["make"]) <| ref localRuntime
429 body :: [Statement ()]
430 body =
431 concat (evalState defs 0)
432 where
433 defs =
434 Module.program (Module.body modul)
435 |> flattenLets []
436 |> fst
437 |> mapM definition
439 setup namespace path =
440 map create paths
441 where
442 create name =
443 assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
444 paths =
445 namespace : path
446 |> List.inits
447 |> init
448 |> drop 2
450 jsExports =
451 assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)
452 where
453 exs = map entry $ "_op" : concatMap extract (exports modul)
454 entry x = (prop x, ref x)
455 extract value =
456 case value of
457 Var.Alias _ -> []
459 Var.Value x
460 | Help.isOp x -> []
461 | otherwise -> [Var.varName x]
463 Var.Union _ (Var.Listing ctors _) ->
464 map Var.varName ctors
466 assign path expr =
467 case path of
468 [x] -> VarDeclStmt () [ varDecl x expr ]
469 _ ->
470 ExprStmt () $
471 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
474binop
475 :: R.Region
476 -> Var.Canonical
477 -> Canonical.Expr
478 -> Canonical.Expr
479 -> State Int (Expression ())
480binop region func@(Var.Canonical home op) e1 e2 =
481 case (home, op) of
482 (Var.Module ["Basics"], ">>") ->
483 do es <- mapM expression (collectLeftAssoc [e2] e1)
484 return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es
486 (Var.Module ["Basics"], "<<") ->
487 do es <- mapM expression (e1 : collectRightAssoc [] e2)
488 return $ ["$"] ==> foldr (<|) (ref "$") es
490 (Var.Module ["Basics"], "<|") ->
491 do e2' <- expression e2
492 es <- mapM expression (collectRightAssoc [] e1)
493 return $ foldr (<|) e2' es
495 (Var.BuiltIn, "::") ->
496 expression (A.A region (Data "::" [e1,e2]))
498 (Var.Module ["Basics"], _) ->
499 do e1' <- expression e1
500 e2' <- expression e2
501 case Map.lookup op basicOps of
502 Just f ->
503 return (f e1' e2')
505 Nothing ->
506 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
508 _ ->
509 do e1' <- expression e1
510 e2' <- expression e2
511 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
513 where
514 collectRightAssoc es e =
515 case e of
516 A.A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->
517 collectRightAssoc (es ++ [e1]) e2
518 _ -> es ++ [e]
520 collectLeftAssoc es e =
521 case e of
522 A.A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->
523 collectLeftAssoc (e2 : es) e1
524 _ -> e : es
526 basicOps =
527 Map.fromList (infixOps ++ specialOps)
529 infixOps =
530 let infixOp str op = (str, InfixExpr () op) in
531 [ infixOp "+" OpAdd
532 , infixOp "-" OpSub
533 , infixOp "*" OpMul
534 , infixOp "/" OpDiv
535 , infixOp "&&" OpLAnd
536 , infixOp "||" OpLOr
537 ]
539 specialOps =
540 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
541 , (,) "|>" $ flip (<|)
542 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
543 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
544 , (,) "<" $ cmp OpLT 0
545 , (,) ">" $ cmp OpGT 0
546 , (,) "<=" $ cmp OpLT 1
547 , (,) ">=" $ cmp OpGT (-1)
548 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
549 ]
551 cmp op n a b =
552 InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)