git.iko.soy/elk
on 854eeaa help sign in
elk/compiler/Generate/JavaScript.hs
416 lines 16 kB history raw
1module Generate.JavaScript where
3import Control.Arrow (first,(***))
4import Control.Applicative ((<$>),(<*>))
5import Control.Monad.State
6import qualified Data.List as List
7import qualified Data.Map as Map
8import qualified Data.Set as Set
10import qualified Generate.Cases as Case
11import qualified Generate.Markdown as MD
12import SourceSyntax.Everything
13import SourceSyntax.Location
14import qualified Transform.SortDefinitions as SD
15import Language.ECMAScript3.Syntax
16import Language.ECMAScript3.PrettyPrint
17import Parse.Helpers (jsReserveds)
19makeSafe :: String -> String
20makeSafe = List.intercalate "." . map dereserve . split . deprime
21 where
22 deprime = map (\c -> if c == '\'' then '$' else c)
23 dereserve x = case Set.member x jsReserveds of
24 False -> x
25 True -> "$" ++ x
27split = go []
28 where
29 go vars str =
30 case break (=='.') str of
31 (x,'.':rest) | isOp x -> vars ++ [x ++ '.' : rest]
32 | otherwise -> go (vars ++ [x]) rest
33 (x,[]) -> vars ++ [x]
35var name = Id () (makeSafe name)
36ref name = VarRef () (var name)
37prop name = PropId () (var name)
38f <| x = CallExpr () f [x]
39args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ]
40function args stmts = FuncExpr () Nothing (map var args) stmts
41call = CallExpr ()
42string = StringLit ()
44dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)
45obj = dotSep . split
47varDecl x expr =
48 VarDecl () (var x) (Just expr)
50include alias moduleName =
51 varDecl alias (obj (moduleName ++ ".make") <| ref "elm")
53internalImports name =
54 VarDeclStmt ()
55 [ varDecl "N" (obj "Elm.Native")
56 , include "_N" "N.Utils"
57 , include "_L" "N.List"
58 , include "_E" "N.Error"
59 , include "_J" "N.JavaScript"
60 , varDecl "$moduleName" (string name)
61 ]
63literal lit =
64 case lit of
65 Chr c -> obj "_N.chr" <| string [c]
66 Str s -> string s
67 IntNum n -> IntLit () n
68 FloatNum n -> NumLit () n
69 Boolean b -> BoolLit () b
71expression :: LExpr () () -> State Int (Expression ())
72expression (L span expr) =
73 case expr of
74 Var x -> return $ ref x
75 Literal lit -> return $ literal lit
77 Range lo hi ->
78 do lo' <- expression lo
79 hi' <- expression hi
80 return $ obj "_L.range" `call` [lo',hi']
82 Access e x ->
83 do e' <- expression e
84 return $ DotRef () e' (var x)
86 Remove e x ->
87 do e' <- expression e
88 return $ obj "_N.remove" `call` [string x, e']
90 Insert e x v ->
91 do v' <- expression v
92 e' <- expression e
93 return $ obj "_N.insert" `call` [string x, v', e']
95 Modify e fs ->
96 do e' <- expression e
97 fs' <- forM fs $ \(f,v) -> do
98 v' <- expression v
99 return $ ArrayLit () [string f, v']
100 return $ obj "_N.replace" `call` [ArrayLit () fs', e']
102 Record fields ->
103 do fields' <- forM fields $ \(f,e) -> do
104 (,) f <$> expression e
105 let fieldMap = List.foldl' combine Map.empty fields'
106 return $ ObjectLit () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
107 where
108 combine r (k,v) = Map.insertWith (++) k [v] r
109 prop = PropId () . var
110 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
111 Map.toList . Map.filter (not . null) $ Map.map tail fs
112 visible fs = map (first prop) . Map.toList $ Map.map head fs
114 Binop op e1 e2 -> binop span op e1 e2
116 Lambda p e@(L s _) ->
117 do body' <- expression body
118 return $ case length args < 2 || length args > 9 of
119 True -> foldr (==>) body' (map (:[]) args)
120 False -> ref ("F" ++ show (length args)) <| (args ==> body')
121 where
122 (args, body) = foldr depattern ([], innerBody) (zip patterns [0..])
124 depattern (pattern,n) (args, body) =
125 case pattern of
126 PVar x -> (args ++ [x], body)
127 _ -> let arg = "arg" ++ show n
128 in (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
130 (patterns, innerBody) = collect [p] e
132 collect patterns lexpr@(L _ expr) =
133 case expr of
134 Lambda p e -> collect (p:patterns) e
135 _ -> (patterns, lexpr)
137 App e1 e2 ->
138 do func' <- expression func
139 args' <- mapM expression args
140 return $ case args' of
141 [arg] -> func' <| arg
142 _ | length args' <= 9 -> ref aN `call` (func':args')
143 | otherwise -> foldl1 (<|) (func':args')
144 where
145 aN = "A" ++ show (length args)
146 (func, args) = getArgs e1 [e2]
147 getArgs func args =
148 case func of
149 (L _ (App f arg)) -> getArgs f (arg : args)
150 _ -> (func, args)
152 Let defs e ->
153 do let (defs',e') = SD.flattenLets defs e
154 stmts <- concat <$> mapM definition defs'
155 exp <- expression e'
156 return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []
158 MultiIf branches ->
159 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
160 return $ case last branches of
161 (L _ (Var "Basics.otherwise"), e) -> ifs (init branches') (snd (last branches'))
162 _ -> ifs branches'
163 (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
164 where
165 ifs branches finally = foldr iff finally branches
166 iff (if', then') else' = CondExpr () if' then' else'
168 Case e cases ->
169 do (tempVar,initialMatch) <- Case.toMatch cases
170 (revisedMatch, stmt) <-
171 case e of
172 L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, [])
173 _ -> do e' <- expression e
174 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
175 match' <- match span revisedMatch
176 return (function [] (stmt ++ match') `call` [])
178 ExplicitList es ->
179 do es' <- mapM expression es
180 return $ obj "_J.toList" <| ArrayLit () es'
182 Data name es ->
183 do es' <- mapM expression es
184 return $ ObjectLit () (ctor : fields es')
185 where
186 ctor = (prop "ctor", string (makeSafe name))
187 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
189 Markdown md _ -> return $ obj "Text.text" <| string (pad ++ MD.toHtml md ++ pad)
190 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
192definition :: Def () () -> State Int [Statement ()]
193definition def =
194 case def of
195 TypeAnnotation _ _ -> return []
197 Def pattern expr@(L span _) -> do
198 expr' <- expression expr
199 let assign x = varDecl x expr'
200 case pattern of
201 PVar x
202 | isOp x ->
203 let op = LBracket () (ref "_op") (string x) in
204 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
205 | otherwise ->
206 return [ VarDeclStmt () [ assign x ] ]
208 PRecord fields ->
209 let setField f = varDecl f (dotSep ["$",f]) in
210 return [ VarDeclStmt () (assign "$" : map setField fields) ]
212 PData name patterns | vars /= Nothing ->
213 case vars of
214 Just vs -> return [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]
215 where
216 vars = getVars patterns
217 getVars patterns =
218 case patterns of
219 PVar x : rest -> (x:) `fmap` getVars rest
220 [] -> Just []
221 _ -> Nothing
223 decl x n = varDecl x (dotSep ["$","_" ++ show n])
224 setup vars
225 | isTuple name = assign "$" : vars
226 | otherwise = safeAssign : vars
228 safeAssign = varDecl "$" (CondExpr () if' expr' exception)
229 if' = InfixExpr () OpStrictEq (obj "$.ctor") (string name)
230 exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
232 _ ->
233 do defs' <- concat <$> mapM toDef vars
234 return (VarDeclStmt () [assign "$"] : defs')
235 where
236 vars = Set.toList $ SD.boundVars pattern
237 mkVar = L span . Var
238 toDef y = definition $
239 Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])
241match :: (Show a) => a -> Case.Match () () -> State Int [Statement ()]
242match span mtch =
243 case mtch of
244 Case.Match name clauses mtch' ->
245 do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
246 mtch'' <- match span mtch'
247 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
248 where
249 isLiteral p = case p of
250 Case.Clause (Right _) _ _ -> True
251 _ -> False
252 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
253 format isChars e
254 | or isChars = InfixExpr () OpAdd e (string "")
255 | otherwise = e
257 Case.Fail ->
258 return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
260 Case.Break -> return [BreakStmt () Nothing]
261 Case.Other e ->
262 do e' <- expression e
263 return [ ReturnStmt () (Just e') ]
264 Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
265 where
266 dropEnd acc [] = acc
267 dropEnd acc (m:ms) =
268 case m of
269 Case.Other _ -> acc ++ [m]
270 _ -> dropEnd (acc ++ [m]) ms
272clause span variable (Case.Clause value vars mtch) =
273 (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
274 where
275 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
276 (isChar, pattern) =
277 case value of
278 Right (Chr c) -> (True, string [c])
279 _ -> (,) False $ case value of
280 Right (Boolean b) -> BoolLit () b
281 Right lit -> literal lit
282 Left name -> string $ case List.elemIndices '.' name of
283 [] -> name
284 is -> drop (last is + 1) name
287jsModule :: MetadataModule () () -> String
288jsModule modul =
289 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
290 [ assign ("Elm" : names modul ++ ["make"]) (function ["elm"] programStmts) ]
291 where
292 thisModule = dotSep ("elm" : names modul ++ ["values"])
293 programStmts =
294 concat [ setup (Just "elm") (names modul ++ ["values"])
295 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
296 , [ internalImports (List.intercalate "." (names modul)) ]
297 , concatMap jsImport (imports modul)
298 , concatMap importEvent (foreignImports modul)
299 , [ assign ["_op"] (ObjectLit () []) ]
300 , concat $ evalState (mapM definition . fst . SD.flattenLets [] $ program modul) 0
301 , map exportEvent $ foreignExports modul
302 , [ jsExports ]
303 , [ ReturnStmt () (Just thisModule) ]
304 ]
306 jsExports = assign ("elm" : names modul ++ ["values"]) (ObjectLit () exs)
307 where
308 exs = map entry . filter (not . isOp) $ "_op" : exports modul
309 entry x = (PropId () (var x), ref x)
311 assign path expr =
312 case path of
313 [x] -> VarDeclStmt () [ varDecl x expr ]
314 _ -> ExprStmt () $
315 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
317 jsImport (modul,_) = setup Nothing path ++ [ include ]
318 where
319 path = split modul
320 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "elm"
322 setup namespace path = map create paths
323 where
324 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
325 paths = case namespace of
326 Nothing -> tail . init $ List.inits path
327 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
329 addId js = InfixExpr () OpAdd (string (js++"_")) (obj "elm.id")
331 importEvent (js,base,elm,_) =
332 [ VarDeclStmt () [ varDecl elm $ obj "Signal.constant" <| evalState (expression base) 0 ]
333 , ExprStmt () $
334 obj "document.addEventListener" `call`
335 [ addId js
336 , function ["e"]
337 [ ExprStmt () $ obj "elm.notify" `call` [dotSep [elm,"id"], obj "e.value"] ]
338 ]
339 ]
341 exportEvent (js,elm,_) =
342 ExprStmt () $
343 ref "A2" `call`
344 [ obj "Signal.lift"
345 , function ["v"]
346 [ VarDeclStmt () [varDecl "e" $ obj "document.createEvent" <| string "Event"]
347 , ExprStmt () $
348 obj "e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]
349 , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "e") "value") (ref "v")
350 , ExprStmt () $ obj "document.dispatchEvent" <| ref "e"
351 , ReturnStmt () (Just $ ref "v")
352 ]
353 , ref elm ]
355binop span op e1 e2 =
356 case op of
357 "Basics.." ->
358 do es <- mapM expression (e1 : collect [] e2)
359 return $ ["$"] ==> foldr (<|) (ref "$") es
360 "Basics.<|" ->
361 do e2' <- expression e2
362 es <- mapM expression (collect [] e1)
363 return $ foldr (<|) e2' es
364 "List.++" ->
365 do e1' <- expression e1
366 e2' <- expression e2
367 return $ obj "_L.append" `call` [e1', e2']
368 "::" -> expression (L span (Data "::" [e1,e2]))
369 _ ->
370 do e1' <- expression e1
371 e2' <- expression e2
372 return $ case Map.lookup op opDict of
373 Just f -> f e1' e2'
374 Nothing -> ref "A2" `call` [ func, e1', e2' ]
375 where
376 collect es e =
377 case e of
378 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
379 _ -> es ++ [e]
381 js1 = expression e1
382 js2 = expression e2
384 func | isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
385 | otherwise = dotSep parts
386 where
387 parts = split op
388 operator = last parts
390 opDict = Map.fromList (infixOps ++ specialOps)
392 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
393 infixOp str op = specialOp str (InfixExpr () op)
395 infixOps = concat
396 [ infixOp "+" OpAdd
397 , infixOp "-" OpSub
398 , infixOp "*" OpMul
399 , infixOp "/" OpDiv
400 , infixOp "&&" OpLAnd
401 , infixOp "||" OpLOr
402 ]
404 specialOps = concat
405 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
406 , specialOp "|>" $ flip (<|)
407 , specialOp "==" $ \a b -> obj "_N.eq" `call` [a,b]
408 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_N.eq" `call` [a,b])
409 , specialOp "<" $ cmp OpLT 0
410 , specialOp ">" $ cmp OpGT 0
411 , specialOp "<=" $ cmp OpLT 1
412 , specialOp ">=" $ cmp OpGT (-1)
413 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
414 ]
416 cmp op n a b = InfixExpr () op (obj "_N.cmp" `call` [a,b]) (IntLit () n)