git.iko.soy/elk
on d41a656 help sign in
elk/compiler/Generate/JavaScript.hs
429 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
14import qualified Generate.Cases as Case
15import qualified Generate.JavaScript.Ports as Port
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 AST.PrettyPrint (renderPretty)
27import qualified AST.Variable as Var
29varDecl :: String -> Expression () -> VarDecl ()
30varDecl x expr =
31 VarDecl () (var x) (Just expr)
33include :: String -> String -> VarDecl ()
34include alias moduleName =
35 varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")
37internalImports :: String -> Statement ()
38internalImports name =
39 VarDeclStmt ()
40 [ varDecl "_N" (obj "Elm.Native")
41 , include "_U" "_N.Utils"
42 , include "_L" "_N.List"
43 , include "_E" "_N.Error"
44 , varDecl "$moduleName" (string name)
45 ]
47literal :: Literal -> Expression ()
48literal lit =
49 case lit of
50 Chr c -> obj "_U.chr" <| string [c]
51 Str s -> string s
52 IntNum n -> IntLit () n
53 FloatNum n -> NumLit () n
54 Boolean b -> BoolLit () b
56canonical :: Var.Canonical -> Expression ()
57canonical (Var.Canonical home name) =
58 case Help.isOp name of
59 True -> BracketRef () (dotSep (home' ++ ["_op"])) (string name)
60 False -> dotSep (home' ++ [map (swap '\'' '$') name])
61 where
62 swap from to c = if c == from then to else c
64 home' =
65 case home of
66 Var.Local -> []
67 Var.BuiltIn -> []
68 Var.Module path -> [ map (swap '.' '$') path ]
70expression :: Canonical.Expr -> State Int (Expression ())
71expression (A region expr) =
72 case expr of
73 Var var -> return $ canonical var
75 Literal lit -> return $ literal lit
77 Range lo hi ->
78 do lo' <- expression lo
79 hi' <- expression hi
80 return $ obj "_L.range" `call` [lo',hi']
82 Access e x ->
83 do e' <- expression e
84 return $ DotRef () e' (var x)
86 Remove e x ->
87 do e' <- expression e
88 return $ obj "_U.remove" `call` [string x, e']
90 Insert e x v ->
91 do v' <- expression v
92 e' <- expression e
93 return $ obj "_U.insert" `call` [string x, v', e']
95 Modify e fs ->
96 do e' <- expression e
97 fs' <- forM fs $ \(f,v) -> do
98 v' <- expression v
99 return $ ArrayLit () [string f, v']
100 return $ obj "_U.replace" `call` [ArrayLit () fs', e']
102 Record fields ->
103 do fields' <- forM fields $ \(f,e) -> do
104 (,) f <$> expression e
105 let fieldMap = List.foldl' combine Map.empty fields'
106 return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
107 where
108 combine r (k,v) = Map.insertWith (++) k [v] r
109 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
110 Map.toList . Map.filter (not . null) $ Map.map tail fs
111 visible fs = map (first prop) . Map.toList $ Map.map head fs
113 Binop op e1 e2 -> binop region op e1 e2
115 Lambda p e@(A ann _) ->
116 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
117 body' <- expression body
118 return $ case length args < 2 || length args > 9 of
119 True -> foldr (==>) body' (map (:[]) args)
120 False -> ref ("F" ++ show (length args)) <| (args ==> body')
121 where
122 depattern (args, body) pattern =
123 case pattern of
124 P.Var x -> return (args ++ [x], body)
125 _ -> do arg <- Case.newVar
126 return ( args ++ [arg]
127 , A ann (Case (A ann (localVar arg)) [(pattern, body)]))
129 (patterns, innerBody) = collect [p] e
131 collect patterns lexpr@(A _ expr) =
132 case expr of
133 Lambda p e -> collect (p:patterns) e
134 _ -> (patterns, lexpr)
136 App e1 e2 ->
137 do func' <- expression func
138 args' <- mapM expression args
139 return $ case args' of
140 [arg] -> func' <| arg
141 _ | length args' <= 9 -> ref aN `call` (func':args')
142 | otherwise -> foldl1 (<|) (func':args')
143 where
144 aN = "A" ++ show (length args)
145 (func, args) = getArgs e1 [e2]
146 getArgs func args =
147 case func of
148 (A _ (App f arg)) -> getArgs f (arg : args)
149 _ -> (func, args)
151 Let defs e ->
152 do let (defs',e') = flattenLets defs e
153 stmts <- concat <$> mapM definition defs'
154 exp <- expression e'
155 return $ function [] (stmts ++ [ ret exp ]) `call` []
157 MultiIf branches ->
158 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
159 return $ case last branches of
160 (A _ (Var (Var.Canonical (Var.Module "Basics") "otherwise")), _) ->
161 safeIfs branches'
162 (A _ (Literal (Boolean True)), _) -> safeIfs branches'
163 _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ])
164 where
165 safeIfs branches = ifs (init branches) (snd (last branches))
166 ifs branches finally = foldr iff finally branches
167 iff (if', then') else' = CondExpr () if' then' else'
169 Case e cases ->
170 do (tempVar,initialMatch) <- Case.toMatch cases
171 (revisedMatch, stmt) <-
172 case e of
173 A _ (Var (Var.Canonical Var.Local x)) ->
174 return (Case.matchSubst [(tempVar,x)] initialMatch, [])
175 _ ->
176 do e' <- expression e
177 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
178 match' <- match region revisedMatch
179 return (function [] (stmt ++ match') `call` [])
181 ExplicitList es ->
182 do es' <- mapM expression es
183 return $ obj "_L.fromArray" <| ArrayLit () es'
185 Data name es ->
186 do es' <- mapM expression es
187 return $ ObjectLit () (ctor : fields es')
188 where
189 ctor = (prop "ctor", string name)
190 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
192 Markdown uid doc es ->
193 do es' <- mapM expression es
194 return $ obj "Text.markdown" `call` (string md : string uid : es')
195 where
196 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
197 md = pad ++ MD.toHtml doc ++ pad
199 GLShader _uid src _tipe ->
200 return $ ObjectLit () [(PropString () "src", literal (Str src))]
202 PortIn name tipe ->
203 return $ obj "Native.Ports.portIn" `call` [ string name, Port.incoming tipe ]
205 PortOut name tipe value ->
206 do value' <- expression value
207 return $ obj "Native.Ports.portOut" `call`
208 [ string name, Port.outgoing tipe, value' ]
210definition :: Canonical.Def -> State Int [Statement ()]
211definition (Canonical.Definition pattern expr@(A region _) _) = do
212 expr' <- expression expr
213 let assign x = varDecl x expr'
214 case pattern of
215 P.Var x
216 | Help.isOp x ->
217 let op = LBracket () (ref "_op") (string x) in
218 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
219 | otherwise ->
220 return [ VarDeclStmt () [ assign x ] ]
222 P.Record fields ->
223 let setField f = varDecl f (dotSep ["$",f]) in
224 return [ VarDeclStmt () (assign "$" : map setField fields) ]
226 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
227 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
228 where
229 vars = getVars patterns
230 getVars patterns =
231 case patterns of
232 P.Var x : rest -> (x:) `fmap` getVars rest
233 [] -> Just []
234 _ -> Nothing
236 decl x n = varDecl x (dotSep ["$","_" ++ show n])
237 setup vars
238 | Help.isTuple name = assign "$" : vars
239 | otherwise = assign "_raw" : safeAssign : vars
241 safeAssign = varDecl "$" (CondExpr () if' (obj "_raw") exception)
242 if' = InfixExpr () OpStrictEq (obj "_raw.ctor") (string name)
243 exception = obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]
245 _ ->
246 do defs' <- concat <$> mapM toDef vars
247 return (VarDeclStmt () [assign "_"] : defs')
248 where
249 vars = P.boundVarList pattern
250 mkVar = A region . localVar
251 toDef y = let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]
252 in definition $ Canonical.Definition (P.Var y) expr Nothing
254match :: Region -> Case.Match -> State Int [Statement ()]
255match region mtch =
256 case mtch of
257 Case.Match name clauses mtch' ->
258 do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
259 mtch'' <- match region mtch'
260 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
261 where
262 isLiteral p = case p of
263 Case.Clause (Right _) _ _ -> True
264 _ -> False
266 access name
267 | any isLiteral clauses = obj name
268 | otherwise = dotSep (split name ++ ["ctor"])
270 format isChars e
271 | or isChars = InfixExpr () OpAdd e (string "")
272 | otherwise = e
274 Case.Fail ->
275 return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]) ]
277 Case.Break -> return [BreakStmt () Nothing]
279 Case.Other e ->
280 do e' <- expression e
281 return [ ret e' ]
283 Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
284 where
285 dropEnd acc [] = acc
286 dropEnd acc (m:ms) =
287 case m of
288 Case.Other _ -> acc ++ [m]
289 _ -> dropEnd (acc ++ [m]) ms
291clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
292clause region variable (Case.Clause value vars mtch) =
293 (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
294 where
295 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
296 (isChar, pattern) =
297 case value of
298 Right (Chr c) -> (True, string [c])
299 _ -> (,) False $ case value of
300 Right (Boolean b) -> BoolLit () b
301 Right lit -> literal lit
302 Left (Var.Canonical _ name) ->
303 string name
305flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)
306flattenLets defs lexpr@(A _ expr) =
307 case expr of
308 Let ds body -> flattenLets (defs ++ ds) body
309 _ -> (defs, lexpr)
311generate :: CanonicalModule -> String
312generate modul =
313 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
314 [ assign ("Elm" : names ++ ["make"]) (function ["_elm"] programStmts) ]
315 where
316 names = Module.names modul
318 thisModule = dotSep ("_elm" : names ++ ["values"])
319 programStmts =
320 concat
321 [ [ ExprStmt () $ string "use strict" ]
322 , setup "_elm" (names ++ ["values"])
323 , [ IfSingleStmt () thisModule (ret thisModule) ]
324 , [ internalImports (List.intercalate "." names) ]
325 , map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul
326 , [ assign ["_op"] (ObjectLit () []) ]
327 , concat $ evalState (mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)) 0
328 , [ jsExports ]
329 , [ ret thisModule ]
330 ]
332 jsExports = assign ("_elm" : names ++ ["values"]) (ObjectLit () exs)
333 where
334 exs = map entry $ "_op" : concatMap extract (exports modul)
335 entry x = (prop x, ref x)
336 extract value =
337 case value of
338 Var.Alias _ -> []
339 Var.Value x | Help.isOp x -> []
340 | otherwise -> [x]
341 Var.ADT _ (Var.Listing ctors _) -> ctors
343 assign path expr =
344 case path of
345 [x] -> VarDeclStmt () [ varDecl x expr ]
346 _ -> ExprStmt () $
347 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
349 jsImport name =
350 assign [dolarize name] $ dotSep ("Elm" : Help.splitDots name ++ ["make"]) <| ref "_elm"
352 setup namespace path = map create paths
353 where
354 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
355 paths = drop 2 . init . List.inits $ namespace : path
357binop :: Region -> Var.Canonical -> Canonical.Expr -> Canonical.Expr
358 -> State Int (Expression ())
359binop region (Var.Canonical home op) e1 e2 =
360 case (home, op) of
361 (Var.Module "Basics", ".") ->
362 do es <- mapM expression (e1 : collect [] e2)
363 return $ ["$"] ==> foldr (<|) (ref "$") es
365 (Var.Module "Basics", "<|") ->
366 do e2' <- expression e2
367 es <- mapM expression (collect [] e1)
368 return $ foldr (<|) e2' es
370 (Var.Module "List", "++") ->
371 do e1' <- expression e1
372 e2' <- expression e2
373 return $ obj "_L.append" `call` [e1', e2']
375 (Var.BuiltIn, "::") ->
376 expression (A region (Data "::" [e1,e2]))
378 (Var.Module "Basics", _) ->
379 do e1' <- expression e1
380 e2' <- expression e2
381 return $ case Map.lookup op basicOps of
382 Just f -> f e1' e2'
383 Nothing -> ref "A2" `call` [ func, e1', e2' ]
385 _ ->
386 do e1' <- expression e1
387 e2' <- expression e2
388 return (ref "A2" `call` [ func, e1', e2' ])
390 where
391 collect es e =
392 case e of
393 A _ (Binop (Var.Canonical (Var.Module "Basics") ".") e1 e2) ->
394 collect (es ++ [e1]) e2
395 _ -> es ++ [e]
397 func | Help.isOp op = BracketRef () (dotSep (path ++ ["_op"])) (string op)
398 | otherwise = dotSep (path ++ [op])
399 where
400 path = case home of
401 Var.Local -> []
402 Var.BuiltIn -> []
403 Var.Module m -> [dolarize m]
405 basicOps = Map.fromList (infixOps ++ specialOps)
407 infixOps =
408 let infixOp str op = (str, InfixExpr () op) in
409 [ infixOp "+" OpAdd
410 , infixOp "-" OpSub
411 , infixOp "*" OpMul
412 , infixOp "/" OpDiv
413 , infixOp "&&" OpLAnd
414 , infixOp "||" OpLOr
415 ]
417 specialOps =
418 [ (,) "^" $ \a b -> obj "Math.pow" `call` [a,b]
419 , (,) "|>" $ flip (<|)
420 , (,) "==" $ \a b -> obj "_U.eq" `call` [a,b]
421 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])
422 , (,) "<" $ cmp OpLT 0
423 , (,) ">" $ cmp OpGT 0
424 , (,) "<=" $ cmp OpLT 1
425 , (,) ">=" $ cmp OpGT (-1)
426 , (,) "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
427 ]
429 cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)