git.iko.soy/elk
on 4b559e0 help sign in
elk/src/Generate/JavaScript.hs
489 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 Loopback name tipe maybeExpr ->
218 case maybeExpr of
219 Nothing ->
220 return $ obj ["_P","writableStream"] `call` [ string name ]
222 Just expr ->
223 error "run the promises"
226definition :: Canonical.Def -> State Int [Statement ()]
227definition (Canonical.Definition pattern expr@(A region _) _) =
228 do expr' <- expression expr
229 let assign x = varDecl x expr'
230 case pattern of
231 P.Var x
232 | Help.isOp x ->
233 let op = LBracket () (ref "_op") (string x) in
234 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
236 | otherwise ->
237 return [ VarDeclStmt () [ assign (Var.varName x) ] ]
239 P.Record fields ->
240 let setField f = varDecl f (obj ["$",f]) in
241 return [ VarDeclStmt () (assign "$" : map setField fields) ]
243 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
244 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
245 where
246 vars = getVars patterns
247 getVars patterns =
248 case patterns of
249 P.Var x : rest -> (Var.varName x :) `fmap` getVars rest
250 [] -> Just []
251 _ -> Nothing
253 decl x n = varDecl x (obj ["$","_" ++ show n])
254 setup vars
255 | Help.isTuple name = assign "$" : vars
256 | otherwise = assign "_raw" : safeAssign : vars
258 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
259 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
260 exception = Help.throw "badCase" region
262 _ ->
263 do defs' <- concat <$> mapM toDef vars
264 return (VarDeclStmt () [assign "_"] : defs')
265 where
266 vars = P.boundVarList pattern
267 mkVar = A region . localVar
268 toDef y =
269 let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]
270 in
271 definition $ Canonical.Definition (P.Var y) expr Nothing
274match :: Region -> Case.Match -> State Int [Statement ()]
275match region mtch =
276 case mtch of
277 Case.Match name clauses mtch' ->
278 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
279 mtch'' <- match region mtch'
280 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
281 where
282 isLiteral p =
283 case p of
284 Case.Clause (Right _) _ _ -> True
285 _ -> False
287 access name
288 | any isLiteral clauses = obj [name]
289 | otherwise = obj (Help.splitDots name ++ ["ctor"])
291 format isChars e
292 | or isChars = InfixExpr () OpAdd e (string "")
293 | otherwise = e
295 Case.Fail ->
296 return [ ExprStmt () (Help.throw "badCase" region) ]
298 Case.Break ->
299 return [BreakStmt () Nothing]
301 Case.Other e ->
302 do e' <- expression e
303 return [ ret e' ]
305 Case.Seq ms ->
306 concat <$> mapM (match region) (dropEnd [] ms)
307 where
308 dropEnd acc [] = acc
309 dropEnd acc (m:ms) =
310 case m of
311 Case.Other _ -> acc ++ [m]
312 _ -> dropEnd (acc ++ [m]) ms
315clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
316clause region variable (Case.Clause value vars mtch) =
317 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
318 where
319 vars' =
320 map (\n -> variable ++ "._" ++ show n) [0..]
322 (isChar, pattern) =
323 case value of
324 Right (Chr c) -> (True, string [c])
325 _ ->
326 (,) False $
327 case value of
328 Right (Boolean b) -> BoolLit () b
329 Right lit -> literal lit
330 Left (Var.Canonical _ name) ->
331 string name
334flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
335flattenLets defs lexpr@(A _ expr) =
336 case expr of
337 Let ds body -> flattenLets (defs ++ ds) body
338 _ -> (defs, lexpr)
341generate :: CanonicalModule -> String
342generate modul =
343 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
344 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]
345 where
346 names :: [String]
347 names = Module.names modul
349 thisModule :: Expression ()
350 thisModule = obj (localRuntime : names ++ ["values"])
352 programStmts :: [Statement ()]
353 programStmts =
354 concat
355 [ [ ExprStmt () (string "use strict") ]
356 , setup localRuntime (names ++ ["values"])
357 , [ IfSingleStmt () thisModule (ret thisModule) ]
358 , [ VarDeclStmt () localVars ]
359 , body
360 , [ jsExports ]
361 , [ ret thisModule ]
362 ]
364 localVars :: [VarDecl ()]
365 localVars = varDecl "_op" (ObjectLit () []) :
366 internalImports (Module.names modul) ++
367 explicitImports
368 where
369 explicitImports :: [VarDecl ()]
370 explicitImports =
371 map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul
373 jsImport :: Module.Name -> VarDecl ()
374 jsImport name =
375 varDecl (Var.moduleName name) $
376 obj ("Elm" : name ++ ["make"]) <| ref localRuntime
378 body :: [Statement ()]
379 body = concat $ evalState defs 0
380 where
381 defs = mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)
383 setup namespace path = map create paths
384 where
385 create name = assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
386 paths = drop 2 . init . List.inits $ namespace : path
388 jsExports = assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)
389 where
390 exs = map entry $ "_op" : concatMap extract (exports modul)
391 entry x = (prop x, ref x)
392 extract value =
393 case value of
394 Var.Alias _ -> []
396 Var.Value x
397 | Help.isOp x -> []
398 | otherwise -> [Var.varName x]
400 Var.Union _ (Var.Listing ctors _) ->
401 map Var.varName ctors
403 assign path expr =
404 case path of
405 [x] -> VarDeclStmt () [ varDecl x expr ]
406 _ ->
407 ExprStmt () $
408 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
411binop
412 :: Region
413 -> Var.Canonical
414 -> Canonical.Expr
415 -> Canonical.Expr
416 -> State Int (Expression ())
417binop region func@(Var.Canonical home op) e1 e2 =
418 case (home, op) of
419 (Var.Module ["Basics"], ">>") ->
420 do es <- mapM expression (collectLeftAssoc [e2] e1)
421 return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es
423 (Var.Module ["Basics"], "<<") ->
424 do es <- mapM expression (e1 : collectRightAssoc [] e2)
425 return $ ["$"] ==> foldr (<|) (ref "$") es
427 (Var.Module ["Basics"], "<|") ->
428 do e2' <- expression e2
429 es <- mapM expression (collectRightAssoc [] e1)
430 return $ foldr (<|) e2' es
432 (Var.BuiltIn, "::") ->
433 expression (A region (Data "::" [e1,e2]))
435 (Var.Module ["Basics"], _) ->
436 do e1' <- expression e1
437 e2' <- expression e2
438 case Map.lookup op basicOps of
439 Just f ->
440 return (f e1' e2')
442 Nothing ->
443 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
445 _ ->
446 do e1' <- expression e1
447 e2' <- expression e2
448 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
450 where
451 collectRightAssoc es e =
452 case e of
453 A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->
454 collectRightAssoc (es ++ [e1]) e2
455 _ -> es ++ [e]
457 collectLeftAssoc es e =
458 case e of
459 A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->
460 collectLeftAssoc (e2 : es) e1
461 _ -> e : es
463 basicOps =
464 Map.fromList (infixOps ++ specialOps)
466 infixOps =
467 let infixOp str op = (str, InfixExpr () op) in
468 [ infixOp "+" OpAdd
469 , infixOp "-" OpSub
470 , infixOp "*" OpMul
471 , infixOp "/" OpDiv
472 , infixOp "&&" OpLAnd
473 , infixOp "||" OpLOr
474 ]
476 specialOps =
477 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
478 , (,) "|>" $ flip (<|)
479 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
480 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
481 , (,) "<" $ cmp OpLT 0
482 , (,) ">" $ cmp OpGT 0
483 , (,) "<=" $ cmp OpLT 1
484 , (,) ">=" $ cmp OpGT (-1)
485 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
486 ]
488 cmp op n a b =
489 InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)