git.iko.soy/elk
on f8bf89b help sign in
elk/compiler/Generate/JavaScript.hs
415 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 SourceSyntax.Everything
13import SourceSyntax.Location
14import qualified Transform.SortDefinitions as SD
15import Language.ECMAScript3.Syntax
16import Language.ECMAScript3.PrettyPrint
17import qualified Transform.SafeNames as MakeSafe
19split :: String -> [String]
20split = go []
21 where
22 go vars str =
23 case break (=='.') str of
24 (x,'.':rest) | isOp x -> vars ++ [x ++ '.' : rest]
25 | otherwise -> go (vars ++ [x]) rest
26 (x,[]) -> vars ++ [x]
28var name = Id () name
29ref name = VarRef () (var name)
30prop name = PropId () (var name)
31f <| x = CallExpr () f [x]
32args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ]
33function args stmts = FuncExpr () Nothing (map var args) stmts
34call = CallExpr ()
35string = StringLit ()
37dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)
38obj = dotSep . split
40varDecl :: String -> Expression () -> VarDecl ()
41varDecl x expr =
42 VarDecl () (var x) (Just expr)
44include alias moduleName =
45 varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")
47internalImports name =
48 VarDeclStmt ()
49 [ varDecl "N" (obj "Elm.Native")
50 , include "_N" "N.Utils"
51 , include "_L" "N.List"
52 , include "_E" "N.Error"
53 , include "_J" "N.JavaScript"
54 , varDecl "$moduleName" (string name)
55 ]
57literal :: Literal -> Expression ()
58literal lit =
59 case lit of
60 Chr c -> obj "_N.chr" <| string [c]
61 Str s -> string s
62 IntNum n -> IntLit () n
63 FloatNum n -> NumLit () n
64 Boolean b -> BoolLit () b
66expression :: LExpr () () -> State Int (Expression ())
67expression (L span expr) =
68 case expr of
69 Var x -> return $ ref x
70 Literal lit -> return $ literal lit
72 Range lo hi ->
73 do lo' <- expression lo
74 hi' <- expression hi
75 return $ obj "_L.range" `call` [lo',hi']
77 Access e x ->
78 do e' <- expression e
79 return $ DotRef () e' (var x)
81 Remove e x ->
82 do e' <- expression e
83 return $ obj "_N.remove" `call` [string x, e']
85 Insert e x v ->
86 do v' <- expression v
87 e' <- expression e
88 return $ obj "_N.insert" `call` [string x, v', e']
90 Modify e fs ->
91 do e' <- expression e
92 fs' <- forM fs $ \(f,v) -> do
93 v' <- expression v
94 return $ ArrayLit () [string f, v']
95 return $ obj "_N.replace" `call` [ArrayLit () fs', e']
97 Record fields ->
98 do fields' <- forM fields $ \(f,e) -> do
99 (,) f <$> expression e
100 let fieldMap = List.foldl' combine Map.empty fields'
101 return $ ObjectLit () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
102 where
103 combine r (k,v) = Map.insertWith (++) k [v] r
104 prop = PropId () . var
105 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
106 Map.toList . Map.filter (not . null) $ Map.map tail fs
107 visible fs = map (first prop) . Map.toList $ Map.map head fs
109 Binop op e1 e2 -> binop span op e1 e2
111 Lambda p e@(L s _) ->
112 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
113 body' <- expression body
114 return $ case length args < 2 || length args > 9 of
115 True -> foldr (==>) body' (map (:[]) args)
116 False -> ref ("F" ++ show (length args)) <| (args ==> body')
117 where
118 depattern (args, body) pattern =
119 case pattern of
120 PVar x -> return (args ++ [x], body)
121 _ -> do arg <- Case.newVar
122 return (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
124 (patterns, innerBody) = collect [p] e
126 collect patterns lexpr@(L _ expr) =
127 case expr of
128 Lambda p e -> collect (p:patterns) e
129 _ -> (patterns, lexpr)
131 App e1 e2 ->
132 do func' <- expression func
133 args' <- mapM expression args
134 return $ case args' of
135 [arg] -> func' <| arg
136 _ | length args' <= 9 -> ref aN `call` (func':args')
137 | otherwise -> foldl1 (<|) (func':args')
138 where
139 aN = "A" ++ show (length args)
140 (func, args) = getArgs e1 [e2]
141 getArgs func args =
142 case func of
143 (L _ (App f arg)) -> getArgs f (arg : args)
144 _ -> (func, args)
146 Let defs e ->
147 do let (defs',e') = SD.flattenLets defs e
148 stmts <- concat <$> mapM definition defs'
149 exp <- expression e'
150 return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []
152 MultiIf branches ->
153 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
154 return $ case last branches of
155 (L _ (Var "Basics.otherwise"), e) -> ifs (init branches') (snd (last branches'))
156 _ -> ifs branches'
157 (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
158 where
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 L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, [])
167 _ -> do e' <- expression e
168 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
169 match' <- match span revisedMatch
170 return (function [] (stmt ++ match') `call` [])
172 ExplicitList es ->
173 do es' <- mapM expression es
174 return $ obj "_J.toList" <| 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 $ obj "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
190definition :: Def () () -> State Int [Statement ()]
191definition def =
192 case def of
193 TypeAnnotation _ _ -> return []
195 Def pattern expr@(L span _) -> do
196 expr' <- expression expr
197 let assign x = varDecl x expr'
198 case pattern of
199 PVar x
200 | isOp x ->
201 let op = LBracket () (ref "_op") (string x) in
202 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
203 | otherwise ->
204 return [ VarDeclStmt () [ assign x ] ]
206 PRecord fields ->
207 let setField f = varDecl f (dotSep ["$",f]) in
208 return [ VarDeclStmt () (assign "$" : map setField fields) ]
210 PData name patterns | vars /= Nothing ->
211 case vars of
212 Just vs -> return [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]
213 where
214 vars = getVars patterns
215 getVars patterns =
216 case patterns of
217 PVar x : rest -> (x:) `fmap` getVars rest
218 [] -> Just []
219 _ -> Nothing
221 decl x n = varDecl x (dotSep ["$","_" ++ show n])
222 setup vars
223 | isTuple name = assign "$" : vars
224 | otherwise = safeAssign : vars
226 safeAssign = varDecl "$" (CondExpr () if' expr' exception)
227 if' = InfixExpr () OpStrictEq (obj "$.ctor") (string name)
228 exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
230 _ ->
231 do defs' <- concat <$> mapM toDef vars
232 return (VarDeclStmt () [assign "$"] : defs')
233 where
234 vars = Set.toList $ SD.boundVars pattern
235 mkVar = L span . Var
236 toDef y = definition $
237 Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])
239match :: (Show a) => a -> Case.Match () () -> State Int [Statement ()]
240match span mtch =
241 case mtch of
242 Case.Match name clauses mtch' ->
243 do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
244 mtch'' <- match span mtch'
245 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
246 where
247 isLiteral p = case p of
248 Case.Clause (Right _) _ _ -> True
249 _ -> False
250 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
251 format isChars e
252 | or isChars = InfixExpr () OpAdd e (string "")
253 | otherwise = e
255 Case.Fail ->
256 return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
258 Case.Break -> return [BreakStmt () Nothing]
259 Case.Other e ->
260 do e' <- expression e
261 return [ ReturnStmt () (Just e') ]
262 Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
263 where
264 dropEnd acc [] = acc
265 dropEnd acc (m:ms) =
266 case m of
267 Case.Other _ -> acc ++ [m]
268 _ -> dropEnd (acc ++ [m]) ms
270clause span variable (Case.Clause value vars mtch) =
271 (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
272 where
273 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
274 (isChar, pattern) =
275 case value of
276 Right (Chr c) -> (True, string [c])
277 _ -> (,) False $ case value of
278 Right (Boolean b) -> BoolLit () b
279 Right lit -> literal lit
280 Left name -> string $ case List.elemIndices '.' name of
281 [] -> name
282 is -> drop (last is + 1) name
285generate :: MetadataModule () () -> String
286generate unsafeModule =
287 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
288 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]
289 where
290 modul = MakeSafe.metadataModule unsafeModule
291 thisModule = dotSep ("_elm" : names modul ++ ["values"])
292 programStmts =
293 concat [ setup (Just "_elm") (names modul ++ ["values"])
294 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
295 , [ internalImports (List.intercalate "." (names modul)) ]
296 , concatMap jsImport (imports modul)
297 , concatMap importEvent (foreignImports modul)
298 , [ assign ["_op"] (ObjectLit () []) ]
299 , concat $ evalState (mapM definition . fst . SD.flattenLets [] $ program modul) 0
300 , map exportEvent $ foreignExports modul
301 , [ jsExports ]
302 , [ ReturnStmt () (Just thisModule) ]
303 ]
305 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
306 where
307 exs = map entry . filter (not . isOp) $ "_op" : exports modul
308 entry x = (PropId () (var x), ref x)
310 assign path expr =
311 case path of
312 [x] -> VarDeclStmt () [ varDecl x expr ]
313 _ -> ExprStmt () $
314 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
316 jsImport (modul,_) = setup Nothing path ++ [ include ]
317 where
318 path = split modul
319 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
321 setup namespace path = map create paths
322 where
323 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
324 paths = case namespace of
325 Nothing -> tail . init $ List.inits path
326 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
328 addId js = InfixExpr () OpAdd (string (js++"_")) (obj "_elm.id")
330 importEvent (js,base,elm,_) =
331 [ VarDeclStmt () [ varDecl elm $ obj "Signal.constant" <| evalState (expression base) 0 ]
332 , ExprStmt () $
333 obj "document.addEventListener" `call`
334 [ addId js
335 , function ["_e"]
336 [ ExprStmt () $ obj "_elm.notify" `call` [dotSep [elm,"id"], obj "_e.value"] ]
337 ]
338 ]
340 exportEvent (js,elm,_) =
341 ExprStmt () $
342 ref "A2" `call`
343 [ obj "Signal.lift"
344 , function ["_v"]
345 [ VarDeclStmt () [varDecl "_e" $ obj "document.createEvent" <| string "Event"]
346 , ExprStmt () $
347 obj "_e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]
348 , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "_e") "value") (ref "_v")
349 , ExprStmt () $ obj "document.dispatchEvent" <| ref "_e"
350 , ReturnStmt () (Just $ ref "_v")
351 ]
352 , ref elm ]
354binop span op e1 e2 =
355 case op of
356 "Basics.." ->
357 do es <- mapM expression (e1 : collect [] e2)
358 return $ ["$"] ==> foldr (<|) (ref "$") es
359 "Basics.<|" ->
360 do e2' <- expression e2
361 es <- mapM expression (collect [] e1)
362 return $ foldr (<|) e2' es
363 "List.++" ->
364 do e1' <- expression e1
365 e2' <- expression e2
366 return $ obj "_L.append" `call` [e1', e2']
367 "::" -> expression (L span (Data "::" [e1,e2]))
368 _ ->
369 do e1' <- expression e1
370 e2' <- expression e2
371 return $ case Map.lookup op opDict of
372 Just f -> f e1' e2'
373 Nothing -> ref "A2" `call` [ func, e1', e2' ]
374 where
375 collect es e =
376 case e of
377 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
378 _ -> es ++ [e]
380 js1 = expression e1
381 js2 = expression e2
383 func | isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
384 | otherwise = dotSep parts
385 where
386 parts = split op
387 operator = last parts
389 opDict = Map.fromList (infixOps ++ specialOps)
391 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
392 infixOp str op = specialOp str (InfixExpr () op)
394 infixOps = concat
395 [ infixOp "+" OpAdd
396 , infixOp "-" OpSub
397 , infixOp "*" OpMul
398 , infixOp "/" OpDiv
399 , infixOp "&&" OpLAnd
400 , infixOp "||" OpLOr
401 ]
403 specialOps = concat
404 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
405 , specialOp "|>" $ flip (<|)
406 , specialOp "==" $ \a b -> obj "_N.eq" `call` [a,b]
407 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_N.eq" `call` [a,b])
408 , specialOp "<" $ cmp OpLT 0
409 , specialOp ">" $ cmp OpGT 0
410 , specialOp "<=" $ cmp OpLT 1
411 , specialOp ">=" $ cmp OpGT (-1)
412 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
413 ]
415 cmp op n a b = InfixExpr () op (obj "_N.cmp" `call` [a,b]) (IntLit () n)