@@ -1,293 +1,223 @@
1−module Generate.JavaScript (jsModule) where
1+module Generate.JavaScript where
3−import Control.Arrow (first,second)
3+import Control.Arrow ((***))
4−import Control.Monad (liftM,(<=<),join,ap)
5−import Data.Char (isAlpha,isDigit)
6import qualified Data.List as List
4import qualified Data.List as List
7import qualified Data.Map as Map
5import qualified Data.Map as Map
8import qualified Data.Set as Set
6import qualified Data.Set as Set
9−import Data.Either (partitionEithers)
10import qualified Text.Pandoc as Pan
7import qualified Text.Pandoc as Pan
13import Generate.Cases
9import Generate.Cases
14import SourceSyntax.Everything
10import SourceSyntax.Everything
15import SourceSyntax.Location
11import SourceSyntax.Location
16import qualified Transform.SortDefinitions as SD
12import qualified Transform.SortDefinitions as SD
13+import Language.ECMAScript3.Syntax
14+import Language.ECMAScript3.PrettyPrint
15+import Parse.Helpers (jsReserveds)
18−indent = concatMap f
17+makeSafe :: String -> String
19− where f '\n' = "\n "
18+makeSafe = dereserve . deprime
22−internalImports name =
23− [ ("N" , "Elm.Native"),
24− ("_N", "N.Utils(elm)"),
25− ("_L", "N.List(elm)"),
26− ("_E", "N.Error(elm)"),
27− ("_J", "N.JavaScript(elm)"),
28− ("_str", "_J.toString"),
29− ("$moduleName", quoted name)
32−parens s = "(" ++ s ++ ")"
33−brackets s = "{" ++ s ++ "}"
34−commaSep = List.intercalate ", "
35−dotSep = List.intercalate "."
36−jsObj = brackets . commaSep
37−jsList ss = "["++ List.intercalate "," ss ++"]"
38−jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
39−assign x e = "\nvar " ++ x ++ " = " ++ e ++ ";"
40−ret e = "\nreturn "++ e ++";"
41−quoted s = "'" ++ concatMap f s ++ "'"
49−globalAssign n e = "\n" ++ assign' n e ++ ";"
50−assign' n e = n ++ " = " ++ e
52−jsModule :: MetadataModule t v -> String
55− body <- toJS . fst . SD.flattenLets [] $ program modul
56− foreignImport <- mapM importEvent (foreignImports modul)
57− return $ concat [ setup ("Elm" : names modul)
58− , globalAssign ("Elm." ++ modName)
59− (jsFunc "elm" $ makeProgram body foreignImport) ]
61− modName = dotSep (names modul)
20+ deprime = map (\c -> if c == '\'' then '$' else c)
62− makeProgram body foreignImport =
21+ dereserve x = case Set.member x jsReserveds of
63− concat [ setup ("elm" : names modul)
22+ False -> x
64− , "\nif (elm." ++ modName ++ ") return elm." ++ modName ++ ";"
23+ True -> "$" ++ x
65− , "\nvar " ++ usefulFuncs ++ ";"
66− , concatMap jsImport (imports modul)
67− , concat foreignImport
70− , concatMap exportEvent $ foreignExports modul
73− setup names = concatMap (\n -> globalAssign n $ n ++ " || {}") .
74− map dotSep . drop 2 . List.inits $ init names
75− usefulFuncs = commaSep (map (uncurry assign') (internalImports modName))
77− jsExports = ret (assign' ("elm." ++ modName) (brackets exs))
79− exs = indent . commaSep . concatMap pair $ "_op" : exports modul
81− | otherwise = ["\n" ++ x ++ " : " ++ x]
84− importEvent (js,base,elm,_) =
86− return $ concat [ "\nvar " ++ elm ++ "=Signal.constant(" ++ v ++ ");"
87− , "\ndocument.addEventListener('", js
88− , "_' + elm.id, function(e) { elm.notify(", elm
89− , ".id, e.value); });" ]
91− exportEvent (js,elm,_) =
25+split = go []
92− concat [ "\nA2( Signal.lift, function(v) { "
93− , "var e = document.createEvent('Event');"
94− , "e.initEvent('", js, "_' + elm.id, true, true);"
96− , "document.dispatchEvent(e); return v; }, ", elm, ");" ]
98−jsImport (modul, method) =
99− concat $ zipWith3 (\s n v -> s ++ assign' n v ++ ";") starters subnames values
101− starters = "\nvar " : repeat "\n"
27+ go vars str =
102− values = map (\name -> name ++ " || {}") (init subnames) ++
28+ case break (=='.') str of
103− ["Elm." ++ modul ++ parens "elm"]
29+ (x,'.':rest) -> go (vars ++ [x]) rest
104− subnames = map dotSep . tail . List.inits $ split modul
30+ (x,[]) -> vars ++ [x]
106− split names = case go [] names of
107− (name, []) -> [name]
108− (name, ns) -> name : split ns
109− go name str = case str of
110− '.':rest -> (reverse name, rest)
111− c:rest -> go (c:name) rest
112− [] -> (reverse name, [])
116− toJS :: a -> Unique String
119−instance ToJS (Def t v) where
32+var name = Id () (makeSafe name)
33+ref name = VarRef () (var name)
34+prop name = PropId () (var name)
35+f <| x = CallExpr () f [x]
36+args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ]
37+function args stmts = FuncExpr () Nothing (map var args) stmts
121− -- TODO: Make this handle patterns besides plain variables
41+dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)
122− toJS (Def (PVar x) e)
42+get = dotSep . split
123− | isOp x = globalAssign ("_op['" ++ x ++ "']") `liftM` toJS' e
124− | otherwise = assign x `liftM` toJS' e
126− toJS (Def pattern e@(L s _)) =
44+varDecl x expr =
127− do n <- guid
45+ VarDecl () (var x) (Just expr)
128− let x = "_" ++ show n
130− toDef y = Def (PVar y) (L s $ Case (var x) [(pattern, var y)])
131− stmt <- assign x `liftM` toJS' e
132− vars <- toJS . map toDef . Set.toList $ SD.boundVars pattern
133− return (stmt ++ vars)
135− toJS (TypeAnnotation _ _) = return ""
47+include alias moduleName =
48+ varDecl alias (get moduleName <| ref "elm")
50+internalImports name =
52+ [ varDecl "N" (get "Elm.Native")
53+ , include "_N" "N.Utils"
54+ , include "_L" "N.List"
55+ , include "_E" "N.Error"
56+ , include "_J" "N.JavaScript"
57+ , varDecl "_str" (get "_J.toString")
58+ , varDecl "$moduleName" (string name)
138−instance ToJS a => ToJS [a] where
61+literal lit =
139− toJS xs = concat `liftM` mapM toJS xs
141−toJS' :: LExpr t v -> Unique String
142−toJS' (L span expr) =
144− MultiIf ps -> multiIfToJS span ps
145− Case e cases -> caseToJS span e cases
148−remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
149−addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
150−setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
151− where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
152−access x e = e ++ "." ++ x
153−makeRecord kvs = record `liftM` collect kvs
155− combine r (k,v) = Map.insertWith (++) k v r
156− collect = liftM (List.foldl' combine Map.empty) . mapM prep
161− brackets ("\n "++List.intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
162− hidden = fields . map (second jsList) .
163− filter (not . null . snd) . Map.toList . Map.map tail
164− record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
167−instance ToJS Literal where
169 case lit of
62 case lit of
170− Chr c -> return $ quoted [c]
63+ Chr c -> string [c]
171− Str s -> return $ "_str" ++ parens (quoted s)
64+ Str s -> ref "_str" <| string s
172− IntNum n -> return $ show n
65+ IntNum n -> IntLit () n
173− FloatNum n -> return $ show n
66+ FloatNum n -> NumLit () n
174− Boolean b -> return $ if b then "true" else "false"
67+ Boolean b -> BoolLit () b
176−
69+expression :: LExpr () () -> Expression ()
177−instance ToJS (Expr t v) where
70+expression (L span expr) =
179− case expr of
71+ case expr of
180− Var x -> return x
72+ Var x -> ref x
181− Literal lit -> toJS lit
73+ Literal lit -> literal lit
182− Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
74+ Range lo hi -> get "_L.range" `call` [expression lo, expression hi]
183− Access e x -> access x `liftM` toJS' e
75+
76+ Access e x -> DotRef () (expression e) (var x)
184− Remove e x -> remove x `liftM` toJS' e
77+ Remove e x -> get "_N.remove" `call` [string x, expression e]
185− Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
78+ Insert e x v -> get "_N.insert" `call` [string x, expression v, expression e]
186− Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
79+ Modify e fs ->
187− setField fs' `liftM` toJS' e
80+ let modify (f,v) = ArrayLit () [string f, expression v]
188− Record fs -> makeRecord fs
81+ in get "_N.replace" `call` [ArrayLit () (map modify fs), expression e]
189− Binop op e1 e2 -> binop op e1 e2
82+
190−
83+ Record fields -> ObjectLit () $ (PropId () (var "_"), hidden) : visible
191− Lambda p e@(L s _) -> liftM fastFunc (toJS' body)
193− fastFunc body
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
91+ Binop op e1 e2 -> binop span op e1 e2
93+ Lambda p e@(L s _) -> fastFunc
194− | length args < 2 || length args > 9 =
96+ | length args < 2 || length args > 9 =
195− foldr (\arg bod -> jsFunc arg (ret bod)) body args
97+ foldr (==>) (expression body) (map (:[]) args)
196− | otherwise =
98+ | otherwise =
197− "F" ++ show (length args) ++ parens (jsFunc (commaSep args) (ret body))
99+ ref ("F" ++ show (length args)) <| (args ==> expression body)
199− (args, body) = first reverse $ foldr depattern ([], innerBody) (zip patterns [1..])
101+ (args, body) = foldr depattern ([], innerBody) (zip patterns [0..])
201− depattern (pattern,n) (args, body) =
103+ depattern (pattern,n) (args, body) =
202− case pattern of
104+ case pattern of
203− PVar x -> (x : args, body)
105+ PVar x -> (args ++ [x], body)
204− _ -> let arg = "arg" ++ show n
106+ _ -> let arg = "arg" ++ show n
205− in (arg:args, L s (Case (L s (Var arg)) [(pattern, body)]))
107+ in (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
207− (patterns, innerBody) = collect [p] e
109+ (patterns, innerBody) = collect [p] e
209− collect patterns lexpr@(L _ expr) =
111+ collect patterns lexpr@(L _ expr) =
210− case expr of
112+ case expr of
211− Lambda p e -> collect (p:patterns) e
113+ Lambda p e -> collect (p:patterns) e
212− _ -> (patterns, lexpr)
114+ _ -> (patterns, lexpr)
214− App e1 e2 -> jsApp e1 e2
116+ App e1 e2 ->
118+ [arg] -> func <| arg
119+ _ -> ref aN `call` (func:args)
121+ aN = "A" ++ show (length args)
122+ (func, args) = getArgs e1 [e2]
125+ (L _ (App f arg)) -> getArgs f (arg : args)
126+ _ -> (expression func, map expression args)
128+ Let defs e -> function [] stmts `call` []
215− Let defs e -> jsLet $ SD.flattenLets defs e
130+ (defs',e') = SD.flattenLets defs e
216−
131+ stmts = concatMap definition defs' ++ [ ReturnStmt () (Just (expression e')) ]
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) ])
138+ ifs branches finally = foldr iff finally branches
139+ iff (if', then') else' = CondExpr () (expression if') (expression then') else'
141+ Case e cases -> function [] (stmt ++ match span revisedMatch) `call` []
143+ (tempVar,initialMatch) = caseToMatch cases
144+ (revisedMatch, stmt) =
146+ L _ (Var x) -> (matchSubst [(tempVar,x)] initialMatch, [])
147+ _ -> (initialMatch, [VarDeclStmt () [varDecl tempVar (expression e)]])
217− ExplicitList es ->
149+ ExplicitList es ->
218− do es' <- mapM toJS' es
150+ get "_J.toList" <| ArrayLit () (map expression es)
219− return $ "_J.toList" ++ parens (jsList es')
151+
221− Data name es ->
152+ Data name es ->
222− do fs <- mapM toJS' es
153+ ObjectLit () (ctor : fields)
223− return $ case name of
154+ where
224− "[]" -> jsNil
155+ ctor = (prop "ctor", string (makeSafe name))
225− "::" -> jsCons (head fs) ((head . tail) fs)
226− _ -> jsObj $ ("ctor:" ++ show name) : fields
227− where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
156+ fields = zipWith (\n e -> (prop ("_" ++ show n), expression e)) [0..] es
229− Markdown doc -> return $ "Text.text('" ++ pad ++ md ++ pad ++ "')"
158+ Markdown doc -> get "Text.text" <| string (pad ++ md ++ pad)
230− where pad = "<div style=\"height:0;width:0;\"> </div>"
159+ where pad = "<div style=\"height:0;width:0;\"> </div>"
231− md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
160+ md = Pan.writeHtmlString Pan.def doc
234− do f <- toJS' func
163+definition def =
235− as <- mapM toJS' args
164+ case def of
236− return $ case as of
165+ TypeAnnotation _ _ -> []
237− [a] -> f ++ parens a
166+ Def pattern expr@(L span _) ->
238− _ -> "A" ++ show (length as) ++ parens (commaSep (f:as))
167+ let assign x = varDecl x (expression expr) in
239− where
168+ case pattern of
240− (func, args) = go [e2] e1
169+ PVar x
241− go args e =
170+ | isOp x ->
242− case e of
171+ let op = LBracket () (ref "_op") (string x) in
243− (L _ (App e1 e2)) -> go (e2 : args) e1
172+ [ ExprStmt () (AssignExpr () OpAssign op (expression expr)) ]
244− _ -> (e, args)
173+ | otherwise ->
245−
174+ [ VarDeclStmt () [ assign x ] ]
246−formatMarkdown = concatMap f
175+
247− where f '\'' = "\\'"
176+ PRecord fields -> [ VarDeclStmt () (assign "$" : map setField fields) ]
248− f '\n' = "\\n"
177+ where
249− f '"' = "\""
178+ setField f = varDecl f (dotSep ["$",f])
251−
180+ PData name patterns | vars /= Nothing ->
252−multiIfToJS span ps =
181+ case vars of
253− case last ps of
182+ Just vs -> [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]
254− (L _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
255− _ -> format ("_E.If" ++ parens ("$moduleName," ++ quoted (show span))) ps
257− format base ps =
184+ vars = getVars patterns
258− foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
185+ getVars patterns =
259− f (b,e) = do b' <- toJS' b
186+ case patterns of
260− e' <- toJS' e
187+ PVar x : rest -> (x:) `fmap` getVars rest
261− return (b' ++ " ? " ++ e')
188+ [] -> Just []
263−jsLet (defs,e') = do ds <- mapM toJS defs
190+
264− e <- toJS' e'
191+ decl x n = varDecl x (dotSep ["$","_" ++ show n])
265− return $ jsFunc "" (concat ds ++ ret e) ++ "()"
192+ setup vars
266−
193+ | isTuple name = assign "$" : vars
267−caseToJS span e ps = do
194+ | otherwise = safeAssign : vars
268− (tempVar,match) <- caseToMatch ps
195+
269− e' <- toJS' e
196+ safeAssign = varDecl "$" (CondExpr () if' (expression expr) exception)
270− let (match',stmt) = case e of
197+ if' = InfixExpr () OpStrictEq (get "$.ctor") (string name)
271− L _ (Var x) -> (matchSubst [(tempVar,x)] match, "")
198+ exception = get "_E.Case" `call` [ref "$moduleName", string (show span)]
272− _ -> (match, assign tempVar e')
199+
273− matches <- matchToJS span match'
200+ _ -> VarDeclStmt () [assign "$"] : concatMap toDef vars
274− return $ jsFunc "" (stmt ++ matches) ++ "()"
201+ where
275−
202+ vars = Set.toList $ SD.boundVars pattern
276−matchToJS span match =
203+ mkVar = L span . Var
204+ toDef y = definition $
205+ Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])
277− case match of
208+ case mtch of
278− Match name clauses def ->
209+ Match name clauses mtch' -> SwitchStmt () (access name) clauses' : match span mtch'
279− do cases <- concat `liftM` mapM (clauseToJS span name) clauses
210+ where
280− finally <- matchToJS span def
211+ clauses' = map (clause span name) clauses
281− let isLiteral p = case p of
212+ isLiteral p = case p of
282− Clause (Right _) _ _ -> True
213+ Clause (Right _) _ _ -> True
283− _ -> False
214+ _ -> False
284− access = if any isLiteral clauses then "" else ".ctor"
215+ access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
285− return $ concat [ "\nswitch (", name, access, ") {"
216+
286− , indent cases, "\n}", finally ]
287− Fail -> return ("_E.Case" ++ parens ("$moduleName," ++ quoted (show span)))
217+ Fail -> [ ExprStmt () (get "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
288− Break -> return "break;"
218+ Break -> []
289− Other e -> ret `liftM` toJS' e
219+ Other e -> [ ReturnStmt () (Just $ expression e) ]
290− Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)
220+ Seq ms -> concatMap (match span) (dropEnd [] ms)
292 dropEnd acc [] = acc
222 dropEnd acc [] = acc
293 dropEnd acc (m:ms) =
223 dropEnd acc (m:ms) =
@@ -295,68 +225,133 @@ matchToJS span match =
295 Other _ -> acc ++ [m]
225 Other _ -> acc ++ [m]
296 _ -> dropEnd (acc ++ [m]) ms
226 _ -> dropEnd (acc ++ [m]) ms
298−clauseToJS span var (Clause value vars e) = do
228+clause span variable (Clause value vars mtch) =
229+ CaseClause () pattern stmt
299− let vars' = map (\n -> var ++ "._" ++ show n) [0..]
231+ vars' = map (\n -> variable ++ "._" ++ show n) [0..]
300− s <- matchToJS span $ matchSubst (zip vars vars') e
232+ stmt = match span $ matchSubst (zip vars vars') mtch
301− pattern <- case value of
233+ pattern = case value of
302− Right (Boolean True) -> return "true"
234+ Right (Boolean b) -> BoolLit () b
303− Right (Boolean False) -> return "false"
304− Right lit -> toJS lit
235+ Right lit -> literal lit
305− Left name -> return . quoted $ case List.elemIndices '.' name of
236+ Left name -> string $ case List.elemIndices '.' name of
306− [] -> name
237+ [] -> name
307− is -> drop (last is + 1) name
238+ is -> drop (last is + 1) name
308− return $ concat [ "\ncase ", pattern, ":", indent s ]
239+
309−
240+jsModule :: MetadataModule () () -> String -- [Statement ()]
310−jsNil = "_L.Nil"
241+jsModule modul = show . prettyPrint $ setup (Just "Elm") (names modul) ++
311−jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
242+ [ assign ("Elm" : names modul) (function ["elm"] programStmts) ]
312−jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
313−jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ")" ++ op)
317− | op == "Basics.." =
318− do ss <- mapM toJS' (e1 : collect [] e2)
319− return . jsFunc "$" . ret $ apply "$" ss
320− | op == "Basics.<|" =
322− funcs <- mapM toJS' (collect [] e1)
323− return (apply arg funcs)
325− binopNormal op `liftM` toJS' e1 `ap` toJS' e2
327− apply = foldr (\f arg-> f ++ parens arg)
244+ thisModule = dotSep ("elm" : names modul)
246+ concat [ setup (Just "elm") (names modul)
247+ , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
248+ , [ internalImports (List.intercalate "." (names modul)) ]
249+ , concatMap jsImport (imports modul)
250+ , concatMap importEvent (foreignImports modul)
251+ , [ assign ["_op"] (ObjectLit () []) ]
252+ , concatMap definition . fst . SD.flattenLets [] $ program modul
253+ , map exportEvent $ foreignExports modul
255+ , [ ReturnStmt () (Just thisModule) ]
258+ jsExports = assign ("elm" : names modul) (ObjectLit () exs)
260+ exs = map entry . filter (not . isOp) $ "_op" : exports modul
261+ entry x = (PropId () (var x), ref x)
265+ [x] -> VarDeclStmt () [ varDecl x expr ]
267+ AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
269+ jsImport (modul,_) = setup Nothing path ++ [ assign path (dotSep ("Elm" : path) <| ref "elm") ]
273+ setup namespace path = map create paths
275+ create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
276+ paths = case namespace of
277+ Nothing -> tail . init $ List.inits path
278+ Just nmspc -> drop 2 . init . List.inits $ nmspc : path
280+ addId js = InfixExpr () OpAdd (string (js++"_")) (get "elm.id")
282+ importEvent (js,base,elm,_) =
283+ [ VarDeclStmt () [ varDecl elm $ get "Signal.constant" <| expression base ]
285+ get "document.addEventListener" `call`
288+ [ ExprStmt () $ get "elm.notify" `call` [dotSep [elm,"id"], get "e.value"] ]
292+ exportEvent (js,elm,_) =
297+ [ VarDeclStmt () [varDecl "e" $ get "document.createEvent" <| string "Event"]
299+ get "e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]
300+ , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "e") "value") (ref "v")
301+ , ExprStmt () $ get "document.dispatchEvent" <| ref "e"
302+ , ReturnStmt () (Just $ ref "v")
307+binop span op e1 e2 =
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
315+ Nothing -> ref "A2" `call` [ func, js1, js2 ]
329 collect es e =
317 collect es e =
330 case e of
318 case e of
331 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
319 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
332 _ -> es ++ [e]
320 _ -> es ++ [e]
334−binopNormal op s1 s2 =
322+ js1 = expression e1
335− case Map.lookup op opDict of
323+ js2 = expression e2
337− Nothing -> "A2" ++ parens (commaSep [ prefix ++ func, s1, s2 ])
325+ func | isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string op)
339− func | isOp op' = "_op['" ++ op' ++ "']"
340− | otherwise = op'
326+ | otherwise = dotSep parts
341− (prefix, op') = case List.elemIndices '.' op of
327+ where
342− [] -> ("", op)
328+ parts = split op
343− xs -> splitAt (last xs + 1) op
329+ operator = last parts
345− opDict = Map.fromList $ basics ++
331+ opDict = Map.fromList (infixOps ++ specialOps)
346− [ ("::", jsCons s1 s2)
332+
347− , ("List.++", "_L.append" ++ parens (s1 ++ "," ++ s2)) ]
333+ specialOp str func = ("Basics." ++ str, func)
348−
334+ infixOp str op = specialOp str (InfixExpr () op)
349− ops = pow : map (\op -> (op, parens (s1 ++ op ++ s2))) ["+","-","*","/","&&","||"]
335+
350− where pow = ("^" , "Math.pow(" ++ s1 ++ "," ++ s2 ++ ")")
336+ infixOps =
351−
337+ [ infixOp "+" OpAdd
352− basics = ops ++ map (\(op,e) -> ("Basics." ++ op, e))
338+ , infixOp "-" OpSub
353− (ops ++ [ ("<|", s1 ++ parens s2)
339+ , infixOp "*" OpMul
354− , ("|>", s2 ++ parens s1)
340+ , infixOp "/" OpDiv
355− , ("==", "_N.eq(" ++ s1 ++ "," ++ s2 ++ ")")
341+ , infixOp "&&" OpLAnd
356− , ("/=", "!_N.eq(" ++ s1 ++ "," ++ s2 ++ ")")
342+ , infixOp "||" OpLOr
357− , ("<" , jsCompare s1 s2 "<0")
343+ ]
358− , (">" , jsCompare s1 s2 ">0")
344+
359− , ("<=", jsCompare s1 s2 "<1")
345+ specialOps =
360− , (">=", jsCompare s1 s2 ">-1")
346+ [ specialOp "^" $ \a b -> get "Math.pow" `call` [a,b]
361− , ("div", parens (s1 ++ "/" ++ s2 ++ "|0"))
347+ , specialOp "|>" $ flip (<|)
362− ])
348+ , specialOp "==" $ \a b -> get "_N.eq" `call` [a,b]
349+ , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (get "_N.eq" `call` [a,b])
350+ , specialOp "<" $ cmp OpLT 0
351+ , specialOp ">" $ cmp OpGT 0
352+ , specialOp "<=" $ cmp OpLT 1
353+ , specialOp ">=" $ cmp OpGT (-1)
354+ , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
357+ cmp op n a b = InfixExpr () op (get "_N.cmp" `call` [a,b]) (IntLit () n)