git.iko.soy/elk
on 8913c30 help sign in
elk/src/Generate/JavaScript.hs
490 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 Generate.JavaScript.Helpers as Help
13import qualified Generate.Cases as Case
14import qualified Generate.JavaScript.Port as Port
15import qualified Generate.JavaScript.Variable as Var
17import AST.Annotation
18import AST.Module
19import AST.Expression.General
20import qualified AST.Expression.Canonical as Canonical
21import qualified AST.Helpers as Help
22import AST.Literal
23import qualified AST.Module as Module
24import qualified AST.Pattern as P
25import qualified AST.Type as Type
26import qualified AST.Variable as Var
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 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 p e@(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 P.Var x ->
132 return (args ++ [ Var.varName x ], body)
133 _ ->
134 do arg <- Case.newVar
135 return ( args ++ [arg]
136 , A ann (Case (A ann (localVar arg)) [(pattern, body)])
137 )
139 (patterns, innerBody) = collect [p] e
141 collect patterns lexpr@(A _ expr) =
142 case expr of
143 Lambda p e -> collect (p:patterns) e
144 _ -> (patterns, lexpr)
146 App e1 e2 ->
147 do func' <- expression func
148 args' <- mapM expression args
149 return $
150 case args' of
151 [arg] -> func' <| arg
152 _ | length args' <= 9 -> ref aN `call` (func':args')
153 | otherwise -> foldl1 (<|) (func':args')
154 where
155 aN = "A" ++ show (length args)
156 (func, args) = getArgs e1 [e2]
157 getArgs func args =
158 case func of
159 (A _ (App f arg)) -> getArgs f (arg : args)
160 _ -> (func, args)
162 Let defs e ->
163 do let (defs',e') = flattenLets defs e
164 stmts <- concat <$> mapM definition defs'
165 exp <- expression e'
166 return $ function [] (stmts ++ [ ret exp ]) `call` []
168 MultiIf branches ->
169 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
170 return $
171 case last branches of
172 (A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) ->
173 safeIfs branches'
174 (A _ (Literal (Boolean True)), _) ->
175 safeIfs branches'
176 _ ->
177 ifs branches' (throw "badIf" region)
178 where
179 safeIfs branches = ifs (init branches) (snd (last branches))
180 ifs branches finally = foldr iff finally branches
181 iff (if', then') else' = CondExpr () if' then' else'
183 Case e cases ->
184 do (tempVar,initialMatch) <- Case.toMatch cases
185 (revisedMatch, stmt) <-
186 case e of
187 A _ (Var (Var.Canonical Var.Local x)) ->
188 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
189 _ ->
190 do e' <- expression e
191 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
192 match' <- match region revisedMatch
193 return (function [] (stmt ++ match') `call` [])
195 ExplicitList es ->
196 do es' <- mapM expression es
197 return $ _List "fromArray" <| ArrayLit () es'
199 Data name es ->
200 do es' <- mapM expression es
201 return $ ObjectLit () (ctor : fields es')
202 where
203 ctor = (prop "ctor", string name)
204 fields =
205 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
207 GLShader _uid src _tipe ->
208 return $ ObjectLit () [(PropString () "src", literal (Str src))]
210 Port name impl ->
211 case impl of
212 Inbound (Type.Normal tipe) ->
213 return (Port.inbound name tipe)
215 Inbound (Type.Stream _ tipe) ->
216 return (Port.inboundStream name tipe)
218 Outbound (Type.Normal tipe) expr ->
219 do expr' <- expression expr
220 return (Port.outbound name tipe expr')
222 Outbound (Type.Stream _ tipe) expr ->
223 do expr' <- expression expr
224 return (Port.outboundStream name tipe expr')
227definition :: Canonical.Def -> State Int [Statement ()]
228definition (Canonical.Definition pattern expr@(A region _) _) =
229 do expr' <- expression expr
230 let assign x = varDecl x expr'
231 case pattern of
232 P.Var x
233 | Help.isOp x ->
234 let op = LBracket () (ref "_op") (string x) in
235 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
237 | otherwise ->
238 return [ VarDeclStmt () [ assign (Var.varName x) ] ]
240 P.Record fields ->
241 let setField f = varDecl f (obj ["$",f]) in
242 return [ VarDeclStmt () (assign "$" : map setField fields) ]
244 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
245 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
246 where
247 vars = getVars patterns
248 getVars patterns =
249 case patterns of
250 P.Var x : rest -> (Var.varName x :) `fmap` getVars rest
251 [] -> Just []
252 _ -> Nothing
254 decl x n = varDecl x (obj ["$","_" ++ show n])
255 setup vars
256 | Help.isTuple name = assign "$" : vars
257 | otherwise = assign "_raw" : safeAssign : vars
259 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
260 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
261 exception = Help.throw "badCase" region
263 _ ->
264 do defs' <- concat <$> mapM toDef vars
265 return (VarDeclStmt () [assign "_"] : defs')
266 where
267 vars = P.boundVarList pattern
268 mkVar = A region . localVar
269 toDef y =
270 let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]
271 in
272 definition $ Canonical.Definition (P.Var y) expr Nothing
275match :: Region -> Case.Match -> State Int [Statement ()]
276match region mtch =
277 case mtch of
278 Case.Match name clauses mtch' ->
279 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
280 mtch'' <- match region mtch'
281 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
282 where
283 isLiteral p =
284 case p of
285 Case.Clause (Right _) _ _ -> True
286 _ -> False
288 access name
289 | any isLiteral clauses = obj [name]
290 | otherwise = obj (Help.splitDots name ++ ["ctor"])
292 format isChars e
293 | or isChars = InfixExpr () OpAdd e (string "")
294 | otherwise = e
296 Case.Fail ->
297 return [ ExprStmt () (Help.throw "badCase" region) ]
299 Case.Break ->
300 return [BreakStmt () Nothing]
302 Case.Other e ->
303 do e' <- expression e
304 return [ ret e' ]
306 Case.Seq ms ->
307 concat <$> mapM (match region) (dropEnd [] ms)
308 where
309 dropEnd acc [] = acc
310 dropEnd acc (m:ms) =
311 case m of
312 Case.Other _ -> acc ++ [m]
313 _ -> dropEnd (acc ++ [m]) ms
316clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
317clause region variable (Case.Clause value vars mtch) =
318 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
319 where
320 vars' =
321 map (\n -> variable ++ "._" ++ show n) [0..]
323 (isChar, pattern) =
324 case value of
325 Right (Chr c) -> (True, string [c])
326 _ ->
327 (,) False $
328 case value of
329 Right (Boolean b) -> BoolLit () b
330 Right lit -> literal lit
331 Left (Var.Canonical _ name) ->
332 string name
335flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
336flattenLets defs lexpr@(A _ expr) =
337 case expr of
338 Let ds body -> flattenLets (defs ++ ds) body
339 _ -> (defs, lexpr)
342generate :: CanonicalModule -> String
343generate modul =
344 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
345 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]
346 where
347 names :: [String]
348 names = Module.names modul
350 thisModule :: Expression ()
351 thisModule = obj (localRuntime : names ++ ["values"])
353 programStmts :: [Statement ()]
354 programStmts =
355 concat
356 [ [ ExprStmt () (string "use strict") ]
357 , setup localRuntime (names ++ ["values"])
358 , [ IfSingleStmt () thisModule (ret thisModule) ]
359 , [ VarDeclStmt () localVars ]
360 , body
361 , [ jsExports ]
362 , [ ret thisModule ]
363 ]
365 localVars :: [VarDecl ()]
366 localVars = varDecl "_op" (ObjectLit () []) :
367 internalImports (Module.names modul) ++
368 explicitImports
369 where
370 explicitImports :: [VarDecl ()]
371 explicitImports =
372 map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul
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 = concat $ evalState defs 0
381 where
382 defs = mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)
384 setup namespace path = map create paths
385 where
386 create name = assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
387 paths = drop 2 . init . List.inits $ namespace : path
389 jsExports = assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)
390 where
391 exs = map entry $ "_op" : concatMap extract (exports modul)
392 entry x = (prop x, ref x)
393 extract value =
394 case value of
395 Var.Alias _ -> []
397 Var.Value x
398 | Help.isOp x -> []
399 | otherwise -> [Var.varName x]
401 Var.Union _ (Var.Listing ctors _) ->
402 map Var.varName ctors
404 assign path expr =
405 case path of
406 [x] -> VarDeclStmt () [ varDecl x expr ]
407 _ ->
408 ExprStmt () $
409 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
412binop
413 :: Region
414 -> Var.Canonical
415 -> Canonical.Expr
416 -> Canonical.Expr
417 -> State Int (Expression ())
418binop region func@(Var.Canonical home op) e1 e2 =
419 case (home, op) of
420 (Var.Module ["Basics"], ">>") ->
421 do es <- mapM expression (collectLeftAssoc [e2] e1)
422 return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es
424 (Var.Module ["Basics"], "<<") ->
425 do es <- mapM expression (e1 : collectRightAssoc [] e2)
426 return $ ["$"] ==> foldr (<|) (ref "$") es
428 (Var.Module ["Basics"], "<|") ->
429 do e2' <- expression e2
430 es <- mapM expression (collectRightAssoc [] e1)
431 return $ foldr (<|) e2' es
433 (Var.BuiltIn, "::") ->
434 expression (A region (Data "::" [e1,e2]))
436 (Var.Module ["Basics"], _) ->
437 do e1' <- expression e1
438 e2' <- expression e2
439 case Map.lookup op basicOps of
440 Just f ->
441 return (f e1' e2')
443 Nothing ->
444 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
446 _ ->
447 do e1' <- expression e1
448 e2' <- expression e2
449 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
451 where
452 collectRightAssoc es e =
453 case e of
454 A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->
455 collectRightAssoc (es ++ [e1]) e2
456 _ -> es ++ [e]
458 collectLeftAssoc es e =
459 case e of
460 A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->
461 collectLeftAssoc (e2 : es) e1
462 _ -> e : es
464 basicOps =
465 Map.fromList (infixOps ++ specialOps)
467 infixOps =
468 let infixOp str op = (str, InfixExpr () op) in
469 [ infixOp "+" OpAdd
470 , infixOp "-" OpSub
471 , infixOp "*" OpMul
472 , infixOp "/" OpDiv
473 , infixOp "&&" OpLAnd
474 , infixOp "||" OpLOr
475 ]
477 specialOps =
478 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
479 , (,) "|>" $ flip (<|)
480 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
481 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
482 , (,) "<" $ cmp OpLT 0
483 , (,) ">" $ cmp OpGT 0
484 , (,) "<=" $ cmp OpLT 1
485 , (,) ">=" $ cmp OpGT (-1)
486 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
487 ]
489 cmp op n a b =
490 InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)