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