git.iko.soy/elk
on ff9d643 help sign in
elk/compiler/Generate/JavaScript.hs
432 lines 16 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Generate.JavaScript (generate) where
4import Control.Applicative ((<$>),(<*>))
5import Control.Arrow (first,(***))
6import Control.Monad.State
7import qualified Data.List as List
8import qualified Data.Map as Map
9import qualified Data.Set as Set
10import Language.ECMAScript3.PrettyPrint
11import Language.ECMAScript3.Syntax
13import Generate.JavaScript.Helpers as Help
14import qualified Generate.Cases as Case
15import qualified Generate.JavaScript.Ports as Port
16import qualified Generate.JavaScript.Variable as Var
17import qualified Generate.Markdown as MD
19import AST.Annotation
20import AST.Module
21import AST.Expression.General
22import qualified AST.Expression.Canonical as Canonical
23import qualified AST.Module as Module
24import qualified AST.Helpers as Help
25import AST.Literal
26import qualified AST.Pattern as P
27import qualified AST.Variable as Var
29varDecl :: String -> Expression () -> VarDecl ()
30varDecl x expr =
31 VarDecl () (var x) (Just expr)
33internalImports :: String -> [VarDecl ()]
34internalImports name =
35 [ varDecl "_N" (obj ["Elm","Native"])
36 , include "_U" "Utils"
37 , include "_L" "List"
38 , include "_A" "Array"
39 , include "_E" "Error"
40 , include "_P" "Ports"
41 , varDecl Help.localModuleName (string name)
42 ]
43 where
44 include :: String -> String -> VarDecl ()
45 include alias modul =
46 varDecl alias (obj ["_N", modul, "make"] <| ref "_elm")
48_Utils :: String -> Expression ()
49_Utils x = obj ["_U", x]
51_List :: String -> Expression ()
52_List x = obj ["_L", x]
54literal :: Literal -> Expression ()
55literal lit =
56 case lit of
57 Chr c -> _Utils "chr" <| string [c]
58 Str s -> string s
59 IntNum n -> IntLit () n
60 FloatNum n -> NumLit () n
61 Boolean b -> BoolLit () b
63expression :: Canonical.Expr -> State Int (Expression ())
64expression (A region expr) =
65 case expr of
66 Var var -> return $ Var.canonical var
68 Literal lit -> return $ literal lit
70 Range lo hi ->
71 do lo' <- expression lo
72 hi' <- expression hi
73 return $ _List "range" `call` [lo',hi']
75 Access e x ->
76 do e' <- expression e
77 return $ DotRef () e' (var x)
79 Remove e x ->
80 do e' <- expression e
81 return $ _Utils "remove" `call` [string x, e']
83 Insert e x v ->
84 do v' <- expression v
85 e' <- expression e
86 return $ _Utils "insert" `call` [string x, v', e']
88 Modify e fs ->
89 do e' <- expression e
90 fs' <- forM fs $ \(f,v) -> do
91 v' <- expression v
92 return $ ArrayLit () [string f, v']
93 return $ _Utils "replace" `call` [ArrayLit () fs', e']
95 Record fields ->
96 do fields' <- forM fields $ \(f,e) -> do
97 (,) f <$> expression e
98 let fieldMap = List.foldl' combine Map.empty fields'
99 return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
100 where
101 combine r (k,v) = Map.insertWith (++) k [v] r
102 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
103 Map.toList . Map.filter (not . null) $ Map.map tail fs
104 visible fs = map (first prop) . Map.toList $ Map.map head fs
106 Binop op e1 e2 -> binop region op e1 e2
108 Lambda p e@(A ann _) ->
109 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
110 body' <- expression body
111 return $ case length args < 2 || length args > 9 of
112 True -> foldr (==>) body' (map (:[]) args)
113 False -> ref ("F" ++ show (length args)) <| (args ==> body')
114 where
115 depattern (args, body) pattern =
116 case pattern of
117 P.Var x -> return (args ++ [ Var.varName x ], body)
118 _ -> do arg <- Case.newVar
119 return ( args ++ [arg]
120 , A ann (Case (A ann (localVar arg)) [(pattern, body)]))
122 (patterns, innerBody) = collect [p] e
124 collect patterns lexpr@(A _ expr) =
125 case expr of
126 Lambda p e -> collect (p:patterns) e
127 _ -> (patterns, lexpr)
129 App e1 e2 ->
130 do func' <- expression func
131 args' <- mapM expression args
132 return $ case args' of
133 [arg] -> func' <| arg
134 _ | length args' <= 9 -> ref aN `call` (func':args')
135 | otherwise -> foldl1 (<|) (func':args')
136 where
137 aN = "A" ++ show (length args)
138 (func, args) = getArgs e1 [e2]
139 getArgs func args =
140 case func of
141 (A _ (App f arg)) -> getArgs f (arg : args)
142 _ -> (func, args)
144 Let defs e ->
145 do let (defs',e') = flattenLets defs e
146 stmts <- concat <$> mapM definition defs'
147 exp <- expression e'
148 return $ function [] (stmts ++ [ ret exp ]) `call` []
150 MultiIf branches ->
151 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
152 return $ case last branches of
153 (A _ (Var (Var.Canonical (Var.Module "Basics") "otherwise")), _) ->
154 safeIfs branches'
155 (A _ (Literal (Boolean True)), _) -> safeIfs branches'
156 _ -> ifs branches' (throw "If" region)
157 where
158 safeIfs branches = ifs (init branches) (snd (last branches))
159 ifs branches finally = foldr iff finally branches
160 iff (if', then') else' = CondExpr () if' then' else'
162 Case e cases ->
163 do (tempVar,initialMatch) <- Case.toMatch cases
164 (revisedMatch, stmt) <-
165 case e of
166 A _ (Var (Var.Canonical Var.Local x)) ->
167 return (Case.matchSubst [(tempVar,x)] initialMatch, [])
168 _ ->
169 do e' <- expression e
170 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
171 match' <- match region revisedMatch
172 return (function [] (stmt ++ match') `call` [])
174 ExplicitList es ->
175 do es' <- mapM expression es
176 return $ _List "fromArray" <| ArrayLit () es'
178 Data name es ->
179 do es' <- mapM expression es
180 return $ ObjectLit () (ctor : fields es')
181 where
182 ctor = (prop "ctor", string name)
183 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
185 Markdown uid doc es ->
186 do es' <- mapM expression es
187 return $ obj ["Text","markdown"] `call` (string md : string uid : es')
188 where
189 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
190 md = pad ++ MD.toHtml doc ++ pad
192 GLShader _uid src _tipe ->
193 return $ ObjectLit () [(PropString () "src", literal (Str src))]
195 PortIn name tipe ->
196 return $ obj ["_P","portIn"] `call` [ string name, Port.incoming tipe ]
198 PortOut name tipe value ->
199 do value' <- expression value
200 return $ obj ["_P","portOut"] `call`
201 [ string name, Port.outgoing tipe, value' ]
203definition :: Canonical.Def -> State Int [Statement ()]
204definition (Canonical.Definition pattern expr@(A region _) _) = do
205 expr' <- expression expr
206 let assign x = varDecl x expr'
207 case pattern of
208 P.Var x
209 | Help.isOp x ->
210 let op = LBracket () (ref "_op") (string x) in
211 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
212 | otherwise ->
213 return [ VarDeclStmt () [ assign (Var.varName x) ] ]
215 P.Record fields ->
216 let setField f = varDecl f (obj ["$",f]) in
217 return [ VarDeclStmt () (assign "$" : map setField fields) ]
219 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
220 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
221 where
222 vars = getVars patterns
223 getVars patterns =
224 case patterns of
225 P.Var x : rest -> (Var.varName x :) `fmap` getVars rest
226 [] -> Just []
227 _ -> Nothing
229 decl x n = varDecl x (obj ["$","_" ++ show n])
230 setup vars
231 | Help.isTuple name = assign "$" : vars
232 | otherwise = assign "_raw" : safeAssign : vars
234 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
235 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
236 exception = Help.throw "Case" region
238 _ ->
239 do defs' <- concat <$> mapM toDef vars
240 return (VarDeclStmt () [assign "_"] : defs')
241 where
242 vars = P.boundVarList pattern
243 mkVar = A region . localVar
244 toDef y = let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]
245 in definition $ Canonical.Definition (P.Var y) expr Nothing
247match :: Region -> Case.Match -> State Int [Statement ()]
248match region mtch =
249 case mtch of
250 Case.Match name clauses mtch' ->
251 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
252 mtch'' <- match region mtch'
253 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
254 where
255 isLiteral p = case p of
256 Case.Clause (Right _) _ _ -> True
257 _ -> False
259 access name
260 | any isLiteral clauses = obj [name]
261 | otherwise = obj (Help.splitDots name ++ ["ctor"])
263 format isChars e
264 | or isChars = InfixExpr () OpAdd e (string "")
265 | otherwise = e
267 Case.Fail ->
268 return [ ExprStmt () (Help.throw "Case" region) ]
270 Case.Break -> return [BreakStmt () Nothing]
272 Case.Other e ->
273 do e' <- expression e
274 return [ ret e' ]
276 Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
277 where
278 dropEnd acc [] = acc
279 dropEnd acc (m:ms) =
280 case m of
281 Case.Other _ -> acc ++ [m]
282 _ -> dropEnd (acc ++ [m]) ms
284clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
285clause region variable (Case.Clause value vars mtch) =
286 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
287 where
288 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
289 (isChar, pattern) =
290 case value of
291 Right (Chr c) -> (True, string [c])
292 _ -> (,) False $ case value of
293 Right (Boolean b) -> BoolLit () b
294 Right lit -> literal lit
295 Left (Var.Canonical _ name) ->
296 string name
298flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
299flattenLets defs lexpr@(A _ expr) =
300 case expr of
301 Let ds body -> flattenLets (defs ++ ds) body
302 _ -> (defs, lexpr)
304generate :: CanonicalModule -> String
305generate modul =
306 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
307 [ assign ("Elm" : names ++ ["make"]) (function ["_elm"] programStmts) ]
308 where
309 names :: [String]
310 names = Module.names modul
312 thisModule :: Expression ()
313 thisModule = obj ("_elm" : names ++ ["values"])
315 programStmts :: [Statement ()]
316 programStmts =
317 concat
318 [ [ ExprStmt () (string "use strict") ]
319 , setup "_elm" (names ++ ["values"])
320 , [ IfSingleStmt () thisModule (ret thisModule) ]
321 , [ VarDeclStmt () localVars ]
322 , body
323 , [ jsExports ]
324 , [ ret thisModule ]
325 ]
327 localVars :: [VarDecl ()]
328 localVars = varDecl "_op" (ObjectLit () []) :
329 internalImports (Module.getName modul) ++
330 explicitImports
331 where
332 explicitImports :: [VarDecl ()]
333 explicitImports =
334 map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul
336 jsImport :: String -> VarDecl ()
337 jsImport name =
338 varDecl (Var.moduleName name) $
339 obj ("Elm" : Help.splitDots name ++ ["make"]) <| ref "_elm"
341 body :: [Statement ()]
342 body = concat $ evalState defs 0
343 where
344 defs = mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)
346 setup namespace path = map create paths
347 where
348 create name = assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
349 paths = drop 2 . init . List.inits $ namespace : path
351 jsExports = assign ("_elm" : names ++ ["values"]) (ObjectLit () exs)
352 where
353 exs = map entry $ "_op" : concatMap extract (exports modul)
354 entry x = (prop x, ref x)
355 extract value =
356 case value of
357 Var.Alias _ -> []
358 Var.Value x | Help.isOp x -> []
359 | otherwise -> [x]
360 Var.ADT _ (Var.Listing ctors _) -> ctors
362 assign path expr =
363 case path of
364 [x] -> VarDeclStmt () [ varDecl x expr ]
365 _ -> ExprStmt () $
366 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
368binop :: Region -> Var.Canonical -> Canonical.Expr -> Canonical.Expr
369 -> State Int (Expression ())
370binop region func@(Var.Canonical home op) e1 e2 =
371 case (home, op) of
372 (Var.Module "Basics", ".") ->
373 do es <- mapM expression (e1 : collect [] e2)
374 return $ ["$"] ==> foldr (<|) (ref "$") es
376 (Var.Module "Basics", "<|") ->
377 do e2' <- expression e2
378 es <- mapM expression (collect [] 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 collect es e =
403 case e of
404 A _ (Binop (Var.Canonical (Var.Module "Basics") ".") e1 e2) ->
405 collect (es ++ [e1]) e2
406 _ -> es ++ [e]
408 basicOps = Map.fromList (infixOps ++ specialOps)
410 infixOps =
411 let infixOp str op = (str, InfixExpr () op) in
412 [ infixOp "+" OpAdd
413 , infixOp "-" OpSub
414 , infixOp "*" OpMul
415 , infixOp "/" OpDiv
416 , infixOp "&&" OpLAnd
417 , infixOp "||" OpLOr
418 ]
420 specialOps =
421 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
422 , (,) "|>" $ flip (<|)
423 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
424 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
425 , (,) "<" $ cmp OpLT 0
426 , (,) ">" $ cmp OpGT 0
427 , (,) "<=" $ cmp OpLT 1
428 , (,) ">=" $ cmp OpGT (-1)
429 , (,) "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
430 ]
432 cmp op n a b = InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)