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

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) ::)

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 *)

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)

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