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