git.iko.soy/elk
on 8c50652 help sign in
elk/compiler/Generate/JavaScript.hs
362 lines 13 kB history raw
1module Generate.JavaScript where
3import Control.Monad (liftM,(<=<),join,ap)
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)
11import Unique
12import Generate.Cases
13import SourceSyntax.Everything
14import SourceSyntax.Location
15import qualified Transform.SortDefinitions as SD
16import Language.ECMAScript3.Syntax
17import Language.ECMAScript3.PrettyPrint
18import Parse.Helpers (makeSafe, iParse)
20import Parse.Expression
22testExpr str = (prettyPrint . expression) `fmap` iParse expr "" str
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 (L span expr) =
60 case expr of
61 Var x -> ref x
62 Literal lit -> literal lit
63 Range lo hi -> dotSep ["_L","range"] `call` [expression lo, expression hi]
65 Access e x -> DotRef () (expression e) (var x)
66 Remove e x -> dotSep ["_N","remove"] `call` [ref x, expression e]
67 Insert e x v -> dotSep ["_N","insert"] `call` [ref x, expression v, expression e]
68{--
69 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
70 setField fs' `liftM` toJS' e
71 Record fs -> makeRecord fs
73addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
74setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
75 where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
76makeRecord kvs = record `liftM` collect kvs
77 where
78 combine r (k,v) = Map.insertWith (++) k v r
79 collect = liftM (List.foldl' combine Map.empty) . mapM prep
80 prep (k, e) =
81 do v <- toJS' e
82 return (k, [v])
83 fields fs =
84 brackets ("\n "++List.intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
85 hidden = fields . map (second jsList) .
86 filter (not . null . snd) . Map.toList . Map.map tail
87 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
88--}
89 Binop op e1 e2 -> binop span op e1 e2
91 Lambda p e@(L s _) -> fastFunc
92 where
93 fastFunc
94 | length args < 2 || length args > 9 =
95 foldr (==>) (expression body) (map (:[]) args)
96 | otherwise =
97 ref ("F" ++ show (length args)) <| (args ==> expression body)
99 (args, body) = foldr depattern ([], innerBody) (zip patterns [1..])
101 depattern (pattern,n) (args, body) =
102 case pattern of
103 PVar x -> (args ++ [x], body)
104 _ -> let arg = "arg" ++ show n
105 in (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
107 (patterns, innerBody) = collect [p] e
109 collect patterns lexpr@(L _ expr) =
110 case expr of
111 Lambda p e -> collect (p:patterns) e
112 _ -> (patterns, lexpr)
113--}
114 App e1 e2 ->
115 case args of
116 [arg] -> func <| arg
117 _ -> ref aN `call` (func:args)
118 where
119 aN = "A" ++ show (length args)
120 (func, args) = getArgs e1 [e2]
121 getArgs func args =
122 case func of
123 (L _ (App f arg)) -> getArgs f (arg : args)
124 _ -> (expression func, map expression args)
125{--
126 Let defs e -> jsLet $ SD.flattenLets defs e
127--}
129 MultiIf branches ->
130 case last branches of
131 (L _ (Var "otherwise"), e) -> ifs (init branches) (expression e)
132 _ -> ifs branches (dotSep ["_E","If"] `call` [ ref "$moduleName", string (show span) ])
133 where
134 ifs branches finally = foldr iff finally branches
135 iff (if', then') else' = CondExpr () (expression if') (expression then') else'
137 ExplicitList es ->
138 dotSep ["_J","toList"] <| ArrayLit () (map expression es)
140 Data name es ->
141 ObjectLit () (ctor : fields)
142 where
143 ctor = (prop "ctor", string (makeSafe name))
144 fields = zipWith (\n e -> (prop ("_" ++ show n), expression e)) [0..] es
145{--
146 Markdown doc -> return $ "Text.text('" ++ pad ++ md ++ pad ++ "')"
147 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
148 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
149--}
151{--
153globalAssign n e = "\n" ++ assign' n e ++ ";"
154assign' n e = n ++ " = " ++ e
156jsModule :: MetadataModule t v -> String
157jsModule modul =
158 run $ do
159 body <- toJS . fst . SD.flattenLets [] $ program modul
160 foreignImport <- mapM importEvent (foreignImports modul)
161 return $ concat [ setup ("Elm" : names modul)
162 , globalAssign ("Elm." ++ modName)
163 (jsFunc "elm" $ makeProgram body foreignImport) ]
164 where
165 modName = dotSep (names modul)
166 makeProgram body foreignImport =
167 concat [ setup ("elm" : names modul)
168 , "\nif (elm." ++ modName ++ ") return elm." ++ modName ++ ";"
169 , "\nvar " ++ usefulFuncs ++ ";"
170 , concatMap jsImport (imports modul)
171 , concat foreignImport
172 , assign "_op" "{}"
173 , body
174 , concatMap exportEvent $ foreignExports modul
175 , jsExports
176 ]
177 setup names = concatMap (\n -> globalAssign n $ n ++ " || {}") .
178 map dotSep . drop 2 . List.inits $ init names
179 usefulFuncs = commaSep (map (uncurry assign') (internalImports modName))
181 jsExports = ret (assign' ("elm." ++ modName) (brackets exs))
182 where
183 exs = indent . commaSep . concatMap pair $ "_op" : exports modul
184 pair x | isOp x = []
185 | otherwise = ["\n" ++ x ++ " : " ++ x]
188 importEvent (js,base,elm,_) =
189 do v <- toJS' base
190 return $ concat [ "\nvar " ++ elm ++ "=Signal.constant(" ++ v ++ ");"
191 , "\ndocument.addEventListener('", js
192 , "_' + elm.id, function(e) { elm.notify(", elm
193 , ".id, e.value); });" ]
195 exportEvent (js,elm,_) =
196 concat [ "\nA2( Signal.lift, function(v) { "
197 , "var e = document.createEvent('Event');"
198 , "e.initEvent('", js, "_' + elm.id, true, true);"
199 , "e.value = v;"
200 , "document.dispatchEvent(e); return v; }, ", elm, ");" ]
202jsImport (modul, method) =
203 concat $ zipWith3 (\s n v -> s ++ assign' n v ++ ";") starters subnames values
204 where
205 starters = "\nvar " : repeat "\n"
206 values = map (\name -> name ++ " || {}") (init subnames) ++
207 ["Elm." ++ modul ++ parens "elm"]
208 subnames = map dotSep . tail . List.inits $ split modul
210 split names = case go [] names of
211 (name, []) -> [name]
212 (name, ns) -> name : split ns
213 go name str = case str of
214 '.':rest -> (reverse name, rest)
215 c:rest -> go (c:name) rest
216 [] -> (reverse name, [])
219class ToJS a where
220 toJS :: a -> Unique String
223instance ToJS (Def t v) where
225 -- TODO: Make this handle patterns besides plain variables
226 toJS (Def (PVar x) e)
227 | isOp x = globalAssign ("_op['" ++ x ++ "']") `liftM` toJS' e
228 | otherwise = assign x `liftM` toJS' e
230 toJS (Def pattern e@(L s _)) =
231 do n <- guid
232 let x = "_" ++ show n
233 var = L s . Var
234 toDef y = Def (PVar y) (L s $ Case (var x) [(pattern, var y)])
235 stmt <- assign x `liftM` toJS' e
236 vars <- toJS . map toDef . Set.toList $ SD.boundVars pattern
237 return (stmt ++ vars)
239 toJS (TypeAnnotation _ _) = return ""
242instance ToJS a => ToJS [a] where
243 toJS xs = concat `liftM` mapM toJS xs
245toJS' :: LExpr t v -> Unique String
246toJS' (L span expr) =
247 case expr of
248 Case e cases -> caseToJS span e cases
249 _ -> toJS expr
253formatMarkdown = concatMap f
254 where f '\'' = "\\'"
255 f '\n' = "\\n"
256 f '"' = "\""
257 f c = [c]
259jsLet (defs,e') = do ds <- mapM toJS defs
260 e <- toJS' e'
261 return $ jsFunc "" (concat ds ++ ret e) ++ "()"
263caseToJS span e ps = do
264 (tempVar,match) <- caseToMatch ps
265 e' <- toJS' e
266 let (match',stmt) = case e of
267 L _ (Var x) -> (matchSubst [(tempVar,x)] match, "")
268 _ -> (match, assign tempVar e')
269 matches <- matchToJS span match'
270 return $ jsFunc "" (stmt ++ matches) ++ "()"
272matchToJS span match =
273 case match of
274 Match name clauses def ->
275 do cases <- concat `liftM` mapM (clauseToJS span name) clauses
276 finally <- matchToJS span def
277 let isLiteral p = case p of
278 Clause (Right _) _ _ -> True
279 _ -> False
280 access = if any isLiteral clauses then "" else ".ctor"
281 return $ concat [ "\nswitch (", name, access, ") {"
282 , indent cases, "\n}", finally ]
283 Fail -> return ("_E.Case" ++ parens ("$moduleName," ++ quoted (show span)))
284 Break -> return "break;"
285 Other e -> ret `liftM` toJS' e
286 Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)
287 where
288 dropEnd acc [] = acc
289 dropEnd acc (m:ms) =
290 case m of
291 Other _ -> acc ++ [m]
292 _ -> dropEnd (acc ++ [m]) ms
294clauseToJS span var (Clause value vars e) = do
295 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
296 s <- matchToJS span $ matchSubst (zip vars vars') e
297 pattern <- case value of
298 Right (Boolean True) -> return "true"
299 Right (Boolean False) -> return "false"
300 Right lit -> toJS lit
301 Left name -> return . quoted $ case List.elemIndices '.' name of
302 [] -> name
303 is -> drop (last is + 1) name
304 return $ concat [ "\ncase ", pattern, ":", indent s ]
306jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
307jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ")" ++ op)
309--}
310binop span op e1 e2 =
311 case op of
312 "Basics.." -> ["$"] ==> foldr (<|) (ref "$") (map expression (e1 : collect [] e2))
313 "Basics.<|" -> foldr (<|) (expression e2) (map expression (collect [] e1))
314 "::" -> expression (L span (Data "::" [e1,e2]))
315 "List.++" -> dotSep ["_L","append"] `call` [js1, js2]
316 _ -> case Map.lookup op opDict of
317 Just f -> f js1 js2
318 Nothing -> ref "A2" `call` [ func [] op, js1, js2 ]
319 where
320 collect es e =
321 case e of
322 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
323 _ -> es ++ [e]
325 js1 = expression e1
326 js2 = expression e2
328 func vs str =
329 case break (=='.') str of
330 (x,'.':rest) -> func (vs ++ [x]) rest
331 (op,[])
332 | isOp op -> BracketRef () (dotSep (vs ++ ["_op"])) (string op)
333 | otherwise -> dotSep (vs ++ [op])
335 opDict = Map.fromList (infixOps ++ specialOps)
337 specialOp str func = ("Basic." ++ str, func)
338 infixOp str op = specialOp str (InfixExpr () op)
340 infixOps =
341 [ infixOp "+" OpAdd
342 , infixOp "-" OpSub
343 , infixOp "*" OpMul
344 , infixOp "/" OpDiv
345 , infixOp "&&" OpLAnd
346 , infixOp "||" OpLOr
347 ]
349 specialOps =
350 [ specialOp "^" $ \a b -> dotSep ["Math","pow"] `call` [a,b]
351 , specialOp "|>" $ flip (<|)
352 , specialOp "==" $ \a b -> dotSep ["_N","eq"] `call` [a,b]
353 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (dotSep ["_N","eq"] `call` [a,b])
354 , specialOp "<" $ cmp OpLT 0
355 , specialOp ">" $ cmp OpGT 0
356 , specialOp "<=" $ cmp OpLT 1
357 , specialOp ">=" $ cmp OpGT (-1)
358 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
359 ]
361 cmp op n a b = InfixExpr () op (dotSep ["_N","cmp"] `call` [a,b]) (IntLit () n)
362--}