add if expressions (and work around a bug in amc)

3 years ago · 84b9d6c6fe
--- a/compile.ml
+++ b/compile.ml
@ -98,6 +98,7 @@ let rec lambda_lift strict = function
 (v,) <$> lambda_lift false e
 let! e = lambda_lift true e
 pure (Let (vs, e))
 | If _ -> error "if expression in lambda-lifting"

 let rec eta_contract = function
 | Decl (n, a, e) as dec ->
@ -172,6 +173,8 @@ let rec compile_lazy (env : M.t string slot) = function
 f # x # (Mkap ::)
 | Lam _ ->
 error "Can not compile lambda expression, did you forget to lift?"
 | If _ ->
 error "Can not compile if expression, did you forget to TC?"
 | Case _ ->
 error "Case expression in lazy context"
 | Lit i -> (Push (Int i) ::)
--- a/lib/parsers.ml
+++ b/lib/parsers.ml
@ -224,11 +224,13 @@ and sep_end_by sep p =

 let chainr1 p op =
 let rec scan =
 let! x = p
 rest x
 lazy (
 let! x = p
 rest x
 )
 and rest x =
 ( let! f = op
 let! y = scan
 let! y = force scan
 pure (f x y)
 ) <|> pure x
 let _ = rest (* shut up, amc *)
--- a/parser.ml
+++ b/parser.ml
@ -47,7 +47,13 @@ and expr : forall 'm. monad 'm => parser_t 'm expr =
 let! _ = keyword "in"
 let! b = expr
 pure (Let (bs, b))
 try lam <|> try case <|> try hslet <+> fexp
 let hsif =
 let! _ = keyword "if"
 let! c = fexp <* keyword "then"
 let! t = expr <* keyword "else"
 let! e = expr
 pure (If (c, t, e))
 try lam <|> try case <|> try hslet <|> try hsif <+> fexp

 let rec ty_atom : forall 'm. monad 'm => parser_t 'm hstype =
 map Tyvar (try varid)
--- a/tc.ml
+++ b/tc.ml
@ -329,6 +329,11 @@ and check dt_info level scope wanted = function
 (con, args, check dt_info level scope' wanted expr)

 Case (scrutinee, zip_with go_arm data patterns)
 | If (cond, e_then, e_else) ->
 let cond = check dt_info level scope (T_con "Bool") cond
 let e_t = check dt_info level scope wanted e_then
 let e_e = check dt_info level scope wanted e_else
 Case (cond, [ ("True", [], e_t), ("False", [], e_e) ])
 | x ->
 let (x, t) = infer dt_info level scope x
 is_subtype t wanted
@ -383,7 +388,6 @@ let dependency_graph defs =
 |> M.insert name S.empty
 |> (, define name x defs)
 let (graph, defs) = foldl go (M.empty, M.empty) defs
 G.dot_of_graph graph |> put_line
 (G.groups_of_sccs graph, defs)

 let mk_lam args body = foldr (curry Lam) body args