git.iko.soy/elk
on df67fe5 help sign in
elk/compiler/Generate/JavaScript.hs
409 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 ++ ".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 "_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 =
282 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
283 [ assign ("Elm" : names modul ++ ["make"]) (function ["elm"] programStmts) ]
284 where
285 thisModule = dotSep ("elm" : names modul ++ ["values"])
286 programStmts =
287 concat [ setup (Just "elm") (names modul ++ ["values"])
288 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
289 , [ internalImports (List.intercalate "." (names modul)) ]
290 , concatMap jsImport (imports modul)
291 , concatMap importEvent (foreignImports modul)
292 , [ assign ["_op"] (ObjectLit () []) ]
293 , concat $ evalState (mapM definition . fst . SD.flattenLets [] $ program modul) 0
294 , map exportEvent $ foreignExports modul
295 , [ jsExports ]
296 , [ ReturnStmt () (Just thisModule) ]
297 ]
299 jsExports = assign ("elm" : names modul ++ ["values"]) (ObjectLit () exs)
300 where
301 exs = map entry . filter (not . isOp) $ "_op" : exports modul
302 entry x = (PropId () (var x), ref x)
304 assign path expr =
305 case path of
306 [x] -> VarDeclStmt () [ varDecl x expr ]
307 _ -> ExprStmt () $
308 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
310 jsImport (modul,_) = setup Nothing path ++ [ include ]
311 where
312 path = split modul
313 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "elm"
315 setup namespace path = map create paths
316 where
317 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
318 paths = case namespace of
319 Nothing -> tail . init $ List.inits path
320 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
322 addId js = InfixExpr () OpAdd (string (js++"_")) (obj "elm.id")
324 importEvent (js,base,elm,_) =
325 [ VarDeclStmt () [ varDecl elm $ obj "Signal.constant" <| evalState (expression base) 0 ]
326 , ExprStmt () $
327 obj "document.addEventListener" `call`
328 [ addId js
329 , function ["e"]
330 [ ExprStmt () $ obj "elm.notify" `call` [dotSep [elm,"id"], obj "e.value"] ]
331 ]
332 ]
334 exportEvent (js,elm,_) =
335 ExprStmt () $
336 ref "A2" `call`
337 [ obj "Signal.lift"
338 , function ["v"]
339 [ VarDeclStmt () [varDecl "e" $ obj "document.createEvent" <| string "Event"]
340 , ExprStmt () $
341 obj "e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]
342 , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "e") "value") (ref "v")
343 , ExprStmt () $ obj "document.dispatchEvent" <| ref "e"
344 , ReturnStmt () (Just $ ref "v")
345 ]
346 , ref elm ]
348binop span op e1 e2 =
349 case op of
350 "Basics.." ->
351 do es <- mapM expression (e1 : collect [] e2)
352 return $ ["$"] ==> foldr (<|) (ref "$") es
353 "Basics.<|" ->
354 do e2' <- expression e2
355 es <- mapM expression (collect [] e1)
356 return $ foldr (<|) e2' es
357 "List.++" ->
358 do e1' <- expression e1
359 e2' <- expression e2
360 return $ obj "_L.append" `call` [e1', e2']
361 "::" -> expression (L span (Data "::" [e1,e2]))
362 _ ->
363 do e1' <- expression e1
364 e2' <- expression e2
365 return $ case Map.lookup op opDict of
366 Just f -> f e1' e2'
367 Nothing -> ref "A2" `call` [ func, e1', e2' ]
368 where
369 collect es e =
370 case e of
371 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
372 _ -> es ++ [e]
374 js1 = expression e1
375 js2 = expression e2
377 func | isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
378 | otherwise = dotSep parts
379 where
380 parts = split op
381 operator = last parts
383 opDict = Map.fromList (infixOps ++ specialOps)
385 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
386 infixOp str op = specialOp str (InfixExpr () op)
388 infixOps = concat
389 [ infixOp "+" OpAdd
390 , infixOp "-" OpSub
391 , infixOp "*" OpMul
392 , infixOp "/" OpDiv
393 , infixOp "&&" OpLAnd
394 , infixOp "||" OpLOr
395 ]
397 specialOps = concat
398 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
399 , specialOp "|>" $ flip (<|)
400 , specialOp "==" $ \a b -> obj "_N.eq" `call` [a,b]
401 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_N.eq" `call` [a,b])
402 , specialOp "<" $ cmp OpLT 0
403 , specialOp ">" $ cmp OpGT 0
404 , specialOp "<=" $ cmp OpLT 1
405 , specialOp ">=" $ cmp OpGT (-1)
406 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
407 ]
409 cmp op n a b = InfixExpr () op (obj "_N.cmp" `call` [a,b]) (IntLit () n)