git.iko.soy/elk
on d0df030 help sign in
elk/compiler/Generate/JavaScript.hs
407 lines 15 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 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 (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 <| 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 "_str" (obj "_J.toString")
61 , varDecl "$moduleName" (string name)
62 ]
64literal lit =
65 case lit of
66 Chr c -> string [c]
67 Str s -> ref "_str" <| string s
68 IntNum n -> IntLit () n
69 FloatNum n -> NumLit () n
70 Boolean b -> BoolLit () b
72expression :: LExpr () () -> State Int (Expression ())
73expression (L span expr) =
74 case expr of
75 Var x -> return $ ref x
76 Literal lit -> return $ literal lit
78 Range lo hi ->
79 do lo' <- expression lo
80 hi' <- expression hi
81 return $ obj "_L.range" `call` [lo',hi']
83 Access e x ->
84 do e' <- expression e
85 return $ DotRef () e' (var x)
87 Remove e x ->
88 do e' <- expression e
89 return $ obj "_N.remove" `call` [string x, e']
91 Insert e x v ->
92 do v' <- expression v
93 e' <- expression e
94 return $ obj "_N.insert" `call` [string x, v', e']
96 Modify e fs ->
97 do e' <- expression e
98 fs' <- forM fs $ \(f,v) -> do
99 v' <- expression v
100 return $ ArrayLit () [string f, v']
101 return $ obj "_N.replace" `call` [ArrayLit () fs', e']
103 Record fields ->
104 do fields' <- forM fields $ \(f,e) -> do
105 (,) f <$> expression e
106 let fieldMap = List.foldl' combine Map.empty fields'
107 return $ ObjectLit () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
108 where
109 combine r (k,v) = Map.insertWith (++) k [v] r
110 prop = PropId () . var
111 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
112 Map.toList . Map.filter (not . null) $ Map.map tail fs
113 visible fs = map (first prop) . Map.toList $ Map.map head fs
115 Binop op e1 e2 -> binop span op e1 e2
117 Lambda p e@(L s _) ->
118 do body' <- expression body
119 return $ case length args < 2 || length args > 9 of
120 True -> foldr (==>) body' (map (:[]) args)
121 False -> ref ("F" ++ show (length args)) <| (args ==> body')
122 where
123 (args, body) = foldr depattern ([], innerBody) (zip patterns [0..])
125 depattern (pattern,n) (args, body) =
126 case pattern of
127 PVar x -> (args ++ [x], body)
128 _ -> let arg = "arg" ++ show n
129 in (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
131 (patterns, innerBody) = collect [p] e
133 collect patterns lexpr@(L _ expr) =
134 case expr of
135 Lambda p e -> collect (p:patterns) e
136 _ -> (patterns, lexpr)
138 App e1 e2 ->
139 do func' <- expression func
140 args' <- mapM expression args
141 return $ case args' of
142 [arg] -> func' <| arg
143 _ | length args' <= 9 -> ref aN `call` (func':args')
144 | otherwise -> foldl1 (<|) (func':args')
145 where
146 aN = "A" ++ show (length args)
147 (func, args) = getArgs e1 [e2]
148 getArgs func args =
149 case func of
150 (L _ (App f arg)) -> getArgs f (arg : args)
151 _ -> (func, args)
153 Let defs e ->
154 do let (defs',e') = SD.flattenLets defs e
155 stmts <- concat <$> mapM definition defs'
156 exp <- expression e'
157 return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []
159 MultiIf branches ->
160 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
161 return $ case last branches of
162 (L _ (Var "Basics.otherwise"), e) -> ifs (init branches') (snd (last branches'))
163 _ -> ifs branches'
164 (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
165 where
166 ifs branches finally = foldr iff finally branches
167 iff (if', then') else' = CondExpr () if' then' else'
169 Case e cases ->
170 do (tempVar,initialMatch) <- caseToMatch cases
171 (revisedMatch, stmt) <-
172 case e of
173 L _ (Var x) -> return (matchSubst [(tempVar,x)] initialMatch, [])
174 _ -> do e' <- expression e
175 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
176 match' <- match span revisedMatch
177 return (function [] (stmt ++ match') `call` [])
179 ExplicitList es ->
180 do es' <- mapM expression es
181 return $ obj "_J.toList" <| ArrayLit () es'
183 Data name es ->
184 do es' <- mapM expression es
185 return $ ObjectLit () (ctor : fields es')
186 where
187 ctor = (prop "ctor", string (makeSafe name))
188 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
190 Markdown doc _ -> return $ obj "Text.text" <| string (pad ++ md ++ pad)
191 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
192 md = Pan.writeHtmlString Pan.def doc
194definition :: Def () () -> State Int [Statement ()]
195definition def =
196 case def of
197 TypeAnnotation _ _ -> return []
199 Def pattern expr@(L span _) -> do
200 expr' <- expression expr
201 let assign x = varDecl x expr'
202 case pattern of
203 PVar x
204 | isOp x ->
205 let op = LBracket () (ref "_op") (string x) in
206 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
207 | otherwise ->
208 return [ VarDeclStmt () [ assign x ] ]
210 PRecord fields ->
211 let setField f = varDecl f (dotSep ["$",f]) in
212 return [ VarDeclStmt () (assign "$" : map setField fields) ]
214 PData name patterns | vars /= Nothing ->
215 case vars of
216 Just vs -> return [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]
217 where
218 vars = getVars patterns
219 getVars patterns =
220 case patterns of
221 PVar x : rest -> (x:) `fmap` getVars rest
222 [] -> Just []
223 _ -> Nothing
225 decl x n = varDecl x (dotSep ["$","_" ++ show n])
226 setup vars
227 | isTuple name = assign "$" : vars
228 | otherwise = safeAssign : vars
230 safeAssign = varDecl "$" (CondExpr () if' expr' exception)
231 if' = InfixExpr () OpStrictEq (obj "$.ctor") (string name)
232 exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
234 _ ->
235 do defs' <- concat <$> mapM toDef vars
236 return (VarDeclStmt () [assign "$"] : defs')
237 where
238 vars = Set.toList $ SD.boundVars pattern
239 mkVar = L span . Var
240 toDef y = definition $
241 Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])
243match span mtch =
244 case mtch of
245 Match name clauses mtch' ->
246 do clauses' <- mapM (clause span name) clauses
247 mtch'' <- match span mtch'
248 return (SwitchStmt () (access name) clauses' : mtch'')
249 where
250 isLiteral p = case p of
251 Clause (Right _) _ _ -> True
252 _ -> False
253 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
255 Fail -> return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
256 Break -> return []
257 Other e ->
258 do e' <- expression e
259 return [ ReturnStmt () (Just e') ]
260 Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
261 where
262 dropEnd acc [] = acc
263 dropEnd acc (m:ms) =
264 case m of
265 Other _ -> acc ++ [m]
266 _ -> dropEnd (acc ++ [m]) ms
268clause span variable (Clause value vars mtch) =
269 CaseClause () pattern <$> match span (matchSubst (zip vars vars') mtch)
270 where
271 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
272 pattern = case value of
273 Right (Boolean b) -> BoolLit () b
274 Right lit -> literal lit
275 Left name -> string $ case List.elemIndices '.' name of
276 [] -> name
277 is -> drop (last is + 1) name
280jsModule :: MetadataModule () () -> String
281jsModule modul = show . prettyPrint $ setup (Just "Elm") (names modul) ++
282 [ assign ("Elm" : names modul) (function ["elm"] programStmts) ]
283 where
284 thisModule = dotSep ("elm" : names modul)
285 programStmts =
286 concat [ setup (Just "elm") (names modul)
287 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
288 , [ internalImports (List.intercalate "." (names modul)) ]
289 , concatMap jsImport (imports modul)
290 , concatMap importEvent (foreignImports modul)
291 , [ assign ["_op"] (ObjectLit () []) ]
292 , concat $ evalState (mapM definition . fst . SD.flattenLets [] $ program modul) 0
293 , map exportEvent $ foreignExports modul
294 , [ jsExports ]
295 , [ ReturnStmt () (Just thisModule) ]
296 ]
298 jsExports = assign ("elm" : names modul) (ObjectLit () exs)
299 where
300 exs = map entry . filter (not . isOp) $ "_op" : exports modul
301 entry x = (PropId () (var x), ref x)
303 assign path expr =
304 case path of
305 [x] -> VarDeclStmt () [ varDecl x expr ]
306 _ -> ExprStmt () $
307 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
309 jsImport (modul,_) = setup Nothing path ++ [ assign path (dotSep ("Elm" : path) <| ref "elm") ]
310 where
311 path = split modul
313 setup namespace path = map create paths
314 where
315 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
316 paths = case namespace of
317 Nothing -> tail . init $ List.inits path
318 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
320 addId js = InfixExpr () OpAdd (string (js++"_")) (obj "elm.id")
322 importEvent (js,base,elm,_) =
323 [ VarDeclStmt () [ varDecl elm $ obj "Signal.constant" <| evalState (expression base) 0 ]
324 , ExprStmt () $
325 obj "document.addEventListener" `call`
326 [ addId js
327 , function ["e"]
328 [ ExprStmt () $ obj "elm.notify" `call` [dotSep [elm,"id"], obj "e.value"] ]
329 ]
330 ]
332 exportEvent (js,elm,_) =
333 ExprStmt () $
334 ref "A2" `call`
335 [ obj "Signal.lift"
336 , function ["v"]
337 [ VarDeclStmt () [varDecl "e" $ obj "document.createEvent" <| string "Event"]
338 , ExprStmt () $
339 obj "e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]
340 , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "e") "value") (ref "v")
341 , ExprStmt () $ obj "document.dispatchEvent" <| ref "e"
342 , ReturnStmt () (Just $ ref "v")
343 ]
344 , ref elm ]
346binop span op e1 e2 =
347 case op of
348 "Basics.." ->
349 do es <- mapM expression (e1 : collect [] e2)
350 return $ ["$"] ==> foldr (<|) (ref "$") es
351 "Basics.<|" ->
352 do e2' <- expression e2
353 es <- mapM expression (collect [] e1)
354 return $ foldr (<|) e2' es
355 "List.++" ->
356 do e1' <- expression e1
357 e2' <- expression e2
358 return $ obj "_L.append" `call` [e1', e2']
359 "::" -> expression (L span (Data "::" [e1,e2]))
360 _ ->
361 do e1' <- expression e1
362 e2' <- expression e2
363 return $ case Map.lookup op opDict of
364 Just f -> f e1' e2'
365 Nothing -> ref "A2" `call` [ func, e1', e2' ]
366 where
367 collect es e =
368 case e of
369 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
370 _ -> es ++ [e]
372 js1 = expression e1
373 js2 = expression e2
375 func | isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
376 | otherwise = dotSep parts
377 where
378 parts = split op
379 operator = last parts
381 opDict = Map.fromList (infixOps ++ specialOps)
383 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
384 infixOp str op = specialOp str (InfixExpr () op)
386 infixOps = concat
387 [ infixOp "+" OpAdd
388 , infixOp "-" OpSub
389 , infixOp "*" OpMul
390 , infixOp "/" OpDiv
391 , infixOp "&&" OpLAnd
392 , infixOp "||" OpLOr
393 ]
395 specialOps = concat
396 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
397 , specialOp "|>" $ flip (<|)
398 , specialOp "==" $ \a b -> obj "_N.eq" `call` [a,b]
399 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_N.eq" `call` [a,b])
400 , specialOp "<" $ cmp OpLT 0
401 , specialOp ">" $ cmp OpGT 0
402 , specialOp "<=" $ cmp OpLT 1
403 , specialOp ">=" $ cmp OpGT (-1)
404 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
405 ]
407 cmp op n a b = InfixExpr () op (obj "_N.cmp" `call` [a,b]) (IntLit () n)