Add type information to AP_app constructors

3 files changed, 24 insertions, 12 deletions

diff --git a/src/anf.ml b/src/anf.ml
index c686754f..845759cd 100644
--- a/src/anf.ml
+++ b/src/anf.ml
@@ -117,7 +117,7 @@ and 'a apat_aux =
   | AP_tup of ('a apat) list
   | AP_id of id * 'a
   | AP_global of id * 'a
-  | AP_app of id * 'a apat
+  | AP_app of id * 'a apat * 'a
   | AP_cons of 'a apat * 'a apat
   | AP_nil of 'a
   | AP_wild of 'a
@@ -139,11 +139,13 @@ let rec apat_bindings (AP_aux (apat_aux, _, _)) =
   | AP_tup apats -> List.fold_left IdSet.union IdSet.empty (List.map apat_bindings apats)
   | AP_id (id, _) -> IdSet.singleton id
   | AP_global (id, _) -> IdSet.empty
-  | AP_app (id, apat) -> apat_bindings apat
+  | AP_app (id, apat, _) -> apat_bindings apat
   | AP_cons (apat1, apat2) -> IdSet.union (apat_bindings apat1) (apat_bindings apat2)
   | AP_nil _ -> IdSet.empty
   | AP_wild _ -> IdSet.empty
 
+(** This function returns the types of all bound variables in a
+   pattern. It ignores AP_global, apat_globals is used for that. *)
 let rec apat_types (AP_aux (apat_aux, _, _)) =
   let merge id b1 b2 =
     match b1, b2 with
@@ -156,7 +158,7 @@ let rec apat_types (AP_aux (apat_aux, _, _)) =
   | AP_tup apats -> List.fold_left (Bindings.merge merge) Bindings.empty (List.map apat_types apats)
   | AP_id (id, typ) -> Bindings.singleton id typ
   | AP_global (id, _) -> Bindings.empty
-  | AP_app (id, apat) -> apat_types apat
+  | AP_app (id, apat, _) -> apat_types apat
   | AP_cons (apat1, apat2) -> (Bindings.merge merge) (apat_types apat1) (apat_types apat2)
   | AP_nil _ -> Bindings.empty
   | AP_wild _ -> Bindings.empty
@@ -167,7 +169,7 @@ let rec apat_rename from_id to_id (AP_aux (apat_aux, env, l)) =
     | AP_id (id, typ) when Id.compare id from_id = 0 -> AP_id (to_id, typ)
     | AP_id (id, typ) -> AP_id (id, typ)
     | AP_global (id, typ) -> AP_global (id, typ)
-    | AP_app (ctor, apat) -> AP_app (ctor, apat_rename from_id to_id apat)
+    | AP_app (ctor, apat, typ) -> AP_app (ctor, apat_rename from_id to_id apat, typ)
     | AP_cons (apat1, apat2) -> AP_cons (apat_rename from_id to_id apat1, apat_rename from_id to_id apat2)
     | AP_nil typ -> AP_nil typ
     | AP_wild typ -> AP_wild typ
@@ -405,7 +407,7 @@ and pp_apat (AP_aux (apat_aux, _, _)) =
   | AP_id (id, typ) -> pp_annot typ (pp_id id)
   | AP_global (id, _) -> pp_id id
   | AP_tup apats -> parens (separate_map (comma ^^ space) pp_apat apats)
-  | AP_app (id, apat) -> pp_id id ^^ parens (pp_apat apat)
+  | AP_app (id, apat, typ) -> pp_annot typ (pp_id id ^^ parens (pp_apat apat))
   | AP_nil _ -> string "[||]"
   | AP_cons (hd_apat, tl_apat) -> pp_apat hd_apat ^^ string " :: " ^^ pp_apat tl_apat
 
@@ -460,8 +462,8 @@ let rec anf_pat ?global:(global=false) (P_aux (p_aux, annot) as pat) =
   | P_id id -> mk_apat (AP_id (id, pat_typ_of pat))
   | P_wild -> mk_apat (AP_wild (pat_typ_of pat))
   | P_tup pats -> mk_apat (AP_tup (List.map (fun pat -> anf_pat ~global:global pat) pats))
-  | P_app (id, [pat]) -> mk_apat (AP_app (id, anf_pat ~global:global pat))
-  | P_app (id, pats) -> mk_apat (AP_app (id, mk_apat (AP_tup (List.map (fun pat -> anf_pat ~global:global pat) pats))))
+  | P_app (id, [subpat]) -> mk_apat (AP_app (id, anf_pat ~global:global subpat, pat_typ_of pat))
+  | P_app (id, pats) -> mk_apat (AP_app (id, mk_apat (AP_tup (List.map (fun pat -> anf_pat ~global:global pat) pats)), pat_typ_of pat))
   | P_typ (_, pat) -> anf_pat ~global:global pat
   | P_var (pat, _) -> anf_pat ~global:global pat
   | P_cons (hd_pat, tl_pat) -> mk_apat (AP_cons (anf_pat ~global:global hd_pat, anf_pat ~global:global tl_pat))
@@ -473,7 +475,7 @@ let rec apat_globals (AP_aux (aux, _, _)) =
   | AP_nil _ | AP_wild _ | AP_id _ -> []
   | AP_global (id, typ) -> [(id, typ)]
   | AP_tup apats -> List.concat (List.map apat_globals apats)
-  | AP_app (_, apat) -> apat_globals apat
+  | AP_app (_, apat, _) -> apat_globals apat
   | AP_cons (hd_apat, tl_apat) -> apat_globals hd_apat @ apat_globals tl_apat
 
 let rec anf (E_aux (e_aux, ((l, _) as exp_annot)) as exp) =
diff --git a/src/anf.mli b/src/anf.mli
index 56c3b520..9854b04c 100644
--- a/src/anf.mli
+++ b/src/anf.mli
@@ -83,7 +83,7 @@ and 'a apat_aux =
   | AP_tup of ('a apat) list
   | AP_id of id * 'a
   | AP_global of id * 'a
-  | AP_app of id * 'a apat
+  | AP_app of id * 'a apat * 'a
   | AP_cons of 'a apat * 'a apat
   | AP_nil of 'a
   | AP_wild of 'a
diff --git a/src/c_backend.ml b/src/c_backend.ml
index 3655768d..d6276bdd 100644
--- a/src/c_backend.ml
+++ b/src/c_backend.ml
@@ -828,6 +828,7 @@ let rec apat_ctyp ctx (AP_aux (apat, _, _)) =
   | AP_global (_, typ) -> ctyp_of_typ ctx typ
   | AP_cons (apat, _) -> CT_list (apat_ctyp ctx apat)
   | AP_wild typ | AP_nil typ | AP_id (_, typ) -> ctyp_of_typ ctx typ
+  | AP_app (_, _, typ) -> ctyp_of_typ ctx typ
 
 let rec compile_match ctx (AP_aux (apat_aux, env, l)) cval case_label =
   let ctx = { ctx with local_env = env } in
@@ -868,11 +869,15 @@ let rec compile_match ctx (AP_aux (apat_aux, env, l)) cval case_label =
        | _ -> failwith ("AP_tup with ctyp " ^ string_of_ctyp ctyp)
      end
 
-  | AP_app (ctor, apat), (frag, ctyp) ->
+  | AP_app (ctor, apat, variant_typ), (frag, ctyp) ->
      begin match ctyp with
      | CT_variant (_, ctors) ->
         let ctor_c_id = string_of_id ctor in
         let ctor_ctyp = Bindings.find ctor (ctor_bindings ctors) in
+        (* These should really be the same, something has gone wrong if they are not. *)
+        if ctyp_equal ctor_ctyp (ctyp_of_typ ctx variant_typ) then
+          c_error ~loc:l (Printf.sprintf "%s is not the same type as %s" (string_of_ctyp ctor_ctyp) (string_of_ctyp (ctyp_of_typ ctx variant_typ)))
+        else ();
         let ctor_c_id =
           if is_polymorphic ctor_ctyp then
             let unification = List.map ctyp_suprema (ctyp_unify ctor_ctyp (apat_ctyp ctx apat)) in
@@ -880,13 +885,18 @@ let rec compile_match ctx (AP_aux (apat_aux, env, l)) cval case_label =
           else
             ctor_c_id
         in
-        let instrs, cleanup, ctx = compile_match ctx apat ((F_field (frag, Util.zencode_string ctor_c_id), ctor_ctyp)) case_label in
+        let instrs, cleanup, ctx = compile_match ctx apat ((F_field (frag, Util.zencode_string ctor_c_id), apat_ctyp ctx apat)) case_label in
         [icomment (string_of_ctyp (apat_ctyp ctx apat)); ijump (F_op (F_field (frag, "kind"), "!=", F_lit (V_ctor_kind ctor_c_id)), CT_bool) case_label]
         @ instrs
         @ [icomment (string_of_ctyp ctor_ctyp)],
         cleanup,
         ctx
-     | _ -> failwith "AP_app constructor with non-variant type"
+     | ctyp ->
+        c_error ~loc:l (Printf.sprintf "Variant constructor %s : %s matching against non-variant type %s : %s"
+                                       (string_of_id ctor)
+                                       (string_of_typ variant_typ)
+                                       (string_of_fragment ~zencode:false frag)
+                                       (string_of_ctyp ctyp))
      end
 
   | AP_wild _, _ -> [], [], ctx