git.iko.soy/elk
on f9f5d8e help sign in
elk/src/Generate/JavaScript.hs
464 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
28varDecl :: String -> Expression () -> VarDecl ()
29varDecl x expr =
30 VarDecl () (var x) (Just expr)
33localRuntime :: String
34localRuntime =
35 "_elm"
38internalImports :: Module.Name -> [VarDecl ()]
39internalImports name =
40 [ varDecl "_N" (obj ["Elm","Native"])
41 , include "_U" "Utils"
42 , include "_L" "List"
43 , include "_P" "Ports"
44 , varDecl Help.localModuleName (string (Module.nameToString name))
45 ]
46 where
47 include :: String -> String -> VarDecl ()
48 include alias modul =
49 varDecl alias (obj ["_N", modul, "make"] <| ref localRuntime)
52_Utils :: String -> Expression ()
53_Utils x =
54 obj ["_U", x]
57_List :: String -> Expression ()
58_List x =
59 obj ["_L", x]
62literal :: Literal -> Expression ()
63literal lit =
64 case lit of
65 Chr c -> _Utils "chr" <| string [c]
66 Str s -> string s
67 IntNum n -> IntLit () n
68 FloatNum n -> NumLit () n
69 Boolean b -> BoolLit () b
72expression :: Canonical.Expr -> State Int (Expression ())
73expression (A region expr) =
74 case expr of
75 Var var -> return $ Var.canonical var
77 Literal lit -> return $ literal lit
79 Range lo hi ->
80 do lo' <- expression lo
81 hi' <- expression hi
82 return $ _List "range" `call` [lo',hi']
84 Access e x ->
85 do e' <- expression e
86 return $ DotRef () e' (var x)
88 Remove e x ->
89 do e' <- expression e
90 return $ _Utils "remove" `call` [string x, e']
92 Insert e x v ->
93 do v' <- expression v
94 e' <- expression e
95 return $ _Utils "insert" `call` [string x, v', e']
97 Modify e fs ->
98 do e' <- expression e
99 fs' <- forM fs $ \(f,v) -> do
100 v' <- expression v
101 return $ ArrayLit () [string f, v']
102 return $ _Utils "replace" `call` [ArrayLit () fs', e']
104 Record fields ->
105 do fields' <- forM fields $ \(f,e) -> do
106 (,) f <$> expression e
107 let fieldMap = List.foldl' combine Map.empty fields'
108 return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
109 where
110 combine r (k,v) = Map.insertWith (++) k [v] r
111 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
112 Map.toList . Map.filter (not . null) $ Map.map tail fs
113 visible fs = map (first prop) . Map.toList $ Map.map head fs
115 Binop op e1 e2 -> binop region op e1 e2
117 Lambda p e@(A ann _) ->
118 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
119 body' <- expression body
120 return $ case length args < 2 || length args > 9 of
121 True -> foldr (==>) body' (map (:[]) args)
122 False -> ref ("F" ++ show (length args)) <| (args ==> body')
123 where
124 depattern (args, body) pattern =
125 case pattern of
126 P.Var x -> return (args ++ [ Var.varName x ], body)
127 _ -> do arg <- Case.newVar
128 return ( args ++ [arg]
129 , A ann (Case (A ann (localVar arg)) [(pattern, body)]))
131 (patterns, innerBody) = collect [p] e
133 collect patterns lexpr@(A _ expr) =
134 case expr of
135 Lambda p e -> collect (p:patterns) e
136 _ -> (patterns, lexpr)
138 App e1 e2 ->
139 do func' <- expression func
140 args' <- mapM expression args
141 return $ case args' of
142 [arg] -> func' <| arg
143 _ | length args' <= 9 -> ref aN `call` (func':args')
144 | otherwise -> foldl1 (<|) (func':args')
145 where
146 aN = "A" ++ show (length args)
147 (func, args) = getArgs e1 [e2]
148 getArgs func args =
149 case func of
150 (A _ (App f arg)) -> getArgs f (arg : args)
151 _ -> (func, args)
153 Let defs e ->
154 do let (defs',e') = flattenLets defs e
155 stmts <- concat <$> mapM definition defs'
156 exp <- expression e'
157 return $ function [] (stmts ++ [ ret exp ]) `call` []
159 MultiIf branches ->
160 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
161 return $ case last branches of
162 (A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) ->
163 safeIfs branches'
164 (A _ (Literal (Boolean True)), _) -> safeIfs branches'
165 _ -> ifs branches' (throw "badIf" region)
166 where
167 safeIfs branches = ifs (init branches) (snd (last branches))
168 ifs branches finally = foldr iff finally branches
169 iff (if', then') else' = CondExpr () if' then' else'
171 Case e cases ->
172 do (tempVar,initialMatch) <- Case.toMatch cases
173 (revisedMatch, stmt) <-
174 case e of
175 A _ (Var (Var.Canonical Var.Local x)) ->
176 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
177 _ ->
178 do e' <- expression e
179 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
180 match' <- match region revisedMatch
181 return (function [] (stmt ++ match') `call` [])
183 ExplicitList es ->
184 do es' <- mapM expression es
185 return $ _List "fromArray" <| ArrayLit () es'
187 Data name es ->
188 do es' <- mapM expression es
189 return $ ObjectLit () (ctor : fields es')
190 where
191 ctor = (prop "ctor", string name)
192 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
194 GLShader _uid src _tipe ->
195 return $ ObjectLit () [(PropString () "src", literal (Str src))]
197 PortIn name tipe ->
198 return $ obj ["_P","portIn"] `call`
199 [ string name, Port.incoming tipe ]
201 PortOut name tipe value ->
202 do value' <- expression value
203 return $ obj ["_P","portOut"] `call`
204 [ string name, Port.outgoing tipe, value' ]
207definition :: Canonical.Def -> State Int [Statement ()]
208definition (Canonical.Definition pattern expr@(A region _) _) = do
209 expr' <- expression expr
210 let assign x = varDecl x expr'
211 case pattern of
212 P.Var x
213 | Help.isOp x ->
214 let op = LBracket () (ref "_op") (string x) in
215 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
216 | otherwise ->
217 return [ VarDeclStmt () [ assign (Var.varName x) ] ]
219 P.Record fields ->
220 let setField f = varDecl f (obj ["$",f]) in
221 return [ VarDeclStmt () (assign "$" : map setField fields) ]
223 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
224 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
225 where
226 vars = getVars patterns
227 getVars patterns =
228 case patterns of
229 P.Var x : rest -> (Var.varName x :) `fmap` getVars rest
230 [] -> Just []
231 _ -> Nothing
233 decl x n = varDecl x (obj ["$","_" ++ show n])
234 setup vars
235 | Help.isTuple name = assign "$" : vars
236 | otherwise = assign "_raw" : safeAssign : vars
238 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
239 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
240 exception = Help.throw "badCase" region
242 _ ->
243 do defs' <- concat <$> mapM toDef vars
244 return (VarDeclStmt () [assign "_"] : defs')
245 where
246 vars = P.boundVarList pattern
247 mkVar = A region . localVar
248 toDef y =
249 let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]
250 in
251 definition $ Canonical.Definition (P.Var y) expr Nothing
254match :: Region -> Case.Match -> State Int [Statement ()]
255match region mtch =
256 case mtch of
257 Case.Match name clauses mtch' ->
258 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
259 mtch'' <- match region mtch'
260 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
261 where
262 isLiteral p = case p of
263 Case.Clause (Right _) _ _ -> True
264 _ -> False
266 access name
267 | any isLiteral clauses = obj [name]
268 | otherwise = obj (Help.splitDots name ++ ["ctor"])
270 format isChars e
271 | or isChars = InfixExpr () OpAdd e (string "")
272 | otherwise = e
274 Case.Fail ->
275 return [ ExprStmt () (Help.throw "badCase" region) ]
277 Case.Break -> return [BreakStmt () Nothing]
279 Case.Other e ->
280 do e' <- expression e
281 return [ ret e' ]
283 Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
284 where
285 dropEnd acc [] = acc
286 dropEnd acc (m:ms) =
287 case m of
288 Case.Other _ -> acc ++ [m]
289 _ -> dropEnd (acc ++ [m]) ms
292clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
293clause region variable (Case.Clause value vars mtch) =
294 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
295 where
296 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
297 (isChar, pattern) =
298 case value of
299 Right (Chr c) -> (True, string [c])
300 _ ->
301 (,) False $
302 case value of
303 Right (Boolean b) -> BoolLit () b
304 Right lit -> literal lit
305 Left (Var.Canonical _ name) ->
306 string name
309flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
310flattenLets defs lexpr@(A _ expr) =
311 case expr of
312 Let ds body -> flattenLets (defs ++ ds) body
313 _ -> (defs, lexpr)
316generate :: CanonicalModule -> String
317generate modul =
318 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
319 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]
320 where
321 names :: [String]
322 names = Module.names modul
324 thisModule :: Expression ()
325 thisModule = obj (localRuntime : names ++ ["values"])
327 programStmts :: [Statement ()]
328 programStmts =
329 concat
330 [ [ ExprStmt () (string "use strict") ]
331 , setup localRuntime (names ++ ["values"])
332 , [ IfSingleStmt () thisModule (ret thisModule) ]
333 , [ VarDeclStmt () localVars ]
334 , body
335 , [ jsExports ]
336 , [ ret thisModule ]
337 ]
339 localVars :: [VarDecl ()]
340 localVars = varDecl "_op" (ObjectLit () []) :
341 internalImports (Module.names modul) ++
342 explicitImports
343 where
344 explicitImports :: [VarDecl ()]
345 explicitImports =
346 map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul
348 jsImport :: Module.Name -> VarDecl ()
349 jsImport name =
350 varDecl (Var.moduleName name) $
351 obj ("Elm" : name ++ ["make"]) <| ref localRuntime
353 body :: [Statement ()]
354 body = concat $ evalState defs 0
355 where
356 defs = mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)
358 setup namespace path = map create paths
359 where
360 create name = assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
361 paths = drop 2 . init . List.inits $ namespace : path
363 jsExports = assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)
364 where
365 exs = map entry $ "_op" : concatMap extract (exports modul)
366 entry x = (prop x, ref x)
367 extract value =
368 case value of
369 Var.Alias _ -> []
371 Var.Value x
372 | Help.isOp x -> []
373 | otherwise -> [Var.varName x]
375 Var.Union _ (Var.Listing ctors _) ->
376 map Var.varName ctors
378 assign path expr =
379 case path of
380 [x] -> VarDeclStmt () [ varDecl x expr ]
381 _ ->
382 ExprStmt () $
383 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
386binop
387 :: Region
388 -> Var.Canonical
389 -> Canonical.Expr
390 -> Canonical.Expr
391 -> State Int (Expression ())
392binop region func@(Var.Canonical home op) e1 e2 =
393 case (home, op) of
394 (Var.Module ["Basics"], ">>") ->
395 do es <- mapM expression (collectLeftAssoc [e2] e1)
396 return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es
398 (Var.Module ["Basics"], "<<") ->
399 do es <- mapM expression (e1 : collectRightAssoc [] e2)
400 return $ ["$"] ==> foldr (<|) (ref "$") es
402 (Var.Module ["Basics"], "<|") ->
403 do e2' <- expression e2
404 es <- mapM expression (collectRightAssoc [] e1)
405 return $ foldr (<|) e2' es
407 (Var.BuiltIn, "::") ->
408 expression (A region (Data "::" [e1,e2]))
410 (Var.Module ["Basics"], _) ->
411 do e1' <- expression e1
412 e2' <- expression e2
413 case Map.lookup op basicOps of
414 Just f ->
415 return (f e1' e2')
417 Nothing ->
418 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
420 _ ->
421 do e1' <- expression e1
422 e2' <- expression e2
423 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
425 where
426 collectRightAssoc es e =
427 case e of
428 A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->
429 collectRightAssoc (es ++ [e1]) e2
430 _ -> es ++ [e]
432 collectLeftAssoc es e =
433 case e of
434 A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->
435 collectLeftAssoc (e2 : es) e1
436 _ -> e : es
438 basicOps =
439 Map.fromList (infixOps ++ specialOps)
441 infixOps =
442 let infixOp str op = (str, InfixExpr () op) in
443 [ infixOp "+" OpAdd
444 , infixOp "-" OpSub
445 , infixOp "*" OpMul
446 , infixOp "/" OpDiv
447 , infixOp "&&" OpLAnd
448 , infixOp "||" OpLOr
449 ]
451 specialOps =
452 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
453 , (,) "|>" $ flip (<|)
454 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
455 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
456 , (,) "<" $ cmp OpLT 0
457 , (,) ">" $ cmp OpGT 0
458 , (,) "<=" $ cmp OpLT 1
459 , (,) ">=" $ cmp OpGT (-1)
460 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
461 ]
463 cmp op n a b =
464 InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)