git.iko.soy/elk
on 779f7aa help sign in
elk/src/Generate/JavaScript.hs
502 lines 16 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.Set as Set
9import Language.ECMAScript3.PrettyPrint
10import Language.ECMAScript3.Syntax
12import AST.Module
13import AST.Expression.General
14import qualified AST.Expression.Canonical as Canonical
15import qualified AST.Helpers as Help
16import AST.Literal
17import qualified AST.Module as Module
18import qualified AST.Pattern as P
19import qualified AST.Variable as Var
20import Elm.Utils ((|>))
21import Generate.JavaScript.Helpers as Help
22import qualified Generate.Cases as Case
23import qualified Generate.JavaScript.Port as Port
24import qualified Generate.JavaScript.Variable as Var
25import qualified Reporting.Annotation as A
26import qualified Reporting.Region as R
29internalImports :: Module.Name -> [VarDecl ()]
30internalImports name =
31 [ varDecl "_N" (obj ["Elm","Native"])
32 , include "_U" "Utils"
33 , include "_L" "List"
34 , varDecl Help.localModuleName (string (Module.nameToString name))
35 ]
36 where
37 include :: String -> String -> VarDecl ()
38 include alias modul =
39 varDecl alias (Help.make ["_N", modul])
42_Utils :: String -> Expression ()
43_Utils x =
44 obj ["_U", x]
47_List :: String -> Expression ()
48_List x =
49 obj ["_L", x]
52literal :: Literal -> Expression ()
53literal lit =
54 case lit of
55 Chr c -> _Utils "chr" <| string [c]
56 Str s -> string s
57 IntNum n -> IntLit () n
58 FloatNum n -> NumLit () n
59 Boolean b -> BoolLit () b
62expression :: Canonical.Expr -> State Int (Expression ())
63expression (A.A region expr) =
64 case expr of
65 Var var ->
66 return $ Var.canonical var
68 Literal lit ->
69 return $ literal lit
71 Range lo hi ->
72 do lo' <- expression lo
73 hi' <- expression hi
74 return $ _List "range" `call` [lo',hi']
76 Access e field ->
77 do e' <- expression e
78 return $ DotRef () e' (var (Var.varName field))
80 Update e fields ->
81 do e' <- expression e
82 fields' <-
83 forM fields $ \(field, value) ->
84 do value' <- expression value
85 return $ ArrayLit () [ string (Var.varName field), value' ]
87 return $ _Utils "replace" `call` [ArrayLit () fields', e']
89 Record fields ->
90 do fields' <-
91 forM fields $ \(field, e) ->
92 (,) (Var.varName field) <$> expression e
94 let fieldMap =
95 List.foldl' combine Map.empty fields'
97 return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
98 where
99 combine record (field, value) =
100 Map.insertWith (++) field [value] record
102 hidden fs =
103 ObjectLit () . map (prop *** ArrayLit ()) $
104 Map.toList (Map.filter (not . null) (Map.map tail fs))
106 visible fs =
107 map (first prop) (Map.toList (Map.map head fs))
109 Binop op e1 e2 ->
110 binop region op e1 e2
112 Lambda pattern rawBody@(A.A ann _) ->
113 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
114 body' <- expression body
115 return $
116 case length args < 2 || length args > 9 of
117 True -> foldr (==>) body' (map (:[]) args)
118 False -> ref ("F" ++ show (length args)) <| (args ==> body')
119 where
120 depattern (args, body) pattern =
121 case pattern of
122 A.A _ (P.Var x) ->
123 return (args ++ [ Var.varName x ], body)
125 _ ->
126 do arg <- Case.newVar
127 return
128 ( args ++ [arg]
129 , A.A ann (Case (A.A ann (localVar arg)) [(pattern, body)])
130 )
132 (patterns, innerBody) =
133 collect [pattern] rawBody
135 collect patterns lexpr@(A.A _ expr) =
136 case expr of
137 Lambda p e -> collect (p:patterns) e
138 _ -> (patterns, lexpr)
140 App e1 e2 ->
141 do func' <- expression func
142 args' <- mapM expression args
143 return $
144 case args' of
145 [arg] -> func' <| arg
146 _ | length args' <= 9 -> ref aN `call` (func':args')
147 | otherwise -> foldl1 (<|) (func':args')
148 where
149 aN = "A" ++ show (length args)
150 (func, args) = getArgs e1 [e2]
151 getArgs func args =
152 case func of
153 (A.A _ (App f arg)) -> getArgs f (arg : args)
154 _ -> (func, args)
156 Let defs e ->
157 do let (defs',e') = flattenLets defs e
158 stmts <- concat <$> mapM definition defs'
159 exp <- expression e'
160 return $ function [] (stmts ++ [ ret exp ]) `call` []
162 MultiIf branches ->
163 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
164 return $
165 case last branches of
166 (A.A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) ->
167 safeIfs branches'
168 (A.A _ (Literal (Boolean True)), _) ->
169 safeIfs branches'
170 _ ->
171 ifs branches' (throw "badIf" region)
172 where
173 safeIfs branches = ifs (init branches) (snd (last branches))
174 ifs branches finally = foldr iff finally branches
175 iff (if', then') else' = CondExpr () if' then' else'
177 Case e cases ->
178 do (tempVar,initialMatch) <- Case.toMatch cases
179 (revisedMatch, stmt) <-
180 case e of
181 A.A _ (Var (Var.Canonical Var.Local x)) ->
182 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
183 _ ->
184 do e' <- expression e
185 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
186 match' <- match region revisedMatch
187 return (function [] (stmt ++ match') `call` [])
189 ExplicitList es ->
190 do es' <- mapM expression es
191 return $ _List "fromArray" <| ArrayLit () es'
193 Data name es ->
194 do es' <- mapM expression es
195 return $ ObjectLit () (ctor : fields es')
196 where
197 ctor = (prop "ctor", string name)
198 fields =
199 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
201 GLShader _uid src _tipe ->
202 return $ ObjectLit () [(PropString () "src", literal (Str src))]
204 Port impl ->
205 case impl of
206 In name portType ->
207 return (Port.inbound name portType)
209 Out name expr portType ->
210 do expr' <- expression expr
211 return (Port.outbound name expr' portType)
213 Task name expr portType ->
214 do expr' <- expression expr
215 return (Port.task name expr' portType)
218definition :: Canonical.Def -> State Int [Statement ()]
219definition (Canonical.Definition annPattern expr@(A.A region _) _) =
220 do expr' <- expression expr
221 let assign x = varDecl x expr'
222 let (A.A patternRegion pattern) = annPattern
223 case pattern of
224 P.Var x
225 | Help.isOp x ->
226 let op = LBracket () (ref "_op") (string x) in
227 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
229 | otherwise ->
230 return [ VarDeclStmt () [ assign (Var.varName x) ] ]
232 P.Record fields ->
233 let setField f = varDecl f (obj ["$",f]) in
234 return [ VarDeclStmt () (assign "$" : map setField fields) ]
236 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
237 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
238 where
239 vars = getVars patterns
240 getVars patterns =
241 case patterns of
242 A.A _ (P.Var x) : rest ->
243 (Var.varName x :) `fmap` getVars rest
244 [] ->
245 Just []
246 _ ->
247 Nothing
249 decl x n = varDecl x (obj ["$","_" ++ show n])
250 setup vars
251 | Help.isTuple name = assign "$" : vars
252 | otherwise = assign "_raw" : safeAssign : vars
254 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
255 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
256 exception = Help.throw "badCase" region
258 _ ->
259 do defs' <- concat <$> mapM toDef vars
260 return (VarDeclStmt () [assign "_"] : defs')
261 where
262 vars = P.boundVarList annPattern
263 mkVar = A.A region . localVar
264 toDef y =
265 let expr = A.A region $ Case (mkVar "_") [(annPattern, mkVar y)]
266 pat = A.A patternRegion (P.Var y)
267 in
268 definition (Canonical.Definition pat expr Nothing)
271match :: R.Region -> Case.Match -> State Int [Statement ()]
272match region mtch =
273 case mtch of
274 Case.Match name clauses mtch' ->
275 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
276 mtch'' <- match region mtch'
277 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
278 where
279 isLiteral p =
280 case p of
281 Case.Clause (Right _) _ _ -> True
282 _ -> False
284 access name
285 | any isLiteral clauses = obj [name]
286 | otherwise = obj (Help.splitDots name ++ ["ctor"])
288 format isChars e
289 | or isChars = InfixExpr () OpAdd e (string "")
290 | otherwise = e
292 Case.Fail ->
293 return [ ExprStmt () (Help.throw "badCase" region) ]
295 Case.Break ->
296 return [BreakStmt () Nothing]
298 Case.Other e ->
299 do e' <- expression e
300 return [ ret e' ]
302 Case.Seq ms ->
303 concat <$> mapM (match region) (dropEnd [] ms)
304 where
305 dropEnd acc [] = acc
306 dropEnd acc (m:ms) =
307 case m of
308 Case.Other _ -> acc ++ [m]
309 _ -> dropEnd (acc ++ [m]) ms
312clause :: R.Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
313clause region variable (Case.Clause value vars mtch) =
314 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
315 where
316 vars' =
317 map (\n -> variable ++ "._" ++ show n) [0..]
319 (isChar, pattern) =
320 case value of
321 Right (Chr c) -> (True, string [c])
322 _ ->
323 (,) False $
324 case value of
325 Right (Boolean b) -> BoolLit () b
326 Right lit -> literal lit
327 Left (Var.Canonical _ name) ->
328 string name
331flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
332flattenLets defs lexpr@(A.A _ expr) =
333 case expr of
334 Let ds body -> flattenLets (defs ++ ds) body
335 _ -> (defs, lexpr)
338generate :: Module.CanonicalModule -> String
339generate modul =
340 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
341 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]
342 where
343 names :: [String]
344 names = Module.names modul
346 thisModule :: Expression ()
347 thisModule = obj (localRuntime : names ++ ["values"])
349 programStmts :: [Statement ()]
350 programStmts =
351 concat
352 [ [ ExprStmt () (string "use strict") ]
353 , setup localRuntime (names ++ ["values"])
354 , [ IfSingleStmt () thisModule (ret thisModule) ]
355 , [ VarDeclStmt () localVars ]
356 , body
357 , [ jsExports ]
358 , [ ret thisModule ]
359 ]
361 localVars :: [VarDecl ()]
362 localVars =
363 varDecl "_op" (ObjectLit () [])
364 : internalImports (Module.names modul)
365 ++ explicitImports
366 where
367 explicitImports :: [VarDecl ()]
368 explicitImports =
369 Module.imports modul
370 |> Set.fromList
371 |> Set.toList
372 |> map jsImport
374 jsImport :: Module.Name -> VarDecl ()
375 jsImport name =
376 varDecl (Var.moduleName name) $
377 obj ("Elm" : name ++ ["make"]) <| ref localRuntime
379 body :: [Statement ()]
380 body =
381 concat (evalState defs 0)
382 where
383 defs =
384 Module.program (Module.body modul)
385 |> flattenLets []
386 |> fst
387 |> mapM definition
389 setup namespace path =
390 map create paths
391 where
392 create name =
393 assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
394 paths =
395 namespace : path
396 |> List.inits
397 |> init
398 |> drop 2
400 jsExports =
401 assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)
402 where
403 exs = map entry $ "_op" : concatMap extract (exports modul)
404 entry x = (prop x, ref x)
405 extract value =
406 case value of
407 Var.Alias _ -> []
409 Var.Value x
410 | Help.isOp x -> []
411 | otherwise -> [Var.varName x]
413 Var.Union _ (Var.Listing ctors _) ->
414 map Var.varName ctors
416 assign path expr =
417 case path of
418 [x] -> VarDeclStmt () [ varDecl x expr ]
419 _ ->
420 ExprStmt () $
421 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
424binop
425 :: R.Region
426 -> Var.Canonical
427 -> Canonical.Expr
428 -> Canonical.Expr
429 -> State Int (Expression ())
430binop region func@(Var.Canonical home op) e1 e2 =
431 case (home, op) of
432 (Var.Module ["Basics"], ">>") ->
433 do es <- mapM expression (collectLeftAssoc [e2] e1)
434 return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es
436 (Var.Module ["Basics"], "<<") ->
437 do es <- mapM expression (e1 : collectRightAssoc [] e2)
438 return $ ["$"] ==> foldr (<|) (ref "$") es
440 (Var.Module ["Basics"], "<|") ->
441 do e2' <- expression e2
442 es <- mapM expression (collectRightAssoc [] e1)
443 return $ foldr (<|) e2' es
445 (Var.BuiltIn, "::") ->
446 expression (A.A region (Data "::" [e1,e2]))
448 (Var.Module ["Basics"], _) ->
449 do e1' <- expression e1
450 e2' <- expression e2
451 case Map.lookup op basicOps of
452 Just f ->
453 return (f e1' e2')
455 Nothing ->
456 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
458 _ ->
459 do e1' <- expression e1
460 e2' <- expression e2
461 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
463 where
464 collectRightAssoc es e =
465 case e of
466 A.A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->
467 collectRightAssoc (es ++ [e1]) e2
468 _ -> es ++ [e]
470 collectLeftAssoc es e =
471 case e of
472 A.A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->
473 collectLeftAssoc (e2 : es) e1
474 _ -> e : es
476 basicOps =
477 Map.fromList (infixOps ++ specialOps)
479 infixOps =
480 let infixOp str op = (str, InfixExpr () op) in
481 [ infixOp "+" OpAdd
482 , infixOp "-" OpSub
483 , infixOp "*" OpMul
484 , infixOp "/" OpDiv
485 , infixOp "&&" OpLAnd
486 , infixOp "||" OpLOr
487 ]
489 specialOps =
490 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
491 , (,) "|>" $ flip (<|)
492 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
493 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
494 , (,) "<" $ cmp OpLT 0
495 , (,) ">" $ cmp OpGT 0
496 , (,) "<=" $ cmp OpLT 1
497 , (,) ">=" $ cmp OpGT (-1)
498 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
499 ]
501 cmp op n a b =
502 InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)