git.iko.soy/elk
on edfca84 help sign in
elk/src/Generate/JavaScript.hs
486 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)), _) -> safeIfs branches'
175 _ -> ifs branches' (throw "badIf" region)
176 where
177 safeIfs branches = ifs (init branches) (snd (last branches))
178 ifs branches finally = foldr iff finally branches
179 iff (if', then') else' = CondExpr () if' then' else'
181 Case e cases ->
182 do (tempVar,initialMatch) <- Case.toMatch cases
183 (revisedMatch, stmt) <-
184 case e of
185 A _ (Var (Var.Canonical Var.Local x)) ->
186 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
187 _ ->
188 do e' <- expression e
189 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
190 match' <- match region revisedMatch
191 return (function [] (stmt ++ match') `call` [])
193 ExplicitList es ->
194 do es' <- mapM expression es
195 return $ _List "fromArray" <| ArrayLit () es'
197 Data name es ->
198 do es' <- mapM expression es
199 return $ ObjectLit () (ctor : fields es')
200 where
201 ctor = (prop "ctor", string name)
202 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
204 GLShader _uid src _tipe ->
205 return $ ObjectLit () [(PropString () "src", literal (Str src))]
207 Input name tipe ->
208 return (Foreign.input name tipe)
210 Output name tipe value ->
211 do value' <- expression value
212 return (Foreign.output name tipe value')
214 Loopback name tipe maybeExpr ->
215 case maybeExpr of
216 Nothing ->
217 error "create writable stream"
219 Just expr ->
220 error "run the promises"
223definition :: Canonical.Def -> State Int [Statement ()]
224definition (Canonical.Definition pattern expr@(A region _) _) =
225 do expr' <- expression expr
226 let assign x = varDecl x expr'
227 case pattern of
228 P.Var x
229 | Help.isOp x ->
230 let op = LBracket () (ref "_op") (string x) in
231 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
233 | otherwise ->
234 return [ VarDeclStmt () [ assign (Var.varName x) ] ]
236 P.Record fields ->
237 let setField f = varDecl f (obj ["$",f]) in
238 return [ VarDeclStmt () (assign "$" : map setField fields) ]
240 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
241 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
242 where
243 vars = getVars patterns
244 getVars patterns =
245 case patterns of
246 P.Var x : rest -> (Var.varName x :) `fmap` getVars rest
247 [] -> Just []
248 _ -> Nothing
250 decl x n = varDecl x (obj ["$","_" ++ show n])
251 setup vars
252 | Help.isTuple name = assign "$" : vars
253 | otherwise = assign "_raw" : safeAssign : vars
255 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
256 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
257 exception = Help.throw "badCase" region
259 _ ->
260 do defs' <- concat <$> mapM toDef vars
261 return (VarDeclStmt () [assign "_"] : defs')
262 where
263 vars = P.boundVarList pattern
264 mkVar = A region . localVar
265 toDef y =
266 let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]
267 in
268 definition $ Canonical.Definition (P.Var y) expr Nothing
271match :: Region -> Case.Match -> State Int [Statement ()]
272match region mtch =
273 case mtch of
274 Case.Match name clauses mtch' ->
275 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
276 mtch'' <- match region mtch'
277 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
278 where
279 isLiteral p =
280 case p of
281 Case.Clause (Right _) _ _ -> True
282 _ -> False
284 access name
285 | any isLiteral clauses = obj [name]
286 | otherwise = obj (Help.splitDots name ++ ["ctor"])
288 format isChars e
289 | or isChars = InfixExpr () OpAdd e (string "")
290 | otherwise = e
292 Case.Fail ->
293 return [ ExprStmt () (Help.throw "badCase" region) ]
295 Case.Break ->
296 return [BreakStmt () Nothing]
298 Case.Other e ->
299 do e' <- expression e
300 return [ ret e' ]
302 Case.Seq ms ->
303 concat <$> mapM (match region) (dropEnd [] ms)
304 where
305 dropEnd acc [] = acc
306 dropEnd acc (m:ms) =
307 case m of
308 Case.Other _ -> acc ++ [m]
309 _ -> dropEnd (acc ++ [m]) ms
312clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
313clause region variable (Case.Clause value vars mtch) =
314 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
315 where
316 vars' =
317 map (\n -> variable ++ "._" ++ show n) [0..]
319 (isChar, pattern) =
320 case value of
321 Right (Chr c) -> (True, string [c])
322 _ ->
323 (,) False $
324 case value of
325 Right (Boolean b) -> BoolLit () b
326 Right lit -> literal lit
327 Left (Var.Canonical _ name) ->
328 string name
331flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
332flattenLets defs lexpr@(A _ expr) =
333 case expr of
334 Let ds body -> flattenLets (defs ++ ds) body
335 _ -> (defs, lexpr)
338generate :: CanonicalModule -> String
339generate modul =
340 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
341 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]
342 where
343 names :: [String]
344 names = Module.names modul
346 thisModule :: Expression ()
347 thisModule = obj (localRuntime : names ++ ["values"])
349 programStmts :: [Statement ()]
350 programStmts =
351 concat
352 [ [ ExprStmt () (string "use strict") ]
353 , setup localRuntime (names ++ ["values"])
354 , [ IfSingleStmt () thisModule (ret thisModule) ]
355 , [ VarDeclStmt () localVars ]
356 , body
357 , [ jsExports ]
358 , [ ret thisModule ]
359 ]
361 localVars :: [VarDecl ()]
362 localVars = varDecl "_op" (ObjectLit () []) :
363 internalImports (Module.names modul) ++
364 explicitImports
365 where
366 explicitImports :: [VarDecl ()]
367 explicitImports =
368 map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul
370 jsImport :: Module.Name -> VarDecl ()
371 jsImport name =
372 varDecl (Var.moduleName name) $
373 obj ("Elm" : name ++ ["make"]) <| ref localRuntime
375 body :: [Statement ()]
376 body = concat $ evalState defs 0
377 where
378 defs = mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)
380 setup namespace path = map create paths
381 where
382 create name = assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
383 paths = drop 2 . init . List.inits $ namespace : path
385 jsExports = assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)
386 where
387 exs = map entry $ "_op" : concatMap extract (exports modul)
388 entry x = (prop x, ref x)
389 extract value =
390 case value of
391 Var.Alias _ -> []
393 Var.Value x
394 | Help.isOp x -> []
395 | otherwise -> [Var.varName x]
397 Var.Union _ (Var.Listing ctors _) ->
398 map Var.varName ctors
400 assign path expr =
401 case path of
402 [x] -> VarDeclStmt () [ varDecl x expr ]
403 _ ->
404 ExprStmt () $
405 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
408binop
409 :: Region
410 -> Var.Canonical
411 -> Canonical.Expr
412 -> Canonical.Expr
413 -> State Int (Expression ())
414binop region func@(Var.Canonical home op) e1 e2 =
415 case (home, op) of
416 (Var.Module ["Basics"], ">>") ->
417 do es <- mapM expression (collectLeftAssoc [e2] e1)
418 return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es
420 (Var.Module ["Basics"], "<<") ->
421 do es <- mapM expression (e1 : collectRightAssoc [] e2)
422 return $ ["$"] ==> foldr (<|) (ref "$") es
424 (Var.Module ["Basics"], "<|") ->
425 do e2' <- expression e2
426 es <- mapM expression (collectRightAssoc [] e1)
427 return $ foldr (<|) e2' es
429 (Var.BuiltIn, "::") ->
430 expression (A region (Data "::" [e1,e2]))
432 (Var.Module ["Basics"], _) ->
433 do e1' <- expression e1
434 e2' <- expression e2
435 case Map.lookup op basicOps of
436 Just f ->
437 return (f e1' e2')
439 Nothing ->
440 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
442 _ ->
443 do e1' <- expression e1
444 e2' <- expression e2
445 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
447 where
448 collectRightAssoc es e =
449 case e of
450 A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->
451 collectRightAssoc (es ++ [e1]) e2
452 _ -> es ++ [e]
454 collectLeftAssoc es e =
455 case e of
456 A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->
457 collectLeftAssoc (e2 : es) e1
458 _ -> e : es
460 basicOps =
461 Map.fromList (infixOps ++ specialOps)
463 infixOps =
464 let infixOp str op = (str, InfixExpr () op) in
465 [ infixOp "+" OpAdd
466 , infixOp "-" OpSub
467 , infixOp "*" OpMul
468 , infixOp "/" OpDiv
469 , infixOp "&&" OpLAnd
470 , infixOp "||" OpLOr
471 ]
473 specialOps =
474 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
475 , (,) "|>" $ flip (<|)
476 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
477 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
478 , (,) "<" $ cmp OpLT 0
479 , (,) ">" $ cmp OpGT 0
480 , (,) "<=" $ cmp OpLT 1
481 , (,) ">=" $ cmp OpGT (-1)
482 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
483 ]
485 cmp op n a b =
486 InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)