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