git.iko.soy/elk
on 24751a3 help sign in
elk/compiler/Generate/JavaScript.hs
420 lines 16 kB history raw
1module Generate.JavaScript (generate) where
3import Control.Arrow (first,(***))
4import Control.Applicative ((<$>),(<*>))
5import Control.Monad.State
6import qualified Data.List as List
7import qualified Data.Map as Map
8import qualified Data.Set as Set
10import qualified Generate.Cases as Case
11import qualified Generate.Markdown as MD
12import qualified SourceSyntax.Helpers as Help
13import SourceSyntax.Literal
14import SourceSyntax.Pattern
15import SourceSyntax.Location
16import SourceSyntax.Expression
17import SourceSyntax.Module
18import qualified Transform.SortDefinitions as SD
19import Language.ECMAScript3.Syntax
20import Language.ECMAScript3.PrettyPrint
21import qualified Transform.SafeNames as MakeSafe
23split :: String -> [String]
24split = go []
25 where
26 go vars str =
27 case break (=='.') str of
28 (x,'.':rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]
29 | otherwise -> go (vars ++ [x]) rest
30 (x,[]) -> vars ++ [x]
32var name = Id () name
33ref name = VarRef () (var name)
34prop name = PropId () (var name)
35f <| x = CallExpr () f [x]
36args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ]
37function args stmts = FuncExpr () Nothing (map var args) stmts
38call = CallExpr ()
39string = StringLit ()
41dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)
42obj = dotSep . split
44varDecl :: String -> Expression () -> VarDecl ()
45varDecl x expr =
46 VarDecl () (var x) (Just expr)
48include alias moduleName =
49 varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")
51internalImports name =
52 VarDeclStmt ()
53 [ varDecl "N" (obj "Elm.Native")
54 , include "_N" "N.Utils"
55 , include "_L" "N.List"
56 , include "_E" "N.Error"
57 , include "_J" "N.JavaScript"
58 , varDecl "$moduleName" (string name)
59 ]
61literal :: Literal -> Expression ()
62literal lit =
63 case lit of
64 Chr c -> obj "_N.chr" <| string [c]
65 Str s -> string s
66 IntNum n -> IntLit () n
67 FloatNum n -> NumLit () n
68 Boolean b -> BoolLit () b
70expression :: LExpr () () -> State Int (Expression ())
71expression (L span expr) =
72 case expr of
73 Var x -> return $ ref x
74 Literal lit -> return $ literal lit
76 Range lo hi ->
77 do lo' <- expression lo
78 hi' <- expression hi
79 return $ obj "_L.range" `call` [lo',hi']
81 Access e x ->
82 do e' <- expression e
83 return $ DotRef () e' (var x)
85 Remove e x ->
86 do e' <- expression e
87 return $ obj "_N.remove" `call` [string x, e']
89 Insert e x v ->
90 do v' <- expression v
91 e' <- expression e
92 return $ obj "_N.insert" `call` [string x, v', e']
94 Modify e fs ->
95 do e' <- expression e
96 fs' <- forM fs $ \(f,v) -> do
97 v' <- expression v
98 return $ ArrayLit () [string f, v']
99 return $ obj "_N.replace" `call` [ArrayLit () fs', e']
101 Record fields ->
102 do fields' <- forM fields $ \(f,e) -> do
103 (,) f <$> expression e
104 let fieldMap = List.foldl' combine Map.empty fields'
105 return $ ObjectLit () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
106 where
107 combine r (k,v) = Map.insertWith (++) k [v] r
108 prop = PropId () . var
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 span op e1 e2
115 Lambda p e@(L s _) ->
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 PVar x -> return (args ++ [x], body)
125 _ -> do arg <- Case.newVar
126 return (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
128 (patterns, innerBody) = collect [p] e
130 collect patterns lexpr@(L _ expr) =
131 case expr of
132 Lambda p e -> collect (p:patterns) e
133 _ -> (patterns, lexpr)
135 App e1 e2 ->
136 do func' <- expression func
137 args' <- mapM expression args
138 return $ case args' of
139 [arg] -> func' <| arg
140 _ | length args' <= 9 -> ref aN `call` (func':args')
141 | otherwise -> foldl1 (<|) (func':args')
142 where
143 aN = "A" ++ show (length args)
144 (func, args) = getArgs e1 [e2]
145 getArgs func args =
146 case func of
147 (L _ (App f arg)) -> getArgs f (arg : args)
148 _ -> (func, args)
150 Let defs e ->
151 do let (defs',e') = SD.flattenLets defs e
152 stmts <- concat <$> mapM definition defs'
153 exp <- expression e'
154 return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []
156 MultiIf branches ->
157 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
158 return $ case last branches of
159 (L _ (Var "Basics.otherwise"), _) -> safeIfs branches'
160 (L _ (Literal (Boolean True)), _) -> safeIfs branches'
161 _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
162 where
163 safeIfs branches = ifs (init branches) (snd (last branches))
164 ifs branches finally = foldr iff finally branches
165 iff (if', then') else' = CondExpr () if' then' else'
167 Case e cases ->
168 do (tempVar,initialMatch) <- Case.toMatch cases
169 (revisedMatch, stmt) <-
170 case e of
171 L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, [])
172 _ -> do e' <- expression e
173 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
174 match' <- match span revisedMatch
175 return (function [] (stmt ++ match') `call` [])
177 ExplicitList es ->
178 do es' <- mapM expression es
179 return $ obj "_J.toList" <| ArrayLit () es'
181 Data name es ->
182 do es' <- mapM expression es
183 return $ ObjectLit () (ctor : fields es')
184 where
185 ctor = (prop "ctor", string name)
186 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
188 Markdown uid doc es ->
189 do es' <- mapM expression es
190 return $ obj "Text.markdown" `call` (string md : string uid : es')
191 where
192 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
193 md = pad ++ MD.toHtml doc ++ pad
195definition :: Def () () -> State Int [Statement ()]
196definition def =
197 case def of
198 TypeAnnotation _ _ -> return []
200 Def pattern expr@(L span _) -> do
201 expr' <- expression expr
202 let assign x = varDecl x expr'
203 case pattern of
204 PVar x
205 | Help.isOp x ->
206 let op = LBracket () (ref "_op") (string x) in
207 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
208 | otherwise ->
209 return [ VarDeclStmt () [ assign x ] ]
211 PRecord fields ->
212 let setField f = varDecl f (dotSep ["$",f]) in
213 return [ VarDeclStmt () (assign "$" : map setField fields) ]
215 PData name patterns | vars /= Nothing ->
216 case vars of
217 Just vs -> return [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]
218 where
219 vars = getVars patterns
220 getVars patterns =
221 case patterns of
222 PVar x : rest -> (x:) `fmap` getVars rest
223 [] -> Just []
224 _ -> Nothing
226 decl x n = varDecl x (dotSep ["$","_" ++ show n])
227 setup vars
228 | Help.isTuple name = assign "$" : vars
229 | otherwise = assign "$raw" : safeAssign : vars
231 safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
232 if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)
233 exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
235 _ ->
236 do defs' <- concat <$> mapM toDef vars
237 return (VarDeclStmt () [assign "$"] : defs')
238 where
239 vars = Set.toList $ SD.boundVars pattern
240 mkVar = L span . Var
241 toDef y = definition $
242 Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])
244match :: (Show a) => a -> Case.Match () () -> State Int [Statement ()]
245match span mtch =
246 case mtch of
247 Case.Match name clauses mtch' ->
248 do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
249 mtch'' <- match span 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
255 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
256 format isChars e
257 | or isChars = InfixExpr () OpAdd e (string "")
258 | otherwise = e
260 Case.Fail ->
261 return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
263 Case.Break -> return [BreakStmt () Nothing]
264 Case.Other e ->
265 do e' <- expression e
266 return [ ReturnStmt () (Just e') ]
267 Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
268 where
269 dropEnd acc [] = acc
270 dropEnd acc (m:ms) =
271 case m of
272 Case.Other _ -> acc ++ [m]
273 _ -> dropEnd (acc ++ [m]) ms
275clause span variable (Case.Clause value vars mtch) =
276 (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
277 where
278 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
279 (isChar, pattern) =
280 case value of
281 Right (Chr c) -> (True, string [c])
282 _ -> (,) False $ case value of
283 Right (Boolean b) -> BoolLit () b
284 Right lit -> literal lit
285 Left name -> string $ case List.elemIndices '.' name of
286 [] -> name
287 is -> drop (last is + 1) name
290generate :: MetadataModule () () -> String
291generate unsafeModule =
292 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
293 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]
294 where
295 modul = MakeSafe.metadataModule unsafeModule
296 thisModule = dotSep ("_elm" : names modul ++ ["values"])
297 programStmts =
298 concat [ setup (Just "_elm") (names modul ++ ["values"])
299 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
300 , [ internalImports (List.intercalate "." (names modul)) ]
301 , concatMap jsImport (imports modul)
302 , concatMap importEvent (foreignImports modul)
303 , [ assign ["_op"] (ObjectLit () []) ]
304 , concat $ evalState (mapM definition . fst . SD.flattenLets [] $ program modul) 0
305 , map exportEvent $ foreignExports modul
306 , [ jsExports ]
307 , [ ReturnStmt () (Just thisModule) ]
308 ]
310 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
311 where
312 exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
313 entry x = (PropId () (var x), ref x)
315 assign path expr =
316 case path of
317 [x] -> VarDeclStmt () [ varDecl x expr ]
318 _ -> ExprStmt () $
319 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
321 jsImport (modul,_) = setup Nothing path ++ [ include ]
322 where
323 path = split modul
324 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
326 setup namespace path = map create paths
327 where
328 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
329 paths = case namespace of
330 Nothing -> tail . init $ List.inits path
331 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
333 addId js = InfixExpr () OpAdd (string (js++"_")) (obj "_elm.id")
335 importEvent (js,base,elm,_) =
336 [ VarDeclStmt () [ varDecl elm $ obj "Signal.constant" <| evalState (expression base) 0 ]
337 , ExprStmt () $
338 obj "document.addEventListener" `call`
339 [ addId js
340 , function ["_e"]
341 [ ExprStmt () $ obj "_elm.notify" `call` [dotSep [elm,"id"], obj "_e.value"] ]
342 ]
343 ]
345 exportEvent (js,elm,_) =
346 ExprStmt () $
347 ref "A2" `call`
348 [ obj "Signal.lift"
349 , function ["_v"]
350 [ VarDeclStmt () [varDecl "_e" $ obj "document.createEvent" <| string "Event"]
351 , ExprStmt () $
352 obj "_e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]
353 , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "_e") "value") (ref "_v")
354 , ExprStmt () $ obj "document.dispatchEvent" <| ref "_e"
355 , ReturnStmt () (Just $ ref "_v")
356 ]
357 , ref elm ]
359binop span op e1 e2 =
360 case op of
361 "Basics.." ->
362 do es <- mapM expression (e1 : collect [] e2)
363 return $ ["$"] ==> foldr (<|) (ref "$") es
364 "Basics.<|" ->
365 do e2' <- expression e2
366 es <- mapM expression (collect [] e1)
367 return $ foldr (<|) e2' es
368 "List.++" ->
369 do e1' <- expression e1
370 e2' <- expression e2
371 return $ obj "_L.append" `call` [e1', e2']
372 "::" -> expression (L span (Data "::" [e1,e2]))
373 _ ->
374 do e1' <- expression e1
375 e2' <- expression e2
376 return $ case Map.lookup op opDict of
377 Just f -> f e1' e2'
378 Nothing -> ref "A2" `call` [ func, e1', e2' ]
379 where
380 collect es e =
381 case e of
382 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
383 _ -> es ++ [e]
385 js1 = expression e1
386 js2 = expression e2
388 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
389 | otherwise = dotSep parts
390 where
391 parts = split op
392 operator = last parts
394 opDict = Map.fromList (infixOps ++ specialOps)
396 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
397 infixOp str op = specialOp str (InfixExpr () op)
399 infixOps = concat
400 [ infixOp "+" OpAdd
401 , infixOp "-" OpSub
402 , infixOp "*" OpMul
403 , infixOp "/" OpDiv
404 , infixOp "&&" OpLAnd
405 , infixOp "||" OpLOr
406 ]
408 specialOps = concat
409 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
410 , specialOp "|>" $ flip (<|)
411 , specialOp "==" $ \a b -> obj "_N.eq" `call` [a,b]
412 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_N.eq" `call` [a,b])
413 , specialOp "<" $ cmp OpLT 0
414 , specialOp ">" $ cmp OpGT 0
415 , specialOp "<=" $ cmp OpLT 1
416 , specialOp ">=" $ cmp OpGT (-1)
417 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
418 ]
420 cmp op n a b = InfixExpr () op (obj "_N.cmp" `call` [a,b]) (IntLit () n)