git.iko.soy/elk
on d94e218 help sign in
elk/compiler/Generate/JavaScript.hs
406 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) | 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 _ -> ref aN `call` (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) <- caseToMatch cases
170 (revisedMatch, stmt) <-
171 case e of
172 L _ (Var x) -> return (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 span mtch =
243 case mtch of
244 Match name clauses mtch' ->
245 do clauses' <- mapM (clause span name) clauses
246 mtch'' <- match span mtch'
247 return (SwitchStmt () (access name) clauses' : mtch'')
248 where
249 isLiteral p = case p of
250 Clause (Right _) _ _ -> True
251 _ -> False
252 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
254 Fail -> return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
255 Break -> return []
256 Other e ->
257 do e' <- expression e
258 return [ ReturnStmt () (Just e') ]
259 Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
260 where
261 dropEnd acc [] = acc
262 dropEnd acc (m:ms) =
263 case m of
264 Other _ -> acc ++ [m]
265 _ -> dropEnd (acc ++ [m]) ms
267clause span variable (Clause value vars mtch) =
268 CaseClause () pattern <$> match span (matchSubst (zip vars vars') mtch)
269 where
270 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
271 pattern = case value of
272 Right (Boolean b) -> BoolLit () b
273 Right lit -> literal lit
274 Left name -> string $ case List.elemIndices '.' name of
275 [] -> name
276 is -> drop (last is + 1) name
279jsModule :: MetadataModule () () -> String
280jsModule modul = show . prettyPrint $ setup (Just "Elm") (names modul) ++
281 [ assign ("Elm" : names modul) (function ["elm"] programStmts) ]
282 where
283 thisModule = dotSep ("elm" : names modul)
284 programStmts =
285 concat [ setup (Just "elm") (names modul)
286 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
287 , [ internalImports (List.intercalate "." (names modul)) ]
288 , concatMap jsImport (imports modul)
289 , concatMap importEvent (foreignImports modul)
290 , [ assign ["_op"] (ObjectLit () []) ]
291 , concat $ evalState (mapM definition . fst . SD.flattenLets [] $ program modul) 0
292 , map exportEvent $ foreignExports modul
293 , [ jsExports ]
294 , [ ReturnStmt () (Just thisModule) ]
295 ]
297 jsExports = assign ("elm" : names modul) (ObjectLit () exs)
298 where
299 exs = map entry . filter (not . isOp) $ "_op" : exports modul
300 entry x = (PropId () (var x), ref x)
302 assign path expr =
303 case path of
304 [x] -> VarDeclStmt () [ varDecl x expr ]
305 _ -> ExprStmt () $
306 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
308 jsImport (modul,_) = setup Nothing path ++ [ assign path (dotSep ("Elm" : path) <| ref "elm") ]
309 where
310 path = split modul
312 setup namespace path = map create paths
313 where
314 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
315 paths = case namespace of
316 Nothing -> tail . init $ List.inits path
317 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
319 addId js = InfixExpr () OpAdd (string (js++"_")) (obj "elm.id")
321 importEvent (js,base,elm,_) =
322 [ VarDeclStmt () [ varDecl elm $ obj "Signal.constant" <| evalState (expression base) 0 ]
323 , ExprStmt () $
324 obj "document.addEventListener" `call`
325 [ addId js
326 , function ["e"]
327 [ ExprStmt () $ obj "elm.notify" `call` [dotSep [elm,"id"], obj "e.value"] ]
328 ]
329 ]
331 exportEvent (js,elm,_) =
332 ExprStmt () $
333 ref "A2" `call`
334 [ obj "Signal.lift"
335 , function ["v"]
336 [ VarDeclStmt () [varDecl "e" $ obj "document.createEvent" <| string "Event"]
337 , ExprStmt () $
338 obj "e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]
339 , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "e") "value") (ref "v")
340 , ExprStmt () $ obj "document.dispatchEvent" <| ref "e"
341 , ReturnStmt () (Just $ ref "v")
342 ]
343 , ref elm ]
345binop span op e1 e2 =
346 case op of
347 "Basics.." ->
348 do es <- mapM expression (e1 : collect [] e2)
349 return $ ["$"] ==> foldr (<|) (ref "$") es
350 "Basics.<|" ->
351 do e2' <- expression e2
352 es <- mapM expression (collect [] e1)
353 return $ foldr (<|) e2' es
354 "List.++" ->
355 do e1' <- expression e1
356 e2' <- expression e2
357 return $ obj "_L.append" `call` [e1', e2']
358 "::" -> expression (L span (Data "::" [e1,e2]))
359 _ ->
360 do e1' <- expression e1
361 e2' <- expression e2
362 return $ case Map.lookup op opDict of
363 Just f -> f e1' e2'
364 Nothing -> ref "A2" `call` [ func, e1', e2' ]
365 where
366 collect es e =
367 case e of
368 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
369 _ -> es ++ [e]
371 js1 = expression e1
372 js2 = expression e2
374 func | isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
375 | otherwise = dotSep parts
376 where
377 parts = split op
378 operator = last parts
380 opDict = Map.fromList (infixOps ++ specialOps)
382 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
383 infixOp str op = specialOp str (InfixExpr () op)
385 infixOps = concat
386 [ infixOp "+" OpAdd
387 , infixOp "-" OpSub
388 , infixOp "*" OpMul
389 , infixOp "/" OpDiv
390 , infixOp "&&" OpLAnd
391 , infixOp "||" OpLOr
392 ]
394 specialOps = concat
395 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
396 , specialOp "|>" $ flip (<|)
397 , specialOp "==" $ \a b -> obj "_N.eq" `call` [a,b]
398 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_N.eq" `call` [a,b])
399 , specialOp "<" $ cmp OpLT 0
400 , specialOp ">" $ cmp OpGT 0
401 , specialOp "<=" $ cmp OpLT 1
402 , specialOp ">=" $ cmp OpGT (-1)
403 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
404 ]
406 cmp op n a b = InfixExpr () op (obj "_N.cmp" `call` [a,b]) (IntLit () n)