git.iko.soy/elk
on 6fb2fa9 help sign in
elk/compiler/Generate/JavaScript.hs
417 lines 16 kB history raw
1module Generate.JavaScript 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
9import qualified Text.Pandoc as Pan
11import Generate.Cases
12import SourceSyntax.Everything
13import SourceSyntax.Location
14import qualified Transform.SortDefinitions as SD
15import Language.ECMAScript3.Syntax
16import Language.ECMAScript3.PrettyPrint
17import Parse.Helpers (jsReserveds)
19makeSafe :: String -> String
20makeSafe = dereserve . deprime
21 where
22 deprime = map (\c -> if c == '\'' then '$' else c)
23 dereserve x = case Set.member x jsReserveds of
24 False -> x
25 True -> "$" ++ x
27split = go []
28 where
29 go vars str =
30 case break (=='.') str of
31 (x,'.':rest) -> go (vars ++ [x]) rest
32 (x,[]) -> vars ++ [x]
34var name = Id () (makeSafe name)
35ref name = VarRef () (var name)
36prop name = PropId () (var name)
37f <| x = CallExpr () f [x]
38args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ]
39namedFunction name args e = FuncExpr () name (map var args) [ ReturnStmt () (Just e) ]
40function args stmts = FuncExpr () Nothing (map var args) stmts
41call = CallExpr ()
42string = StringLit ()
44dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)
45obj = dotSep . split
47varDecl x expr =
48 VarDecl () (var x) (Just expr)
50include alias moduleName =
51 varDecl alias (obj moduleName <| ref "elm")
53internalImports name =
54 VarDeclStmt ()
55 [ varDecl "N" (obj "Elm.Native")
56 , include "_N" "N.Utils"
57 , include "_L" "N.List"
58 , include "_E" "N.Error"
59 , include "_J" "N.JavaScript"
60 , varDecl "_str" (obj "_J.toString")
61 , varDecl "$moduleName" (string name)
62 ]
64literal lit =
65 case lit of
66 Chr c -> string [c]
67 Str s -> ref "_str" <| string s
68 IntNum n -> IntLit () n
69 FloatNum n -> NumLit () n
70 Boolean b -> BoolLit () b
72expression :: LExpr () () -> State Int (Expression ())
73expression (L span expr) =
74 case expr of
75 Var x -> return $ ref x
76 Literal lit -> return $ literal lit
78 Range lo hi ->
79 do lo' <- expression lo
80 hi' <- expression hi
81 return $ obj "_L.range" `call` [lo',hi']
83 Access e x ->
84 do e' <- expression e
85 return $ DotRef () e' (var x)
87 Remove e x ->
88 do e' <- expression e
89 return $ obj "_N.remove" `call` [string x, e']
91 Insert e x v ->
92 do v' <- expression v
93 e' <- expression e
94 return $ obj "_N.insert" `call` [string x, v', e']
96 Modify e fs ->
97 do e' <- expression e
98 fs' <- forM fs $ \(f,v) -> do
99 v' <- expression v
100 return $ ArrayLit () [string f, v']
101 return $ obj "_N.replace" `call` [ArrayLit () fs', e']
103 Record fields ->
104 do fields' <- forM fields $ \(f,e) -> do
105 (,) f <$> expression e
106 let fieldMap = List.foldl' combine Map.empty fields'
107 return $ ObjectLit () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
108 where
109 combine r (k,v) = Map.insertWith (++) k [v] r
110 prop = PropId () . var
111 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
112 Map.toList . Map.filter (not . null) $ Map.map tail fs
113 visible fs = map (first prop) . Map.toList $ Map.map head fs
115 Binop op e1 e2 -> binop span op e1 e2
117 Lambda pattern body -> lambda Nothing span pattern body
119 App e1 e2 ->
120 do func' <- expression func
121 args' <- mapM expression args
122 return $ case args' of
123 [arg] -> func' <| arg
124 _ -> ref aN `call` (func':args')
125 where
126 aN = "A" ++ show (length args)
127 (func, args) = getArgs e1 [e2]
128 getArgs func args =
129 case func of
130 (L _ (App f arg)) -> getArgs f (arg : args)
131 _ -> (func, args)
133 Let defs e ->
134 do let (defs',e') = SD.flattenLets defs e
135 stmts <- concat <$> mapM definition defs'
136 exp <- expression e'
137 return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []
139 MultiIf branches ->
140 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
141 return $ case last branches of
142 (L _ (Var "otherwise"), e) -> ifs (init branches') (snd (last branches'))
143 _ -> ifs branches'
144 (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
145 where
146 ifs branches finally = foldr iff finally branches
147 iff (if', then') else' = CondExpr () if' then' else'
149 Case e cases ->
150 do (tempVar,initialMatch) <- caseToMatch cases
151 (revisedMatch, stmt) <-
152 case e of
153 L _ (Var x) -> return (matchSubst [(tempVar,x)] initialMatch, [])
154 _ -> do e' <- expression e
155 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
156 match' <- match span revisedMatch
157 return (function [] (stmt ++ match') `call` [])
159 ExplicitList es ->
160 do es' <- mapM expression es
161 return $ obj "_J.toList" <| ArrayLit () es'
163 Data name es ->
164 do es' <- mapM expression es
165 return $ ObjectLit () (ctor : fields es')
166 where
167 ctor = (prop "ctor", string (makeSafe name))
168 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
170 Markdown doc _ -> return $ obj "Text.text" <| string (pad ++ md ++ pad)
171 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
172 md = Pan.writeHtmlString Pan.def doc
174definition :: Def () () -> State Int [Statement ()]
175definition def =
176 case def of
177 TypeAnnotation _ _ -> return []
179 Def (PVar f) (L span (Lambda pattern body))
180 | not (isOp f) ->
181 do expr <- lambda (Just (var f)) span pattern body
182 return [ VarDeclStmt () [ varDecl f expr ] ]
184 Def pattern expr@(L span _) -> do
185 expr' <- expression expr
186 let assign x = varDecl x expr'
187 case pattern of
188 PVar x
189 | isOp x ->
190 let op = LBracket () (ref "_op") (string x) in
191 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
192 | otherwise ->
193 return [ VarDeclStmt () [ assign x ] ]
195 PRecord fields ->
196 let setField f = varDecl f (dotSep ["$",f]) in
197 return [ VarDeclStmt () (assign "$" : map setField fields) ]
199 PData name patterns | vars /= Nothing ->
200 case vars of
201 Just vs -> return [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]
202 where
203 vars = getVars patterns
204 getVars patterns =
205 case patterns of
206 PVar x : rest -> (x:) `fmap` getVars rest
207 [] -> Just []
208 _ -> Nothing
210 decl x n = varDecl x (dotSep ["$","_" ++ show n])
211 setup vars
212 | isTuple name = assign "$" : vars
213 | otherwise = safeAssign : vars
215 safeAssign = varDecl "$" (CondExpr () if' expr' exception)
216 if' = InfixExpr () OpStrictEq (obj "$.ctor") (string name)
217 exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
219 _ ->
220 do defs' <- concat <$> mapM toDef vars
221 return (VarDeclStmt () [assign "$"] : defs')
222 where
223 vars = Set.toList $ SD.boundVars pattern
224 mkVar = L span . Var
225 toDef y = definition $
226 Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])
229lambda name span outerPattern outerBody =
230 do body' <- expression body
231 return $ case args of
232 [arg] -> namedFunction name args body'
233 arg:rest ->
234 case length args < 10 of
235 True -> ref ("F" ++ show (length args)) <| (namedFunction name args body')
236 False -> namedFunction name [arg] (foldr (==>) body' (map (:[]) rest))
237 where
238 (args, body) = foldr depattern ([], innerBody) (zip patterns [0..])
240 depattern (pattern,n) (args, body) =
241 case pattern of
242 PVar x -> (args ++ [x], body)
243 _ -> let arg = "arg" ++ show n
244 in (args ++ [arg], L span (Case (L span (Var arg)) [(pattern, body)]))
246 (patterns, innerBody) = collect [outerPattern] outerBody
248 collect patterns lexpr@(L _ expr) =
249 case expr of
250 Lambda p e -> collect (p:patterns) e
251 _ -> (patterns, lexpr)
253match span mtch =
254 case mtch of
255 Match name clauses mtch' ->
256 do clauses' <- mapM (clause span name) clauses
257 mtch'' <- match span mtch'
258 return (SwitchStmt () (access name) clauses' : mtch'')
259 where
260 isLiteral p = case p of
261 Clause (Right _) _ _ -> True
262 _ -> False
263 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
265 Fail -> return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
266 Break -> return []
267 Other e ->
268 do e' <- expression e
269 return [ ReturnStmt () (Just e') ]
270 Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
271 where
272 dropEnd acc [] = acc
273 dropEnd acc (m:ms) =
274 case m of
275 Other _ -> acc ++ [m]
276 _ -> dropEnd (acc ++ [m]) ms
278clause span variable (Clause value vars mtch) =
279 CaseClause () pattern <$> match span (matchSubst (zip vars vars') mtch)
280 where
281 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
282 pattern = 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
290jsModule :: MetadataModule () () -> String
291jsModule modul = show . prettyPrint $ setup (Just "Elm") (names modul) ++
292 [ assign ("Elm" : names modul) (function ["elm"] programStmts) ]
293 where
294 thisModule = dotSep ("elm" : names modul)
295 programStmts =
296 concat [ setup (Just "elm") (names modul)
297 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
298 , [ internalImports (List.intercalate "." (names modul)) ]
299 , concatMap jsImport (imports modul)
300 , concatMap importEvent (foreignImports modul)
301 , [ assign ["_op"] (ObjectLit () []) ]
302 , concat $ evalState (mapM definition . fst . SD.flattenLets [] $ program modul) 0
303 , map exportEvent $ foreignExports modul
304 , [ jsExports ]
305 , [ ReturnStmt () (Just thisModule) ]
306 ]
308 jsExports = assign ("elm" : names modul) (ObjectLit () exs)
309 where
310 exs = map entry . filter (not . isOp) $ "_op" : exports modul
311 entry x = (PropId () (var x), ref x)
313 assign path expr =
314 case path of
315 [x] -> VarDeclStmt () [ varDecl x expr ]
316 _ -> ExprStmt () $
317 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
319 jsImport (modul,_) = setup Nothing path ++ [ assign path (dotSep ("Elm" : path) <| ref "elm") ]
320 where
321 path = split modul
323 setup namespace path = map create paths
324 where
325 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
326 paths = case namespace of
327 Nothing -> tail . init $ List.inits path
328 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
330 addId js = InfixExpr () OpAdd (string (js++"_")) (obj "elm.id")
332 importEvent (js,base,elm,_) =
333 [ VarDeclStmt () [ varDecl elm $ obj "Signal.constant" <| evalState (expression base) 0 ]
334 , ExprStmt () $
335 obj "document.addEventListener" `call`
336 [ addId js
337 , function ["e"]
338 [ ExprStmt () $ obj "elm.notify" `call` [dotSep [elm,"id"], obj "e.value"] ]
339 ]
340 ]
342 exportEvent (js,elm,_) =
343 ExprStmt () $
344 ref "A2" `call`
345 [ obj "Signal.lift"
346 , function ["v"]
347 [ VarDeclStmt () [varDecl "e" $ obj "document.createEvent" <| string "Event"]
348 , ExprStmt () $
349 obj "e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]
350 , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "e") "value") (ref "v")
351 , ExprStmt () $ obj "document.dispatchEvent" <| ref "e"
352 , ReturnStmt () (Just $ ref "v")
353 ]
354 , ref elm ]
356binop span op e1 e2 =
357 case op of
358 "Basics.." ->
359 do es <- mapM expression (e1 : collect [] e2)
360 return $ ["$"] ==> foldr (<|) (ref "$") es
361 "Basics.<|" ->
362 do e2' <- expression e2
363 es <- mapM expression (collect [] e1)
364 return $ foldr (<|) e2' es
365 "List.++" ->
366 do e1' <- expression e1
367 e2' <- expression e2
368 return $ obj "_L.append" `call` [e1', e2']
369 "::" -> expression (L span (Data "::" [e1,e2]))
370 _ ->
371 do e1' <- expression e1
372 e2' <- expression e2
373 return $ case Map.lookup op opDict of
374 Just f -> f e1' e2'
375 Nothing -> ref "A2" `call` [ func, e1', e2' ]
376 where
377 collect es e =
378 case e of
379 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
380 _ -> es ++ [e]
382 js1 = expression e1
383 js2 = expression e2
385 func | isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
386 | otherwise = dotSep parts
387 where
388 parts = split op
389 operator = last parts
391 opDict = Map.fromList (infixOps ++ specialOps)
393 specialOp str func = ("Basics." ++ str, func)
394 infixOp str op = specialOp str (InfixExpr () op)
396 infixOps =
397 [ infixOp "+" OpAdd
398 , infixOp "-" OpSub
399 , infixOp "*" OpMul
400 , infixOp "/" OpDiv
401 , infixOp "&&" OpLAnd
402 , infixOp "||" OpLOr
403 ]
405 specialOps =
406 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
407 , specialOp "|>" $ flip (<|)
408 , specialOp "==" $ \a b -> obj "_N.eq" `call` [a,b]
409 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_N.eq" `call` [a,b])
410 , specialOp "<" $ cmp OpLT 0
411 , specialOp ">" $ cmp OpGT 0
412 , specialOp "<=" $ cmp OpLT 1
413 , specialOp ">=" $ cmp OpGT (-1)
414 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
415 ]
417 cmp op n a b = InfixExpr () op (obj "_N.cmp" `call` [a,b]) (IntLit () n)