git.iko.soy/elk
on 394d398 help sign in
elk/compiler/Generate/JavaScript.hs
354 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 Data.Either (partitionEithers)
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)
24var name = Id () (makeSafe name)
25ref name = VarRef () (var name)
26prop name = PropId () (var name)
27f <| x = CallExpr () f [x]
28args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ]
29call = CallExpr ()
30string = StringLit ()
32dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)
34varDecl x expr =
35 VarDecl () (var x) (Just expr)
37include alias moduleName =
38 varDecl alias (dotSep moduleName <| ref "elm")
40internalImports name =
41 VarDeclStmt ()
42 [ varDecl "N" (dotSep ["Elm","Native"])
43 , include "_N" ["N","Utils"]
44 , include "_L" ["N","List"]
45 , include "_E" ["N","Error"]
46 , include "_J" ["N","JavaScript"]
47 , varDecl "_str" (dotSep ["_J","toString"])
48 , varDecl "$moduleName" (string name)
49 ]
51literal lit =
52 case lit of
53 Chr c -> string [c]
54 Str s -> ref "_str" <| string s
55 IntNum n -> IntLit () n
56-- FloatNum n -> NumLit () (float2Double n) -- wrong!!!
57 Boolean b -> BoolLit () b
59expression :: LExpr () () -> Expression ()
60expression (L span expr) =
61 case expr of
62 Var x -> ref x
63 Literal lit -> literal lit
64 Range lo hi -> dotSep ["_L","range"] `call` [expression lo, expression hi]
66 Access e x -> DotRef () (expression e) (var x)
67 Remove e x -> dotSep ["_N","remove"] `call` [ref x, expression e]
68 Insert e x v -> dotSep ["_N","insert"] `call` [ref x, expression v, expression e]
69 Modify e fs ->
70 let modify (f,v) = ArrayLit () [ref f, expression e]
71 in dotSep ["_N","replace"] `call` [ArrayLit () (map modify fs), expression e]
73 Record fields -> ObjectLit () $ (PropId () (var "_"), hidden) : visible
74 where
75 combine r (k,v) = Map.insertWith (++) k [v] r
76 fieldMap = List.foldl' combine Map.empty fields
77 hidden = ObjectLit () . map ((PropId () . var) *** (ArrayLit () . map expression)) .
78 Map.toList . Map.filter (not . null) $ Map.map tail fieldMap
79 visible = map ((PropId () . var) *** expression) . Map.toList $ Map.map head fieldMap
81 Binop op e1 e2 -> binop span op e1 e2
83 Lambda p e@(L s _) -> fastFunc
84 where
85 fastFunc
86 | length args < 2 || length args > 9 =
87 foldr (==>) (expression body) (map (:[]) args)
88 | otherwise =
89 ref ("F" ++ show (length args)) <| (args ==> expression body)
91 (args, body) = foldr depattern ([], innerBody) (zip patterns [0..])
93 depattern (pattern,n) (args, body) =
94 case pattern of
95 PVar x -> (args ++ [x], body)
96 _ -> let arg = "arg" ++ show n
97 in (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
99 (patterns, innerBody) = collect [p] e
101 collect patterns lexpr@(L _ expr) =
102 case expr of
103 Lambda p e -> collect (p:patterns) e
104 _ -> (patterns, lexpr)
106 App e1 e2 ->
107 case args of
108 [arg] -> func <| arg
109 _ -> ref aN `call` (func:args)
110 where
111 aN = "A" ++ show (length args)
112 (func, args) = getArgs e1 [e2]
113 getArgs func args =
114 case func of
115 (L _ (App f arg)) -> getArgs f (arg : args)
116 _ -> (expression func, map expression args)
118 Let defs e -> FuncExpr () Nothing [] stmts `call` []
119 where
120 (defs',e') = SD.flattenLets defs e
121 stmts = map definition defs' ++ [ ReturnStmt () (Just (expression e')) ]
123 MultiIf branches ->
124 case last branches of
125 (L _ (Var "otherwise"), e) -> ifs (init branches) (expression e)
126 _ -> ifs branches (dotSep ["_E","If"] `call` [ ref "$moduleName", string (show span) ])
127 where
128 ifs branches finally = foldr iff finally branches
129 iff (if', then') else' = CondExpr () (expression if') (expression then') else'
131 Case e cases -> FuncExpr () Nothing [] (stmt ++ match span revisedMatch) `call` []
132 where
133 (tempVar,initialMatch) = caseToMatch cases
134 (revisedMatch, stmt) =
135 case e of
136 L _ (Var x) -> (matchSubst [(tempVar,x)] initialMatch, [])
137 _ -> let decl = VarDecl () (var tempVar) (Just $ expression e)
138 in (initialMatch, [VarDeclStmt () [decl]])
140 ExplicitList es ->
141 dotSep ["_J","toList"] <| ArrayLit () (map expression es)
143 Data name es ->
144 ObjectLit () (ctor : fields)
145 where
146 ctor = (prop "ctor", string (makeSafe name))
147 fields = zipWith (\n e -> (prop ("_" ++ show n), expression e)) [0..] es
148{--
149 Markdown doc -> return $ "Text.text('" ++ pad ++ md ++ pad ++ "')"
150 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
151 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
152--}
154definition def =
155 case def of
156 TypeAnnotation _ _ -> EmptyStmt ()
157 Def pattern expr@(L span _) ->
158 let assign x = VarDecl () (var x) (Just (expression expr)) in
159 case pattern of
160 PVar x
161 | isOp x ->
162 let op = LBracket () (ref "_op") (string x) in
163 ExprStmt () (AssignExpr () OpAssign op (expression expr))
164 | otherwise ->
165 VarDeclStmt () [ assign x ]
167 PRecord fields -> VarDeclStmt () (assign "$" : map setField fields)
168 where
169 setField f = VarDecl () (var f) (Just (dotSep ["$",f]))
171 PData name patterns | vars /= Nothing ->
172 case vars of
173 Just vs -> VarDeclStmt () (setup (zipWith varDecl vs [0..]))
174 where
175 vars = getVars patterns
176 getVars patterns =
177 case patterns of
178 PVar x : rest -> (x:) <$> getVars rest
179 [] -> Just []
180 _ -> Nothing
182 varDecl x n = VarDecl () (var x) (Just (dotSep ["$","_" ++ show n]))
183 setup vars
184 | isTuple name = assign "$" : vars
185 | otherwise = safeAssign : vars
187 safeAssign = VarDecl () (var "$") (Just $ CondExpr () if' (expression expr) exception)
188 if' = InfixExpr () OpStrictEq (dotSep ["$","ctor"]) (string name)
189 exception = dotSep ["_E","Case"] `call` [ref "$moduleName", string (show span)]
191 _ -> BlockStmt () ( VarDeclStmt () [assign "$"] : map toDef vars )
192 where
193 vars = Set.toList $ SD.boundVars pattern
194 mkVar = L span . Var
195 toDef y = definition $
196 Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])
197--}
199match span mtch =
200 case mtch of
201 Match name clauses mtch' -> SwitchStmt () (access name) clauses' : match span mtch'
202 where
203 clauses' = map (clause span name) clauses
204 isLiteral p = case p of
205 Clause (Right _) _ _ -> True
206 _ -> False
207 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
209 Fail -> [ ExprStmt () (dotSep ["_E","Case"] `call` [ref "$moduleName", string (show span)]) ]
210 Break -> []
211 Other e -> [ ReturnStmt () (Just $ expression e) ]
212 Seq ms -> concatMap (match span) (dropEnd [] ms)
213 where
214 dropEnd acc [] = acc
215 dropEnd acc (m:ms) =
216 case m of
217 Other _ -> acc ++ [m]
218 _ -> dropEnd (acc ++ [m]) ms
220clause span variable (Clause value vars mtch) =
221 CaseClause () pattern stmt
222 where
223 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
224 stmt = match span $ matchSubst (zip vars vars') mtch
225 pattern = case value of
226 Right (Boolean b) -> BoolLit () b
227 Right lit -> literal lit
228 Left name -> string $ case List.elemIndices '.' name of
229 [] -> name
230 is -> drop (last is + 1) name
231--}
232{--
234jsModule :: MetadataModule t v -> String
235jsModule modul =
236 run $ do
237 body <- toJS . fst . SD.flattenLets [] $ program modul
238 foreignImport <- mapM importEvent (foreignImports modul)
239 return $ concat [ setup ("Elm" : names modul)
240 , globalAssign ("Elm." ++ modName)
241 (jsFunc "elm" $ makeProgram body foreignImport) ]
242 where
243 modName = dotSep (names modul)
244 makeProgram body foreignImport =
245 concat [ setup ("elm" : names modul)
246 , "\nif (elm." ++ modName ++ ") return elm." ++ modName ++ ";"
247 , "\nvar " ++ usefulFuncs ++ ";"
248 , concatMap jsImport (imports modul)
249 , concat foreignImport
250 , assign "_op" "{}"
251 , body
252 , concatMap exportEvent $ foreignExports modul
253 , jsExports
254 ]
255 setup names = concatMap (\n -> globalAssign n $ n ++ " || {}") .
256 map dotSep . drop 2 . List.inits $ init names
257 usefulFuncs = commaSep (map (uncurry assign') (internalImports modName))
259 jsExports = ret (assign' ("elm." ++ modName) (brackets exs))
260 where
261 exs = indent . commaSep . concatMap pair $ "_op" : exports modul
262 pair x | isOp x = []
263 | otherwise = ["\n" ++ x ++ " : " ++ x]
266 importEvent (js,base,elm,_) =
267 do v <- toJS' base
268 return $ concat [ "\nvar " ++ elm ++ "=Signal.constant(" ++ v ++ ");"
269 , "\ndocument.addEventListener('", js
270 , "_' + elm.id, function(e) { elm.notify(", elm
271 , ".id, e.value); });" ]
273 exportEvent (js,elm,_) =
274 concat [ "\nA2( Signal.lift, function(v) { "
275 , "var e = document.createEvent('Event');"
276 , "e.initEvent('", js, "_' + elm.id, true, true);"
277 , "e.value = v;"
278 , "document.dispatchEvent(e); return v; }, ", elm, ");" ]
280jsImport (modul, method) =
281 concat $ zipWith3 (\s n v -> s ++ assign' n v ++ ";") starters subnames values
282 where
283 starters = "\nvar " : repeat "\n"
284 values = map (\name -> name ++ " || {}") (init subnames) ++
285 ["Elm." ++ modul ++ parens "elm"]
286 subnames = map dotSep . tail . List.inits $ split modul
288 split names = case go [] names of
289 (name, []) -> [name]
290 (name, ns) -> name : split ns
291 go name str = case str of
292 '.':rest -> (reverse name, rest)
293 c:rest -> go (c:name) rest
294 [] -> (reverse name, [])
297formatMarkdown = concatMap f
298 where f '\'' = "\\'"
299 f '\n' = "\\n"
300 f '"' = "\""
301 f c = [c]
302--}
303binop span op e1 e2 =
304 case op of
305 "Basics.." -> ["$"] ==> foldr (<|) (ref "$") (map expression (e1 : collect [] e2))
306 "Basics.<|" -> foldr (<|) (expression e2) (map expression (collect [] e1))
307 "::" -> expression (L span (Data "::" [e1,e2]))
308 "List.++" -> dotSep ["_L","append"] `call` [js1, js2]
309 _ -> case Map.lookup op opDict of
310 Just f -> f js1 js2
311 Nothing -> ref "A2" `call` [ func [] op, js1, js2 ]
312 where
313 collect es e =
314 case e of
315 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
316 _ -> es ++ [e]
318 js1 = expression e1
319 js2 = expression e2
321 func vs str =
322 case break (=='.') str of
323 (x,'.':rest) -> func (vs ++ [x]) rest
324 (op,[])
325 | isOp op -> BracketRef () (dotSep (vs ++ ["_op"])) (string op)
326 | otherwise -> dotSep (vs ++ [op])
328 opDict = Map.fromList (infixOps ++ specialOps)
330 specialOp str func = ("Basic." ++ str, func)
331 infixOp str op = specialOp str (InfixExpr () op)
333 infixOps =
334 [ infixOp "+" OpAdd
335 , infixOp "-" OpSub
336 , infixOp "*" OpMul
337 , infixOp "/" OpDiv
338 , infixOp "&&" OpLAnd
339 , infixOp "||" OpLOr
340 ]
342 specialOps =
343 [ specialOp "^" $ \a b -> dotSep ["Math","pow"] `call` [a,b]
344 , specialOp "|>" $ flip (<|)
345 , specialOp "==" $ \a b -> dotSep ["_N","eq"] `call` [a,b]
346 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (dotSep ["_N","eq"] `call` [a,b])
347 , specialOp "<" $ cmp OpLT 0
348 , specialOp ">" $ cmp OpGT 0
349 , specialOp "<=" $ cmp OpLT 1
350 , specialOp ">=" $ cmp OpGT (-1)
351 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
352 ]
354 cmp op n a b = InfixExpr () op (dotSep ["_N","cmp"] `call` [a,b]) (IntLit () n)