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