git.iko.soy/elk
on eafdaa2 help sign in
elk/compiler/Generate/JavaScript.hs
365 lines 14 kB history raw
1module Generate.JavaScript where
3import Control.Applicative ((<$>))
4import Data.Char (isAlpha,isDigit)
5import qualified Data.List as List
6import qualified Data.Map as Map
7import qualified Data.Set as Set
8import Data.Either (partitionEithers)
10import Unique
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 (makeSafe, iParse)
19import Parse.Expression
21testExpr str = case iParse expr "" str of
22 Right e -> prettyPrint (expression e)
23 Left err -> error (show err)
25var name = Id () (makeSafe name)
26ref name = VarRef () (var name)
27prop name = PropId () (var name)
28f <| x = CallExpr () f [x]
29args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ]
30call = CallExpr ()
31string = StringLit ()
33dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)
35varDecl x expr =
36 VarDecl () (var x) (Just expr)
38include alias moduleName =
39 varDecl alias (dotSep moduleName <| ref "elm")
41internalImports name =
42 VarDeclStmt ()
43 [ varDecl "N" (dotSep ["Elm","Native"])
44 , include "_N" ["N","Utils"]
45 , include "_L" ["N","List"]
46 , include "_E" ["N","Error"]
47 , include "_J" ["N","JavaScript"]
48 , varDecl "_str" (dotSep ["_J","toString"])
49 , varDecl "$moduleName" (string name)
50 ]
52literal lit =
53 case lit of
54 Chr c -> string [c]
55 Str s -> ref "_str" <| string s
56 IntNum n -> IntLit () n
57-- FloatNum n -> NumLit () (float2Double n) -- wrong!!!
58 Boolean b -> BoolLit () b
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{--
74 Record fs -> makeRecord fs
75makeRecord kvs = record `liftM` collect kvs
76 where
77 combine r (k,v) = Map.insertWith (++) k v r
78 collect = liftM (List.foldl' combine Map.empty) . mapM prep
79 prep (k, e) =
80 do v <- toJS' e
81 return (k, [v])
82 fields fs =
83 brackets ("\n "++List.intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
84 hidden = fields . map (second jsList) .
85 filter (not . null . snd) . Map.toList . Map.map tail
86 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
87--}
88 Binop op e1 e2 -> binop span op e1 e2
90 Lambda p e@(L s _) -> fastFunc
91 where
92 fastFunc
93 | length args < 2 || length args > 9 =
94 foldr (==>) (expression body) (map (:[]) args)
95 | otherwise =
96 ref ("F" ++ show (length args)) <| (args ==> expression body)
98 (args, body) = foldr depattern ([], innerBody) (zip patterns [0..])
100 depattern (pattern,n) (args, body) =
101 case pattern of
102 PVar x -> (args ++ [x], body)
103 _ -> let arg = "arg" ++ show n
104 in (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
106 (patterns, innerBody) = collect [p] e
108 collect patterns lexpr@(L _ expr) =
109 case expr of
110 Lambda p e -> collect (p:patterns) e
111 _ -> (patterns, lexpr)
113 App e1 e2 ->
114 case args of
115 [arg] -> func <| arg
116 _ -> ref aN `call` (func:args)
117 where
118 aN = "A" ++ show (length args)
119 (func, args) = getArgs e1 [e2]
120 getArgs func args =
121 case func of
122 (L _ (App f arg)) -> getArgs f (arg : args)
123 _ -> (expression func, map expression args)
125 Let defs e -> FuncExpr () Nothing [] stmts `call` []
126 where
127 (defs',e') = SD.flattenLets defs e
128 stmts = map definition defs' ++ [ ReturnStmt () (Just (expression e')) ]
130 MultiIf branches ->
131 case last branches of
132 (L _ (Var "otherwise"), e) -> ifs (init branches) (expression e)
133 _ -> ifs branches (dotSep ["_E","If"] `call` [ ref "$moduleName", string (show span) ])
134 where
135 ifs branches finally = foldr iff finally branches
136 iff (if', then') else' = CondExpr () (expression if') (expression then') else'
138 ExplicitList es ->
139 dotSep ["_J","toList"] <| ArrayLit () (map expression es)
141 Data name es ->
142 ObjectLit () (ctor : fields)
143 where
144 ctor = (prop "ctor", string (makeSafe name))
145 fields = zipWith (\n e -> (prop ("_" ++ show n), expression e)) [0..] es
146{--
147 Markdown doc -> return $ "Text.text('" ++ pad ++ md ++ pad ++ "')"
148 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
149 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
150--}
152definition def =
153 case def of
154 TypeAnnotation _ _ -> EmptyStmt ()
155 Def pattern expr@(L span _) ->
156 let assign x = VarDecl () (var x) (Just (expression expr)) in
157 case pattern of
158 PVar x
159 | isOp x ->
160 let op = LBracket () (ref "_op") (string x) in
161 ExprStmt () (AssignExpr () OpAssign op (expression expr))
162 | otherwise ->
163 VarDeclStmt () [ assign x ]
165 PRecord fields -> VarDeclStmt () (assign "$" : map setField fields)
166 where
167 setField f = VarDecl () (var f) (Just (dotSep ["$",f]))
169 PData name patterns | vars /= Nothing ->
170 case vars of
171 Just vs -> VarDeclStmt () (setup (zipWith varDecl vs [0..]))
172 where
173 vars = getVars patterns
174 getVars patterns =
175 case patterns of
176 PVar x : rest -> (x:) <$> getVars rest
177 [] -> Just []
178 _ -> Nothing
180 varDecl x n = VarDecl () (var x) (Just (dotSep ["$","_" ++ show n]))
181 setup vars
182 | isTuple name = assign "$" : vars
183 | otherwise = safeAssign : vars
185 safeAssign = VarDecl () (var "$") (Just $ CondExpr () if' (expression expr) exception)
186 if' = InfixExpr () OpStrictEq (dotSep ["$","ctor"]) (string name)
187 exception = dotSep ["_E","Case"] `call` [ref "$moduleName", string (show span)]
189 _ -> BlockStmt () ( VarDeclStmt () [assign "$"] : map toDef vars )
190 where
191 vars = Set.toList $ SD.boundVars pattern
192 mkVar = L span . Var
193 toDef y = definition $
194 Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])
195--}
196{--
198globalAssign n e = "\n" ++ assign' n e ++ ";"
199assign' n e = n ++ " = " ++ e
201jsModule :: MetadataModule t v -> String
202jsModule modul =
203 run $ do
204 body <- toJS . fst . SD.flattenLets [] $ program modul
205 foreignImport <- mapM importEvent (foreignImports modul)
206 return $ concat [ setup ("Elm" : names modul)
207 , globalAssign ("Elm." ++ modName)
208 (jsFunc "elm" $ makeProgram body foreignImport) ]
209 where
210 modName = dotSep (names modul)
211 makeProgram body foreignImport =
212 concat [ setup ("elm" : names modul)
213 , "\nif (elm." ++ modName ++ ") return elm." ++ modName ++ ";"
214 , "\nvar " ++ usefulFuncs ++ ";"
215 , concatMap jsImport (imports modul)
216 , concat foreignImport
217 , assign "_op" "{}"
218 , body
219 , concatMap exportEvent $ foreignExports modul
220 , jsExports
221 ]
222 setup names = concatMap (\n -> globalAssign n $ n ++ " || {}") .
223 map dotSep . drop 2 . List.inits $ init names
224 usefulFuncs = commaSep (map (uncurry assign') (internalImports modName))
226 jsExports = ret (assign' ("elm." ++ modName) (brackets exs))
227 where
228 exs = indent . commaSep . concatMap pair $ "_op" : exports modul
229 pair x | isOp x = []
230 | otherwise = ["\n" ++ x ++ " : " ++ x]
233 importEvent (js,base,elm,_) =
234 do v <- toJS' base
235 return $ concat [ "\nvar " ++ elm ++ "=Signal.constant(" ++ v ++ ");"
236 , "\ndocument.addEventListener('", js
237 , "_' + elm.id, function(e) { elm.notify(", elm
238 , ".id, e.value); });" ]
240 exportEvent (js,elm,_) =
241 concat [ "\nA2( Signal.lift, function(v) { "
242 , "var e = document.createEvent('Event');"
243 , "e.initEvent('", js, "_' + elm.id, true, true);"
244 , "e.value = v;"
245 , "document.dispatchEvent(e); return v; }, ", elm, ");" ]
247jsImport (modul, method) =
248 concat $ zipWith3 (\s n v -> s ++ assign' n v ++ ";") starters subnames values
249 where
250 starters = "\nvar " : repeat "\n"
251 values = map (\name -> name ++ " || {}") (init subnames) ++
252 ["Elm." ++ modul ++ parens "elm"]
253 subnames = map dotSep . tail . List.inits $ split modul
255 split names = case go [] names of
256 (name, []) -> [name]
257 (name, ns) -> name : split ns
258 go name str = case str of
259 '.':rest -> (reverse name, rest)
260 c:rest -> go (c:name) rest
261 [] -> (reverse name, [])
264formatMarkdown = concatMap f
265 where f '\'' = "\\'"
266 f '\n' = "\\n"
267 f '"' = "\""
268 f c = [c]
270caseToJS span e ps = do
271 (tempVar,match) <- caseToMatch ps
272 e' <- toJS' e
273 let (match',stmt) = case e of
274 L _ (Var x) -> (matchSubst [(tempVar,x)] match, "")
275 _ -> (match, assign tempVar e')
276 matches <- matchToJS span match'
277 return $ jsFunc "" (stmt ++ matches) ++ "()"
279matchToJS span match =
280 case match of
281 Match name clauses def ->
282 do cases <- concat `liftM` mapM (clauseToJS span name) clauses
283 finally <- matchToJS span def
284 let isLiteral p = case p of
285 Clause (Right _) _ _ -> True
286 _ -> False
287 access = if any isLiteral clauses then "" else ".ctor"
288 return $ concat [ "\nswitch (", name, access, ") {"
289 , indent cases, "\n}", finally ]
290 Fail -> return ("_E.Case" ++ parens ("$moduleName," ++ quoted (show span)))
291 Break -> return "break;"
292 Other e -> ret `liftM` toJS' e
293 Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)
294 where
295 dropEnd acc [] = acc
296 dropEnd acc (m:ms) =
297 case m of
298 Other _ -> acc ++ [m]
299 _ -> dropEnd (acc ++ [m]) ms
301clauseToJS span var (Clause value vars e) = do
302 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
303 s <- matchToJS span $ matchSubst (zip vars vars') e
304 pattern <- case value of
305 Right (Boolean True) -> return "true"
306 Right (Boolean False) -> return "false"
307 Right lit -> toJS lit
308 Left name -> return . quoted $ case List.elemIndices '.' name of
309 [] -> name
310 is -> drop (last is + 1) name
311 return $ concat [ "\ncase ", pattern, ":", indent s ]
313--}
314binop span op e1 e2 =
315 case op of
316 "Basics.." -> ["$"] ==> foldr (<|) (ref "$") (map expression (e1 : collect [] e2))
317 "Basics.<|" -> foldr (<|) (expression e2) (map expression (collect [] e1))
318 "::" -> expression (L span (Data "::" [e1,e2]))
319 "List.++" -> dotSep ["_L","append"] `call` [js1, js2]
320 _ -> case Map.lookup op opDict of
321 Just f -> f js1 js2
322 Nothing -> ref "A2" `call` [ func [] op, js1, js2 ]
323 where
324 collect es e =
325 case e of
326 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
327 _ -> es ++ [e]
329 js1 = expression e1
330 js2 = expression e2
332 func vs str =
333 case break (=='.') str of
334 (x,'.':rest) -> func (vs ++ [x]) rest
335 (op,[])
336 | isOp op -> BracketRef () (dotSep (vs ++ ["_op"])) (string op)
337 | otherwise -> dotSep (vs ++ [op])
339 opDict = Map.fromList (infixOps ++ specialOps)
341 specialOp str func = ("Basic." ++ str, func)
342 infixOp str op = specialOp str (InfixExpr () op)
344 infixOps =
345 [ infixOp "+" OpAdd
346 , infixOp "-" OpSub
347 , infixOp "*" OpMul
348 , infixOp "/" OpDiv
349 , infixOp "&&" OpLAnd
350 , infixOp "||" OpLOr
351 ]
353 specialOps =
354 [ specialOp "^" $ \a b -> dotSep ["Math","pow"] `call` [a,b]
355 , specialOp "|>" $ flip (<|)
356 , specialOp "==" $ \a b -> dotSep ["_N","eq"] `call` [a,b]
357 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (dotSep ["_N","eq"] `call` [a,b])
358 , specialOp "<" $ cmp OpLT 0
359 , specialOp ">" $ cmp OpGT 0
360 , specialOp "<=" $ cmp OpLT 1
361 , specialOp ">=" $ cmp OpGT (-1)
362 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
363 ]
365 cmp op n a b = InfixExpr () op (dotSep ["_N","cmp"] `call` [a,b]) (IntLit () n)