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