git.iko.soy/elk
on cf016ea help sign in
elk/compiler/Generate/JavaScript.hs
426 lines 16 kB history raw
1{-# OPTIONS -Wall #-}
3module Generate.JavaScript (generate) 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 qualified SourceSyntax.Helpers as Help
15import SourceSyntax.Literal
16import SourceSyntax.Pattern
17import SourceSyntax.Location
18import SourceSyntax.Expression
19import SourceSyntax.Module
20import qualified Transform.SortDefinitions as SD
21import Language.ECMAScript3.Syntax
22import Language.ECMAScript3.PrettyPrint
23import qualified Transform.SafeNames as MakeSafe
25split :: String -> [String]
26split = go []
27 where
28 go vars str =
29 case break (=='.') str of
30 (x,'.':rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]
31 | otherwise -> go (vars ++ [x]) rest
32 (x,[]) -> vars ++ [x]
34var name = Id () name
35ref name = VarRef () (var name)
36prop name = PropId () (var name)
37f <| x = CallExpr () f [x]
38args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ]
39function args stmts = FuncExpr () Nothing (map var args) stmts
40call = CallExpr ()
41string = StringLit ()
43dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)
44obj = dotSep . split
46varDecl :: String -> Expression () -> VarDecl ()
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 "$moduleName" (string name)
61 ]
63literal :: Literal -> Expression ()
64literal lit =
65 case lit of
66 Chr c -> obj "_N.chr" <| string [c]
67 Str s -> 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 (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
119 body' <- expression body
120 return $ case length args < 2 || length args > 9 of
121 True -> foldr (==>) body' (map (:[]) args)
122 False -> ref ("F" ++ show (length args)) <| (args ==> body')
123 where
124 depattern (args, body) pattern =
125 case pattern of
126 PVar x -> return (args ++ [x], body)
127 _ -> do arg <- Case.newVar
128 return (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
130 (patterns, innerBody) = collect [p] e
132 collect patterns lexpr@(L _ expr) =
133 case expr of
134 Lambda p e -> collect (p:patterns) e
135 _ -> (patterns, lexpr)
137 App e1 e2 ->
138 do func' <- expression func
139 args' <- mapM expression args
140 return $ case args' of
141 [arg] -> func' <| arg
142 _ | length args' <= 9 -> ref aN `call` (func':args')
143 | otherwise -> foldl1 (<|) (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"), _) -> safeIfs branches'
162 (L _ (Literal (Boolean True)), _) -> safeIfs branches'
163 _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
164 where
165 safeIfs branches = ifs (init branches) (snd (last branches))
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) <- Case.toMatch cases
171 (revisedMatch, stmt) <-
172 case e of
173 L _ (Var x) -> return (Case.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 name)
188 fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
190 Markdown uid doc es ->
191 do es' <- mapM expression es
192 return $ obj "Text.markdown" `call` (string md : string uid : es')
193 where
194 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
195 md = pad ++ MD.toHtml doc ++ pad
197 GLShader uid src ->
198 return . literal $ Str src
201definition :: Def () () -> State Int [Statement ()]
202definition def =
203 case def of
204 TypeAnnotation _ _ -> return []
206 Def pattern expr@(L span _) -> do
207 expr' <- expression expr
208 let assign x = varDecl x expr'
209 case pattern of
210 PVar x
211 | Help.isOp x ->
212 let op = LBracket () (ref "_op") (string x) in
213 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
214 | otherwise ->
215 return [ VarDeclStmt () [ assign x ] ]
217 PRecord fields ->
218 let setField f = varDecl f (dotSep ["$",f]) in
219 return [ VarDeclStmt () (assign "$" : map setField fields) ]
221 PData name patterns | vars /= Nothing ->
222 case vars of
223 Just vs -> return [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]
224 where
225 vars = getVars patterns
226 getVars patterns =
227 case patterns of
228 PVar x : rest -> (x:) `fmap` getVars rest
229 [] -> Just []
230 _ -> Nothing
232 decl x n = varDecl x (dotSep ["$","_" ++ show n])
233 setup vars
234 | Help.isTuple name = assign "$" : vars
235 | otherwise = assign "$raw" : safeAssign : vars
237 safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
238 if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)
239 exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
241 _ ->
242 do defs' <- concat <$> mapM toDef vars
243 return (VarDeclStmt () [assign "$"] : defs')
244 where
245 vars = Set.toList $ SD.boundVars pattern
246 mkVar = L span . Var
247 toDef y = definition $
248 Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])
250match :: (Show a) => a -> Case.Match () () -> State Int [Statement ()]
251match span mtch =
252 case mtch of
253 Case.Match name clauses mtch' ->
254 do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
255 mtch'' <- match span mtch'
256 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
257 where
258 isLiteral p = case p of
259 Case.Clause (Right _) _ _ -> True
260 _ -> False
261 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
262 format isChars e
263 | or isChars = InfixExpr () OpAdd e (string "")
264 | otherwise = e
266 Case.Fail ->
267 return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
269 Case.Break -> return [BreakStmt () Nothing]
270 Case.Other e ->
271 do e' <- expression e
272 return [ ReturnStmt () (Just e') ]
273 Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
274 where
275 dropEnd acc [] = acc
276 dropEnd acc (m:ms) =
277 case m of
278 Case.Other _ -> acc ++ [m]
279 _ -> dropEnd (acc ++ [m]) ms
281clause span variable (Case.Clause value vars mtch) =
282 (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
283 where
284 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
285 (isChar, pattern) =
286 case value of
287 Right (Chr c) -> (True, string [c])
288 _ -> (,) False $ case value of
289 Right (Boolean b) -> BoolLit () b
290 Right lit -> literal lit
291 Left name -> string $ case List.elemIndices '.' name of
292 [] -> name
293 is -> drop (last is + 1) name
296generate :: MetadataModule () () -> String
297generate unsafeModule =
298 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
299 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]
300 where
301 modul = MakeSafe.metadataModule unsafeModule
302 thisModule = dotSep ("_elm" : names modul ++ ["values"])
303 programStmts =
304 concat [ setup (Just "_elm") (names modul ++ ["values"])
305 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
306 , [ internalImports (List.intercalate "." (names modul)) ]
307 , concatMap jsImport (imports modul)
308 , concatMap importEvent (foreignImports modul)
309 , [ assign ["_op"] (ObjectLit () []) ]
310 , concat $ evalState (mapM definition . fst . SD.flattenLets [] $ program modul) 0
311 , map exportEvent $ foreignExports modul
312 , [ jsExports ]
313 , [ ReturnStmt () (Just thisModule) ]
314 ]
316 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
317 where
318 exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
319 entry x = (PropId () (var x), ref x)
321 assign path expr =
322 case path of
323 [x] -> VarDeclStmt () [ varDecl x expr ]
324 _ -> ExprStmt () $
325 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
327 jsImport (modul,_) = setup Nothing path ++ [ include ]
328 where
329 path = split modul
330 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
332 setup namespace path = map create paths
333 where
334 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
335 paths = case namespace of
336 Nothing -> tail . init $ List.inits path
337 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
339 addId js = InfixExpr () OpAdd (string (js++"_")) (obj "_elm.id")
341 importEvent (js,base,elm,_) =
342 [ VarDeclStmt () [ varDecl elm $ obj "Signal.constant" <| evalState (expression base) 0 ]
343 , ExprStmt () $
344 obj "document.addEventListener" `call`
345 [ addId js
346 , function ["_e"]
347 [ ExprStmt () $ obj "_elm.notify" `call` [dotSep [elm,"id"], obj "_e.value"] ]
348 ]
349 ]
351 exportEvent (js,elm,_) =
352 ExprStmt () $
353 ref "A2" `call`
354 [ obj "Signal.lift"
355 , function ["_v"]
356 [ VarDeclStmt () [varDecl "_e" $ obj "document.createEvent" <| string "Event"]
357 , ExprStmt () $
358 obj "_e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]
359 , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "_e") "value") (ref "_v")
360 , ExprStmt () $ obj "document.dispatchEvent" <| ref "_e"
361 , ReturnStmt () (Just $ ref "_v")
362 ]
363 , ref elm ]
365binop span op e1 e2 =
366 case op of
367 "Basics.." ->
368 do es <- mapM expression (e1 : collect [] e2)
369 return $ ["$"] ==> foldr (<|) (ref "$") es
370 "Basics.<|" ->
371 do e2' <- expression e2
372 es <- mapM expression (collect [] e1)
373 return $ foldr (<|) e2' es
374 "List.++" ->
375 do e1' <- expression e1
376 e2' <- expression e2
377 return $ obj "_L.append" `call` [e1', e2']
378 "::" -> expression (L span (Data "::" [e1,e2]))
379 _ ->
380 do e1' <- expression e1
381 e2' <- expression e2
382 return $ case Map.lookup op opDict of
383 Just f -> f e1' e2'
384 Nothing -> ref "A2" `call` [ func, e1', e2' ]
385 where
386 collect es e =
387 case e of
388 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
389 _ -> es ++ [e]
391 js1 = expression e1
392 js2 = expression e2
394 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
395 | otherwise = dotSep parts
396 where
397 parts = split op
398 operator = last parts
400 opDict = Map.fromList (infixOps ++ specialOps)
402 specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
403 infixOp str op = specialOp str (InfixExpr () op)
405 infixOps = concat
406 [ infixOp "+" OpAdd
407 , infixOp "-" OpSub
408 , infixOp "*" OpMul
409 , infixOp "/" OpDiv
410 , infixOp "&&" OpLAnd
411 , infixOp "||" OpLOr
412 ]
414 specialOps = concat
415 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
416 , specialOp "|>" $ flip (<|)
417 , specialOp "==" $ \a b -> obj "_N.eq" `call` [a,b]
418 , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_N.eq" `call` [a,b])
419 , specialOp "<" $ cmp OpLT 0
420 , specialOp ">" $ cmp OpGT 0
421 , specialOp "<=" $ cmp OpLT 1
422 , specialOp ">=" $ cmp OpGT (-1)
423 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
424 ]
426 cmp op n a b = InfixExpr () op (obj "_N.cmp" `call` [a,b]) (IntLit () n)