git.iko.soy/elk
on master help sign in
Fix problem with overlapping variable names in generated code
6b855f9Evan Czaplicki
compiler/Generate/Cases.hs+8−12
compare with master
unifiedsplit
@@ -1,7 +1,7 @@
1module Generate.Cases (caseToMatch, Match (..), Clause (..), matchSubst) where
1module Generate.Cases (caseToMatch, Match (..), Clause (..), matchSubst) where
2
2
3import Control.Applicative ((<$>),(<*>))
3import Control.Applicative ((<$>),(<*>))
4−import Control.Arrow (first)
4+import Control.Arrow (first,second)
5import Control.Monad.State
5import Control.Monad.State
6import Data.List (groupBy,sortBy,lookup)
6import Data.List (groupBy,sortBy,lookup)
7import Data.Maybe (fromMaybe)
7import Data.Maybe (fromMaybe)
@@ -13,14 +13,15 @@ import SourceSyntax.Expression
13import Transform.Substitute
13import Transform.Substitute
14
14
15
15
16−caseToMatch :: [(Pattern, LExpr t v)] -> (String, Match t v)
16+caseToMatch :: [(Pattern, LExpr t v)] -> State Int (String, Match t v)
17−caseToMatch patterns = flip evalState 0 $ do
17+caseToMatch patterns = do
18 v <- newVar
18 v <- newVar
19 (,) v <$> match [v] (map (first (:[])) patterns) Fail
19 (,) v <$> match [v] (map (first (:[])) patterns) Fail
20
20
21+newVar :: State Int String
21newVar = do n <- get
22newVar = do n <- get
22 modify (+1)
23 modify (+1)
23− return $ "case" ++ show n
24+ return $ "_case" ++ show n
24
25
25data Match t v
26data Match t v
26 = Match String [Clause t v] (Match t v)
27 = Match String [Clause t v] (Match t v)
@@ -83,8 +84,7 @@ matchVar (v:vs) cs def = match vs (map subVar cs) def
83 PRecord fs ->
84 PRecord fs ->
84 foldr (\x -> subst x (Access (L s (Var v)) x)) e fs
85 foldr (\x -> subst x (Access (L s (Var v)) x)) e fs
85
86
86−matchCon :: [String] -> [([Pattern],LExpr t v)] -> Match t v
87+matchCon :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> State Int (Match t v)
87− -> State Int (Match t v)
88matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css
88matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css
89 where
89 where
90 css = groupBy eq (sortBy cmp cs)
90 css = groupBy eq (sortBy cmp cs)
@@ -104,11 +104,7 @@ matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css
104 (PData name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
104 (PData name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
105 (PLiteral lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
105 (PLiteral lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
106
106
107−matchClause :: Either String Literal
107+--matchClause :: Either String Literal -> [String] -> [([Pattern],LExpr t v)] -> Match t v -> State Int (Clause a)
108− -> [String]
109− -> [([Pattern],LExpr t v)]
110− -> Match t v
111− -> State Int (Clause t v)
112matchClause c (v:vs) cs def =
108matchClause c (v:vs) cs def =
113 do vs' <- getVars
109 do vs' <- getVars
114 Clause c vs' <$> match (vs' ++ vs) (map flatten cs) def
110 Clause c vs' <$> match (vs' ++ vs) (map flatten cs) def
@@ -121,7 +117,7 @@ matchClause c (v:vs) cs def =
121
117
122 getVars =
118 getVars =
123 case head cs of
119 case head cs of
124− (PData _ ps : _, _) -> mapM (\_ -> newVar) ps
120+ (PData _ ps : _, _) -> forM ps (const newVar)
125 (PLiteral _ : _, _) -> return []
121 (PLiteral _ : _, _) -> return []
126
122
127matchMix :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> State Int (Match t v)
123matchMix :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> State Int (Match t v)
compiler/Generate/JavaScript.hs+150−102
@@ -1,6 +1,8 @@
1module Generate.JavaScript where
1module Generate.JavaScript where
2
2
3−import Control.Arrow ((***))
3+import Control.Arrow (first,(***))
4+import Control.Applicative ((<$>),(<*>))
5+import Control.Monad.State
4import qualified Data.List as List
6import qualified Data.List as List
5import qualified Data.Map as Map
7import qualified Data.Map as Map
6import qualified Data.Set as Set
8import qualified Data.Set as Set
@@ -39,22 +41,22 @@ call = CallExpr ()
39string = StringLit ()
41string = StringLit ()
40
42
41dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)
43dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)
42−get = dotSep . split
44+obj = dotSep . split
43
45
44varDecl x expr =
46varDecl x expr =
45 VarDecl () (var x) (Just expr)
47 VarDecl () (var x) (Just expr)
46
48
47include alias moduleName =
49include alias moduleName =
48− varDecl alias (get moduleName <| ref "elm")
50+ varDecl alias (obj moduleName <| ref "elm")
49
51
50internalImports name =
52internalImports name =
51 VarDeclStmt ()
53 VarDeclStmt ()
52− [ varDecl "N" (get "Elm.Native")
54+ [ varDecl "N" (obj "Elm.Native")
53 , include "_N" "N.Utils"
55 , include "_N" "N.Utils"
54 , include "_L" "N.List"
56 , include "_L" "N.List"
55 , include "_E" "N.Error"
57 , include "_E" "N.Error"
56 , include "_J" "N.JavaScript"
58 , include "_J" "N.JavaScript"
57− , varDecl "_str" (get "_J.toString")
59+ , varDecl "_str" (obj "_J.toString")
58 , varDecl "$moduleName" (string name)
60 , varDecl "$moduleName" (string name)
59 ]
61 ]
60
62
@@ -66,38 +68,57 @@ literal lit =
66 FloatNum n -> NumLit () n
68 FloatNum n -> NumLit () n
67 Boolean b -> BoolLit () b
69 Boolean b -> BoolLit () b
68
70
69−expression :: LExpr () () -> Expression ()
71+expression :: LExpr () () -> State Int (Expression ())
70expression (L span expr) =
72expression (L span expr) =
71 case expr of
73 case expr of
72− Var x -> ref x
74+ Var x -> return $ ref x
73− Literal lit -> literal lit
75+ Literal lit -> return $ literal lit
74− Range lo hi -> get "_L.range" `call` [expression lo, expression hi]
75
76
76− Access e x -> DotRef () (expression e) (var x)
77+ Range lo hi ->
77− Remove e x -> get "_N.remove" `call` [string x, expression e]
78+ do lo' <- expression lo
78− Insert e x v -> get "_N.insert" `call` [string x, expression v, expression e]
79+ hi' <- expression hi
79− Modify e fs ->
80+ return $ obj "_L.range" `call` [lo',hi']
80− let modify (f,v) = ArrayLit () [string f, expression v]
81− in get "_N.replace" `call` [ArrayLit () (map modify fs), expression e]
82
81
83− Record fields -> ObjectLit () $ (PropId () (var "_"), hidden) : visible
82+ Access e x ->
84− where
83+ do e' <- expression e
85− combine r (k,v) = Map.insertWith (++) k [v] r
84+ return $ DotRef () e' (var x)
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
90
85
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']
92
89
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
94 where
107 where
95− fastFunc
108+ combine r (k,v) = Map.insertWith (++) k [v] r
96− | length args < 2 || length args > 9 =
109+ prop = PropId () . var
97− foldr (==>) (expression body) (map (:[]) args)
110+ hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
98− | otherwise =
111+ Map.toList . Map.filter (not . null) $ Map.map tail fs
99− ref ("F" ++ show (length args)) <| (args ==> expression body)
112+ visible fs = map (first prop) . Map.toList $ Map.map head fs
100
113
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
101 (args, body) = foldr depattern ([], innerBody) (zip patterns [0..])
122 (args, body) = foldr depattern ([], innerBody) (zip patterns [0..])
102
123
103 depattern (pattern,n) (args, body) =
124 depattern (pattern,n) (args, body) =
@@ -114,72 +135,83 @@ expression (L span expr) =
114 _ -> (patterns, lexpr)
135 _ -> (patterns, lexpr)
115
136
116 App e1 e2 ->
137 App e1 e2 ->
138+ do func' <- expression func
139+ args' <- mapM expression args
117− case args of
140+ return $ case args' of
118− [arg] -> func <| arg
141+ [arg] -> func' <| arg
119− _ -> ref aN `call` (func:args)
142+ _ -> ref aN `call` (func':args')
120 where
143 where
121 aN = "A" ++ show (length args)
144 aN = "A" ++ show (length args)
122 (func, args) = getArgs e1 [e2]
145 (func, args) = getArgs e1 [e2]
123 getArgs func args =
146 getArgs func args =
124 case func of
147 case func of
125 (L _ (App f arg)) -> getArgs f (arg : args)
148 (L _ (App f arg)) -> getArgs f (arg : args)
126− _ -> (expression func, map expression args)
149+ _ -> (func, args)
127
150
128− Let defs e -> function [] stmts `call` []
151+ Let defs e ->
129− where
130− (defs',e') = SD.flattenLets defs e
152+ do let (defs',e') = SD.flattenLets defs e
131− stmts = concatMap definition defs' ++ [ ReturnStmt () (Just (expression e')) ]
153+ stmts <- concat <$> mapM definition defs'
154+ exp <- expression e'
155+ return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []
132
156
133 MultiIf branches ->
157 MultiIf branches ->
158+ do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
134− case last branches of
159+ return $ case last branches of
135− (L _ (Var "otherwise"), e) -> ifs (init branches) (expression e)
160+ (L _ (Var "otherwise"), e) -> ifs (init branches') (snd (last branches'))
161+ _ -> ifs branches'
136− _ -> ifs branches (get "_E.If" `call` [ ref "$moduleName", string (show span) ])
162+ (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
137 where
163 where
138 ifs branches finally = foldr iff finally branches
164 ifs branches finally = foldr iff finally branches
139− iff (if', then') else' = CondExpr () (expression if') (expression then') else'
165+ iff (if', then') else' = CondExpr () if' then' else'
140−
166+
141− Case e cases -> function [] (stmt ++ match span revisedMatch) `call` []
167+ Case e cases ->
142− where
143− (tempVar,initialMatch) = caseToMatch cases
168+ do (tempVar,initialMatch) <- caseToMatch cases
144− (revisedMatch, stmt) =
169+ (revisedMatch, stmt) <-
145− case e of
170+ case e of
146− L _ (Var x) -> (matchSubst [(tempVar,x)] initialMatch, [])
171+ L _ (Var x) -> return (matchSubst [(tempVar,x)] initialMatch, [])
172+ _ -> do e' <- expression e
147− _ -> (initialMatch, [VarDeclStmt () [varDecl tempVar (expression e)]])
173+ return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
174+ match' <- match span revisedMatch
175+ return (function [] (stmt ++ match') `call` [])
148
176
149 ExplicitList es ->
177 ExplicitList es ->
178+ do es' <- mapM expression es
150− get "_J.toList" <| ArrayLit () (map expression es)
179+ return $ obj "_J.toList" <| ArrayLit () es'
151
180
152 Data name es ->
181 Data name es ->
182+ do es' <- mapM expression es
153− ObjectLit () (ctor : fields)
183+ return $ ObjectLit () (ctor : fields es')
154− where
184+ where
155− ctor = (prop "ctor", string (makeSafe name))
185+ ctor = (prop "ctor", string (makeSafe name))
156− fields = zipWith (\n e -> (prop ("_" ++ show n), expression e)) [0..] es
186+ fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
157
187
158− Markdown doc -> get "Text.text" <| string (pad ++ md ++ pad)
188+ Markdown doc -> return $ obj "Text.text" <| string (pad ++ md ++ pad)
159 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
189 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
160 md = Pan.writeHtmlString Pan.def doc
190 md = Pan.writeHtmlString Pan.def doc
161
191
162−
192+definition :: Def () () -> State Int [Statement ()]
163definition def =
193definition def =
164 case def of
194 case def of
165− TypeAnnotation _ _ -> []
195+ TypeAnnotation _ _ -> return []
196+
166− Def pattern expr@(L span _) ->
197+ Def pattern expr@(L span _) -> do
198+ expr' <- expression expr
167− let assign x = varDecl x (expression expr) in
199+ let assign x = varDecl x expr'
168 case pattern of
200 case pattern of
169 PVar x
201 PVar x
170− | isOp x ->
202+ | isOp x ->
171− let op = LBracket () (ref "_op") (string x) in
203+ let op = LBracket () (ref "_op") (string x) in
172− [ ExprStmt () (AssignExpr () OpAssign op (expression expr)) ]
204+ return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
173− | otherwise ->
205+ | otherwise ->
174− [ VarDeclStmt () [ assign x ] ]
206+ return [ VarDeclStmt () [ assign x ] ]
175
207
208+ PRecord fields ->
209+ let setField f = varDecl f (dotSep ["$",f]) in
176− PRecord fields -> [ VarDeclStmt () (assign "$" : map setField fields) ]
210+ return [ VarDeclStmt () (assign "$" : map setField fields) ]
177− where
178− setField f = varDecl f (dotSep ["$",f])
179
211
180 PData name patterns | vars /= Nothing ->
212 PData name patterns | vars /= Nothing ->
181 case vars of
213 case vars of
182− Just vs -> [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]
214+ Just vs -> return [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]
183 where
215 where
184 vars = getVars patterns
216 vars = getVars patterns
185 getVars patterns =
217 getVars patterns =
@@ -193,11 +225,13 @@ definition def =
193 | isTuple name = assign "$" : vars
225 | isTuple name = assign "$" : vars
194 | otherwise = safeAssign : vars
226 | otherwise = safeAssign : vars
195
227
196− safeAssign = varDecl "$" (CondExpr () if' (expression expr) exception)
228+ safeAssign = varDecl "$" (CondExpr () if' expr' exception)
197− if' = InfixExpr () OpStrictEq (get "$.ctor") (string name)
229+ if' = InfixExpr () OpStrictEq (obj "$.ctor") (string name)
198− exception = get "_E.Case" `call` [ref "$moduleName", string (show span)]
230+ exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
199
231
232+ _ ->
233+ do defs' <- concat <$> mapM toDef vars
200− _ -> VarDeclStmt () [assign "$"] : concatMap toDef vars
234+ return (VarDeclStmt () [assign "$"] : defs')
201 where
235 where
202 vars = Set.toList $ SD.boundVars pattern
236 vars = Set.toList $ SD.boundVars pattern
203 mkVar = L span . Var
237 mkVar = L span . Var
@@ -206,18 +240,22 @@ definition def =
206
240
207match span mtch =
241match span mtch =
208 case mtch of
242 case mtch of
243+ Match name clauses mtch' ->
244+ do clauses' <- mapM (clause span name) clauses
245+ mtch'' <- match span mtch'
209− Match name clauses mtch' -> SwitchStmt () (access name) clauses' : match span mtch'
246+ return (SwitchStmt () (access name) clauses' : mtch'')
210 where
247 where
211− clauses' = map (clause span name) clauses
212 isLiteral p = case p of
248 isLiteral p = case p of
213 Clause (Right _) _ _ -> True
249 Clause (Right _) _ _ -> True
214 _ -> False
250 _ -> False
215 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
251 access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
216
252
217− Fail -> [ ExprStmt () (get "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
253+ Fail -> return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
218− Break -> []
254+ Break -> return []
255+ Other e ->
256+ do e' <- expression e
219− Other e -> [ ReturnStmt () (Just $ expression e) ]
257+ return [ ReturnStmt () (Just e') ]
220− Seq ms -> concatMap (match span) (dropEnd [] ms)
258+ Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
221 where
259 where
222 dropEnd acc [] = acc
260 dropEnd acc [] = acc
223 dropEnd acc (m:ms) =
261 dropEnd acc (m:ms) =
@@ -226,10 +264,9 @@ match span mtch =
226 _ -> dropEnd (acc ++ [m]) ms
264 _ -> dropEnd (acc ++ [m]) ms
227
265
228clause span variable (Clause value vars mtch) =
266clause span variable (Clause value vars mtch) =
229− CaseClause () pattern stmt
267+ CaseClause () pattern <$> match span (matchSubst (zip vars vars') mtch)
230 where
268 where
231 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
269 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
232− stmt = match span $ matchSubst (zip vars vars') mtch
233 pattern = case value of
270 pattern = case value of
234 Right (Boolean b) -> BoolLit () b
271 Right (Boolean b) -> BoolLit () b
235 Right lit -> literal lit
272 Right lit -> literal lit
@@ -237,7 +274,8 @@ clause span variable (Clause value vars mtch) =
237 [] -> name
274 [] -> name
238 is -> drop (last is + 1) name
275 is -> drop (last is + 1) name
239
276
277+
240−jsModule :: MetadataModule () () -> String -- [Statement ()]
278+jsModule :: MetadataModule () () -> String
241jsModule modul = show . prettyPrint $ setup (Just "Elm") (names modul) ++
279jsModule modul = show . prettyPrint $ setup (Just "Elm") (names modul) ++
242 [ assign ("Elm" : names modul) (function ["elm"] programStmts) ]
280 [ assign ("Elm" : names modul) (function ["elm"] programStmts) ]
243 where
281 where
@@ -249,7 +287,7 @@ jsModule modul = show . prettyPrint $ setup (Just "Elm") (names modul) ++
249 , concatMap jsImport (imports modul)
287 , concatMap jsImport (imports modul)
250 , concatMap importEvent (foreignImports modul)
288 , concatMap importEvent (foreignImports modul)
251 , [ assign ["_op"] (ObjectLit () []) ]
289 , [ assign ["_op"] (ObjectLit () []) ]
252− , concatMap definition . fst . SD.flattenLets [] $ program modul
290+ , concat $ evalState (mapM definition . fst . SD.flattenLets [] $ program modul) 0
253 , map exportEvent $ foreignExports modul
291 , map exportEvent $ foreignExports modul
254 , [ jsExports ]
292 , [ jsExports ]
255 , [ ReturnStmt () (Just thisModule) ]
293 , [ ReturnStmt () (Just thisModule) ]
@@ -277,42 +315,52 @@ jsModule modul = show . prettyPrint $ setup (Just "Elm") (names modul) ++
277 Nothing -> tail . init $ List.inits path
315 Nothing -> tail . init $ List.inits path
278 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
316 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
279
317
280− addId js = InfixExpr () OpAdd (string (js++"_")) (get "elm.id")
318+ addId js = InfixExpr () OpAdd (string (js++"_")) (obj "elm.id")
281
319
282 importEvent (js,base,elm,_) =
320 importEvent (js,base,elm,_) =
283− [ VarDeclStmt () [ varDecl elm $ get "Signal.constant" <| expression base ]
321+ [ VarDeclStmt () [ varDecl elm $ obj "Signal.constant" <| evalState (expression base) 0 ]
284 , ExprStmt () $
322 , ExprStmt () $
285− get "document.addEventListener" `call`
323+ obj "document.addEventListener" `call`
286 [ addId js
324 [ addId js
287 , function ["e"]
325 , 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"] ]
289 ]
327 ]
290 ]
328 ]
291
329
292 exportEvent (js,elm,_) =
330 exportEvent (js,elm,_) =
293 ExprStmt () $
331 ExprStmt () $
294 ref "A2" `call`
332 ref "A2" `call`
295− [ get "Signal.lift"
333+ [ obj "Signal.lift"
296 , function ["v"]
334 , function ["v"]
297− [ VarDeclStmt () [varDecl "e" $ get "document.createEvent" <| string "Event"]
335+ [ VarDeclStmt () [varDecl "e" $ obj "document.createEvent" <| string "Event"]
298 , ExprStmt () $
336 , ExprStmt () $
299− get "e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]
337+ obj "e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]
300 , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "e") "value") (ref "v")
338 , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "e") "value") (ref "v")
301− , ExprStmt () $ get "document.dispatchEvent" <| ref "e"
339+ , ExprStmt () $ obj "document.dispatchEvent" <| ref "e"
302 , ReturnStmt () (Just $ ref "v")
340 , ReturnStmt () (Just $ ref "v")
303 ]
341 ]
304 , ref elm ]
342 , ref elm ]
305
343
306−
307binop span op e1 e2 =
344binop span op e1 e2 =
308 case op of
345 case op of
346+ "Basics.." ->
309− "Basics.." -> ["$"] ==> foldr (<|) (ref "$") (map expression (e1 : collect [] e2))
347+ do es <- mapM expression (e1 : collect [] e2)
348+ return $ ["$"] ==> foldr (<|) (ref "$") es
349+ "Basics.<|" ->
350+ do e2' <- expression e2
310− "Basics.<|" -> foldr (<|) (expression e2) (map expression (collect [] e1))
351+ es <- mapM expression (collect [] e1)
311− "::" -> expression (L span (Data "::" [e1,e2]))
352+ return $ foldr (<|) e2' es
353+ "List.++" ->
354+ do e1' <- expression e1
355+ e2' <- expression e2
312− "List.++" -> get "_L.append" `call` [js1, js2]
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
313− _ -> case Map.lookup op opDict of
361+ return $ case Map.lookup op opDict of
314− Just f -> f js1 js2
362+ Just f -> f e1' e2'
315− Nothing -> ref "A2" `call` [ func, js1, js2 ]
363+ Nothing -> ref "A2" `call` [ func, e1', e2' ]
316 where
364 where
317 collect es e =
365 collect es e =
318 case e of
366 case e of
@@ -343,10 +391,10 @@ binop span op e1 e2 =
343 ]
391 ]
344
392
345 specialOps =
393 specialOps =
346− [ specialOp "^" $ \a b -> get "Math.pow" `call` [a,b]
394+ [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
347 , specialOp "|>" $ flip (<|)
395 , specialOp "|>" $ flip (<|)
348− , specialOp "==" $ \a b -> get "_N.eq" `call` [a,b]
396+ , specialOp "==" $ \a b -> obj "_N.eq" `call` [a,b]
349− , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (get "_N.eq" `call` [a,b])
397+ , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_N.eq" `call` [a,b])
350 , specialOp "<" $ cmp OpLT 0
398 , specialOp "<" $ cmp OpLT 0
351 , specialOp ">" $ cmp OpGT 0
399 , specialOp ">" $ cmp OpGT 0
352 , specialOp "<=" $ cmp OpLT 1
400 , specialOp "<=" $ cmp OpLT 1
@@ -354,4 +402,4 @@ binop span op e1 e2 =
354 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
402 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
355 ]
403 ]
356
404
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)