git.iko.soy/elk
on fe047d5 help sign in
elk/compiler/Generate/JavaScript.hs
422 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 :: String -> [String]
28split = go []
29 where
30 go vars str =
31 case break (=='.') str of
32 (x,'.':rest) | isOp x -> vars ++ [x ++ '.' : rest]
33 | otherwise -> go (vars ++ [x]) rest
34 (x,[]) -> vars ++ [x]
36var name = Id () (makeSafe name)
37ref name = VarRef () (var name)
38prop name = PropId () (var name)
39f <| x = CallExpr () f [x]
40args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ]
41function args stmts = FuncExpr () Nothing (map var args) stmts
42call = CallExpr ()
43string = StringLit ()
45dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)
46obj = dotSep . split
48varDecl :: String -> Expression () -> VarDecl ()
49varDecl x expr =
50 VarDecl () (var x) (Just expr)
52include alias moduleName =
53 varDecl alias (obj (moduleName ++ ".make") <| ref "elm")
55internalImports name =
56 VarDeclStmt ()
57 [ varDecl "N" (obj "Elm.Native")
58 , include "_N" "N.Utils"
59 , include "_L" "N.List"
60 , include "_E" "N.Error"
61 , include "_J" "N.JavaScript"
62 , varDecl "$moduleName" (string name)
63 ]
65literal :: Literal -> Expression ()
66literal lit =
67 case lit of
68 Chr c -> obj "_N.chr" <| string [c]
69 Str s -> string s
70 IntNum n -> IntLit () n
71 FloatNum n -> NumLit () n
72 Boolean b -> BoolLit () b
74expression :: LExpr () () -> State Int (Expression ())
75expression (L span expr) =
76 case expr of
77 Var x -> return $ ref x
78 Literal lit -> return $ literal lit
80 Range lo hi ->
81 do lo' <- expression lo
82 hi' <- expression hi
83 return $ obj "_L.range" `call` [lo',hi']
85 Access e x ->
86 do e' <- expression e
87 return $ DotRef () e' (var x)
89 Remove e x ->
90 do e' <- expression e
91 return $ obj "_N.remove" `call` [string x, e']
93 Insert e x v ->
94 do v' <- expression v
95 e' <- expression e
96 return $ obj "_N.insert" `call` [string x, v', e']
98 Modify e fs ->
99 do e' <- expression e
100 fs' <- forM fs $ \(f,v) -> do
101 v' <- expression v
102 return $ ArrayLit () [string f, v']
103 return $ obj "_N.replace" `call` [ArrayLit () fs', e']
105 Record fields ->
106 do fields' <- forM fields $ \(f,e) -> do
107 (,) f <$> expression e
108 let fieldMap = List.foldl' combine Map.empty fields'
109 return $ ObjectLit () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
110 where
111 combine r (k,v) = Map.insertWith (++) k [v] r
112 prop = PropId () . var
113 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
114 Map.toList . Map.filter (not . null) $ Map.map tail fs
115 visible fs = map (first prop) . Map.toList $ Map.map head fs
117 Binop op e1 e2 -> binop span op e1 e2
119 Lambda p e@(L s _) ->
120 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
121 body' <- expression body
122 return $ case length args < 2 || length args > 9 of
123 True -> foldr (==>) body' (map (:[]) args)
124 False -> ref ("F" ++ show (length args)) <| (args ==> body')
125 where
126 depattern (args, body) pattern =
127 case pattern of
128 PVar x -> return (args ++ [x], body)
129 _ -> do arg <- Case.newVar
130 return (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
132 (patterns, innerBody) = collect [p] e
134 collect patterns lexpr@(L _ expr) =
135 case expr of
136 Lambda p e -> collect (p:patterns) e
137 _ -> (patterns, lexpr)
139 App e1 e2 ->
140 do func' <- expression func
141 args' <- mapM expression args
142 return $ case args' of
143 [arg] -> func' <| arg
144 _ | length args' <= 9 -> ref aN `call` (func':args')
145 | otherwise -> foldl1 (<|) (func':args')
146 where
147 aN = "A" ++ show (length args)
148 (func, args) = getArgs e1 [e2]
149 getArgs func args =
150 case func of
151 (L _ (App f arg)) -> getArgs f (arg : args)
152 _ -> (func, args)
154 Let defs e ->
155 do let (defs',e') = SD.flattenLets defs e
156 stmts <- concat <$> mapM definition defs'
157 exp <- expression e'
158 return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []
160 MultiIf branches ->
161 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
162 return $ case last branches of
163 (L _ (Var "Basics.otherwise"), e) -> ifs (init branches') (snd (last branches'))
164 _ -> ifs branches'
165 (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
166 where
167 ifs branches finally = foldr iff finally branches
168 iff (if', then') else' = CondExpr () if' then' else'
170 Case e cases ->
171 do (tempVar,initialMatch) <- Case.toMatch cases
172 (revisedMatch, stmt) <-
173 case e of
174 L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, [])
175 _ -> do e' <- expression e
176 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
177 match' <- match span revisedMatch
178 return (function [] (stmt ++ match') `call` [])
180 ExplicitList es ->
181 do es' <- mapM expression es
182 return $ obj "_J.toList" <| ArrayLit () es'
184 Data name es ->
185 do es' <- mapM expression es
186 return $ ObjectLit () (ctor : fields es')
187 where
188 ctor = (prop "ctor", string (makeSafe name))
189 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
191 Markdown uid doc es ->
192 do es' <- mapM expression es
193 return $ obj "Text.markdown" `call` (string md : string uid : es')
194 where
195 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
196 md = pad ++ Pan.writeHtmlString Pan.def doc ++ pad
198definition :: Def () () -> State Int [Statement ()]
199definition def =
200 case def of
201 TypeAnnotation _ _ -> return []
203 Def pattern expr@(L span _) -> do
204 expr' <- expression expr
205 let assign x = varDecl x expr'
206 case pattern of
207 PVar x
208 | isOp x ->
209 let op = LBracket () (ref "_op") (string x) in
210 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
211 | otherwise ->
212 return [ VarDeclStmt () [ assign x ] ]
214 PRecord fields ->
215 let setField f = varDecl f (dotSep ["$",f]) in
216 return [ VarDeclStmt () (assign "$" : map setField fields) ]
218 PData name patterns | vars /= Nothing ->
219 case vars of
220 Just vs -> return [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]
221 where
222 vars = getVars patterns
223 getVars patterns =
224 case patterns of
225 PVar x : rest -> (x:) `fmap` getVars rest
226 [] -> Just []
227 _ -> Nothing
229 decl x n = varDecl x (dotSep ["$","_" ++ show n])
230 setup vars
231 | isTuple name = assign "$" : vars
232 | otherwise = safeAssign : vars
234 safeAssign = varDecl "$" (CondExpr () if' expr' exception)
235 if' = InfixExpr () OpStrictEq (obj "$.ctor") (string name)
236 exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
238 _ ->
239 do defs' <- concat <$> mapM toDef vars
240 return (VarDeclStmt () [assign "$"] : defs')
241 where
242 vars = Set.toList $ SD.boundVars pattern
243 mkVar = L span . Var
244 toDef y = definition $
245 Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])
247match :: (Show a) => a -> Case.Match () () -> State Int [Statement ()]
248match span mtch =
249 case mtch of
250 Case.Match name clauses mtch' ->
251 do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
252 mtch'' <- match span mtch'
253 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
254 where
255 isLiteral p = case p of
256 Case.Clause (Right _) _ _ -> True
257 _ -> False
258 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
259 format isChars e
260 | or isChars = InfixExpr () OpAdd e (string "")
261 | otherwise = e
263 Case.Fail ->
264 return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
266 Case.Break -> return [BreakStmt () Nothing]
267 Case.Other e ->
268 do e' <- expression e
269 return [ ReturnStmt () (Just e') ]
270 Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
271 where
272 dropEnd acc [] = acc
273 dropEnd acc (m:ms) =
274 case m of
275 Case.Other _ -> acc ++ [m]
276 _ -> dropEnd (acc ++ [m]) ms
278clause span variable (Case.Clause value vars mtch) =
279 (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
280 where
281 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
282 (isChar, pattern) =
283 case value of
284 Right (Chr c) -> (True, string [c])
285 _ -> (,) False $ case value of
286 Right (Boolean b) -> BoolLit () b
287 Right lit -> literal lit
288 Left name -> string $ case List.elemIndices '.' name of
289 [] -> name
290 is -> drop (last is + 1) name
293jsModule :: MetadataModule () () -> String
294jsModule modul =
295 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
296 [ assign ("Elm" : names modul ++ ["make"]) (function ["elm"] programStmts) ]
297 where
298 thisModule = dotSep ("elm" : names modul ++ ["values"])
299 programStmts =
300 concat [ setup (Just "elm") (names modul ++ ["values"])
301 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
302 , [ internalImports (List.intercalate "." (names modul)) ]
303 , concatMap jsImport (imports modul)
304 , concatMap importEvent (foreignImports modul)
305 , [ assign ["_op"] (ObjectLit () []) ]
306 , concat $ evalState (mapM definition . fst . SD.flattenLets [] $ program modul) 0
307 , map exportEvent $ foreignExports modul
308 , [ jsExports ]
309 , [ ReturnStmt () (Just thisModule) ]
310 ]
312 jsExports = assign ("elm" : names modul ++ ["values"]) (ObjectLit () exs)
313 where
314 exs = map entry . filter (not . isOp) $ "_op" : exports modul
315 entry x = (PropId () (var x), ref x)
317 assign path expr =
318 case path of
319 [x] -> VarDeclStmt () [ varDecl x expr ]
320 _ -> ExprStmt () $
321 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
323 jsImport (modul,_) = setup Nothing path ++ [ include ]
324 where
325 path = split modul
326 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "elm"
328 setup namespace path = map create paths
329 where
330 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
331 paths = case namespace of
332 Nothing -> tail . init $ List.inits path
333 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
335 addId js = InfixExpr () OpAdd (string (js++"_")) (obj "elm.id")
337 importEvent (js,base,elm,_) =
338 [ VarDeclStmt () [ varDecl elm $ obj "Signal.constant" <| evalState (expression base) 0 ]
339 , ExprStmt () $
340 obj "document.addEventListener" `call`
341 [ addId js
342 , function ["e"]
343 [ ExprStmt () $ obj "elm.notify" `call` [dotSep [elm,"id"], obj "e.value"] ]
344 ]
345 ]
347 exportEvent (js,elm,_) =
348 ExprStmt () $
349 ref "A2" `call`
350 [ obj "Signal.lift"
351 , function ["v"]
352 [ VarDeclStmt () [varDecl "e" $ obj "document.createEvent" <| string "Event"]
353 , ExprStmt () $
354 obj "e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]
355 , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "e") "value") (ref "v")
356 , ExprStmt () $ obj "document.dispatchEvent" <| ref "e"
357 , ReturnStmt () (Just $ ref "v")
358 ]
359 , ref elm ]
361binop span op e1 e2 =
362 case op of
363 "Basics.." ->
364 do es <- mapM expression (e1 : collect [] e2)
365 return $ ["$"] ==> foldr (<|) (ref "$") es
366 "Basics.<|" ->
367 do e2' <- expression e2
368 es <- mapM expression (collect [] e1)
369 return $ foldr (<|) e2' es
370 "List.++" ->
371 do e1' <- expression e1
372 e2' <- expression e2
373 return $ obj "_L.append" `call` [e1', e2']
374 "::" -> expression (L span (Data "::" [e1,e2]))
375 _ ->
376 do e1' <- expression e1
377 e2' <- expression e2
378 return $ case Map.lookup op opDict of
379 Just f -> f e1' e2'
380 Nothing -> ref "A2" `call` [ func, e1', e2' ]
381 where
382 collect es e =
383 case e of
384 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
385 _ -> es ++ [e]
387 js1 = expression e1
388 js2 = expression e2
390 func | isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
391 | otherwise = dotSep parts
392 where
393 parts = split op
394 operator = last parts
396 opDict = Map.fromList (infixOps ++ specialOps)
398 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
399 infixOp str op = specialOp str (InfixExpr () op)
401 infixOps = concat
402 [ infixOp "+" OpAdd
403 , infixOp "-" OpSub
404 , infixOp "*" OpMul
405 , infixOp "/" OpDiv
406 , infixOp "&&" OpLAnd
407 , infixOp "||" OpLOr
408 ]
410 specialOps = concat
411 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
412 , specialOp "|>" $ flip (<|)
413 , specialOp "==" $ \a b -> obj "_N.eq" `call` [a,b]
414 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_N.eq" `call` [a,b])
415 , specialOp "<" $ cmp OpLT 0
416 , specialOp ">" $ cmp OpGT 0
417 , specialOp "<=" $ cmp OpLT 1
418 , specialOp ">=" $ cmp OpGT (-1)
419 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
420 ]
422 cmp op n a b = InfixExpr () op (obj "_N.cmp" `call` [a,b]) (IntLit () n)