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