git.iko.soy/elk
on fb08d70 help sign in
elk/src/Generate/JavaScript.hs
511 lines 17 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 Remove e field ->
81 do e' <- expression e
82 return $ _Utils "remove" `call` [ string (Var.varName field), e' ]
84 Insert e field value ->
85 do value' <- expression value
86 e' <- expression e
87 return $ _Utils "insert" `call` [ string (Var.varName field), value', e' ]
89 Modify e fields ->
90 do e' <- expression e
91 fields' <-
92 forM fields $ \(field, value) ->
93 do value' <- expression value
94 return $ ArrayLit () [ string (Var.varName field), value' ]
96 return $ _Utils "replace" `call` [ArrayLit () fields', e']
98 Record fields ->
99 do fields' <-
100 forM fields $ \(field, e) ->
101 (,) (Var.varName field) <$> expression e
103 let fieldMap =
104 List.foldl' combine Map.empty fields'
106 return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
107 where
108 combine record (field, value) =
109 Map.insertWith (++) field [value] record
111 hidden fs =
112 ObjectLit () . map (prop *** ArrayLit ()) $
113 Map.toList (Map.filter (not . null) (Map.map tail fs))
115 visible fs =
116 map (first prop) (Map.toList (Map.map head fs))
118 Binop op e1 e2 ->
119 binop region op e1 e2
121 Lambda pattern rawBody@(A.A ann _) ->
122 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
123 body' <- expression body
124 return $
125 case length args < 2 || length args > 9 of
126 True -> foldr (==>) body' (map (:[]) args)
127 False -> ref ("F" ++ show (length args)) <| (args ==> body')
128 where
129 depattern (args, body) pattern =
130 case pattern of
131 A.A _ (P.Var x) ->
132 return (args ++ [ Var.varName x ], body)
134 _ ->
135 do arg <- Case.newVar
136 return
137 ( args ++ [arg]
138 , A.A ann (Case (A.A ann (localVar arg)) [(pattern, body)])
139 )
141 (patterns, innerBody) =
142 collect [pattern] rawBody
144 collect patterns lexpr@(A.A _ expr) =
145 case expr of
146 Lambda p e -> collect (p:patterns) e
147 _ -> (patterns, lexpr)
149 App e1 e2 ->
150 do func' <- expression func
151 args' <- mapM expression args
152 return $
153 case args' of
154 [arg] -> func' <| arg
155 _ | length args' <= 9 -> ref aN `call` (func':args')
156 | otherwise -> foldl1 (<|) (func':args')
157 where
158 aN = "A" ++ show (length args)
159 (func, args) = getArgs e1 [e2]
160 getArgs func args =
161 case func of
162 (A.A _ (App f arg)) -> getArgs f (arg : args)
163 _ -> (func, args)
165 Let defs e ->
166 do let (defs',e') = flattenLets defs e
167 stmts <- concat <$> mapM definition defs'
168 exp <- expression e'
169 return $ function [] (stmts ++ [ ret exp ]) `call` []
171 MultiIf branches ->
172 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
173 return $
174 case last branches of
175 (A.A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) ->
176 safeIfs branches'
177 (A.A _ (Literal (Boolean True)), _) ->
178 safeIfs branches'
179 _ ->
180 ifs branches' (throw "badIf" region)
181 where
182 safeIfs branches = ifs (init branches) (snd (last branches))
183 ifs branches finally = foldr iff finally branches
184 iff (if', then') else' = CondExpr () if' then' else'
186 Case e cases ->
187 do (tempVar,initialMatch) <- Case.toMatch cases
188 (revisedMatch, stmt) <-
189 case e of
190 A.A _ (Var (Var.Canonical Var.Local x)) ->
191 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
192 _ ->
193 do e' <- expression e
194 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
195 match' <- match region revisedMatch
196 return (function [] (stmt ++ match') `call` [])
198 ExplicitList es ->
199 do es' <- mapM expression es
200 return $ _List "fromArray" <| ArrayLit () es'
202 Data name es ->
203 do es' <- mapM expression es
204 return $ ObjectLit () (ctor : fields es')
205 where
206 ctor = (prop "ctor", string name)
207 fields =
208 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
210 GLShader _uid src _tipe ->
211 return $ ObjectLit () [(PropString () "src", literal (Str src))]
213 Port impl ->
214 case impl of
215 In name portType ->
216 return (Port.inbound name portType)
218 Out name expr portType ->
219 do expr' <- expression expr
220 return (Port.outbound name expr' portType)
222 Task name expr portType ->
223 do expr' <- expression expr
224 return (Port.task name expr' portType)
227definition :: Canonical.Def -> State Int [Statement ()]
228definition (Canonical.Definition annPattern expr@(A.A region _) _) =
229 do expr' <- expression expr
230 let assign x = varDecl x expr'
231 let (A.A patternRegion pattern) = annPattern
232 case pattern of
233 P.Var x
234 | Help.isOp x ->
235 let op = LBracket () (ref "_op") (string x) in
236 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
238 | otherwise ->
239 return [ VarDeclStmt () [ assign (Var.varName x) ] ]
241 P.Record fields ->
242 let setField f = varDecl f (obj ["$",f]) in
243 return [ VarDeclStmt () (assign "$" : map setField fields) ]
245 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
246 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
247 where
248 vars = getVars patterns
249 getVars patterns =
250 case patterns of
251 A.A _ (P.Var x) : rest ->
252 (Var.varName x :) `fmap` getVars rest
253 [] ->
254 Just []
255 _ ->
256 Nothing
258 decl x n = varDecl x (obj ["$","_" ++ show n])
259 setup vars
260 | Help.isTuple name = assign "$" : vars
261 | otherwise = assign "_raw" : safeAssign : vars
263 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
264 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
265 exception = Help.throw "badCase" region
267 _ ->
268 do defs' <- concat <$> mapM toDef vars
269 return (VarDeclStmt () [assign "_"] : defs')
270 where
271 vars = P.boundVarList annPattern
272 mkVar = A.A region . localVar
273 toDef y =
274 let expr = A.A region $ Case (mkVar "_") [(annPattern, mkVar y)]
275 pat = A.A patternRegion (P.Var y)
276 in
277 definition (Canonical.Definition pat expr Nothing)
280match :: R.Region -> Case.Match -> State Int [Statement ()]
281match region mtch =
282 case mtch of
283 Case.Match name clauses mtch' ->
284 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
285 mtch'' <- match region mtch'
286 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
287 where
288 isLiteral p =
289 case p of
290 Case.Clause (Right _) _ _ -> True
291 _ -> False
293 access name
294 | any isLiteral clauses = obj [name]
295 | otherwise = obj (Help.splitDots name ++ ["ctor"])
297 format isChars e
298 | or isChars = InfixExpr () OpAdd e (string "")
299 | otherwise = e
301 Case.Fail ->
302 return [ ExprStmt () (Help.throw "badCase" region) ]
304 Case.Break ->
305 return [BreakStmt () Nothing]
307 Case.Other e ->
308 do e' <- expression e
309 return [ ret e' ]
311 Case.Seq ms ->
312 concat <$> mapM (match region) (dropEnd [] ms)
313 where
314 dropEnd acc [] = acc
315 dropEnd acc (m:ms) =
316 case m of
317 Case.Other _ -> acc ++ [m]
318 _ -> dropEnd (acc ++ [m]) ms
321clause :: R.Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
322clause region variable (Case.Clause value vars mtch) =
323 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
324 where
325 vars' =
326 map (\n -> variable ++ "._" ++ show n) [0..]
328 (isChar, pattern) =
329 case value of
330 Right (Chr c) -> (True, string [c])
331 _ ->
332 (,) False $
333 case value of
334 Right (Boolean b) -> BoolLit () b
335 Right lit -> literal lit
336 Left (Var.Canonical _ name) ->
337 string name
340flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
341flattenLets defs lexpr@(A.A _ expr) =
342 case expr of
343 Let ds body -> flattenLets (defs ++ ds) body
344 _ -> (defs, lexpr)
347generate :: CanonicalModule -> String
348generate modul =
349 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
350 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]
351 where
352 names :: [String]
353 names = Module.names modul
355 thisModule :: Expression ()
356 thisModule = obj (localRuntime : names ++ ["values"])
358 programStmts :: [Statement ()]
359 programStmts =
360 concat
361 [ [ ExprStmt () (string "use strict") ]
362 , setup localRuntime (names ++ ["values"])
363 , [ IfSingleStmt () thisModule (ret thisModule) ]
364 , [ VarDeclStmt () localVars ]
365 , body
366 , [ jsExports ]
367 , [ ret thisModule ]
368 ]
370 localVars :: [VarDecl ()]
371 localVars =
372 varDecl "_op" (ObjectLit () [])
373 : internalImports (Module.names modul)
374 ++ explicitImports
375 where
376 explicitImports :: [VarDecl ()]
377 explicitImports =
378 Module.imports modul
379 |> Set.fromList
380 |> Set.toList
381 |> map jsImport
383 jsImport :: Module.Name -> VarDecl ()
384 jsImport name =
385 varDecl (Var.moduleName name) $
386 obj ("Elm" : name ++ ["make"]) <| ref localRuntime
388 body :: [Statement ()]
389 body =
390 concat (evalState defs 0)
391 where
392 defs =
393 Module.program (Module.body modul)
394 |> flattenLets []
395 |> fst
396 |> mapM definition
398 setup namespace path =
399 map create paths
400 where
401 create name =
402 assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
403 paths =
404 namespace : path
405 |> List.inits
406 |> init
407 |> drop 2
409 jsExports =
410 assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)
411 where
412 exs = map entry $ "_op" : concatMap extract (exports modul)
413 entry x = (prop x, ref x)
414 extract value =
415 case value of
416 Var.Alias _ -> []
418 Var.Value x
419 | Help.isOp x -> []
420 | otherwise -> [Var.varName x]
422 Var.Union _ (Var.Listing ctors _) ->
423 map Var.varName ctors
425 assign path expr =
426 case path of
427 [x] -> VarDeclStmt () [ varDecl x expr ]
428 _ ->
429 ExprStmt () $
430 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
433binop
434 :: R.Region
435 -> Var.Canonical
436 -> Canonical.Expr
437 -> Canonical.Expr
438 -> State Int (Expression ())
439binop region func@(Var.Canonical home op) e1 e2 =
440 case (home, op) of
441 (Var.Module ["Basics"], ">>") ->
442 do es <- mapM expression (collectLeftAssoc [e2] e1)
443 return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es
445 (Var.Module ["Basics"], "<<") ->
446 do es <- mapM expression (e1 : collectRightAssoc [] e2)
447 return $ ["$"] ==> foldr (<|) (ref "$") es
449 (Var.Module ["Basics"], "<|") ->
450 do e2' <- expression e2
451 es <- mapM expression (collectRightAssoc [] e1)
452 return $ foldr (<|) e2' es
454 (Var.BuiltIn, "::") ->
455 expression (A.A region (Data "::" [e1,e2]))
457 (Var.Module ["Basics"], _) ->
458 do e1' <- expression e1
459 e2' <- expression e2
460 case Map.lookup op basicOps of
461 Just f ->
462 return (f e1' e2')
464 Nothing ->
465 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
467 _ ->
468 do e1' <- expression e1
469 e2' <- expression e2
470 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
472 where
473 collectRightAssoc es e =
474 case e of
475 A.A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->
476 collectRightAssoc (es ++ [e1]) e2
477 _ -> es ++ [e]
479 collectLeftAssoc es e =
480 case e of
481 A.A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->
482 collectLeftAssoc (e2 : es) e1
483 _ -> e : es
485 basicOps =
486 Map.fromList (infixOps ++ specialOps)
488 infixOps =
489 let infixOp str op = (str, InfixExpr () op) in
490 [ infixOp "+" OpAdd
491 , infixOp "-" OpSub
492 , infixOp "*" OpMul
493 , infixOp "/" OpDiv
494 , infixOp "&&" OpLAnd
495 , infixOp "||" OpLOr
496 ]
498 specialOps =
499 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
500 , (,) "|>" $ flip (<|)
501 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
502 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
503 , (,) "<" $ cmp OpLT 0
504 , (,) ">" $ cmp OpGT 0
505 , (,) "<=" $ cmp OpLT 1
506 , (,) ">=" $ cmp OpGT (-1)
507 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
508 ]
510 cmp op n a b =
511 InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)