Faster case expressions, and switch to the new uncurried format for function definitions.
This commit is contained in:
parent
9eddb7a3bd
commit
c136ea733e
1 changed files with 51 additions and 33 deletions
|
@ -1,4 +1,4 @@
|
||||||
module CompileToJS (showErr, jsModule) where
|
module CompileToJS (showErr, jsModule) where
|
||||||
|
|
||||||
import Control.Arrow (first,second)
|
import Control.Arrow (first,second)
|
||||||
import Control.Monad (liftM,(<=<),join,ap)
|
import Control.Monad (liftM,(<=<),join,ap)
|
||||||
|
@ -99,7 +99,7 @@ stmtsToJS :: [Statement] -> String
|
||||||
stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
|
stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
|
||||||
return (vars ++ concat program)
|
return (vars ++ concat program)
|
||||||
where
|
where
|
||||||
vars = "\nvar " ++ intercalate "," (letBoundVars stmts) ++ ";"
|
vars = "\nvar " ++ intercalate ", " ("e":"case0":letBoundVars stmts) ++ ";"
|
||||||
cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
|
cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
|
||||||
valueOf s = case s of
|
valueOf s = case s of
|
||||||
Datatype _ _ _ -> 1
|
Datatype _ _ _ -> 1
|
||||||
|
@ -116,12 +116,14 @@ class ToJS a where
|
||||||
|
|
||||||
instance ToJS Def where
|
instance ToJS Def where
|
||||||
toJS (FnDef x [] e) = assign' x `liftM` toJS' e
|
toJS (FnDef x [] e) = assign' x `liftM` toJS' e
|
||||||
toJS (FnDef f (a:as) e) =
|
toJS (FnDef f as e) = (assign' f . wrapper . func) `liftM` toJS' e
|
||||||
do body <- toJS' (foldr (\x e -> noContext (Lambda x e)) e as)
|
where func body = jsFunc (intercalate ", " as) (ret body)
|
||||||
return $ assign' f (jsFunc a (ret body))
|
wrapper e | length as == 1 = e
|
||||||
|
| otherwise = 'F' : show (length as) ++ parens e
|
||||||
toJS (OpDef op a1 a2 e) =
|
toJS (OpDef op a1 a2 e) =
|
||||||
do body <- toJS' (foldr (\x e -> noContext (Lambda x e)) e [a1,a2])
|
do body <- toJS' e
|
||||||
return $ concat [ "\n$op['", op, "'] = ", body, ";" ]
|
let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))
|
||||||
|
return (globalAssign ("$op['" ++ op ++ "']") func)
|
||||||
|
|
||||||
instance ToJS Statement where
|
instance ToJS Statement where
|
||||||
toJS stmt =
|
toJS stmt =
|
||||||
|
@ -203,16 +205,7 @@ instance ToJS Expr where
|
||||||
|
|
||||||
Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
|
Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
|
||||||
|
|
||||||
App (C _ _ (Var "toText")) (C _ _ (Str s)) ->
|
App e1 e2 -> jsApp e1 e2
|
||||||
return $ "toText" ++ parens (quoted s)
|
|
||||||
|
|
||||||
App (C _ _ (Var "link")) (C _ _ (Str s)) ->
|
|
||||||
return $ "link(" ++ quoted s ++ ")"
|
|
||||||
|
|
||||||
App (C _ _ (Var "plainText")) (C _ _ (Str s)) ->
|
|
||||||
return $ "plainText(" ++ quoted s ++ ")"
|
|
||||||
|
|
||||||
App e1 e2 -> (++) `liftM` (toJS' e1) `ap` (parens `liftM` toJS' e2)
|
|
||||||
Let defs e -> jsLet defs e
|
Let defs e -> jsLet defs e
|
||||||
Data name es ->
|
Data name es ->
|
||||||
do fs <- mapM toJS' es
|
do fs <- mapM toJS' es
|
||||||
|
@ -223,6 +216,19 @@ instance ToJS Expr where
|
||||||
where pad = "<div style=\"height:0;width:0;\"> </div>"
|
where pad = "<div style=\"height:0;width:0;\"> </div>"
|
||||||
md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
|
md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
|
||||||
|
|
||||||
|
jsApp e1 e2 =
|
||||||
|
do f <- toJS' func
|
||||||
|
as <- mapM toJS' args
|
||||||
|
return $ case as of
|
||||||
|
[a] -> f ++ parens a
|
||||||
|
_ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))
|
||||||
|
where
|
||||||
|
(func, args) = go [e2] e1
|
||||||
|
go args e =
|
||||||
|
case e of
|
||||||
|
(C _ _ (App e1 e2)) -> go (e2 : args) e1
|
||||||
|
_ -> (e, args)
|
||||||
|
|
||||||
formatMarkdown = concatMap f
|
formatMarkdown = concatMap f
|
||||||
where f '\'' = "\\'"
|
where f '\'' = "\\'"
|
||||||
f '\n' = "\\n"
|
f '\n' = "\\n"
|
||||||
|
@ -255,27 +261,39 @@ caseToJS span e ps = do
|
||||||
match <- caseToMatch ps
|
match <- caseToMatch ps
|
||||||
e' <- toJS' e
|
e' <- toJS' e
|
||||||
(match',stmt) <- case (match,e) of
|
(match',stmt) <- case (match,e) of
|
||||||
(Match name _ _, C _ _ (Var x)) -> return (matchSubst [(name,x)] match, "")
|
(Match name _ _, C _ _ (Var x)) ->
|
||||||
(Match name _ _, _) -> return (match, assign name e')
|
return (matchSubst [(name,x)] match, Nothing)
|
||||||
_ -> liftM (\n -> (match, e')) guid
|
(Match name _ _, _) ->
|
||||||
|
return (match, Just (name ++ " = " ++ e'))
|
||||||
|
_ -> return (match, Nothing) -- Just e'
|
||||||
matches <- matchToJS span match'
|
matches <- matchToJS span match'
|
||||||
return $ concat [ "function(){", stmt, matches, "}()" ]
|
return $ case stmt of
|
||||||
|
Nothing -> matches
|
||||||
|
Just exp -> parens (exp ++ ", " ++ matches)
|
||||||
|
|
||||||
|
matchToJS span match =
|
||||||
|
let sqnc e1 e2 = parens ("e = " ++ e1 ++ " : null, " ++ "e !== null ? e : " ++ e2)
|
||||||
|
in case match of
|
||||||
|
Match name clauses def ->
|
||||||
|
do cases <- intercalate " : " `liftM` mapM (clauseToJS span name) clauses
|
||||||
|
finally <- matchToJS span def
|
||||||
|
return (sqnc cases finally)
|
||||||
|
Fail -> return ("throw new Error(\"Non-exhaustive pattern match " ++
|
||||||
|
"in case expression (" ++ show span ++ ")\")")
|
||||||
|
Break -> return "null"
|
||||||
|
Other e -> toJS' e
|
||||||
|
Seq ms -> foldr1 sqnc `liftM` mapM (matchToJS span) (dropEnd [] ms)
|
||||||
|
where dropEnd acc [] = acc
|
||||||
|
dropEnd acc (m:ms) =
|
||||||
|
case m of
|
||||||
|
Other _ -> acc ++ [m]
|
||||||
|
_ -> dropEnd (acc ++ [m]) ms
|
||||||
|
|
||||||
matchToJS span (Match name clauses def) = do
|
|
||||||
cases <- concat `liftM` mapM (clauseToJS span name) clauses
|
|
||||||
finally <- matchToJS span def
|
|
||||||
return $ concat [ "\nswitch(", name, ".ctor){", indent cases, "\n}", finally ]
|
|
||||||
matchToJS span Fail =
|
|
||||||
return ("\nthrow new Error(\"Non-exhaustive pattern match " ++
|
|
||||||
"in case expression (" ++ show span ++ ")\");")
|
|
||||||
matchToJS span Break = return "break;"
|
|
||||||
matchToJS span (Other e) = ret `liftM` toJS' e
|
|
||||||
matchToJS span (Seq ms) = concat `liftM` mapM (matchToJS span) ms
|
|
||||||
|
|
||||||
clauseToJS span var (Clause name vars e) = do
|
clauseToJS span var (Clause name vars e) = do
|
||||||
let vars' = map (\n -> var ++ "._" ++ show n) [ 1 .. length vars ]
|
let vars' = map (\n -> var ++ "._" ++ show n) [0..]
|
||||||
s <- matchToJS span $ matchSubst (zip vars vars') e
|
s <- matchToJS span $ matchSubst (zip vars vars') e
|
||||||
return $ concat [ "\ncase ", quoted name, ":", s ]
|
return $ concat [ var, ".ctor === ", quoted name, " ? ", s ]
|
||||||
|
|
||||||
jsNil = "{ctor:'Nil'}"
|
jsNil = "{ctor:'Nil'}"
|
||||||
jsCons e1 e2 = "{ctor:'Cons',_0:" ++ e1 ++ ",_1:" ++ e2 ++ "}"
|
jsCons e1 e2 = "{ctor:'Cons',_0:" ++ e1 ++ ",_1:" ++ e2 ++ "}"
|
||||||
|
|
Loading…
Reference in a new issue