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