git.iko.soy/elk
on 254d71f help sign in
elk/compiler/Generate/JavaScript.hs
419 lines 16 kB history raw
1module Generate.JavaScript (generate) 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
10import qualified Generate.Cases as Case
11import qualified Generate.Markdown as MD
12import qualified SourceSyntax.Helpers as Help
13import SourceSyntax.Literal
14import SourceSyntax.Pattern
15import SourceSyntax.Location
16import SourceSyntax.Expression
17import SourceSyntax.Module
18import qualified Transform.SortDefinitions as SD
19import Language.ECMAScript3.Syntax
20import Language.ECMAScript3.PrettyPrint
21import qualified Transform.SafeNames as MakeSafe
23split :: String -> [String]
24split = go []
25 where
26 go vars str =
27 case break (=='.') str of
28 (x,'.':rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]
29 | otherwise -> go (vars ++ [x]) rest
30 (x,[]) -> vars ++ [x]
32var name = Id () name
33ref name = VarRef () (var name)
34prop name = PropId () (var name)
35f <| x = CallExpr () f [x]
36args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ]
37function args stmts = FuncExpr () Nothing (map var args) stmts
38call = CallExpr ()
39string = StringLit ()
41dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)
42obj = dotSep . split
44varDecl :: String -> Expression () -> VarDecl ()
45varDecl x expr =
46 VarDecl () (var x) (Just expr)
48include alias moduleName =
49 varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")
51internalImports name =
52 VarDeclStmt ()
53 [ varDecl "N" (obj "Elm.Native")
54 , include "_N" "N.Utils"
55 , include "_L" "N.List"
56 , include "_E" "N.Error"
57 , include "_J" "N.JavaScript"
58 , varDecl "$moduleName" (string name)
59 ]
61literal :: Literal -> Expression ()
62literal lit =
63 case lit of
64 Chr c -> obj "_N.chr" <| string [c]
65 Str s -> string s
66 IntNum n -> IntLit () n
67 FloatNum n -> NumLit () n
68 Boolean b -> BoolLit () b
70expression :: LExpr () () -> State Int (Expression ())
71expression (L span expr) =
72 case expr of
73 Var x -> return $ ref x
74 Literal lit -> return $ literal lit
76 Range lo hi ->
77 do lo' <- expression lo
78 hi' <- expression hi
79 return $ obj "_L.range" `call` [lo',hi']
81 Access e x ->
82 do e' <- expression e
83 return $ DotRef () e' (var x)
85 Remove e x ->
86 do e' <- expression e
87 return $ obj "_N.remove" `call` [string x, e']
89 Insert e x v ->
90 do v' <- expression v
91 e' <- expression e
92 return $ obj "_N.insert" `call` [string x, v', e']
94 Modify e fs ->
95 do e' <- expression e
96 fs' <- forM fs $ \(f,v) -> do
97 v' <- expression v
98 return $ ArrayLit () [string f, v']
99 return $ obj "_N.replace" `call` [ArrayLit () fs', e']
101 Record fields ->
102 do fields' <- forM fields $ \(f,e) -> do
103 (,) f <$> expression e
104 let fieldMap = List.foldl' combine Map.empty fields'
105 return $ ObjectLit () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
106 where
107 combine r (k,v) = Map.insertWith (++) k [v] r
108 prop = PropId () . var
109 hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
110 Map.toList . Map.filter (not . null) $ Map.map tail fs
111 visible fs = map (first prop) . Map.toList $ Map.map head fs
113 Binop op e1 e2 -> binop span op e1 e2
115 Lambda p e@(L s _) ->
116 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
117 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 depattern (args, body) pattern =
123 case pattern of
124 PVar x -> return (args ++ [x], body)
125 _ -> do arg <- Case.newVar
126 return (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
128 (patterns, innerBody) = collect [p] e
130 collect patterns lexpr@(L _ expr) =
131 case expr of
132 Lambda p e -> collect (p:patterns) e
133 _ -> (patterns, lexpr)
135 App e1 e2 ->
136 do func' <- expression func
137 args' <- mapM expression args
138 return $ case args' of
139 [arg] -> func' <| arg
140 _ | length args' <= 9 -> ref aN `call` (func':args')
141 | otherwise -> foldl1 (<|) (func':args')
142 where
143 aN = "A" ++ show (length args)
144 (func, args) = getArgs e1 [e2]
145 getArgs func args =
146 case func of
147 (L _ (App f arg)) -> getArgs f (arg : args)
148 _ -> (func, args)
150 Let defs e ->
151 do let (defs',e') = SD.flattenLets defs e
152 stmts <- concat <$> mapM definition defs'
153 exp <- expression e'
154 return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []
156 MultiIf branches ->
157 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
158 return $ case last branches of
159 (L _ (Var "Basics.otherwise"), e) -> ifs (init branches') (snd (last branches'))
160 _ -> ifs branches'
161 (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
162 where
163 ifs branches finally = foldr iff finally branches
164 iff (if', then') else' = CondExpr () if' then' else'
166 Case e cases ->
167 do (tempVar,initialMatch) <- Case.toMatch cases
168 (revisedMatch, stmt) <-
169 case e of
170 L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, [])
171 _ -> do e' <- expression e
172 return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
173 match' <- match span revisedMatch
174 return (function [] (stmt ++ match') `call` [])
176 ExplicitList es ->
177 do es' <- mapM expression es
178 return $ obj "_J.toList" <| ArrayLit () es'
180 Data name es ->
181 do es' <- mapM expression es
182 return $ ObjectLit () (ctor : fields es')
183 where
184 ctor = (prop "ctor", string name)
185 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
187 Markdown uid doc es ->
188 do es' <- mapM expression es
189 return $ obj "Text.markdown" `call` (string md : string uid : es')
190 where
191 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
192 md = pad ++ MD.toHtml doc ++ pad
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 | Help.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 | Help.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 :: (Show a) => a -> Case.Match () () -> State Int [Statement ()]
244match span mtch =
245 case mtch of
246 Case.Match name clauses mtch' ->
247 do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
248 mtch'' <- match span mtch'
249 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
250 where
251 isLiteral p = case p of
252 Case.Clause (Right _) _ _ -> True
253 _ -> False
254 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
255 format isChars e
256 | or isChars = InfixExpr () OpAdd e (string "")
257 | otherwise = e
259 Case.Fail ->
260 return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
262 Case.Break -> return [BreakStmt () Nothing]
263 Case.Other e ->
264 do e' <- expression e
265 return [ ReturnStmt () (Just e') ]
266 Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
267 where
268 dropEnd acc [] = acc
269 dropEnd acc (m:ms) =
270 case m of
271 Case.Other _ -> acc ++ [m]
272 _ -> dropEnd (acc ++ [m]) ms
274clause span variable (Case.Clause value vars mtch) =
275 (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
276 where
277 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
278 (isChar, pattern) =
279 case value of
280 Right (Chr c) -> (True, string [c])
281 _ -> (,) False $ case value of
282 Right (Boolean b) -> BoolLit () b
283 Right lit -> literal lit
284 Left name -> string $ case List.elemIndices '.' name of
285 [] -> name
286 is -> drop (last is + 1) name
289generate :: MetadataModule () () -> String
290generate unsafeModule =
291 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
292 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]
293 where
294 modul = MakeSafe.metadataModule unsafeModule
295 thisModule = dotSep ("_elm" : names modul ++ ["values"])
296 programStmts =
297 concat [ setup (Just "_elm") (names modul ++ ["values"])
298 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
299 , [ internalImports (List.intercalate "." (names modul)) ]
300 , concatMap jsImport (imports modul)
301 , concatMap importEvent (foreignImports modul)
302 , [ assign ["_op"] (ObjectLit () []) ]
303 , concat $ evalState (mapM definition . fst . SD.flattenLets [] $ program modul) 0
304 , map exportEvent $ foreignExports modul
305 , [ jsExports ]
306 , [ ReturnStmt () (Just thisModule) ]
307 ]
309 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
310 where
311 exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
312 entry x = (PropId () (var x), ref x)
314 assign path expr =
315 case path of
316 [x] -> VarDeclStmt () [ varDecl x expr ]
317 _ -> ExprStmt () $
318 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
320 jsImport (modul,_) = setup Nothing path ++ [ include ]
321 where
322 path = split modul
323 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
325 setup namespace path = map create paths
326 where
327 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
328 paths = case namespace of
329 Nothing -> tail . init $ List.inits path
330 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
332 addId js = InfixExpr () OpAdd (string (js++"_")) (obj "_elm.id")
334 importEvent (js,base,elm,_) =
335 [ VarDeclStmt () [ varDecl elm $ obj "Signal.constant" <| evalState (expression base) 0 ]
336 , ExprStmt () $
337 obj "document.addEventListener" `call`
338 [ addId js
339 , function ["_e"]
340 [ ExprStmt () $ obj "_elm.notify" `call` [dotSep [elm,"id"], obj "_e.value"] ]
341 ]
342 ]
344 exportEvent (js,elm,_) =
345 ExprStmt () $
346 ref "A2" `call`
347 [ obj "Signal.lift"
348 , function ["_v"]
349 [ VarDeclStmt () [varDecl "_e" $ obj "document.createEvent" <| string "Event"]
350 , ExprStmt () $
351 obj "_e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]
352 , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "_e") "value") (ref "_v")
353 , ExprStmt () $ obj "document.dispatchEvent" <| ref "_e"
354 , ReturnStmt () (Just $ ref "_v")
355 ]
356 , ref elm ]
358binop span op e1 e2 =
359 case op of
360 "Basics.." ->
361 do es <- mapM expression (e1 : collect [] e2)
362 return $ ["$"] ==> foldr (<|) (ref "$") es
363 "Basics.<|" ->
364 do e2' <- expression e2
365 es <- mapM expression (collect [] e1)
366 return $ foldr (<|) e2' es
367 "List.++" ->
368 do e1' <- expression e1
369 e2' <- expression e2
370 return $ obj "_L.append" `call` [e1', e2']
371 "::" -> expression (L span (Data "::" [e1,e2]))
372 _ ->
373 do e1' <- expression e1
374 e2' <- expression e2
375 return $ case Map.lookup op opDict of
376 Just f -> f e1' e2'
377 Nothing -> ref "A2" `call` [ func, e1', e2' ]
378 where
379 collect es e =
380 case e of
381 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
382 _ -> es ++ [e]
384 js1 = expression e1
385 js2 = expression e2
387 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
388 | otherwise = dotSep parts
389 where
390 parts = split op
391 operator = last parts
393 opDict = Map.fromList (infixOps ++ specialOps)
395 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
396 infixOp str op = specialOp str (InfixExpr () op)
398 infixOps = concat
399 [ infixOp "+" OpAdd
400 , infixOp "-" OpSub
401 , infixOp "*" OpMul
402 , infixOp "/" OpDiv
403 , infixOp "&&" OpLAnd
404 , infixOp "||" OpLOr
405 ]
407 specialOps = concat
408 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
409 , specialOp "|>" $ flip (<|)
410 , specialOp "==" $ \a b -> obj "_N.eq" `call` [a,b]
411 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_N.eq" `call` [a,b])
412 , specialOp "<" $ cmp OpLT 0
413 , specialOp ">" $ cmp OpGT 0
414 , specialOp "<=" $ cmp OpLT 1
415 , specialOp ">=" $ cmp OpGT (-1)
416 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
417 ]
419 cmp op n a b = InfixExpr () op (obj "_N.cmp" `call` [a,b]) (IntLit () n)