git.iko.soy/elk
on 8036fca help sign in
elk/src/Generate/JavaScript.hs
493 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.Foreign as Foreign
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.Module as Module
22import qualified AST.Helpers as Help
23import AST.Literal
24import qualified AST.Pattern as P
25import qualified AST.Variable as Var
28internalImports :: Module.Name -> [VarDecl ()]
29internalImports name =
30 [ varDecl "_N" (obj ["Elm","Native"])
31 , include "_U" "Utils"
32 , include "_L" "List"
33 , include "_P" "Ports"
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 Input name tipe ->
211 return (Foreign.input name tipe)
213 Output name tipe value ->
214 do value' <- expression value
215 return (Foreign.output name tipe value')
217 LoopbackIn name source ->
218 case source of
219 Mailbox ->
220 return $ obj ["_P","writableStream"] `call` [ string name ]
222 PromiseStream ->
223 return $ obj ["_P","loopbackIn"] `call` [ string name ]
225 LoopbackOut name expr ->
226 do expr' <- expression expr
227 return $ obj ["_P","loopbackOut"] `call` [ string name, expr' ]
230definition :: Canonical.Def -> State Int [Statement ()]
231definition (Canonical.Definition pattern expr@(A region _) _) =
232 do expr' <- expression expr
233 let assign x = varDecl x expr'
234 case pattern of
235 P.Var x
236 | Help.isOp x ->
237 let op = LBracket () (ref "_op") (string x) in
238 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
240 | otherwise ->
241 return [ VarDeclStmt () [ assign (Var.varName x) ] ]
243 P.Record fields ->
244 let setField f = varDecl f (obj ["$",f]) in
245 return [ VarDeclStmt () (assign "$" : map setField fields) ]
247 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
248 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
249 where
250 vars = getVars patterns
251 getVars patterns =
252 case patterns of
253 P.Var x : rest -> (Var.varName x :) `fmap` getVars rest
254 [] -> Just []
255 _ -> Nothing
257 decl x n = varDecl x (obj ["$","_" ++ show n])
258 setup vars
259 | Help.isTuple name = assign "$" : vars
260 | otherwise = assign "_raw" : safeAssign : vars
262 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
263 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
264 exception = Help.throw "badCase" region
266 _ ->
267 do defs' <- concat <$> mapM toDef vars
268 return (VarDeclStmt () [assign "_"] : defs')
269 where
270 vars = P.boundVarList pattern
271 mkVar = A region . localVar
272 toDef y =
273 let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]
274 in
275 definition $ Canonical.Definition (P.Var y) expr Nothing
278match :: Region -> Case.Match -> State Int [Statement ()]
279match region mtch =
280 case mtch of
281 Case.Match name clauses mtch' ->
282 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
283 mtch'' <- match region mtch'
284 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
285 where
286 isLiteral p =
287 case p of
288 Case.Clause (Right _) _ _ -> True
289 _ -> False
291 access name
292 | any isLiteral clauses = obj [name]
293 | otherwise = obj (Help.splitDots name ++ ["ctor"])
295 format isChars e
296 | or isChars = InfixExpr () OpAdd e (string "")
297 | otherwise = e
299 Case.Fail ->
300 return [ ExprStmt () (Help.throw "badCase" region) ]
302 Case.Break ->
303 return [BreakStmt () Nothing]
305 Case.Other e ->
306 do e' <- expression e
307 return [ ret e' ]
309 Case.Seq ms ->
310 concat <$> mapM (match region) (dropEnd [] ms)
311 where
312 dropEnd acc [] = acc
313 dropEnd acc (m:ms) =
314 case m of
315 Case.Other _ -> acc ++ [m]
316 _ -> dropEnd (acc ++ [m]) ms
319clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
320clause region variable (Case.Clause value vars mtch) =
321 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
322 where
323 vars' =
324 map (\n -> variable ++ "._" ++ show n) [0..]
326 (isChar, pattern) =
327 case value of
328 Right (Chr c) -> (True, string [c])
329 _ ->
330 (,) False $
331 case value of
332 Right (Boolean b) -> BoolLit () b
333 Right lit -> literal lit
334 Left (Var.Canonical _ name) ->
335 string name
338flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
339flattenLets defs lexpr@(A _ expr) =
340 case expr of
341 Let ds body -> flattenLets (defs ++ ds) body
342 _ -> (defs, lexpr)
345generate :: CanonicalModule -> String
346generate modul =
347 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
348 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]
349 where
350 names :: [String]
351 names = Module.names modul
353 thisModule :: Expression ()
354 thisModule = obj (localRuntime : names ++ ["values"])
356 programStmts :: [Statement ()]
357 programStmts =
358 concat
359 [ [ ExprStmt () (string "use strict") ]
360 , setup localRuntime (names ++ ["values"])
361 , [ IfSingleStmt () thisModule (ret thisModule) ]
362 , [ VarDeclStmt () localVars ]
363 , body
364 , [ jsExports ]
365 , [ ret thisModule ]
366 ]
368 localVars :: [VarDecl ()]
369 localVars = varDecl "_op" (ObjectLit () []) :
370 internalImports (Module.names modul) ++
371 explicitImports
372 where
373 explicitImports :: [VarDecl ()]
374 explicitImports =
375 map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul
377 jsImport :: Module.Name -> VarDecl ()
378 jsImport name =
379 varDecl (Var.moduleName name) $
380 obj ("Elm" : name ++ ["make"]) <| ref localRuntime
382 body :: [Statement ()]
383 body = concat $ evalState defs 0
384 where
385 defs = mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)
387 setup namespace path = map create paths
388 where
389 create name = assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
390 paths = drop 2 . init . List.inits $ namespace : path
392 jsExports = assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)
393 where
394 exs = map entry $ "_op" : concatMap extract (exports modul)
395 entry x = (prop x, ref x)
396 extract value =
397 case value of
398 Var.Alias _ -> []
400 Var.Value x
401 | Help.isOp x -> []
402 | otherwise -> [Var.varName x]
404 Var.Union _ (Var.Listing ctors _) ->
405 map Var.varName ctors
407 assign path expr =
408 case path of
409 [x] -> VarDeclStmt () [ varDecl x expr ]
410 _ ->
411 ExprStmt () $
412 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
415binop
416 :: Region
417 -> Var.Canonical
418 -> Canonical.Expr
419 -> Canonical.Expr
420 -> State Int (Expression ())
421binop region func@(Var.Canonical home op) e1 e2 =
422 case (home, op) of
423 (Var.Module ["Basics"], ">>") ->
424 do es <- mapM expression (collectLeftAssoc [e2] e1)
425 return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es
427 (Var.Module ["Basics"], "<<") ->
428 do es <- mapM expression (e1 : collectRightAssoc [] e2)
429 return $ ["$"] ==> foldr (<|) (ref "$") es
431 (Var.Module ["Basics"], "<|") ->
432 do e2' <- expression e2
433 es <- mapM expression (collectRightAssoc [] e1)
434 return $ foldr (<|) e2' es
436 (Var.BuiltIn, "::") ->
437 expression (A region (Data "::" [e1,e2]))
439 (Var.Module ["Basics"], _) ->
440 do e1' <- expression e1
441 e2' <- expression e2
442 case Map.lookup op basicOps of
443 Just f ->
444 return (f e1' e2')
446 Nothing ->
447 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
449 _ ->
450 do e1' <- expression e1
451 e2' <- expression e2
452 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
454 where
455 collectRightAssoc es e =
456 case e of
457 A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->
458 collectRightAssoc (es ++ [e1]) e2
459 _ -> es ++ [e]
461 collectLeftAssoc es e =
462 case e of
463 A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->
464 collectLeftAssoc (e2 : es) e1
465 _ -> e : es
467 basicOps =
468 Map.fromList (infixOps ++ specialOps)
470 infixOps =
471 let infixOp str op = (str, InfixExpr () op) in
472 [ infixOp "+" OpAdd
473 , infixOp "-" OpSub
474 , infixOp "*" OpMul
475 , infixOp "/" OpDiv
476 , infixOp "&&" OpLAnd
477 , infixOp "||" OpLOr
478 ]
480 specialOps =
481 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
482 , (,) "|>" $ flip (<|)
483 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
484 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
485 , (,) "<" $ cmp OpLT 0
486 , (,) ">" $ cmp OpGT 0
487 , (,) "<=" $ cmp OpLT 1
488 , (,) ">=" $ cmp OpGT (-1)
489 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
490 ]
492 cmp op n a b =
493 InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)