git.iko.soy/elk
on 48928dc help sign in
elk/src/Generate/JavaScript.hs
477 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
16import qualified Generate.Markdown as MD
18import AST.Annotation
19import AST.Module
20import AST.Expression.General
21import qualified AST.Expression.Canonical as Canonical
22import qualified AST.Module as Module
23import qualified AST.Helpers as Help
24import AST.Literal
25import qualified AST.Pattern as P
26import qualified AST.Variable as Var
29varDecl :: String -> Expression () -> VarDecl ()
30varDecl x expr =
31 VarDecl () (var x) (Just expr)
34localRuntime :: String
35localRuntime =
36 "_elm"
39internalImports :: Module.Name -> [VarDecl ()]
40internalImports name =
41 [ varDecl "_N" (obj ["Elm","Native"])
42 , include "_U" "Utils"
43 , include "_L" "List"
44 , include "_P" "Ports"
45 , varDecl Help.localModuleName (string (Module.nameToString name))
46 ]
47 where
48 include :: String -> String -> VarDecl ()
49 include alias modul =
50 varDecl alias (obj ["_N", modul, "make"] <| ref localRuntime)
53_Utils :: String -> Expression ()
54_Utils x =
55 obj ["_U", x]
58_List :: String -> Expression ()
59_List x =
60 obj ["_L", x]
63literal :: Literal -> Expression ()
64literal lit =
65 case lit of
66 Chr c -> _Utils "chr" <| string [c]
67 Str s -> string s
68 IntNum n -> IntLit () n
69 FloatNum n -> NumLit () n
70 Boolean b -> BoolLit () b
73expression :: Canonical.Expr -> State Int (Expression ())
74expression (A region expr) =
75 case expr of
76 Var var -> return $ Var.canonical var
78 Literal lit -> return $ literal lit
80 Range lo hi ->
81 do lo' <- expression lo
82 hi' <- expression hi
83 return $ _List "range" `call` [lo',hi']
85 Access e x ->
86 do e' <- expression e
87 return $ DotRef () e' (var x)
89 Remove e x ->
90 do e' <- expression e
91 return $ _Utils "remove" `call` [string x, e']
93 Insert e x v ->
94 do v' <- expression v
95 e' <- expression e
96 return $ _Utils "insert" `call` [string x, v', e']
98 Modify e fs ->
99 do e' <- expression e
100 fs' <- forM fs $ \(f,v) -> do
101 v' <- expression v
102 return $ ArrayLit () [string f, v']
103 return $ _Utils "replace" `call` [ArrayLit () fs', e']
105 Record fields ->
106 do fields' <- forM fields $ \(f,e) -> do
107 (,) f <$> expression e
108 let fieldMap = List.foldl' combine Map.empty fields'
109 return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
110 where
111 combine r (k,v) = Map.insertWith (++) k [v] r
112 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
113 Map.toList . Map.filter (not . null) $ Map.map tail fs
114 visible fs = 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 Markdown uid doc ->
196 let text =
197 obj ["Elm","Text","make"] <| ref localRuntime
199 pad =
200 "<div style=\"height:0;width:0;\">&nbsp;</div>"
202 md =
203 pad ++ MD.toHtml doc ++ pad
204 in
205 return (DotRef () text (var "markdown") `call` [ string md, string uid ])
207 GLShader _uid src _tipe ->
208 return $ ObjectLit () [(PropString () "src", literal (Str src))]
210 PortIn name tipe ->
211 return $ obj ["_P","portIn"] `call`
212 [ string name, Port.incoming tipe ]
214 PortOut name tipe value ->
215 do value' <- expression value
216 return $ obj ["_P","portOut"] `call`
217 [ string name, Port.outgoing tipe, value' ]
220definition :: Canonical.Def -> State Int [Statement ()]
221definition (Canonical.Definition pattern expr@(A region _) _) = do
222 expr' <- expression expr
223 let assign x = varDecl x expr'
224 case pattern of
225 P.Var x
226 | Help.isOp x ->
227 let op = LBracket () (ref "_op") (string x) in
228 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
229 | otherwise ->
230 return [ VarDeclStmt () [ assign (Var.varName x) ] ]
232 P.Record fields ->
233 let setField f = varDecl f (obj ["$",f]) in
234 return [ VarDeclStmt () (assign "$" : map setField fields) ]
236 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
237 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
238 where
239 vars = getVars patterns
240 getVars patterns =
241 case patterns of
242 P.Var x : rest -> (Var.varName x :) `fmap` getVars rest
243 [] -> Just []
244 _ -> Nothing
246 decl x n = varDecl x (obj ["$","_" ++ show n])
247 setup vars
248 | Help.isTuple name = assign "$" : vars
249 | otherwise = assign "_raw" : safeAssign : vars
251 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
252 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
253 exception = Help.throw "badCase" region
255 _ ->
256 do defs' <- concat <$> mapM toDef vars
257 return (VarDeclStmt () [assign "_"] : defs')
258 where
259 vars = P.boundVarList pattern
260 mkVar = A region . localVar
261 toDef y =
262 let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]
263 in
264 definition $ Canonical.Definition (P.Var y) expr Nothing
267match :: Region -> Case.Match -> State Int [Statement ()]
268match region mtch =
269 case mtch of
270 Case.Match name clauses mtch' ->
271 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
272 mtch'' <- match region mtch'
273 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
274 where
275 isLiteral p = case p of
276 Case.Clause (Right _) _ _ -> True
277 _ -> False
279 access name
280 | any isLiteral clauses = obj [name]
281 | otherwise = obj (Help.splitDots name ++ ["ctor"])
283 format isChars e
284 | or isChars = InfixExpr () OpAdd e (string "")
285 | otherwise = e
287 Case.Fail ->
288 return [ ExprStmt () (Help.throw "badCase" region) ]
290 Case.Break -> return [BreakStmt () Nothing]
292 Case.Other e ->
293 do e' <- expression e
294 return [ ret e' ]
296 Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
297 where
298 dropEnd acc [] = acc
299 dropEnd acc (m:ms) =
300 case m of
301 Case.Other _ -> acc ++ [m]
302 _ -> dropEnd (acc ++ [m]) ms
305clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
306clause region variable (Case.Clause value vars mtch) =
307 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
308 where
309 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
310 (isChar, pattern) =
311 case value of
312 Right (Chr c) -> (True, string [c])
313 _ ->
314 (,) False $
315 case value of
316 Right (Boolean b) -> BoolLit () b
317 Right lit -> literal lit
318 Left (Var.Canonical _ name) ->
319 string name
322flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
323flattenLets defs lexpr@(A _ expr) =
324 case expr of
325 Let ds body -> flattenLets (defs ++ ds) body
326 _ -> (defs, lexpr)
329generate :: CanonicalModule -> String
330generate modul =
331 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
332 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]
333 where
334 names :: [String]
335 names = Module.names modul
337 thisModule :: Expression ()
338 thisModule = obj (localRuntime : names ++ ["values"])
340 programStmts :: [Statement ()]
341 programStmts =
342 concat
343 [ [ ExprStmt () (string "use strict") ]
344 , setup localRuntime (names ++ ["values"])
345 , [ IfSingleStmt () thisModule (ret thisModule) ]
346 , [ VarDeclStmt () localVars ]
347 , body
348 , [ jsExports ]
349 , [ ret thisModule ]
350 ]
352 localVars :: [VarDecl ()]
353 localVars = varDecl "_op" (ObjectLit () []) :
354 internalImports (Module.names modul) ++
355 explicitImports
356 where
357 explicitImports :: [VarDecl ()]
358 explicitImports =
359 map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul
361 jsImport :: Module.Name -> VarDecl ()
362 jsImport name =
363 varDecl (Var.moduleName name) $
364 obj ("Elm" : name ++ ["make"]) <| ref localRuntime
366 body :: [Statement ()]
367 body = concat $ evalState defs 0
368 where
369 defs = mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)
371 setup namespace path = map create paths
372 where
373 create name = assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
374 paths = drop 2 . init . List.inits $ namespace : path
376 jsExports = assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)
377 where
378 exs = map entry $ "_op" : concatMap extract (exports modul)
379 entry x = (prop x, ref x)
380 extract value =
381 case value of
382 Var.Alias _ -> []
384 Var.Value x
385 | Help.isOp x -> []
386 | otherwise -> [Var.varName x]
388 Var.Union _ (Var.Listing ctors _) ->
389 map Var.varName ctors
391 assign path expr =
392 case path of
393 [x] -> VarDeclStmt () [ varDecl x expr ]
394 _ ->
395 ExprStmt () $
396 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
399binop
400 :: Region
401 -> Var.Canonical
402 -> Canonical.Expr
403 -> Canonical.Expr
404 -> State Int (Expression ())
405binop region func@(Var.Canonical home op) e1 e2 =
406 case (home, op) of
407 (Var.Module ["Basics"], ">>") ->
408 do es <- mapM expression (collectLeftAssoc [e2] e1)
409 return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es
411 (Var.Module ["Basics"], "<<") ->
412 do es <- mapM expression (e1 : collectRightAssoc [] e2)
413 return $ ["$"] ==> foldr (<|) (ref "$") es
415 (Var.Module ["Basics"], "<|") ->
416 do e2' <- expression e2
417 es <- mapM expression (collectRightAssoc [] e1)
418 return $ foldr (<|) e2' es
420 (Var.BuiltIn, "::") ->
421 expression (A region (Data "::" [e1,e2]))
423 (Var.Module ["Basics"], _) ->
424 do e1' <- expression e1
425 e2' <- expression e2
426 case Map.lookup op basicOps of
427 Just f ->
428 return (f e1' e2')
430 Nothing ->
431 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
433 _ ->
434 do e1' <- expression e1
435 e2' <- expression e2
436 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
438 where
439 collectRightAssoc es e =
440 case e of
441 A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->
442 collectRightAssoc (es ++ [e1]) e2
443 _ -> es ++ [e]
445 collectLeftAssoc es e =
446 case e of
447 A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->
448 collectLeftAssoc (e2 : es) e1
449 _ -> e : es
451 basicOps =
452 Map.fromList (infixOps ++ specialOps)
454 infixOps =
455 let infixOp str op = (str, InfixExpr () op) in
456 [ infixOp "+" OpAdd
457 , infixOp "-" OpSub
458 , infixOp "*" OpMul
459 , infixOp "/" OpDiv
460 , infixOp "&&" OpLAnd
461 , infixOp "||" OpLOr
462 ]
464 specialOps =
465 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
466 , (,) "|>" $ flip (<|)
467 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
468 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
469 , (,) "<" $ cmp OpLT 0
470 , (,) ">" $ cmp OpGT 0
471 , (,) "<=" $ cmp OpLT 1
472 , (,) ">=" $ cmp OpGT (-1)
473 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
474 ]
476 cmp op n a b =
477 InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)