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