@@ -1,6 +1,8 @@
11module Generate.JavaScript where
22
3−import Control.Arrow ((***))
3+import Control.Arrow (first,(***))
4+import Control.Applicative ((<$>),(<*>))
5+import Control.Monad.State
46import qualified Data.List as List
57import qualified Data.Map as Map
68import qualified Data.Set as Set
@@ -39,22 +41,22 @@ call = CallExpr ()
3941string = StringLit ()
4042
4143dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)
42−get = dotSep . split
44+obj = dotSep . split
4345
4446varDecl x expr =
4547 VarDecl () (var x) (Just expr)
4648
4749include alias moduleName =
48− varDecl alias (get moduleName <| ref "elm")
50+ varDecl alias (obj moduleName <| ref "elm")
4951
5052internalImports name =
5153 VarDeclStmt ()
52− [ varDecl "N" (get "Elm.Native")
54+ [ varDecl "N" (obj "Elm.Native")
5355 , include "_N" "N.Utils"
5456 , include "_L" "N.List"
5557 , include "_E" "N.Error"
5658 , include "_J" "N.JavaScript"
57− , varDecl "_str" (get "_J.toString")
59+ , varDecl "_str" (obj "_J.toString")
5860 , varDecl "$moduleName" (string name)
5961 ]
6062
@@ -66,38 +68,57 @@ literal lit =
6668 FloatNum n -> NumLit () n
6769 Boolean b -> BoolLit () b
6870
69−expression :: LExpr () () -> Expression ()
71+expression :: LExpr () () -> State Int (Expression ())
7072expression (L span expr) =
7173 case expr of
72− Var x -> ref x
73− Literal lit -> literal lit
74− Range lo hi -> get "_L.range" `call` [expression lo, expression hi]
74+ Var x -> return $ ref x
75+ Literal lit -> return $ literal lit
7576
76− Access e x -> DotRef () (expression e) (var x)
77− Remove e x -> get "_N.remove" `call` [string x, expression e]
78− Insert e x v -> get "_N.insert" `call` [string x, expression v, expression e]
79− Modify e fs ->
80− let modify (f,v) = ArrayLit () [string f, expression v]
81− in get "_N.replace" `call` [ArrayLit () (map modify fs), expression e]
77+ Range lo hi ->
78+ do lo' <- expression lo
79+ hi' <- expression hi
80+ return $ obj "_L.range" `call` [lo',hi']
8281
83− Record fields -> ObjectLit () $ (PropId () (var "_"), hidden) : visible
84− where
85− combine r (k,v) = Map.insertWith (++) k [v] r
86− fieldMap = List.foldl' combine Map.empty fields
87− hidden = ObjectLit () . map ((PropId () . var) *** (ArrayLit () . map expression)) .
88− Map.toList . Map.filter (not . null) $ Map.map tail fieldMap
89− visible = map ((PropId () . var) *** expression) . Map.toList $ Map.map head fieldMap
82+ Access e x ->
83+ do e' <- expression e
84+ return $ DotRef () e' (var x)
9085
91− Binop op e1 e2 -> binop span op e1 e2
86+ Remove e x ->
87+ do e' <- expression e
88+ return $ obj "_N.remove" `call` [string x, e']
9289
93− Lambda p e@(L s _) -> fastFunc
90+ Insert e x v ->
91+ do v' <- expression v
92+ e' <- expression e
93+ return $ obj "_N.insert" `call` [string x, v', e']
94+
95+ Modify e fs ->
96+ do e' <- expression e
97+ fs' <- forM fs $ \(f,v) -> do
98+ v' <- expression v
99+ return $ ArrayLit () [string f, v']
100+ return $ obj "_N.replace" `call` [ArrayLit () fs', e']
101+
102+ Record fields ->
103+ do fields' <- forM fields $ \(f,e) -> do
104+ (,) f <$> expression e
105+ let fieldMap = List.foldl' combine Map.empty fields'
106+ return $ ObjectLit () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
94107 where
95− fastFunc
96− | length args < 2 || length args > 9 =
97− foldr (==>) (expression body) (map (:[]) args)
98− | otherwise =
99− ref ("F" ++ show (length args)) <| (args ==> expression body)
108+ combine r (k,v) = Map.insertWith (++) k [v] r
109+ prop = PropId () . var
110+ hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
111+ Map.toList . Map.filter (not . null) $ Map.map tail fs
112+ visible fs = map (first prop) . Map.toList $ Map.map head fs
100113
114+ Binop op e1 e2 -> binop span op e1 e2
115+
116+ Lambda p e@(L s _) ->
117+ do 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
101122 (args, body) = foldr depattern ([], innerBody) (zip patterns [0..])
102123
103124 depattern (pattern,n) (args, body) =
@@ -114,72 +135,83 @@ expression (L span expr) =
114135 _ -> (patterns, lexpr)
115136
116137 App e1 e2 ->
117− case args of
118− [arg] -> func <| arg
119− _ -> ref aN `call` (func:args)
138+ do func' <- expression func
139+ args' <- mapM expression args
140+ return $ case args' of
141+ [arg] -> func' <| arg
142+ _ -> ref aN `call` (func':args')
120143 where
121144 aN = "A" ++ show (length args)
122145 (func, args) = getArgs e1 [e2]
123146 getArgs func args =
124147 case func of
125148 (L _ (App f arg)) -> getArgs f (arg : args)
126− _ -> (expression func, map expression args)
149+ _ -> (func, args)
127150
128− Let defs e -> function [] stmts `call` []
129− where
130− (defs',e') = SD.flattenLets defs e
131− stmts = concatMap definition defs' ++ [ ReturnStmt () (Just (expression e')) ]
151+ Let defs e ->
152+ do let (defs',e') = SD.flattenLets defs e
153+ stmts <- concat <$> mapM definition defs'
154+ exp <- expression e'
155+ return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []
132156
133157 MultiIf branches ->
134− case last branches of
135− (L _ (Var "otherwise"), e) -> ifs (init branches) (expression e)
136− _ -> ifs branches (get "_E.If" `call` [ ref "$moduleName", string (show span) ])
158+ do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
159+ return $ case last branches of
160+ (L _ (Var "otherwise"), e) -> ifs (init branches') (snd (last branches'))
161+ _ -> ifs branches'
162+ (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
137163 where
138164 ifs branches finally = foldr iff finally branches
139− iff (if', then') else' = CondExpr () (expression if') (expression then') else'
140−
141− Case e cases -> function [] (stmt ++ match span revisedMatch) `call` []
142− where
143− (tempVar,initialMatch) = caseToMatch cases
144− (revisedMatch, stmt) =
145− case e of
146− L _ (Var x) -> (matchSubst [(tempVar,x)] initialMatch, [])
147− _ -> (initialMatch, [VarDeclStmt () [varDecl tempVar (expression e)]])
165+ iff (if', then') else' = CondExpr () if' then' else'
166+
167+ Case e cases ->
168+ do (tempVar,initialMatch) <- caseToMatch cases
169+ (revisedMatch, stmt) <-
170+ case e of
171+ L _ (Var x) -> return (matchSubst [(tempVar,x)] initialMatch, [])
172+ _ -> do e' <- expression e
173+ return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
174+ match' <- match span revisedMatch
175+ return (function [] (stmt ++ match') `call` [])
148176
149177 ExplicitList es ->
150− get "_J.toList" <| ArrayLit () (map expression es)
178+ do es' <- mapM expression es
179+ return $ obj "_J.toList" <| ArrayLit () es'
151180
152181 Data name es ->
153− ObjectLit () (ctor : fields)
154− where
155− ctor = (prop "ctor", string (makeSafe name))
156− fields = zipWith (\n e -> (prop ("_" ++ show n), expression e)) [0..] es
182+ do es' <- mapM expression es
183+ return $ ObjectLit () (ctor : fields es')
184+ where
185+ ctor = (prop "ctor", string (makeSafe name))
186+ fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
157187
158− Markdown doc -> get "Text.text" <| string (pad ++ md ++ pad)
188+ Markdown doc -> return $ obj "Text.text" <| string (pad ++ md ++ pad)
159189 where pad = "<div style=\"height:0;width:0;\"> </div>"
160190 md = Pan.writeHtmlString Pan.def doc
161191
162−
192+definition :: Def () () -> State Int [Statement ()]
163193definition def =
164194 case def of
165− TypeAnnotation _ _ -> []
166− Def pattern expr@(L span _) ->
167− let assign x = varDecl x (expression expr) in
195+ TypeAnnotation _ _ -> return []
196+
197+ Def pattern expr@(L span _) -> do
198+ expr' <- expression expr
199+ let assign x = varDecl x expr'
168200 case pattern of
169201 PVar x
170− | isOp x ->
171− let op = LBracket () (ref "_op") (string x) in
172− [ ExprStmt () (AssignExpr () OpAssign op (expression expr)) ]
173− | otherwise ->
174− [ VarDeclStmt () [ assign x ] ]
202+ | isOp x ->
203+ let op = LBracket () (ref "_op") (string x) in
204+ return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
205+ | otherwise ->
206+ return [ VarDeclStmt () [ assign x ] ]
175207
176− PRecord fields -> [ VarDeclStmt () (assign "$" : map setField fields) ]
177− where
178− setField f = varDecl f (dotSep ["$",f])
208+ PRecord fields ->
209+ let setField f = varDecl f (dotSep ["$",f]) in
210+ return [ VarDeclStmt () (assign "$" : map setField fields) ]
179211
180212 PData name patterns | vars /= Nothing ->
181213 case vars of
182− Just vs -> [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]
214+ Just vs -> return [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]
183215 where
184216 vars = getVars patterns
185217 getVars patterns =
@@ -193,11 +225,13 @@ definition def =
193225 | isTuple name = assign "$" : vars
194226 | otherwise = safeAssign : vars
195227
196− safeAssign = varDecl "$" (CondExpr () if' (expression expr) exception)
197− if' = InfixExpr () OpStrictEq (get "$.ctor") (string name)
198− exception = get "_E.Case" `call` [ref "$moduleName", string (show span)]
228+ safeAssign = varDecl "$" (CondExpr () if' expr' exception)
229+ if' = InfixExpr () OpStrictEq (obj "$.ctor") (string name)
230+ exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
199231
200− _ -> VarDeclStmt () [assign "$"] : concatMap toDef vars
232+ _ ->
233+ do defs' <- concat <$> mapM toDef vars
234+ return (VarDeclStmt () [assign "$"] : defs')
201235 where
202236 vars = Set.toList $ SD.boundVars pattern
203237 mkVar = L span . Var
@@ -206,18 +240,22 @@ definition def =
206240
207241match span mtch =
208242 case mtch of
209− Match name clauses mtch' -> SwitchStmt () (access name) clauses' : match span mtch'
243+ Match name clauses mtch' ->
244+ do clauses' <- mapM (clause span name) clauses
245+ mtch'' <- match span mtch'
246+ return (SwitchStmt () (access name) clauses' : mtch'')
210247 where
211− clauses' = map (clause span name) clauses
212248 isLiteral p = case p of
213249 Clause (Right _) _ _ -> True
214250 _ -> False
215251 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
216252
217− Fail -> [ ExprStmt () (get "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
218− Break -> []
219− Other e -> [ ReturnStmt () (Just $ expression e) ]
220− Seq ms -> concatMap (match span) (dropEnd [] ms)
253+ Fail -> return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
254+ Break -> return []
255+ Other e ->
256+ do e' <- expression e
257+ return [ ReturnStmt () (Just e') ]
258+ Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
221259 where
222260 dropEnd acc [] = acc
223261 dropEnd acc (m:ms) =
@@ -226,10 +264,9 @@ match span mtch =
226264 _ -> dropEnd (acc ++ [m]) ms
227265
228266clause span variable (Clause value vars mtch) =
229− CaseClause () pattern stmt
267+ CaseClause () pattern <$> match span (matchSubst (zip vars vars') mtch)
230268 where
231269 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
232− stmt = match span $ matchSubst (zip vars vars') mtch
233270 pattern = case value of
234271 Right (Boolean b) -> BoolLit () b
235272 Right lit -> literal lit
@@ -237,7 +274,8 @@ clause span variable (Clause value vars mtch) =
237274 [] -> name
238275 is -> drop (last is + 1) name
239276
240−jsModule :: MetadataModule () () -> String -- [Statement ()]
277+
278+jsModule :: MetadataModule () () -> String
241279jsModule modul = show . prettyPrint $ setup (Just "Elm") (names modul) ++
242280 [ assign ("Elm" : names modul) (function ["elm"] programStmts) ]
243281 where
@@ -249,7 +287,7 @@ jsModule modul = show . prettyPrint $ setup (Just "Elm") (names modul) ++
249287 , concatMap jsImport (imports modul)
250288 , concatMap importEvent (foreignImports modul)
251289 , [ assign ["_op"] (ObjectLit () []) ]
252− , concatMap definition . fst . SD.flattenLets [] $ program modul
290+ , concat $ evalState (mapM definition . fst . SD.flattenLets [] $ program modul) 0
253291 , map exportEvent $ foreignExports modul
254292 , [ jsExports ]
255293 , [ ReturnStmt () (Just thisModule) ]
@@ -277,42 +315,52 @@ jsModule modul = show . prettyPrint $ setup (Just "Elm") (names modul) ++
277315 Nothing -> tail . init $ List.inits path
278316 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
279317
280− addId js = InfixExpr () OpAdd (string (js++"_")) (get "elm.id")
318+ addId js = InfixExpr () OpAdd (string (js++"_")) (obj "elm.id")
281319
282320 importEvent (js,base,elm,_) =
283− [ VarDeclStmt () [ varDecl elm $ get "Signal.constant" <| expression base ]
321+ [ VarDeclStmt () [ varDecl elm $ obj "Signal.constant" <| evalState (expression base) 0 ]
284322 , ExprStmt () $
285− get "document.addEventListener" `call`
323+ obj "document.addEventListener" `call`
286324 [ addId js
287325 , function ["e"]
288− [ ExprStmt () $ get "elm.notify" `call` [dotSep [elm,"id"], get "e.value"] ]
326+ [ ExprStmt () $ obj "elm.notify" `call` [dotSep [elm,"id"], obj "e.value"] ]
289327 ]
290328 ]
291329
292330 exportEvent (js,elm,_) =
293331 ExprStmt () $
294332 ref "A2" `call`
295− [ get "Signal.lift"
333+ [ obj "Signal.lift"
296334 , function ["v"]
297− [ VarDeclStmt () [varDecl "e" $ get "document.createEvent" <| string "Event"]
335+ [ VarDeclStmt () [varDecl "e" $ obj "document.createEvent" <| string "Event"]
298336 , ExprStmt () $
299− get "e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]
337+ obj "e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]
300338 , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "e") "value") (ref "v")
301− , ExprStmt () $ get "document.dispatchEvent" <| ref "e"
339+ , ExprStmt () $ obj "document.dispatchEvent" <| ref "e"
302340 , ReturnStmt () (Just $ ref "v")
303341 ]
304342 , ref elm ]
305343
306−
307344binop span op e1 e2 =
308345 case op of
309− "Basics.." -> ["$"] ==> foldr (<|) (ref "$") (map expression (e1 : collect [] e2))
310− "Basics.<|" -> foldr (<|) (expression e2) (map expression (collect [] e1))
311− "::" -> expression (L span (Data "::" [e1,e2]))
312− "List.++" -> get "_L.append" `call` [js1, js2]
313− _ -> case Map.lookup op opDict of
314− Just f -> f js1 js2
315− Nothing -> ref "A2" `call` [ func, js1, js2 ]
346+ "Basics.." ->
347+ do es <- mapM expression (e1 : collect [] e2)
348+ return $ ["$"] ==> foldr (<|) (ref "$") es
349+ "Basics.<|" ->
350+ do e2' <- expression e2
351+ es <- mapM expression (collect [] e1)
352+ return $ foldr (<|) e2' es
353+ "List.++" ->
354+ do e1' <- expression e1
355+ e2' <- expression e2
356+ return $ obj "_L.append" `call` [e1', e2']
357+ "::" -> expression (L span (Data "::" [e1,e2]))
358+ _ ->
359+ do e1' <- expression e1
360+ e2' <- expression e2
361+ return $ case Map.lookup op opDict of
362+ Just f -> f e1' e2'
363+ Nothing -> ref "A2" `call` [ func, e1', e2' ]
316364 where
317365 collect es e =
318366 case e of
@@ -343,10 +391,10 @@ binop span op e1 e2 =
343391 ]
344392
345393 specialOps =
346− [ specialOp "^" $ \a b -> get "Math.pow" `call` [a,b]
394+ [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
347395 , specialOp "|>" $ flip (<|)
348− , specialOp "==" $ \a b -> get "_N.eq" `call` [a,b]
349− , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (get "_N.eq" `call` [a,b])
396+ , specialOp "==" $ \a b -> obj "_N.eq" `call` [a,b]
397+ , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_N.eq" `call` [a,b])
350398 , specialOp "<" $ cmp OpLT 0
351399 , specialOp ">" $ cmp OpGT 0
352400 , specialOp "<=" $ cmp OpLT 1
@@ -354,4 +402,4 @@ binop span op e1 e2 =
354402 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
355403 ]
356404
357− cmp op n a b = InfixExpr () op (get "_N.cmp" `call` [a,b]) (IntLit () n)
405+ cmp op n a b = InfixExpr () op (obj "_N.cmp" `call` [a,b]) (IntLit () n)