git.iko.soy/elk
on fecc96d help sign in
elk/compiler/Generate/JavaScript.hs
405 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 = dereserve . 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) -> go (vars ++ [x]) rest
32 (x,[]) -> vars ++ [x]
34var name = Id () (makeSafe name)
35ref name = VarRef () (var name)
36prop name = PropId () (var name)
37f <| x = CallExpr () f [x]
38args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ]
39function args stmts = FuncExpr () Nothing (map var args) stmts
40call = CallExpr ()
41string = StringLit ()
43dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)
44obj = dotSep . split
46varDecl x expr =
47 VarDecl () (var x) (Just expr)
49include alias moduleName =
50 varDecl alias (obj moduleName <| ref "elm")
52internalImports name =
53 VarDeclStmt ()
54 [ varDecl "N" (obj "Elm.Native")
55 , include "_N" "N.Utils"
56 , include "_L" "N.List"
57 , include "_E" "N.Error"
58 , include "_J" "N.JavaScript"
59 , varDecl "_str" (obj "_J.toString")
60 , varDecl "$moduleName" (string name)
61 ]
63literal lit =
64 case lit of
65 Chr c -> string [c]
66 Str s -> ref "_str" <| 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 _ -> ref aN `call` (func':args')
143 where
144 aN = "A" ++ show (length args)
145 (func, args) = getArgs e1 [e2]
146 getArgs func args =
147 case func of
148 (L _ (App f arg)) -> getArgs f (arg : args)
149 _ -> (func, args)
151 Let defs e ->
152 do let (defs',e') = SD.flattenLets defs e
153 stmts <- concat <$> mapM definition defs'
154 exp <- expression e'
155 return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []
157 MultiIf branches ->
158 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
159 return $ case last branches of
160 (L _ (Var "otherwise"), e) -> ifs (init branches') (snd (last branches'))
161 _ -> ifs branches'
162 (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
163 where
164 ifs branches finally = foldr iff finally branches
165 iff (if', then') else' = CondExpr () if' then' else'
167 Case e cases ->
168 do (tempVar,initialMatch) <- caseToMatch cases
169 (revisedMatch, stmt) <-
170 case e of
171 L _ (Var x) -> return (matchSubst [(tempVar,x)] initialMatch, [])
172 _ -> do e' <- expression e
173 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
174 match' <- match span revisedMatch
175 return (function [] (stmt ++ match') `call` [])
177 ExplicitList es ->
178 do es' <- mapM expression es
179 return $ obj "_J.toList" <| ArrayLit () es'
181 Data name es ->
182 do es' <- mapM expression es
183 return $ ObjectLit () (ctor : fields es')
184 where
185 ctor = (prop "ctor", string (makeSafe name))
186 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
188 Markdown doc _ -> return $ obj "Text.text" <| string (pad ++ md ++ pad)
189 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
190 md = Pan.writeHtmlString Pan.def doc
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 span mtch =
242 case mtch of
243 Match name clauses mtch' ->
244 do clauses' <- mapM (clause span name) clauses
245 mtch'' <- match span mtch'
246 return (SwitchStmt () (access name) clauses' : mtch'')
247 where
248 isLiteral p = case p of
249 Clause (Right _) _ _ -> True
250 _ -> False
251 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
253 Fail -> return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
254 Break -> return []
255 Other e ->
256 do e' <- expression e
257 return [ ReturnStmt () (Just e') ]
258 Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
259 where
260 dropEnd acc [] = acc
261 dropEnd acc (m:ms) =
262 case m of
263 Other _ -> acc ++ [m]
264 _ -> dropEnd (acc ++ [m]) ms
266clause span variable (Clause value vars mtch) =
267 CaseClause () pattern <$> match span (matchSubst (zip vars vars') mtch)
268 where
269 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
270 pattern = case value of
271 Right (Boolean b) -> BoolLit () b
272 Right lit -> literal lit
273 Left name -> string $ case List.elemIndices '.' name of
274 [] -> name
275 is -> drop (last is + 1) name
278jsModule :: MetadataModule () () -> String
279jsModule modul = show . prettyPrint $ setup (Just "Elm") (names modul) ++
280 [ assign ("Elm" : names modul) (function ["elm"] programStmts) ]
281 where
282 thisModule = dotSep ("elm" : names modul)
283 programStmts =
284 concat [ setup (Just "elm") (names modul)
285 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
286 , [ internalImports (List.intercalate "." (names modul)) ]
287 , concatMap jsImport (imports modul)
288 , concatMap importEvent (foreignImports modul)
289 , [ assign ["_op"] (ObjectLit () []) ]
290 , concat $ evalState (mapM definition . fst . SD.flattenLets [] $ program modul) 0
291 , map exportEvent $ foreignExports modul
292 , [ jsExports ]
293 , [ ReturnStmt () (Just thisModule) ]
294 ]
296 jsExports = assign ("elm" : names modul) (ObjectLit () exs)
297 where
298 exs = map entry . filter (not . isOp) $ "_op" : exports modul
299 entry x = (PropId () (var x), ref x)
301 assign path expr =
302 case path of
303 [x] -> VarDeclStmt () [ varDecl x expr ]
304 _ -> ExprStmt () $
305 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
307 jsImport (modul,_) = setup Nothing path ++ [ assign path (dotSep ("Elm" : path) <| ref "elm") ]
308 where
309 path = split modul
311 setup namespace path = map create paths
312 where
313 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
314 paths = case namespace of
315 Nothing -> tail . init $ List.inits path
316 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
318 addId js = InfixExpr () OpAdd (string (js++"_")) (obj "elm.id")
320 importEvent (js,base,elm,_) =
321 [ VarDeclStmt () [ varDecl elm $ obj "Signal.constant" <| evalState (expression base) 0 ]
322 , ExprStmt () $
323 obj "document.addEventListener" `call`
324 [ addId js
325 , function ["e"]
326 [ ExprStmt () $ obj "elm.notify" `call` [dotSep [elm,"id"], obj "e.value"] ]
327 ]
328 ]
330 exportEvent (js,elm,_) =
331 ExprStmt () $
332 ref "A2" `call`
333 [ obj "Signal.lift"
334 , function ["v"]
335 [ VarDeclStmt () [varDecl "e" $ obj "document.createEvent" <| string "Event"]
336 , ExprStmt () $
337 obj "e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]
338 , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "e") "value") (ref "v")
339 , ExprStmt () $ obj "document.dispatchEvent" <| ref "e"
340 , ReturnStmt () (Just $ ref "v")
341 ]
342 , ref elm ]
344binop span op e1 e2 =
345 case op of
346 "Basics.." ->
347 do es <- mapM expression (e1 : collect [] e2)
348 return $ ["$"] ==> foldr (<|) (ref "$") es
349 "Basics.<|" ->
350 do e2' <- expression e2
351 es <- mapM expression (collect [] e1)
352 return $ foldr (<|) e2' es
353 "List.++" ->
354 do e1' <- expression e1
355 e2' <- expression e2
356 return $ obj "_L.append" `call` [e1', e2']
357 "::" -> expression (L span (Data "::" [e1,e2]))
358 _ ->
359 do e1' <- expression e1
360 e2' <- expression e2
361 return $ case Map.lookup op opDict of
362 Just f -> f e1' e2'
363 Nothing -> ref "A2" `call` [ func, e1', e2' ]
364 where
365 collect es e =
366 case e of
367 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
368 _ -> es ++ [e]
370 js1 = expression e1
371 js2 = expression e2
373 func | isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
374 | otherwise = dotSep parts
375 where
376 parts = split op
377 operator = last parts
379 opDict = Map.fromList (infixOps ++ specialOps)
381 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
382 infixOp str op = specialOp str (InfixExpr () op)
384 infixOps = concat
385 [ infixOp "+" OpAdd
386 , infixOp "-" OpSub
387 , infixOp "*" OpMul
388 , infixOp "/" OpDiv
389 , infixOp "&&" OpLAnd
390 , infixOp "||" OpLOr
391 ]
393 specialOps = concat
394 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
395 , specialOp "|>" $ flip (<|)
396 , specialOp "==" $ \a b -> obj "_N.eq" `call` [a,b]
397 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_N.eq" `call` [a,b])
398 , specialOp "<" $ cmp OpLT 0
399 , specialOp ">" $ cmp OpGT 0
400 , specialOp "<=" $ cmp OpLT 1
401 , specialOp ">=" $ cmp OpGT (-1)
402 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
403 ]
405 cmp op n a b = InfixExpr () op (obj "_N.cmp" `call` [a,b]) (IntLit () n)