git.iko.soy/elk
on 78672b5 help sign in
elk/src/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 , include "_P" "Ports"
38 , varDecl Help.localModuleName (string (Module.nameToString name))
39 ]
40 where
41 include :: String -> String -> VarDecl ()
42 include alias modul =
43 varDecl alias (obj ["_N", modul, "make"] <| ref "_elm")
45_Utils :: String -> Expression ()
46_Utils x = obj ["_U", x]
48_List :: String -> Expression ()
49_List x = obj ["_L", x]
51literal :: Literal -> Expression ()
52literal lit =
53 case lit of
54 Chr c -> _Utils "chr" <| string [c]
55 Str s -> string s
56 IntNum n -> IntLit () n
57 FloatNum n -> NumLit () n
58 Boolean b -> BoolLit () b
60expression :: Canonical.Expr -> State Int (Expression ())
61expression (A region expr) =
62 case expr of
63 Var var -> return $ Var.canonical var
65 Literal lit -> return $ literal lit
67 Range lo hi ->
68 do lo' <- expression lo
69 hi' <- expression hi
70 return $ _List "range" `call` [lo',hi']
72 Access e x ->
73 do e' <- expression e
74 return $ DotRef () e' (var x)
76 Remove e x ->
77 do e' <- expression e
78 return $ _Utils "remove" `call` [string x, e']
80 Insert e x v ->
81 do v' <- expression v
82 e' <- expression e
83 return $ _Utils "insert" `call` [string x, v', e']
85 Modify e fs ->
86 do e' <- expression e
87 fs' <- forM fs $ \(f,v) -> do
88 v' <- expression v
89 return $ ArrayLit () [string f, v']
90 return $ _Utils "replace" `call` [ArrayLit () fs', e']
92 Record fields ->
93 do fields' <- forM fields $ \(f,e) -> do
94 (,) f <$> expression e
95 let fieldMap = List.foldl' combine Map.empty fields'
96 return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
97 where
98 combine r (k,v) = Map.insertWith (++) k [v] r
99 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
100 Map.toList . Map.filter (not . null) $ Map.map tail fs
101 visible fs = map (first prop) . Map.toList $ Map.map head fs
103 Binop op e1 e2 -> binop region op e1 e2
105 Lambda p e@(A ann _) ->
106 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
107 body' <- expression body
108 return $ case length args < 2 || length args > 9 of
109 True -> foldr (==>) body' (map (:[]) args)
110 False -> ref ("F" ++ show (length args)) <| (args ==> body')
111 where
112 depattern (args, body) pattern =
113 case pattern of
114 P.Var x -> return (args ++ [ Var.varName x ], body)
115 _ -> do arg <- Case.newVar
116 return ( args ++ [arg]
117 , A ann (Case (A ann (localVar arg)) [(pattern, body)]))
119 (patterns, innerBody) = collect [p] e
121 collect patterns lexpr@(A _ expr) =
122 case expr of
123 Lambda p e -> collect (p:patterns) e
124 _ -> (patterns, lexpr)
126 App e1 e2 ->
127 do func' <- expression func
128 args' <- mapM expression args
129 return $ case args' of
130 [arg] -> func' <| arg
131 _ | length args' <= 9 -> ref aN `call` (func':args')
132 | otherwise -> foldl1 (<|) (func':args')
133 where
134 aN = "A" ++ show (length args)
135 (func, args) = getArgs e1 [e2]
136 getArgs func args =
137 case func of
138 (A _ (App f arg)) -> getArgs f (arg : args)
139 _ -> (func, args)
141 Let defs e ->
142 do let (defs',e') = flattenLets defs e
143 stmts <- concat <$> mapM definition defs'
144 exp <- expression e'
145 return $ function [] (stmts ++ [ ret exp ]) `call` []
147 MultiIf branches ->
148 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
149 return $ case last branches of
150 (A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) ->
151 safeIfs branches'
152 (A _ (Literal (Boolean True)), _) -> safeIfs branches'
153 _ -> ifs branches' (throw "badIf" region)
154 where
155 safeIfs branches = ifs (init branches) (snd (last branches))
156 ifs branches finally = foldr iff finally branches
157 iff (if', then') else' = CondExpr () if' then' else'
159 Case e cases ->
160 do (tempVar,initialMatch) <- Case.toMatch cases
161 (revisedMatch, stmt) <-
162 case e of
163 A _ (Var (Var.Canonical Var.Local x)) ->
164 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
165 _ ->
166 do e' <- expression e
167 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
168 match' <- match region revisedMatch
169 return (function [] (stmt ++ match') `call` [])
171 ExplicitList es ->
172 do es' <- mapM expression es
173 return $ _List "fromArray" <| ArrayLit () es'
175 Data name es ->
176 do es' <- mapM expression es
177 return $ ObjectLit () (ctor : fields es')
178 where
179 ctor = (prop "ctor", string name)
180 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
182 Markdown uid doc ->
183 return $ Var.value ["Text"] "markdown" `call` [ string md, string uid ]
184 where
185 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
186 md = pad ++ MD.toHtml doc ++ pad
188 GLShader _uid src _tipe ->
189 return $ ObjectLit () [(PropString () "src", literal (Str src))]
191 PortIn name tipe ->
192 return $ obj ["_P","portIn"] `call`
193 [ string name, Port.incoming tipe ]
195 PortOut name tipe value ->
196 do value' <- expression value
197 return $ obj ["_P","portOut"] `call`
198 [ string name, Port.outgoing tipe, value' ]
200definition :: Canonical.Def -> State Int [Statement ()]
201definition (Canonical.Definition pattern expr@(A region _) _) = do
202 expr' <- expression expr
203 let assign x = varDecl x expr'
204 case pattern of
205 P.Var x
206 | Help.isOp x ->
207 let op = LBracket () (ref "_op") (string x) in
208 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
209 | otherwise ->
210 return [ VarDeclStmt () [ assign (Var.varName x) ] ]
212 P.Record fields ->
213 let setField f = varDecl f (obj ["$",f]) in
214 return [ VarDeclStmt () (assign "$" : map setField fields) ]
216 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
217 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
218 where
219 vars = getVars patterns
220 getVars patterns =
221 case patterns of
222 P.Var x : rest -> (Var.varName x :) `fmap` getVars rest
223 [] -> Just []
224 _ -> Nothing
226 decl x n = varDecl x (obj ["$","_" ++ show n])
227 setup vars
228 | Help.isTuple name = assign "$" : vars
229 | otherwise = assign "_raw" : safeAssign : vars
231 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
232 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
233 exception = Help.throw "badCase" region
235 _ ->
236 do defs' <- concat <$> mapM toDef vars
237 return (VarDeclStmt () [assign "_"] : defs')
238 where
239 vars = P.boundVarList pattern
240 mkVar = A region . localVar
241 toDef y = let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]
242 in definition $ Canonical.Definition (P.Var y) expr Nothing
244match :: Region -> Case.Match -> State Int [Statement ()]
245match region mtch =
246 case mtch of
247 Case.Match name clauses mtch' ->
248 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
249 mtch'' <- match region mtch'
250 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
251 where
252 isLiteral p = case p of
253 Case.Clause (Right _) _ _ -> True
254 _ -> False
256 access name
257 | any isLiteral clauses = obj [name]
258 | otherwise = obj (Help.splitDots name ++ ["ctor"])
260 format isChars e
261 | or isChars = InfixExpr () OpAdd e (string "")
262 | otherwise = e
264 Case.Fail ->
265 return [ ExprStmt () (Help.throw "badCase" region) ]
267 Case.Break -> return [BreakStmt () Nothing]
269 Case.Other e ->
270 do e' <- expression e
271 return [ ret e' ]
273 Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
274 where
275 dropEnd acc [] = acc
276 dropEnd acc (m:ms) =
277 case m of
278 Case.Other _ -> acc ++ [m]
279 _ -> dropEnd (acc ++ [m]) ms
281clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
282clause region variable (Case.Clause value vars mtch) =
283 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
284 where
285 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
286 (isChar, pattern) =
287 case value of
288 Right (Chr c) -> (True, string [c])
289 _ -> (,) False $ case value of
290 Right (Boolean b) -> BoolLit () b
291 Right lit -> literal lit
292 Left (Var.Canonical _ name) ->
293 string name
295flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
296flattenLets defs lexpr@(A _ expr) =
297 case expr of
298 Let ds body -> flattenLets (defs ++ ds) body
299 _ -> (defs, lexpr)
301generate :: CanonicalModule -> String
302generate modul =
303 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
304 [ assign ("Elm" : names ++ ["make"]) (function ["_elm"] programStmts) ]
305 where
306 names :: [String]
307 names = Module.names modul
309 thisModule :: Expression ()
310 thisModule = obj ("_elm" : names ++ ["values"])
312 programStmts :: [Statement ()]
313 programStmts =
314 concat
315 [ [ ExprStmt () (string "use strict") ]
316 , setup "_elm" (names ++ ["values"])
317 , [ IfSingleStmt () thisModule (ret thisModule) ]
318 , [ VarDeclStmt () localVars ]
319 , body
320 , [ jsExports ]
321 , [ ret thisModule ]
322 ]
324 localVars :: [VarDecl ()]
325 localVars = varDecl "_op" (ObjectLit () []) :
326 internalImports (Module.names modul) ++
327 explicitImports
328 where
329 explicitImports :: [VarDecl ()]
330 explicitImports =
331 map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul
333 jsImport :: Module.Name -> VarDecl ()
334 jsImport name =
335 varDecl (Var.moduleName name) $
336 obj ("Elm" : name ++ ["make"]) <| ref "_elm"
338 body :: [Statement ()]
339 body = concat $ evalState defs 0
340 where
341 defs = mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)
343 setup namespace path = map create paths
344 where
345 create name = assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
346 paths = drop 2 . init . List.inits $ namespace : path
348 jsExports = assign ("_elm" : names ++ ["values"]) (ObjectLit () exs)
349 where
350 exs = map entry $ "_op" : concatMap extract (exports modul)
351 entry x = (prop x, ref x)
352 extract value =
353 case value of
354 Var.Alias _ -> []
356 Var.Value x
357 | Help.isOp x -> []
358 | otherwise -> [Var.varName x]
360 Var.Union _ (Var.Listing ctors _) ->
361 map Var.varName ctors
363 assign path expr =
364 case path of
365 [x] -> VarDeclStmt () [ varDecl x expr ]
366 _ -> ExprStmt () $
367 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
369binop :: Region -> Var.Canonical -> Canonical.Expr -> Canonical.Expr
370 -> State Int (Expression ())
371binop region func@(Var.Canonical home op) e1 e2 =
372 case (home, op) of
373 (Var.Module ["Basics"], ">>") ->
374 do es <- mapM expression (collectLeftAssoc [e2] e1)
375 return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es
377 (Var.Module ["Basics"], "<<") ->
378 do es <- mapM expression (e1 : collectRightAssoc [] e2)
379 return $ ["$"] ==> foldr (<|) (ref "$") es
381 (Var.Module ["Basics"], "<|") ->
382 do e2' <- expression e2
383 es <- mapM expression (collectRightAssoc [] e1)
384 return $ foldr (<|) e2' es
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)