git.iko.soy/elk
on 3a07298 help sign in
elk/compiler/Generate/JavaScript.hs
357 lines 14 kB history raw
1module Generate.JavaScript where
3import Control.Arrow ((***))
4import qualified Data.List as List
5import qualified Data.Map as Map
6import qualified Data.Set as Set
7import qualified Text.Pandoc as Pan
9import Generate.Cases
10import SourceSyntax.Everything
11import SourceSyntax.Location
12import qualified Transform.SortDefinitions as SD
13import Language.ECMAScript3.Syntax
14import Language.ECMAScript3.PrettyPrint
15import Parse.Helpers (jsReserveds)
17makeSafe :: String -> String
18makeSafe = dereserve . deprime
19 where
20 deprime = map (\c -> if c == '\'' then '$' else c)
21 dereserve x = case Set.member x jsReserveds of
22 False -> x
23 True -> "$" ++ x
25split = go []
26 where
27 go vars str =
28 case break (=='.') str of
29 (x,'.':rest) -> go (vars ++ [x]) rest
30 (x,[]) -> vars ++ [x]
32var name = Id () (makeSafe 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)
42get = dotSep . split
44varDecl x expr =
45 VarDecl () (var x) (Just expr)
47include alias moduleName =
48 varDecl alias (get moduleName <| ref "elm")
50internalImports name =
51 VarDeclStmt ()
52 [ varDecl "N" (get "Elm.Native")
53 , include "_N" "N.Utils"
54 , include "_L" "N.List"
55 , include "_E" "N.Error"
56 , include "_J" "N.JavaScript"
57 , varDecl "_str" (get "_J.toString")
58 , varDecl "$moduleName" (string name)
59 ]
61literal lit =
62 case lit of
63 Chr c -> string [c]
64 Str s -> ref "_str" <| string s
65 IntNum n -> IntLit () n
66 FloatNum n -> NumLit () n
67 Boolean b -> BoolLit () b
69expression :: LExpr () () -> Expression ()
70expression (L span expr) =
71 case expr of
72 Var x -> ref x
73 Literal lit -> literal lit
74 Range lo hi -> get "_L.range" `call` [expression lo, expression hi]
76 Access e x -> DotRef () (expression e) (var x)
77 Remove e x -> get "_N.remove" `call` [string x, expression e]
78 Insert e x v -> get "_N.insert" `call` [string x, expression v, expression e]
79 Modify e fs ->
80 let modify (f,v) = ArrayLit () [string f, expression v]
81 in get "_N.replace" `call` [ArrayLit () (map modify fs), expression e]
83 Record fields -> ObjectLit () $ (PropId () (var "_"), hidden) : visible
84 where
85 combine r (k,v) = Map.insertWith (++) k [v] r
86 fieldMap = List.foldl' combine Map.empty fields
87 hidden = ObjectLit () . map ((PropId () . var) *** (ArrayLit () . map expression)) .
88 Map.toList . Map.filter (not . null) $ Map.map tail fieldMap
89 visible = map ((PropId () . var) *** expression) . Map.toList $ Map.map head fieldMap
91 Binop op e1 e2 -> binop span op e1 e2
93 Lambda p e@(L s _) -> fastFunc
94 where
95 fastFunc
96 | length args < 2 || length args > 9 =
97 foldr (==>) (expression body) (map (:[]) args)
98 | otherwise =
99 ref ("F" ++ show (length args)) <| (args ==> expression body)
101 (args, body) = foldr depattern ([], innerBody) (zip patterns [0..])
103 depattern (pattern,n) (args, body) =
104 case pattern of
105 PVar x -> (args ++ [x], body)
106 _ -> let arg = "arg" ++ show n
107 in (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
109 (patterns, innerBody) = collect [p] e
111 collect patterns lexpr@(L _ expr) =
112 case expr of
113 Lambda p e -> collect (p:patterns) e
114 _ -> (patterns, lexpr)
116 App e1 e2 ->
117 case args of
118 [arg] -> func <| arg
119 _ -> ref aN `call` (func:args)
120 where
121 aN = "A" ++ show (length args)
122 (func, args) = getArgs e1 [e2]
123 getArgs func args =
124 case func of
125 (L _ (App f arg)) -> getArgs f (arg : args)
126 _ -> (expression func, map expression args)
128 Let defs e -> function [] stmts `call` []
129 where
130 (defs',e') = SD.flattenLets defs e
131 stmts = concatMap definition defs' ++ [ ReturnStmt () (Just (expression e')) ]
133 MultiIf branches ->
134 case last branches of
135 (L _ (Var "otherwise"), e) -> ifs (init branches) (expression e)
136 _ -> ifs branches (get "_E.If" `call` [ ref "$moduleName", string (show span) ])
137 where
138 ifs branches finally = foldr iff finally branches
139 iff (if', then') else' = CondExpr () (expression if') (expression then') else'
141 Case e cases -> function [] (stmt ++ match span revisedMatch) `call` []
142 where
143 (tempVar,initialMatch) = caseToMatch cases
144 (revisedMatch, stmt) =
145 case e of
146 L _ (Var x) -> (matchSubst [(tempVar,x)] initialMatch, [])
147 _ -> (initialMatch, [VarDeclStmt () [varDecl tempVar (expression e)]])
149 ExplicitList es ->
150 get "_J.toList" <| ArrayLit () (map expression es)
152 Data name es ->
153 ObjectLit () (ctor : fields)
154 where
155 ctor = (prop "ctor", string (makeSafe name))
156 fields = zipWith (\n e -> (prop ("_" ++ show n), expression e)) [0..] es
158 Markdown doc -> get "Text.text" <| string (pad ++ md ++ pad)
159 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
160 md = Pan.writeHtmlString Pan.def doc
163definition def =
164 case def of
165 TypeAnnotation _ _ -> []
166 Def pattern expr@(L span _) ->
167 let assign x = varDecl x (expression expr) in
168 case pattern of
169 PVar x
170 | isOp x ->
171 let op = LBracket () (ref "_op") (string x) in
172 [ ExprStmt () (AssignExpr () OpAssign op (expression expr)) ]
173 | otherwise ->
174 [ VarDeclStmt () [ assign x ] ]
176 PRecord fields -> [ VarDeclStmt () (assign "$" : map setField fields) ]
177 where
178 setField f = varDecl f (dotSep ["$",f])
180 PData name patterns | vars /= Nothing ->
181 case vars of
182 Just vs -> [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]
183 where
184 vars = getVars patterns
185 getVars patterns =
186 case patterns of
187 PVar x : rest -> (x:) `fmap` getVars rest
188 [] -> Just []
189 _ -> Nothing
191 decl x n = varDecl x (dotSep ["$","_" ++ show n])
192 setup vars
193 | isTuple name = assign "$" : vars
194 | otherwise = safeAssign : vars
196 safeAssign = varDecl "$" (CondExpr () if' (expression expr) exception)
197 if' = InfixExpr () OpStrictEq (get "$.ctor") (string name)
198 exception = get "_E.Case" `call` [ref "$moduleName", string (show span)]
200 _ -> VarDeclStmt () [assign "$"] : concatMap toDef vars
201 where
202 vars = Set.toList $ SD.boundVars pattern
203 mkVar = L span . Var
204 toDef y = definition $
205 Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])
207match span mtch =
208 case mtch of
209 Match name clauses mtch' -> SwitchStmt () (access name) clauses' : match span mtch'
210 where
211 clauses' = map (clause span name) clauses
212 isLiteral p = case p of
213 Clause (Right _) _ _ -> True
214 _ -> False
215 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
217 Fail -> [ ExprStmt () (get "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
218 Break -> []
219 Other e -> [ ReturnStmt () (Just $ expression e) ]
220 Seq ms -> concatMap (match span) (dropEnd [] ms)
221 where
222 dropEnd acc [] = acc
223 dropEnd acc (m:ms) =
224 case m of
225 Other _ -> acc ++ [m]
226 _ -> dropEnd (acc ++ [m]) ms
228clause span variable (Clause value vars mtch) =
229 CaseClause () pattern stmt
230 where
231 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
232 stmt = match span $ matchSubst (zip vars vars') mtch
233 pattern = case value of
234 Right (Boolean b) -> BoolLit () b
235 Right lit -> literal lit
236 Left name -> string $ case List.elemIndices '.' name of
237 [] -> name
238 is -> drop (last is + 1) name
240jsModule :: MetadataModule () () -> String -- [Statement ()]
241jsModule modul = show . prettyPrint $ setup (Just "Elm") (names modul) ++
242 [ assign ("Elm" : names modul) (function ["elm"] programStmts) ]
243 where
244 thisModule = dotSep ("elm" : names modul)
245 programStmts =
246 concat [ setup (Just "elm") (names modul)
247 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
248 , [ internalImports (List.intercalate "." (names modul)) ]
249 , concatMap jsImport (imports modul)
250 , concatMap importEvent (foreignImports modul)
251 , [ assign ["_op"] (ObjectLit () []) ]
252 , concatMap definition . fst . SD.flattenLets [] $ program modul
253 , map exportEvent $ foreignExports modul
254 , [ jsExports ]
255 , [ ReturnStmt () (Just thisModule) ]
256 ]
258 jsExports = assign ("elm" : names modul) (ObjectLit () exs)
259 where
260 exs = map entry . filter (not . isOp) $ "_op" : exports modul
261 entry x = (PropId () (var x), ref x)
263 assign path expr =
264 case path of
265 [x] -> VarDeclStmt () [ varDecl x expr ]
266 _ -> ExprStmt () $
267 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
269 jsImport (modul,_) = setup Nothing path ++ [ assign path (dotSep ("Elm" : path) <| ref "elm") ]
270 where
271 path = split modul
273 setup namespace path = map create paths
274 where
275 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
276 paths = case namespace of
277 Nothing -> tail . init $ List.inits path
278 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
280 addId js = InfixExpr () OpAdd (string (js++"_")) (get "elm.id")
282 importEvent (js,base,elm,_) =
283 [ VarDeclStmt () [ varDecl elm $ get "Signal.constant" <| expression base ]
284 , ExprStmt () $
285 get "document.addEventListener" `call`
286 [ addId js
287 , function ["e"]
288 [ ExprStmt () $ get "elm.notify" `call` [dotSep [elm,"id"], get "e.value"] ]
289 ]
290 ]
292 exportEvent (js,elm,_) =
293 ExprStmt () $
294 ref "A2" `call`
295 [ get "Signal.lift"
296 , function ["v"]
297 [ VarDeclStmt () [varDecl "e" $ get "document.createEvent" <| string "Event"]
298 , ExprStmt () $
299 get "e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]
300 , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "e") "value") (ref "v")
301 , ExprStmt () $ get "document.dispatchEvent" <| ref "e"
302 , ReturnStmt () (Just $ ref "v")
303 ]
304 , ref elm ]
307binop span op e1 e2 =
308 case op of
309 "Basics.." -> ["$"] ==> foldr (<|) (ref "$") (map expression (e1 : collect [] e2))
310 "Basics.<|" -> foldr (<|) (expression e2) (map expression (collect [] e1))
311 "::" -> expression (L span (Data "::" [e1,e2]))
312 "List.++" -> get "_L.append" `call` [js1, js2]
313 _ -> case Map.lookup op opDict of
314 Just f -> f js1 js2
315 Nothing -> ref "A2" `call` [ func, js1, js2 ]
316 where
317 collect es e =
318 case e of
319 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
320 _ -> es ++ [e]
322 js1 = expression e1
323 js2 = expression e2
325 func | isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string op)
326 | otherwise = dotSep parts
327 where
328 parts = split op
329 operator = last parts
331 opDict = Map.fromList (infixOps ++ specialOps)
333 specialOp str func = ("Basics." ++ str, func)
334 infixOp str op = specialOp str (InfixExpr () op)
336 infixOps =
337 [ infixOp "+" OpAdd
338 , infixOp "-" OpSub
339 , infixOp "*" OpMul
340 , infixOp "/" OpDiv
341 , infixOp "&&" OpLAnd
342 , infixOp "||" OpLOr
343 ]
345 specialOps =
346 [ specialOp "^" $ \a b -> get "Math.pow" `call` [a,b]
347 , specialOp "|>" $ flip (<|)
348 , specialOp "==" $ \a b -> get "_N.eq" `call` [a,b]
349 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (get "_N.eq" `call` [a,b])
350 , specialOp "<" $ cmp OpLT 0
351 , specialOp ">" $ cmp OpGT 0
352 , specialOp "<=" $ cmp OpLT 1
353 , specialOp ">=" $ cmp OpGT (-1)
354 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
355 ]
357 cmp op n a b = InfixExpr () op (get "_N.cmp" `call` [a,b]) (IntLit () n)