git.iko.soy/elk
on 9d0075c help sign in
elk/src/Generate/JavaScript.hs
440 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 , include "_A" "Array"
38 , include "_E" "Error"
39 , varDecl Help.localModuleName (string (Module.nameToString name))
40 ]
41 where
42 include :: String -> String -> VarDecl ()
43 include alias modul =
44 varDecl alias (obj ["_N", modul, "make"] <| ref "_elm")
46_Utils :: String -> Expression ()
47_Utils x = obj ["_U", x]
49_List :: String -> Expression ()
50_List x = 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
61expression :: Canonical.Expr -> State Int (Expression ())
62expression (A region expr) =
63 case expr of
64 Var var -> return $ Var.canonical var
66 Literal lit -> return $ literal lit
68 Range lo hi ->
69 do lo' <- expression lo
70 hi' <- expression hi
71 return $ _List "range" `call` [lo',hi']
73 Access e x ->
74 do e' <- expression e
75 return $ DotRef () e' (var x)
77 Remove e x ->
78 do e' <- expression e
79 return $ _Utils "remove" `call` [string x, e']
81 Insert e x v ->
82 do v' <- expression v
83 e' <- expression e
84 return $ _Utils "insert" `call` [string x, v', e']
86 Modify e fs ->
87 do e' <- expression e
88 fs' <- forM fs $ \(f,v) -> do
89 v' <- expression v
90 return $ ArrayLit () [string f, v']
91 return $ _Utils "replace" `call` [ArrayLit () fs', e']
93 Record fields ->
94 do fields' <- forM fields $ \(f,e) -> do
95 (,) f <$> expression e
96 let fieldMap = List.foldl' combine Map.empty fields'
97 return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
98 where
99 combine r (k,v) = Map.insertWith (++) k [v] r
100 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
101 Map.toList . Map.filter (not . null) $ Map.map tail fs
102 visible fs = map (first prop) . Map.toList $ Map.map head fs
104 Binop op e1 e2 -> binop region op e1 e2
106 Lambda p e@(A ann _) ->
107 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
108 body' <- expression body
109 return $ case length args < 2 || length args > 9 of
110 True -> foldr (==>) body' (map (:[]) args)
111 False -> ref ("F" ++ show (length args)) <| (args ==> body')
112 where
113 depattern (args, body) pattern =
114 case pattern of
115 P.Var x -> return (args ++ [ Var.varName x ], body)
116 _ -> do arg <- Case.newVar
117 return ( args ++ [arg]
118 , A ann (Case (A ann (localVar arg)) [(pattern, body)]))
120 (patterns, innerBody) = collect [p] e
122 collect patterns lexpr@(A _ expr) =
123 case expr of
124 Lambda p e -> collect (p:patterns) e
125 _ -> (patterns, lexpr)
127 App e1 e2 ->
128 do func' <- expression func
129 args' <- mapM expression args
130 return $ case args' of
131 [arg] -> func' <| arg
132 _ | length args' <= 9 -> ref aN `call` (func':args')
133 | otherwise -> foldl1 (<|) (func':args')
134 where
135 aN = "A" ++ show (length args)
136 (func, args) = getArgs e1 [e2]
137 getArgs func args =
138 case func of
139 (A _ (App f arg)) -> getArgs f (arg : args)
140 _ -> (func, args)
142 Let defs e ->
143 do let (defs',e') = flattenLets defs e
144 stmts <- concat <$> mapM definition defs'
145 exp <- expression e'
146 return $ function [] (stmts ++ [ ret exp ]) `call` []
148 MultiIf branches ->
149 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
150 return $ case last branches of
151 (A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) ->
152 safeIfs branches'
153 (A _ (Literal (Boolean True)), _) -> safeIfs branches'
154 _ -> ifs branches' (throw "If" region)
155 where
156 safeIfs branches = ifs (init branches) (snd (last branches))
157 ifs branches finally = foldr iff finally branches
158 iff (if', then') else' = CondExpr () if' then' else'
160 Case e cases ->
161 do (tempVar,initialMatch) <- Case.toMatch cases
162 (revisedMatch, stmt) <-
163 case e of
164 A _ (Var (Var.Canonical Var.Local x)) ->
165 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
166 _ ->
167 do e' <- expression e
168 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
169 match' <- match region revisedMatch
170 return (function [] (stmt ++ match') `call` [])
172 ExplicitList es ->
173 do es' <- mapM expression es
174 return $ _List "fromArray" <| ArrayLit () es'
176 Data name es ->
177 do es' <- mapM expression es
178 return $ ObjectLit () (ctor : fields es')
179 where
180 ctor = (prop "ctor", string name)
181 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
183 Markdown uid doc ->
184 return $ Var.value ["Text"] "markdown" `call` [ string md, string uid ]
185 where
186 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
187 md = pad ++ MD.toHtml doc ++ pad
189 GLShader _uid src _tipe ->
190 return $ ObjectLit () [(PropString () "src", literal (Str src))]
192 PortIn name tipe ->
193 return $ Var.value ["Native","Ports"] "portIn" `call`
194 [ string name, Port.incoming tipe ]
196 PortOut name tipe value ->
197 do value' <- expression value
198 return $ Var.value ["Native","Ports"] "portOut" `call`
199 [ string name, Port.outgoing tipe, value' ]
201definition :: Canonical.Def -> State Int [Statement ()]
202definition (Canonical.Definition pattern expr@(A region _) _) = do
203 expr' <- expression expr
204 let assign x = varDecl x expr'
205 case pattern of
206 P.Var x
207 | Help.isOp x ->
208 let op = LBracket () (ref "_op") (string x) in
209 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
210 | otherwise ->
211 return [ VarDeclStmt () [ assign (Var.varName x) ] ]
213 P.Record fields ->
214 let setField f = varDecl f (obj ["$",f]) in
215 return [ VarDeclStmt () (assign "$" : map setField fields) ]
217 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
218 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
219 where
220 vars = getVars patterns
221 getVars patterns =
222 case patterns of
223 P.Var x : rest -> (Var.varName x :) `fmap` getVars rest
224 [] -> Just []
225 _ -> Nothing
227 decl x n = varDecl x (obj ["$","_" ++ show n])
228 setup vars
229 | Help.isTuple name = assign "$" : vars
230 | otherwise = assign "_raw" : safeAssign : vars
232 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
233 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
234 exception = Help.throw "Case" region
236 _ ->
237 do defs' <- concat <$> mapM toDef vars
238 return (VarDeclStmt () [assign "_"] : defs')
239 where
240 vars = P.boundVarList pattern
241 mkVar = A region . localVar
242 toDef y = let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]
243 in definition $ Canonical.Definition (P.Var y) expr Nothing
245match :: Region -> Case.Match -> State Int [Statement ()]
246match region mtch =
247 case mtch of
248 Case.Match name clauses mtch' ->
249 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
250 mtch'' <- match region mtch'
251 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
252 where
253 isLiteral p = case p of
254 Case.Clause (Right _) _ _ -> True
255 _ -> False
257 access name
258 | any isLiteral clauses = obj [name]
259 | otherwise = obj (Help.splitDots name ++ ["ctor"])
261 format isChars e
262 | or isChars = InfixExpr () OpAdd e (string "")
263 | otherwise = e
265 Case.Fail ->
266 return [ ExprStmt () (Help.throw "Case" region) ]
268 Case.Break -> return [BreakStmt () Nothing]
270 Case.Other e ->
271 do e' <- expression e
272 return [ ret e' ]
274 Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
275 where
276 dropEnd acc [] = acc
277 dropEnd acc (m:ms) =
278 case m of
279 Case.Other _ -> acc ++ [m]
280 _ -> 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 _ -> (,) False $ case value of
291 Right (Boolean b) -> BoolLit () b
292 Right lit -> literal lit
293 Left (Var.Canonical _ name) ->
294 string name
296flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
297flattenLets defs lexpr@(A _ expr) =
298 case expr of
299 Let ds body -> flattenLets (defs ++ ds) body
300 _ -> (defs, lexpr)
302generate :: CanonicalModule -> String
303generate modul =
304 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
305 [ assign ("Elm" : names ++ ["make"]) (function ["_elm"] programStmts) ]
306 where
307 names :: [String]
308 names = Module.names modul
310 thisModule :: Expression ()
311 thisModule = obj ("_elm" : names ++ ["values"])
313 programStmts :: [Statement ()]
314 programStmts =
315 concat
316 [ [ ExprStmt () (string "use strict") ]
317 , setup "_elm" (names ++ ["values"])
318 , [ IfSingleStmt () thisModule (ret thisModule) ]
319 , [ VarDeclStmt () localVars ]
320 , body
321 , [ jsExports ]
322 , [ ret thisModule ]
323 ]
325 localVars :: [VarDecl ()]
326 localVars = varDecl "_op" (ObjectLit () []) :
327 internalImports (Module.names modul) ++
328 explicitImports
329 where
330 explicitImports :: [VarDecl ()]
331 explicitImports =
332 map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul
334 jsImport :: Module.Name -> VarDecl ()
335 jsImport name =
336 varDecl (Var.moduleName name) $
337 obj ("Elm" : name ++ ["make"]) <| ref "_elm"
339 body :: [Statement ()]
340 body = concat $ evalState defs 0
341 where
342 defs = mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)
344 setup namespace path = map create paths
345 where
346 create name = assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
347 paths = drop 2 . init . List.inits $ namespace : path
349 jsExports = assign ("_elm" : names ++ ["values"]) (ObjectLit () exs)
350 where
351 exs = map entry $ "_op" : concatMap extract (exports modul)
352 entry x = (prop x, ref x)
353 extract value =
354 case value of
355 Var.Alias _ -> []
356 Var.Value x | Help.isOp x -> []
357 | otherwise -> [Var.varName x]
358 Var.ADT _ (Var.Listing ctors _) -> map Var.varName ctors
360 assign path expr =
361 case path of
362 [x] -> VarDeclStmt () [ varDecl x expr ]
363 _ -> ExprStmt () $
364 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
366binop :: Region -> Var.Canonical -> Canonical.Expr -> Canonical.Expr
367 -> State Int (Expression ())
368binop region func@(Var.Canonical home op) e1 e2 =
369 case (home, op) of
370 (Var.Module ["Basics"], ">>") ->
371 do es <- mapM expression (collectLeftAssoc [e2] e1)
372 return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es
374 (Var.Module ["Basics"], "<<") ->
375 do es <- mapM expression (e1 : collectRightAssoc [] e2)
376 return $ ["$"] ==> foldr (<|) (ref "$") es
378 (Var.Module ["Basics"], "<|") ->
379 do e2' <- expression e2
380 es <- mapM expression (collectRightAssoc [] e1)
381 return $ foldr (<|) e2' es
383 (Var.Module ["List"], "++") ->
384 do e1' <- expression e1
385 e2' <- expression e2
386 return $ _List "append" `call` [e1', e2']
388 (Var.BuiltIn, "::") ->
389 expression (A region (Data "::" [e1,e2]))
391 (Var.Module ["Basics"], _) ->
392 do e1' <- expression e1
393 e2' <- expression e2
394 return $ case Map.lookup op basicOps of
395 Just f -> f e1' e2'
396 Nothing -> ref "A2" `call` [ Var.canonical func, e1', e2' ]
398 _ ->
399 do e1' <- expression e1
400 e2' <- expression e2
401 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
403 where
404 collectRightAssoc es e =
405 case e of
406 A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->
407 collectRightAssoc (es ++ [e1]) e2
408 _ -> es ++ [e]
410 collectLeftAssoc es e =
411 case e of
412 A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->
413 collectLeftAssoc (e2 : es) e1
414 _ -> e : es
416 basicOps = Map.fromList (infixOps ++ specialOps)
418 infixOps =
419 let infixOp str op = (str, InfixExpr () op) in
420 [ infixOp "+" OpAdd
421 , infixOp "-" OpSub
422 , infixOp "*" OpMul
423 , infixOp "/" OpDiv
424 , infixOp "&&" OpLAnd
425 , infixOp "||" OpLOr
426 ]
428 specialOps =
429 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
430 , (,) "|>" $ flip (<|)
431 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
432 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
433 , (,) "<" $ cmp OpLT 0
434 , (,) ">" $ cmp OpGT 0
435 , (,) "<=" $ cmp OpLT 1
436 , (,) ">=" $ cmp OpGT (-1)
437 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
438 ]
440 cmp op n a b = InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)