@@ -1,4 +1,4 @@
1−module CompileToJS (showErr, jsModule) where
1+ module CompileToJS (showErr, jsModule) where
22
33import Control.Arrow (first,second)
44import Control.Monad (liftM,(<=<),join,ap)
@@ -99,7 +99,7 @@ stmtsToJS :: [Statement] -> String
9999stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
100100 return (vars ++ concat program)
101101 where
102− vars = "\nvar " ++ intercalate "," (letBoundVars stmts) ++ ";"
102+ vars = "\nvar " ++ intercalate ", " ("e":"case0":letBoundVars stmts) ++ ";"
103103 cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
104104 valueOf s = case s of
105105 Datatype _ _ _ -> 1
@@ -116,12 +116,14 @@ class ToJS a where
116116
117117instance ToJS Def where
118118 toJS (FnDef x [] e) = assign' x `liftM` toJS' e
119− toJS (FnDef f (a:as) e) =
120− do body <- toJS' (foldr (\x e -> noContext (Lambda x e)) e as)
121− return $ assign' f (jsFunc a (ret body))
119+ toJS (FnDef f as e) = (assign' f . wrapper . func) `liftM` toJS' e
120+ where func body = jsFunc (intercalate ", " as) (ret body)
121+ wrapper e | length as == 1 = e
122+ | otherwise = 'F' : show (length as) ++ parens e
122123 toJS (OpDef op a1 a2 e) =
123− do body <- toJS' (foldr (\x e -> noContext (Lambda x e)) e [a1,a2])
124− return $ concat [ "\n$op['", op, "'] = ", body, ";" ]
124+ do body <- toJS' e
125+ let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))
126+ return (globalAssign ("$op['" ++ op ++ "']") func)
125127
126128instance ToJS Statement where
127129 toJS stmt =
@@ -203,16 +205,7 @@ instance ToJS Expr where
203205
204206 Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
205207
206− App (C _ _ (Var "toText")) (C _ _ (Str s)) ->
207− return $ "toText" ++ parens (quoted s)
208−
209− App (C _ _ (Var "link")) (C _ _ (Str s)) ->
210− return $ "link(" ++ quoted s ++ ")"
211−
212− App (C _ _ (Var "plainText")) (C _ _ (Str s)) ->
213− return $ "plainText(" ++ quoted s ++ ")"
214−
215− App e1 e2 -> (++) `liftM` (toJS' e1) `ap` (parens `liftM` toJS' e2)
208+ App e1 e2 -> jsApp e1 e2
216209 Let defs e -> jsLet defs e
217210 Data name es ->
218211 do fs <- mapM toJS' es
@@ -223,6 +216,19 @@ instance ToJS Expr where
223216 where pad = "<div style=\"height:0;width:0;\"> </div>"
224217 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
225218
219+jsApp e1 e2 =
220+ do f <- toJS' func
221+ as <- mapM toJS' args
222+ return $ case as of
223+ [a] -> f ++ parens a
224+ _ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))
225+ where
226+ (func, args) = go [e2] e1
227+ go args e =
228+ case e of
229+ (C _ _ (App e1 e2)) -> go (e2 : args) e1
230+ _ -> (e, args)
231+
226232formatMarkdown = concatMap f
227233 where f '\'' = "\\'"
228234 f '\n' = "\\n"
@@ -255,27 +261,39 @@ caseToJS span e ps = do
255261 match <- caseToMatch ps
256262 e' <- toJS' e
257263 (match',stmt) <- case (match,e) of
258− (Match name _ _, C _ _ (Var x)) -> return (matchSubst [(name,x)] match, "")
259− (Match name _ _, _) -> return (match, assign name e')
260− _ -> liftM (\n -> (match, e')) guid
264+ (Match name _ _, C _ _ (Var x)) ->
265+ return (matchSubst [(name,x)] match, Nothing)
266+ (Match name _ _, _) ->
267+ return (match, Just (name ++ " = " ++ e'))
268+ _ -> return (match, Nothing) -- Just e'
261269 matches <- matchToJS span match'
262− return $ concat [ "function(){", stmt, matches, "}()" ]
263−
264−matchToJS span (Match name clauses def) = do
265− cases <- concat `liftM` mapM (clauseToJS span name) clauses
266− finally <- matchToJS span def
267− return $ concat [ "\nswitch(", name, ".ctor){", indent cases, "\n}", finally ]
268−matchToJS span Fail =
269− return ("\nthrow new Error(\"Non-exhaustive pattern match " ++
270− "in case expression (" ++ show span ++ ")\");")
271−matchToJS span Break = return "break;"
272−matchToJS span (Other e) = ret `liftM` toJS' e
273−matchToJS span (Seq ms) = concat `liftM` mapM (matchToJS span) ms
270+ return $ case stmt of
271+ Nothing -> matches
272+ Just exp -> parens (exp ++ ", " ++ matches)
273+
274+matchToJS span match =
275+ let sqnc e1 e2 = parens ("e = " ++ e1 ++ " : null, " ++ "e !== null ? e : " ++ e2)
276+ in case match of
277+ Match name clauses def ->
278+ do cases <- intercalate " : " `liftM` mapM (clauseToJS span name) clauses
279+ finally <- matchToJS span def
280+ return (sqnc cases finally)
281+ Fail -> return ("throw new Error(\"Non-exhaustive pattern match " ++
282+ "in case expression (" ++ show span ++ ")\")")
283+ Break -> return "null"
284+ Other e -> toJS' e
285+ Seq ms -> foldr1 sqnc `liftM` mapM (matchToJS span) (dropEnd [] ms)
286+ where dropEnd acc [] = acc
287+ dropEnd acc (m:ms) =
288+ case m of
289+ Other _ -> acc ++ [m]
290+ _ -> dropEnd (acc ++ [m]) ms
291+
274292
275293clauseToJS span var (Clause name vars e) = do
276− let vars' = map (\n -> var ++ "._" ++ show n) [ 1 .. length vars ]
294+ let vars' = map (\n -> var ++ "._" ++ show n) [0..]
277295 s <- matchToJS span $ matchSubst (zip vars vars') e
278− return $ concat [ "\ncase ", quoted name, ":", s ]
296+ return $ concat [ var, ".ctor === ", quoted name, " ? ", s ]
279297
280298jsNil = "{ctor:'Nil'}"
281299jsCons e1 e2 = "{ctor:'Cons',_0:" ++ e1 ++ ",_1:" ++ e2 ++ "}"