git.iko.soy/elk
on 876c49e help sign in
elk/src/Generate/JavaScript.hs
470 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 -> return $ Var.canonical var
67 Literal lit -> return $ literal lit
69 Range lo hi ->
70 do lo' <- expression lo
71 hi' <- expression hi
72 return $ _List "range" `call` [lo',hi']
74 Access e field ->
75 do e' <- expression e
76 return $ DotRef () e' (var (Var.varName field))
78 Remove e field ->
79 do e' <- expression e
80 return $ _Utils "remove" `call` [ string (Var.varName field), e' ]
82 Insert e field value ->
83 do value' <- expression value
84 e' <- expression e
85 return $ _Utils "insert" `call` [ string (Var.varName field), value', e' ]
87 Modify e fields ->
88 do e' <- expression e
89 fields' <-
90 forM fields $ \(field, value) ->
91 do value' <- expression value
92 return $ ArrayLit () [ string (Var.varName field), value' ]
94 return $ _Utils "replace" `call` [ArrayLit () fields', e']
96 Record fields ->
97 do fields' <-
98 forM fields $ \(field, e) ->
99 (,) (Var.varName field) <$> expression e
101 let fieldMap =
102 List.foldl' combine Map.empty fields'
104 return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
105 where
106 combine record (field, value) =
107 Map.insertWith (++) field [value] record
109 hidden fs =
110 ObjectLit () . map (prop *** ArrayLit ()) $
111 Map.toList (Map.filter (not . null) (Map.map tail fs))
113 visible fs =
114 map (first prop) (Map.toList (Map.map head fs))
116 Binop op e1 e2 -> binop region op e1 e2
118 Lambda p e@(A ann _) ->
119 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
120 body' <- expression body
121 return $ case length args < 2 || length args > 9 of
122 True -> foldr (==>) body' (map (:[]) args)
123 False -> ref ("F" ++ show (length args)) <| (args ==> body')
124 where
125 depattern (args, body) pattern =
126 case pattern of
127 P.Var x -> return (args ++ [ Var.varName x ], body)
128 _ -> do arg <- Case.newVar
129 return ( args ++ [arg]
130 , A ann (Case (A ann (localVar arg)) [(pattern, body)]))
132 (patterns, innerBody) = collect [p] e
134 collect patterns lexpr@(A _ expr) =
135 case expr of
136 Lambda p e -> collect (p:patterns) e
137 _ -> (patterns, lexpr)
139 App e1 e2 ->
140 do func' <- expression func
141 args' <- mapM expression args
142 return $ case args' of
143 [arg] -> func' <| arg
144 _ | length args' <= 9 -> ref aN `call` (func':args')
145 | otherwise -> foldl1 (<|) (func':args')
146 where
147 aN = "A" ++ show (length args)
148 (func, args) = getArgs e1 [e2]
149 getArgs func args =
150 case func of
151 (A _ (App f arg)) -> getArgs f (arg : args)
152 _ -> (func, args)
154 Let defs e ->
155 do let (defs',e') = flattenLets defs e
156 stmts <- concat <$> mapM definition defs'
157 exp <- expression e'
158 return $ function [] (stmts ++ [ ret exp ]) `call` []
160 MultiIf branches ->
161 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
162 return $ case last branches of
163 (A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) ->
164 safeIfs branches'
165 (A _ (Literal (Boolean True)), _) -> safeIfs branches'
166 _ -> ifs branches' (throw "badIf" region)
167 where
168 safeIfs branches = ifs (init branches) (snd (last branches))
169 ifs branches finally = foldr iff finally branches
170 iff (if', then') else' = CondExpr () if' then' else'
172 Case e cases ->
173 do (tempVar,initialMatch) <- Case.toMatch cases
174 (revisedMatch, stmt) <-
175 case e of
176 A _ (Var (Var.Canonical Var.Local x)) ->
177 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
178 _ ->
179 do e' <- expression e
180 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
181 match' <- match region revisedMatch
182 return (function [] (stmt ++ match') `call` [])
184 ExplicitList es ->
185 do es' <- mapM expression es
186 return $ _List "fromArray" <| ArrayLit () es'
188 Data name es ->
189 do es' <- mapM expression es
190 return $ ObjectLit () (ctor : fields es')
191 where
192 ctor = (prop "ctor", string name)
193 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
195 GLShader _uid src _tipe ->
196 return $ ObjectLit () [(PropString () "src", literal (Str src))]
198 PortIn name tipe ->
199 return $ obj ["_P","portIn"] `call`
200 [ string name, Port.incoming tipe ]
202 PortOut name tipe value ->
203 do value' <- expression value
204 return $ obj ["_P","portOut"] `call`
205 [ string name, Port.outgoing tipe, value' ]
208definition :: Canonical.Def -> State Int [Statement ()]
209definition (Canonical.Definition pattern expr@(A region _) _) = do
210 expr' <- expression expr
211 let assign x = varDecl x expr'
212 case pattern of
213 P.Var x
214 | Help.isOp x ->
215 let op = LBracket () (ref "_op") (string x) in
216 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
217 | otherwise ->
218 return [ VarDeclStmt () [ assign (Var.varName x) ] ]
220 P.Record fields ->
221 let setField f = varDecl f (obj ["$",f]) in
222 return [ VarDeclStmt () (assign "$" : map setField fields) ]
224 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
225 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
226 where
227 vars = getVars patterns
228 getVars patterns =
229 case patterns of
230 P.Var x : rest -> (Var.varName x :) `fmap` getVars rest
231 [] -> Just []
232 _ -> Nothing
234 decl x n = varDecl x (obj ["$","_" ++ show n])
235 setup vars
236 | Help.isTuple name = assign "$" : vars
237 | otherwise = assign "_raw" : safeAssign : vars
239 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
240 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
241 exception = Help.throw "badCase" region
243 _ ->
244 do defs' <- concat <$> mapM toDef vars
245 return (VarDeclStmt () [assign "_"] : defs')
246 where
247 vars = P.boundVarList pattern
248 mkVar = A region . localVar
249 toDef y =
250 let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]
251 in
252 definition $ Canonical.Definition (P.Var y) expr Nothing
255match :: Region -> Case.Match -> State Int [Statement ()]
256match region mtch =
257 case mtch of
258 Case.Match name clauses mtch' ->
259 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
260 mtch'' <- match region mtch'
261 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
262 where
263 isLiteral p =
264 case p of
265 Case.Clause (Right _) _ _ -> True
266 _ -> False
268 access name
269 | any isLiteral clauses = obj [name]
270 | otherwise = obj (Help.splitDots name ++ ["ctor"])
272 format isChars e
273 | or isChars = InfixExpr () OpAdd e (string "")
274 | otherwise = e
276 Case.Fail ->
277 return [ ExprStmt () (Help.throw "badCase" region) ]
279 Case.Break ->
280 return [BreakStmt () Nothing]
282 Case.Other e ->
283 do e' <- expression e
284 return [ ret e' ]
286 Case.Seq ms ->
287 concat <$> mapM (match region) (dropEnd [] ms)
288 where
289 dropEnd acc [] = acc
290 dropEnd acc (m:ms) =
291 case m of
292 Case.Other _ -> acc ++ [m]
293 _ -> dropEnd (acc ++ [m]) ms
296clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
297clause region variable (Case.Clause value vars mtch) =
298 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
299 where
300 vars' =
301 map (\n -> variable ++ "._" ++ show n) [0..]
303 (isChar, pattern) =
304 case value of
305 Right (Chr c) -> (True, string [c])
306 _ ->
307 (,) False $
308 case value of
309 Right (Boolean b) -> BoolLit () b
310 Right lit -> literal lit
311 Left (Var.Canonical _ name) ->
312 string name
315flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
316flattenLets defs lexpr@(A _ expr) =
317 case expr of
318 Let ds body -> flattenLets (defs ++ ds) body
319 _ -> (defs, lexpr)
322generate :: CanonicalModule -> String
323generate modul =
324 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
325 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]
326 where
327 names :: [String]
328 names = Module.names modul
330 thisModule :: Expression ()
331 thisModule = obj (localRuntime : names ++ ["values"])
333 programStmts :: [Statement ()]
334 programStmts =
335 concat
336 [ [ ExprStmt () (string "use strict") ]
337 , setup localRuntime (names ++ ["values"])
338 , [ IfSingleStmt () thisModule (ret thisModule) ]
339 , [ VarDeclStmt () localVars ]
340 , body
341 , [ jsExports ]
342 , [ ret thisModule ]
343 ]
345 localVars :: [VarDecl ()]
346 localVars = varDecl "_op" (ObjectLit () []) :
347 internalImports (Module.names modul) ++
348 explicitImports
349 where
350 explicitImports :: [VarDecl ()]
351 explicitImports =
352 map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul
354 jsImport :: Module.Name -> VarDecl ()
355 jsImport name =
356 varDecl (Var.moduleName name) $
357 obj ("Elm" : name ++ ["make"]) <| ref localRuntime
359 body :: [Statement ()]
360 body = concat $ evalState defs 0
361 where
362 defs = mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)
364 setup namespace path = map create paths
365 where
366 create name = assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
367 paths = drop 2 . init . List.inits $ namespace : path
369 jsExports = assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)
370 where
371 exs = map entry $ "_op" : concatMap extract (exports modul)
372 entry x = (prop x, ref x)
373 extract value =
374 case value of
375 Var.Alias _ -> []
377 Var.Value x
378 | Help.isOp x -> []
379 | otherwise -> [Var.varName x]
381 Var.Union _ (Var.Listing ctors _) ->
382 map Var.varName ctors
384 assign path expr =
385 case path of
386 [x] -> VarDeclStmt () [ varDecl x expr ]
387 _ ->
388 ExprStmt () $
389 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
392binop
393 :: Region
394 -> Var.Canonical
395 -> Canonical.Expr
396 -> Canonical.Expr
397 -> State Int (Expression ())
398binop region func@(Var.Canonical home op) e1 e2 =
399 case (home, op) of
400 (Var.Module ["Basics"], ">>") ->
401 do es <- mapM expression (collectLeftAssoc [e2] e1)
402 return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es
404 (Var.Module ["Basics"], "<<") ->
405 do es <- mapM expression (e1 : collectRightAssoc [] e2)
406 return $ ["$"] ==> foldr (<|) (ref "$") es
408 (Var.Module ["Basics"], "<|") ->
409 do e2' <- expression e2
410 es <- mapM expression (collectRightAssoc [] e1)
411 return $ foldr (<|) e2' es
413 (Var.BuiltIn, "::") ->
414 expression (A region (Data "::" [e1,e2]))
416 (Var.Module ["Basics"], _) ->
417 do e1' <- expression e1
418 e2' <- expression e2
419 case Map.lookup op basicOps of
420 Just f ->
421 return (f e1' e2')
423 Nothing ->
424 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
426 _ ->
427 do e1' <- expression e1
428 e2' <- expression e2
429 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
431 where
432 collectRightAssoc es e =
433 case e of
434 A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->
435 collectRightAssoc (es ++ [e1]) e2
436 _ -> es ++ [e]
438 collectLeftAssoc es e =
439 case e of
440 A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->
441 collectLeftAssoc (e2 : es) e1
442 _ -> e : es
444 basicOps =
445 Map.fromList (infixOps ++ specialOps)
447 infixOps =
448 let infixOp str op = (str, InfixExpr () op) in
449 [ infixOp "+" OpAdd
450 , infixOp "-" OpSub
451 , infixOp "*" OpMul
452 , infixOp "/" OpDiv
453 , infixOp "&&" OpLAnd
454 , infixOp "||" OpLOr
455 ]
457 specialOps =
458 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
459 , (,) "|>" $ flip (<|)
460 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
461 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
462 , (,) "<" $ cmp OpLT 0
463 , (,) ">" $ cmp OpGT 0
464 , (,) "<=" $ cmp OpLT 1
465 , (,) ">=" $ cmp OpGT (-1)
466 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
467 ]
469 cmp op n a b =
470 InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)