git.iko.soy/elk
on 2234b88 help sign in
elk/src/Generate/JavaScript.hs
465 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 = case p of
264 Case.Clause (Right _) _ _ -> True
265 _ -> False
267 access name
268 | any isLiteral clauses = obj [name]
269 | otherwise = obj (Help.splitDots name ++ ["ctor"])
271 format isChars e
272 | or isChars = InfixExpr () OpAdd e (string "")
273 | otherwise = e
275 Case.Fail ->
276 return [ ExprStmt () (Help.throw "badCase" region) ]
278 Case.Break -> return [BreakStmt () Nothing]
280 Case.Other e ->
281 do e' <- expression e
282 return [ ret e' ]
284 Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
285 where
286 dropEnd acc [] = acc
287 dropEnd acc (m:ms) =
288 case m of
289 Case.Other _ -> acc ++ [m]
290 _ -> dropEnd (acc ++ [m]) ms
293clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
294clause region variable (Case.Clause value vars mtch) =
295 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
296 where
297 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
298 (isChar, pattern) =
299 case value of
300 Right (Chr c) -> (True, string [c])
301 _ ->
302 (,) False $
303 case value of
304 Right (Boolean b) -> BoolLit () b
305 Right lit -> literal lit
306 Left (Var.Canonical _ name) ->
307 string name
310flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
311flattenLets defs lexpr@(A _ expr) =
312 case expr of
313 Let ds body -> flattenLets (defs ++ ds) body
314 _ -> (defs, lexpr)
317generate :: CanonicalModule -> String
318generate modul =
319 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
320 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]
321 where
322 names :: [String]
323 names = Module.names modul
325 thisModule :: Expression ()
326 thisModule = obj (localRuntime : names ++ ["values"])
328 programStmts :: [Statement ()]
329 programStmts =
330 concat
331 [ [ ExprStmt () (string "use strict") ]
332 , setup localRuntime (names ++ ["values"])
333 , [ IfSingleStmt () thisModule (ret thisModule) ]
334 , [ VarDeclStmt () localVars ]
335 , body
336 , [ jsExports ]
337 , [ ret thisModule ]
338 ]
340 localVars :: [VarDecl ()]
341 localVars = varDecl "_op" (ObjectLit () []) :
342 internalImports (Module.names modul) ++
343 explicitImports
344 where
345 explicitImports :: [VarDecl ()]
346 explicitImports =
347 map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul
349 jsImport :: Module.Name -> VarDecl ()
350 jsImport name =
351 varDecl (Var.moduleName name) $
352 obj ("Elm" : name ++ ["make"]) <| ref localRuntime
354 body :: [Statement ()]
355 body = concat $ evalState defs 0
356 where
357 defs = mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)
359 setup namespace path = map create paths
360 where
361 create name = assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
362 paths = drop 2 . init . List.inits $ namespace : path
364 jsExports = assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)
365 where
366 exs = map entry $ "_op" : concatMap extract (exports modul)
367 entry x = (prop x, ref x)
368 extract value =
369 case value of
370 Var.Alias _ -> []
372 Var.Value x
373 | Help.isOp x -> []
374 | otherwise -> [Var.varName x]
376 Var.Union _ (Var.Listing ctors _) ->
377 map Var.varName ctors
379 assign path expr =
380 case path of
381 [x] -> VarDeclStmt () [ varDecl x expr ]
382 _ ->
383 ExprStmt () $
384 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
387binop
388 :: Region
389 -> Var.Canonical
390 -> Canonical.Expr
391 -> Canonical.Expr
392 -> State Int (Expression ())
393binop region func@(Var.Canonical home op) e1 e2 =
394 case (home, op) of
395 (Var.Module ["Basics"], ">>") ->
396 do es <- mapM expression (collectLeftAssoc [e2] e1)
397 return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es
399 (Var.Module ["Basics"], "<<") ->
400 do es <- mapM expression (e1 : collectRightAssoc [] e2)
401 return $ ["$"] ==> foldr (<|) (ref "$") es
403 (Var.Module ["Basics"], "<|") ->
404 do e2' <- expression e2
405 es <- mapM expression (collectRightAssoc [] e1)
406 return $ foldr (<|) e2' es
408 (Var.BuiltIn, "::") ->
409 expression (A region (Data "::" [e1,e2]))
411 (Var.Module ["Basics"], _) ->
412 do e1' <- expression e1
413 e2' <- expression e2
414 case Map.lookup op basicOps of
415 Just f ->
416 return (f e1' e2')
418 Nothing ->
419 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
421 _ ->
422 do e1' <- expression e1
423 e2' <- expression e2
424 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
426 where
427 collectRightAssoc es e =
428 case e of
429 A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->
430 collectRightAssoc (es ++ [e1]) e2
431 _ -> es ++ [e]
433 collectLeftAssoc es e =
434 case e of
435 A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->
436 collectLeftAssoc (e2 : es) e1
437 _ -> e : es
439 basicOps =
440 Map.fromList (infixOps ++ specialOps)
442 infixOps =
443 let infixOp str op = (str, InfixExpr () op) in
444 [ infixOp "+" OpAdd
445 , infixOp "-" OpSub
446 , infixOp "*" OpMul
447 , infixOp "/" OpDiv
448 , infixOp "&&" OpLAnd
449 , infixOp "||" OpLOr
450 ]
452 specialOps =
453 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
454 , (,) "|>" $ flip (<|)
455 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
456 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
457 , (,) "<" $ cmp OpLT 0
458 , (,) ">" $ cmp OpGT 0
459 , (,) "<=" $ cmp OpLT 1
460 , (,) ">=" $ cmp OpGT (-1)
461 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
462 ]
464 cmp op n a b =
465 InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)