git.iko.soy/elk
on f0b38ae help sign in
elk/compiler/Generate/JavaScript.hs
417 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 = 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 doc _ -> return $ obj "Text.text" <| string (pad ++ md ++ pad)
190 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
191 md = Pan.writeHtmlString Pan.def doc
193definition :: Def () () -> State Int [Statement ()]
194definition def =
195 case def of
196 TypeAnnotation _ _ -> return []
198 Def pattern expr@(L span _) -> do
199 expr' <- expression expr
200 let assign x = varDecl x expr'
201 case pattern of
202 PVar x
203 | isOp x ->
204 let op = LBracket () (ref "_op") (string x) in
205 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
206 | otherwise ->
207 return [ VarDeclStmt () [ assign x ] ]
209 PRecord fields ->
210 let setField f = varDecl f (dotSep ["$",f]) in
211 return [ VarDeclStmt () (assign "$" : map setField fields) ]
213 PData name patterns | vars /= Nothing ->
214 case vars of
215 Just vs -> return [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]
216 where
217 vars = getVars patterns
218 getVars patterns =
219 case patterns of
220 PVar x : rest -> (x:) `fmap` getVars rest
221 [] -> Just []
222 _ -> Nothing
224 decl x n = varDecl x (dotSep ["$","_" ++ show n])
225 setup vars
226 | isTuple name = assign "$" : vars
227 | otherwise = safeAssign : vars
229 safeAssign = varDecl "$" (CondExpr () if' expr' exception)
230 if' = InfixExpr () OpStrictEq (obj "$.ctor") (string name)
231 exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
233 _ ->
234 do defs' <- concat <$> mapM toDef vars
235 return (VarDeclStmt () [assign "$"] : defs')
236 where
237 vars = Set.toList $ SD.boundVars pattern
238 mkVar = L span . Var
239 toDef y = definition $
240 Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])
242match :: (Show a) => a -> Case.Match () () -> State Int [Statement ()]
243match span mtch =
244 case mtch of
245 Case.Match name clauses mtch' ->
246 do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
247 mtch'' <- match span mtch'
248 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
249 where
250 isLiteral p = case p of
251 Case.Clause (Right _) _ _ -> True
252 _ -> False
253 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
254 format isChars e
255 | or isChars = InfixExpr () OpAdd e (string "")
256 | otherwise = e
258 Case.Fail ->
259 return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
261 Case.Break -> return [BreakStmt () Nothing]
262 Case.Other e ->
263 do e' <- expression e
264 return [ ReturnStmt () (Just e') ]
265 Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
266 where
267 dropEnd acc [] = acc
268 dropEnd acc (m:ms) =
269 case m of
270 Case.Other _ -> acc ++ [m]
271 _ -> dropEnd (acc ++ [m]) ms
273clause span variable (Case.Clause value vars mtch) =
274 (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
275 where
276 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
277 (isChar, pattern) =
278 case value of
279 Right (Chr c) -> (True, string [c])
280 _ -> (,) False $ case value of
281 Right (Boolean b) -> BoolLit () b
282 Right lit -> literal lit
283 Left name -> string $ case List.elemIndices '.' name of
284 [] -> name
285 is -> drop (last is + 1) name
288jsModule :: MetadataModule () () -> String
289jsModule modul =
290 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
291 [ assign ("Elm" : names modul ++ ["make"]) (function ["elm"] programStmts) ]
292 where
293 thisModule = dotSep ("elm" : names modul ++ ["values"])
294 programStmts =
295 concat [ setup (Just "elm") (names modul ++ ["values"])
296 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
297 , [ internalImports (List.intercalate "." (names modul)) ]
298 , concatMap jsImport (imports modul)
299 , concatMap importEvent (foreignImports modul)
300 , [ assign ["_op"] (ObjectLit () []) ]
301 , concat $ evalState (mapM definition . fst . SD.flattenLets [] $ program modul) 0
302 , map exportEvent $ foreignExports modul
303 , [ jsExports ]
304 , [ ReturnStmt () (Just thisModule) ]
305 ]
307 jsExports = assign ("elm" : names modul ++ ["values"]) (ObjectLit () exs)
308 where
309 exs = map entry . filter (not . isOp) $ "_op" : exports modul
310 entry x = (PropId () (var x), ref x)
312 assign path expr =
313 case path of
314 [x] -> VarDeclStmt () [ varDecl x expr ]
315 _ -> ExprStmt () $
316 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
318 jsImport (modul,_) = setup Nothing path ++ [ include ]
319 where
320 path = split modul
321 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "elm"
323 setup namespace path = map create paths
324 where
325 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
326 paths = case namespace of
327 Nothing -> tail . init $ List.inits path
328 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
330 addId js = InfixExpr () OpAdd (string (js++"_")) (obj "elm.id")
332 importEvent (js,base,elm,_) =
333 [ VarDeclStmt () [ varDecl elm $ obj "Signal.constant" <| evalState (expression base) 0 ]
334 , ExprStmt () $
335 obj "document.addEventListener" `call`
336 [ addId js
337 , function ["e"]
338 [ ExprStmt () $ obj "elm.notify" `call` [dotSep [elm,"id"], obj "e.value"] ]
339 ]
340 ]
342 exportEvent (js,elm,_) =
343 ExprStmt () $
344 ref "A2" `call`
345 [ obj "Signal.lift"
346 , function ["v"]
347 [ VarDeclStmt () [varDecl "e" $ obj "document.createEvent" <| string "Event"]
348 , ExprStmt () $
349 obj "e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]
350 , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "e") "value") (ref "v")
351 , ExprStmt () $ obj "document.dispatchEvent" <| ref "e"
352 , ReturnStmt () (Just $ ref "v")
353 ]
354 , ref elm ]
356binop span op e1 e2 =
357 case op of
358 "Basics.." ->
359 do es <- mapM expression (e1 : collect [] e2)
360 return $ ["$"] ==> foldr (<|) (ref "$") es
361 "Basics.<|" ->
362 do e2' <- expression e2
363 es <- mapM expression (collect [] e1)
364 return $ foldr (<|) e2' es
365 "List.++" ->
366 do e1' <- expression e1
367 e2' <- expression e2
368 return $ obj "_L.append" `call` [e1', e2']
369 "::" -> expression (L span (Data "::" [e1,e2]))
370 _ ->
371 do e1' <- expression e1
372 e2' <- expression e2
373 return $ case Map.lookup op opDict of
374 Just f -> f e1' e2'
375 Nothing -> ref "A2" `call` [ func, e1', e2' ]
376 where
377 collect es e =
378 case e of
379 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
380 _ -> es ++ [e]
382 js1 = expression e1
383 js2 = expression e2
385 func | isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
386 | otherwise = dotSep parts
387 where
388 parts = split op
389 operator = last parts
391 opDict = Map.fromList (infixOps ++ specialOps)
393 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
394 infixOp str op = specialOp str (InfixExpr () op)
396 infixOps = concat
397 [ infixOp "+" OpAdd
398 , infixOp "-" OpSub
399 , infixOp "*" OpMul
400 , infixOp "/" OpDiv
401 , infixOp "&&" OpLAnd
402 , infixOp "||" OpLOr
403 ]
405 specialOps = concat
406 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
407 , specialOp "|>" $ flip (<|)
408 , specialOp "==" $ \a b -> obj "_N.eq" `call` [a,b]
409 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_N.eq" `call` [a,b])
410 , specialOp "<" $ cmp OpLT 0
411 , specialOp ">" $ cmp OpGT 0
412 , specialOp "<=" $ cmp OpLT 1
413 , specialOp ">=" $ cmp OpGT (-1)
414 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
415 ]
417 cmp op n a b = InfixExpr () op (obj "_N.cmp" `call` [a,b]) (IntLit () n)