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