@@ -3,7 +3,7 @@ module CompileToJS (showErr, jsModule) where
5import Control.Arrow (first)
5import Control.Arrow (first)
6−import Control.Monad (liftM,(<=<),join)
6+import Control.Monad (liftM,(<=<),join,ap)
7import Data.Char (isAlpha,isDigit)
7import Data.Char (isAlpha,isDigit)
8import Data.List (intercalate,sortBy,inits)
8import Data.List (intercalate,sortBy,inits)
9import Data.Map (toList)
9import Data.Map (toList)
@@ -11,6 +11,8 @@ import Data.Maybe (mapMaybe)
12import Initialize
12import Initialize
13import Rename (derename)
13import Rename (derename)
15showErr :: String -> String
17showErr :: String -> String
16showErr err = mainEquals $ "text(monospace(" ++ msg ++ "))"
18showErr err = mainEquals $ "text(monospace(" ++ msg ++ "))"
@@ -116,58 +118,67 @@ stmtToJS (ExportEvent js elm _) =
120−toJS :: Expr -> String
123+toJS' :: Expr -> GuidCounter String
121−toJS expr =
124+toJS' expr =
122 case expr of
125 case expr of
123− IntNum n -> show n
126+ IntNum n -> return $ show n
124− FloatNum n -> show n
127+ FloatNum n -> return $ show n
125− Var x -> x
128+ Var x -> return $ x
126− Chr c -> show c
129+ Chr c -> return $ show c
127− Str s -> "Value.str" ++ parens (show s)
130+ Str s -> return $ "Value.str" ++ parens (show s)
128− Boolean b -> if b then "true" else "false"
131+ Boolean b -> return $ if b then "true" else "false"
129− Range lo hi -> jsRange (toJS lo) (toJS hi)
132+ Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
130− Access e lbl -> toJS e ++ "." ++ lbl
133+ Access e lbl -> (\s -> s ++ "." ++ lbl) `liftM` toJS' e
131− Binop op e1 e2 -> binop op (toJS e1) (toJS e2)
134+ Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
132− If eb et ef -> parens $ iff (toJS eb) (toJS et) (toJS ef)
135+ If eb et ef -> parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
133− Lambda v e -> jsFunc v $ ret (toJS e)
136+ Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
134− App (Var "toText") (Str s) -> "toText" ++ parens (show s)
137+ App (Var "toText") (Str s) -> return $ "toText" ++ parens (show s)
135− App (Var "link") (Str s) -> "link(" ++ show s ++ ")"
138+ App (Var "link") (Str s) -> return $ "link(" ++ show s ++ ")"
136− App (Var "plainText") (Str s) -> "plainText(" ++ show s ++ ")"
139+ App (Var "plainText") (Str s) -> return $ "plainText(" ++ show s ++ ")"
137− App e1 e2 -> toJS e1 ++ parens (toJS e2)
140+ App e1 e2 -> (++) `liftM` (toJS' e1) `ap` (parens `liftM` toJS' e2)
138 Let defs e -> jsLet defs e
141 Let defs e -> jsLet defs e
139− Case e cases -> jsCase e cases
142+ Case e cases -> caseToJS e cases
140− Data name es -> jsList $ show name : map toJS es
143+ Data name es -> (\ss -> jsList $ show name : ss) `liftM` mapM toJS' es
142−jsLet defs e' = jsFunc "" (jsDefs defs ++ ret (toJS e')) ++ "()"
146+ body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS' e')
147+ return $ jsFunc "" body ++ "()"
144−jsDefs defs = concatMap toDef $ sortBy f defs
149+jsDefs defs = concat `liftM` mapM toDef (sortBy f defs)
145 where f a b = compare (valueOf a) (valueOf b)
150 where f a b = compare (valueOf a) (valueOf b)
146 valueOf (Definition _ args _) = min 1 (length args)
151 valueOf (Definition _ args _) = min 1 (length args)
147− toDef (Definition x [] e) = assign x (toJS e)
152+ toDef (Definition x [] e) = assign x `liftM` toJS' e
148− toDef (Definition f (a:as) e) =
153+ toDef (Definition f (a:as) e) = do
154+ out <- toJS' $ foldr Lambda e as
149− "\nfunction " ++ f ++ parens a ++ braces (ret . toJS $ foldr Lambda e as) ++ ";"
155+ return $ "\nfunction " ++ f ++ parens a ++ braces (ret out) ++ ";"
151−jsCase e [c] = jsMatch c ++ parens (toJS e)
157+caseToJS e ps = do
152−jsCase e cases = "(function(){" ++
158+ match <- caseToMatch ps
153− assign "v" (toJS e) ++
159+ var <- liftM (\n -> "vv" ++ show n) guid
154− assign "c" jsCases ++
160+ matches <- matchToJS var match
155− "for(var i=c.length;i--;){" ++
161+ e' <- toJS' e
156− assign "r" "c[i](v)" ++
162+ return $ concat [ "function(", var, "){"
157− "if(r!==undefined){return r;}}}())"
163+ , case match of { Match name _ _ -> assign name var ; _ -> "" }
158− where jsCases = jsList $ map jsMatch (reverse cases)
164+ , matches
159−
165+ , "}", parens e' ]
160−jsMatch (p,e) = jsFunc "v" . match p "v" . ret $ toJS e
166+
161−match p v hole =
167+matchToJS v (Match name clauses def) = do
162− case p of
168+ cases <- concat `liftM` mapM (clauseToJS name) clauses
163− PAnything -> hole
169+ finally <- matchToJS v def
164− PVar x -> assign x v ++ hole
170+ return $ concat [ "\nswitch(", name, "[0]){", cases, "\n}", finally ]
165− PData name ps ->
171+matchToJS _ Fail = return "\nthrow \"Non-exhaustive pattern match in case\";"
166− "if(" ++ show name ++ "!==" ++ v ++
172+matchToJS _ Break = return "break;"
167− "[0]){return undefined;}else{"++body++"}"
173+matchToJS _ (Other e) = ret `liftM` toJS' e
168− where matches = zipWith match ps vs
174+matchToJS v (Seq ms) = concat `liftM` mapM (matchToJS v) ms
169− vs = map (\i -> v++"["++show (i+1)++"]") [0..length ps-1]
175+
170− body = foldr ($) hole matches
176+clauseToJS var (Clause name vars e) = do
177+ s <- matchToJS var e
178+ return $ concat [ "\ncase ", show name, ":"
179+ , concat $ zipWith toDef vars [ 1 .. length vars ]
181+ where toDef v n = assign v (var ++ "[" ++ show n ++ "]")
172jsNil = "[\"Nil\"]"
183jsNil = "[\"Nil\"]"
173jsCons e1 e2 = jsList [ show "Cons", e1, e2 ]
184jsCons e1 e2 = jsList [ show "Cons", e1, e2 ]