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