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