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