git.iko.soy/elk
on bb5d079 help sign in
elk/src/Generate/JavaScript.hs
441 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 es ->
184 do es' <- mapM expression es
185 return $ Var.value ["Text"] "markdown" `call` (string md : string uid : es')
186 where
187 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
188 md = pad ++ MD.toHtml doc ++ pad
190 GLShader _uid src _tipe ->
191 return $ ObjectLit () [(PropString () "src", literal (Str src))]
193 PortIn name tipe ->
194 return $ Var.value ["Native","Ports"] "portIn" `call`
195 [ string name, Port.incoming tipe ]
197 PortOut name tipe value ->
198 do value' <- expression value
199 return $ Var.value ["Native","Ports"] "portOut" `call`
200 [ string name, Port.outgoing tipe, value' ]
202definition :: Canonical.Def -> State Int [Statement ()]
203definition (Canonical.Definition pattern expr@(A region _) _) = do
204 expr' <- expression expr
205 let assign x = varDecl x expr'
206 case pattern of
207 P.Var x
208 | Help.isOp x ->
209 let op = LBracket () (ref "_op") (string x) in
210 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
211 | otherwise ->
212 return [ VarDeclStmt () [ assign (Var.varName x) ] ]
214 P.Record fields ->
215 let setField f = varDecl f (obj ["$",f]) in
216 return [ VarDeclStmt () (assign "$" : map setField fields) ]
218 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
219 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
220 where
221 vars = getVars patterns
222 getVars patterns =
223 case patterns of
224 P.Var x : rest -> (Var.varName x :) `fmap` getVars rest
225 [] -> Just []
226 _ -> Nothing
228 decl x n = varDecl x (obj ["$","_" ++ show n])
229 setup vars
230 | Help.isTuple name = assign "$" : vars
231 | otherwise = assign "_raw" : safeAssign : vars
233 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
234 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
235 exception = Help.throw "Case" region
237 _ ->
238 do defs' <- concat <$> mapM toDef vars
239 return (VarDeclStmt () [assign "_"] : defs')
240 where
241 vars = P.boundVarList pattern
242 mkVar = A region . localVar
243 toDef y = let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]
244 in definition $ Canonical.Definition (P.Var y) expr Nothing
246match :: Region -> Case.Match -> State Int [Statement ()]
247match region mtch =
248 case mtch of
249 Case.Match name clauses mtch' ->
250 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
251 mtch'' <- match region mtch'
252 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
253 where
254 isLiteral p = case p of
255 Case.Clause (Right _) _ _ -> True
256 _ -> False
258 access name
259 | any isLiteral clauses = obj [name]
260 | otherwise = obj (Help.splitDots name ++ ["ctor"])
262 format isChars e
263 | or isChars = InfixExpr () OpAdd e (string "")
264 | otherwise = e
266 Case.Fail ->
267 return [ ExprStmt () (Help.throw "Case" region) ]
269 Case.Break -> return [BreakStmt () Nothing]
271 Case.Other e ->
272 do e' <- expression e
273 return [ ret e' ]
275 Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
276 where
277 dropEnd acc [] = acc
278 dropEnd acc (m:ms) =
279 case m of
280 Case.Other _ -> acc ++ [m]
281 _ -> dropEnd (acc ++ [m]) ms
283clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
284clause region variable (Case.Clause value vars mtch) =
285 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
286 where
287 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
288 (isChar, pattern) =
289 case value of
290 Right (Chr c) -> (True, string [c])
291 _ -> (,) False $ case value of
292 Right (Boolean b) -> BoolLit () b
293 Right lit -> literal lit
294 Left (Var.Canonical _ name) ->
295 string name
297flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
298flattenLets defs lexpr@(A _ expr) =
299 case expr of
300 Let ds body -> flattenLets (defs ++ ds) body
301 _ -> (defs, lexpr)
303generate :: CanonicalModule -> String
304generate modul =
305 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
306 [ assign ("Elm" : names ++ ["make"]) (function ["_elm"] programStmts) ]
307 where
308 names :: [String]
309 names = Module.names modul
311 thisModule :: Expression ()
312 thisModule = obj ("_elm" : names ++ ["values"])
314 programStmts :: [Statement ()]
315 programStmts =
316 concat
317 [ [ ExprStmt () (string "use strict") ]
318 , setup "_elm" (names ++ ["values"])
319 , [ IfSingleStmt () thisModule (ret thisModule) ]
320 , [ VarDeclStmt () localVars ]
321 , body
322 , [ jsExports ]
323 , [ ret thisModule ]
324 ]
326 localVars :: [VarDecl ()]
327 localVars = varDecl "_op" (ObjectLit () []) :
328 internalImports (Module.names modul) ++
329 explicitImports
330 where
331 explicitImports :: [VarDecl ()]
332 explicitImports =
333 map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul
335 jsImport :: Module.Name -> VarDecl ()
336 jsImport name =
337 varDecl (Var.moduleName name) $
338 obj ("Elm" : name ++ ["make"]) <| ref "_elm"
340 body :: [Statement ()]
341 body = concat $ evalState defs 0
342 where
343 defs = mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)
345 setup namespace path = map create paths
346 where
347 create name = assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
348 paths = drop 2 . init . List.inits $ namespace : path
350 jsExports = assign ("_elm" : names ++ ["values"]) (ObjectLit () exs)
351 where
352 exs = map entry $ "_op" : concatMap extract (exports modul)
353 entry x = (prop x, ref x)
354 extract value =
355 case value of
356 Var.Alias _ -> []
357 Var.Value x | Help.isOp x -> []
358 | otherwise -> [Var.varName x]
359 Var.ADT _ (Var.Listing ctors _) -> map Var.varName ctors
361 assign path expr =
362 case path of
363 [x] -> VarDeclStmt () [ varDecl x expr ]
364 _ -> ExprStmt () $
365 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
367binop :: Region -> Var.Canonical -> Canonical.Expr -> Canonical.Expr
368 -> State Int (Expression ())
369binop region func@(Var.Canonical home op) e1 e2 =
370 case (home, op) of
371 (Var.Module ["Basics"], ">>") ->
372 do es <- mapM expression (collectLeftAssoc [e2] e1)
373 return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es
375 (Var.Module ["Basics"], "<<") ->
376 do es <- mapM expression (e1 : collectRightAssoc [] e2)
377 return $ ["$"] ==> foldr (<|) (ref "$") es
379 (Var.Module ["Basics"], "<|") ->
380 do e2' <- expression e2
381 es <- mapM expression (collectRightAssoc [] e1)
382 return $ foldr (<|) e2' es
384 (Var.Module ["List"], "++") ->
385 do e1' <- expression e1
386 e2' <- expression e2
387 return $ _List "append" `call` [e1', e2']
389 (Var.BuiltIn, "::") ->
390 expression (A region (Data "::" [e1,e2]))
392 (Var.Module ["Basics"], _) ->
393 do e1' <- expression e1
394 e2' <- expression e2
395 return $ case Map.lookup op basicOps of
396 Just f -> f e1' e2'
397 Nothing -> ref "A2" `call` [ Var.canonical func, e1', e2' ]
399 _ ->
400 do e1' <- expression e1
401 e2' <- expression e2
402 return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
404 where
405 collectRightAssoc es e =
406 case e of
407 A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->
408 collectRightAssoc (es ++ [e1]) e2
409 _ -> es ++ [e]
411 collectLeftAssoc es e =
412 case e of
413 A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->
414 collectLeftAssoc (e2 : es) e1
415 _ -> e : es
417 basicOps = Map.fromList (infixOps ++ specialOps)
419 infixOps =
420 let infixOp str op = (str, InfixExpr () op) in
421 [ infixOp "+" OpAdd
422 , infixOp "-" OpSub
423 , infixOp "*" OpMul
424 , infixOp "/" OpDiv
425 , infixOp "&&" OpLAnd
426 , infixOp "||" OpLOr
427 ]
429 specialOps =
430 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
431 , (,) "|>" $ flip (<|)
432 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
433 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
434 , (,) "<" $ cmp OpLT 0
435 , (,) ">" $ cmp OpGT 0
436 , (,) "<=" $ cmp OpLT 1
437 , (,) ">=" $ cmp OpGT (-1)
438 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
439 ]
441 cmp op n a b = InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)