git.iko.soy/elk
on cf3a0bd 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.Port 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.Helpers as Help
22import AST.Literal
23import qualified AST.Module as Module
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 , varDecl Help.localModuleName (string (Module.nameToString name))
34 ]
35 where
36 include :: String -> String -> VarDecl ()
37 include alias modul =
38 varDecl alias (Help.make ["_N", modul])
41_Utils :: String -> Expression ()
42_Utils x =
43 obj ["_U", x]
46_List :: String -> Expression ()
47_List x =
48 obj ["_L", x]
51literal :: Literal -> Expression ()
52literal lit =
53 case lit of
54 Chr c -> _Utils "chr" <| string [c]
55 Str s -> string s
56 IntNum n -> IntLit () n
57 FloatNum n -> NumLit () n
58 Boolean b -> BoolLit () b
61expression :: Canonical.Expr -> State Int (Expression ())
62expression (A region expr) =
63 case expr of
64 Var var ->
65 return $ Var.canonical var
67 Literal lit ->
68 return $ literal lit
70 Range lo hi ->
71 do lo' <- expression lo
72 hi' <- expression hi
73 return $ _List "range" `call` [lo',hi']
75 Access e field ->
76 do e' <- expression e
77 return $ DotRef () e' (var (Var.varName field))
79 Remove e field ->
80 do e' <- expression e
81 return $ _Utils "remove" `call` [ string (Var.varName field), e' ]
83 Insert e field value ->
84 do value' <- expression value
85 e' <- expression e
86 return $ _Utils "insert" `call` [ string (Var.varName field), value', e' ]
88 Modify e fields ->
89 do e' <- expression e
90 fields' <-
91 forM fields $ \(field, value) ->
92 do value' <- expression value
93 return $ ArrayLit () [ string (Var.varName field), value' ]
95 return $ _Utils "replace" `call` [ArrayLit () fields', e']
97 Record fields ->
98 do fields' <-
99 forM fields $ \(field, e) ->
100 (,) (Var.varName field) <$> expression e
102 let fieldMap =
103 List.foldl' combine Map.empty fields'
105 return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
106 where
107 combine record (field, value) =
108 Map.insertWith (++) field [value] record
110 hidden fs =
111 ObjectLit () . map (prop *** ArrayLit ()) $
112 Map.toList (Map.filter (not . null) (Map.map tail fs))
114 visible fs =
115 map (first prop) (Map.toList (Map.map head fs))
117 Binop op e1 e2 ->
118 binop region op e1 e2
120 Lambda p e@(A ann _) ->
121 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
122 body' <- expression body
123 return $
124 case length args < 2 || length args > 9 of
125 True -> foldr (==>) body' (map (:[]) args)
126 False -> ref ("F" ++ show (length args)) <| (args ==> body')
127 where
128 depattern (args, body) pattern =
129 case pattern of
130 P.Var x ->
131 return (args ++ [ Var.varName x ], body)
132 _ ->
133 do arg <- Case.newVar
134 return ( args ++ [arg]
135 , A ann (Case (A ann (localVar arg)) [(pattern, body)])
136 )
138 (patterns, innerBody) = collect [p] e
140 collect patterns lexpr@(A _ expr) =
141 case expr of
142 Lambda p e -> collect (p:patterns) e
143 _ -> (patterns, lexpr)
145 App e1 e2 ->
146 do func' <- expression func
147 args' <- mapM expression args
148 return $
149 case args' of
150 [arg] -> func' <| arg
151 _ | length args' <= 9 -> ref aN `call` (func':args')
152 | otherwise -> foldl1 (<|) (func':args')
153 where
154 aN = "A" ++ show (length args)
155 (func, args) = getArgs e1 [e2]
156 getArgs func args =
157 case func of
158 (A _ (App f arg)) -> getArgs f (arg : args)
159 _ -> (func, args)
161 Let defs e ->
162 do let (defs',e') = flattenLets defs e
163 stmts <- concat <$> mapM definition defs'
164 exp <- expression e'
165 return $ function [] (stmts ++ [ ret exp ]) `call` []
167 MultiIf branches ->
168 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
169 return $
170 case last branches of
171 (A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) ->
172 safeIfs branches'
173 (A _ (Literal (Boolean True)), _) ->
174 safeIfs branches'
175 _ ->
176 ifs branches' (throw "badIf" region)
177 where
178 safeIfs branches = ifs (init branches) (snd (last branches))
179 ifs branches finally = foldr iff finally branches
180 iff (if', then') else' = CondExpr () if' then' else'
182 Case e cases ->
183 do (tempVar,initialMatch) <- Case.toMatch cases
184 (revisedMatch, stmt) <-
185 case e of
186 A _ (Var (Var.Canonical Var.Local x)) ->
187 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
188 _ ->
189 do e' <- expression e
190 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
191 match' <- match region revisedMatch
192 return (function [] (stmt ++ match') `call` [])
194 ExplicitList es ->
195 do es' <- mapM expression es
196 return $ _List "fromArray" <| ArrayLit () es'
198 Data name es ->
199 do es' <- mapM expression es
200 return $ ObjectLit () (ctor : fields es')
201 where
202 ctor = (prop "ctor", string name)
203 fields =
204 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
206 GLShader _uid src _tipe ->
207 return $ ObjectLit () [(PropString () "src", literal (Str src))]
209 Port impl ->
210 case impl of
211 In name portType ->
212 return (Port.inbound name portType)
214 Out name expr portType ->
215 do expr' <- expression expr
216 return (Port.outbound name expr' portType)
218 Task name expr portType ->
219 do expr' <- expression expr
220 return (Port.task name expr' portType)
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)