pat_to_exp support for vector and string concat patterns; fix typing in exp_of_mpat

1 files changed, 39 insertions, 28 deletions

diff --git a/src/rewrites.ml b/src/rewrites.ml
index 7bc35681..895fa65a 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -1159,8 +1159,10 @@ let subst_id_pat pat (id1,id2) =
 let subst_id_exp exp (id1,id2) =
   Ast_util.subst (Id_aux (id1,Parse_ast.Unknown)) (E_aux (E_id (Id_aux (id2,Parse_ast.Unknown)),(Parse_ast.Unknown,empty_tannot))) exp
 
-let rec pat_to_exp (P_aux (pat,(l,annot))) =
+let rec pat_to_exp ((P_aux (pat,(l,annot))) as p_aux) =
   let rewrap e = E_aux (e,(l,annot)) in
+  let env = pat_env_of p_aux in
+  let typ = pat_typ_of p_aux in
   match pat with
   | P_lit lit -> rewrap (E_lit lit)
   | P_wild -> raise (Reporting_basic.err_unreachable l
@@ -1175,15 +1177,24 @@ let rec pat_to_exp (P_aux (pat,(l,annot))) =
   | P_record (fpats,b) ->
       rewrap (E_record (FES_aux (FES_Fexps (List.map fpat_to_fexp fpats,b),(l,annot))))
   | P_vector pats -> rewrap (E_vector (List.map pat_to_exp pats))
-  | P_vector_concat pats -> raise (Reporting_basic.err_unreachable l
-      "pat_to_exp not implemented for P_vector_concat")
-      (* We assume that vector concatenation patterns have been transformed
-         away already *)
+  | P_vector_concat pats -> begin
+      let empty_vec = E_aux (E_vector [], (l,())) in
+      let concat_vectors vec1 vec2 =
+        E_aux (E_vector_append (vec1, vec2), (l, ()))
+      in
+      check_exp env (List.fold_right concat_vectors (List.map (fun p -> strip_exp (pat_to_exp p)) pats) empty_vec) typ
+    end
   | P_tup pats -> rewrap (E_tuple (List.map pat_to_exp pats))
   | P_list pats -> rewrap (E_list (List.map pat_to_exp pats))
   | P_cons (p,ps) -> rewrap (E_cons (pat_to_exp p, pat_to_exp ps))
-  | P_string_append (ps) -> raise (Reporting_basic.err_unreachable l
-      "pat_to_exp not implemented for P_string_append")
+  | P_string_append (pats) -> begin
+      let empty_string = E_aux (E_lit (L_aux (L_string "", l)), (l, ())) in
+      let string_append str1 str2 =
+        E_aux (E_app (mk_id "string_append", [str1; str2]), (l, ()))
+      in
+      check_exp env (List.fold_right string_append (List.map (fun p -> strip_exp (pat_to_exp p)) pats) empty_string) typ
+    end
+
 and fpat_to_fexp (FP_aux (FP_Fpat (id,pat),(l,annot))) =
   FE_aux (FE_Fexp (id, pat_to_exp pat),(l,annot))
 
@@ -3899,30 +3910,30 @@ let merge_funcls (Defs defs) =
   in Defs (List.map merge_in_def defs)
 
 
-let rec exp_of_mpat (MP_aux (mpat, annot)) =
-  let empty_vec = E_aux (E_vector [], annot) in
-  let concat_vectors annot vec1 vec2 = (* TODO FIXME, this should be OK for typing but doesn't attach location information properly *)
-    E_aux (E_vector_append (vec1, vec2), annot)
+let rec exp_of_mpat ((MP_aux (mpat, (l,annot))) as mp_aux) =
+  let empty_vec = E_aux (E_vector [], (l,())) in
+  let concat_vectors vec1 vec2 =
+    E_aux (E_vector_append (vec1, vec2), (l,()))
   in
-  let empty_string = E_aux (E_lit (L_aux (L_string "", Parse_ast.Unknown)), annot) in
-  let string_append annot str1 str2 =
-    E_aux (E_app (mk_id "string_append", [str1; str2]), annot)
+  let empty_string = E_aux (E_lit (L_aux (L_string "", Parse_ast.Unknown)), (l,())) in
+  let string_append str1 str2 =
+    E_aux (E_app (mk_id "string_append", [str1; str2]), (l,()))
   in
   match mpat with
-  | MP_lit lit                      -> E_aux (E_lit lit, annot)
-  | MP_id id                        -> E_aux (E_id id, annot)
-  | MP_app (id, args)               -> E_aux (E_app (id, (List.map exp_of_mpat args)), annot)
-  | MP_record (mfpats, flag)        -> E_aux (E_record (fexps_of_mfpats mfpats flag annot), annot)
-  | MP_vector mpats                 -> E_aux (E_vector (List.map exp_of_mpat mpats), annot)
-  | MP_vector_concat mpats          -> List.fold_right (concat_vectors annot) (List.map exp_of_mpat mpats) empty_vec
-  | MP_tup mpats                    -> E_aux (E_tuple (List.map exp_of_mpat mpats), annot)
-  | MP_list mpats                   -> E_aux (E_list (List.map exp_of_mpat mpats), annot)
-  | MP_cons (mpat1, mpat2)          -> E_aux (E_cons (exp_of_mpat mpat1, exp_of_mpat mpat2), annot)
-  | MP_string_append mpats          -> List.fold_right (string_append annot) (List.map exp_of_mpat mpats) empty_string
-  | MP_typ (mpat, typ)              -> E_aux (E_cast (typ, exp_of_mpat mpat), annot)
-  | MP_as (mpat, id)                -> E_aux (E_case (E_aux (E_id id, annot), [
-                                                    Pat_aux (Pat_exp (pat_of_mpat mpat, exp_of_mpat mpat), annot)
-                                                ]), annot) (* TODO FIXME ditto *)
+  | MP_lit lit                      -> E_aux (E_lit lit, (l,annot))
+  | MP_id id                        -> E_aux (E_id id, (l,annot))
+  | MP_app (id, args)               -> E_aux (E_app (id, (List.map exp_of_mpat args)), (l,annot))
+  | MP_record (mfpats, flag)        -> E_aux (E_record (fexps_of_mfpats mfpats flag (l,annot)), (l,annot))
+  | MP_vector mpats                 -> E_aux (E_vector (List.map exp_of_mpat mpats), (l,annot))
+  | MP_vector_concat mpats          -> List.fold_right concat_vectors (List.map (fun m -> strip_exp (exp_of_mpat m)) mpats) empty_vec
+  | MP_tup mpats                    -> E_aux (E_tuple (List.map exp_of_mpat mpats), (l,annot))
+  | MP_list mpats                   -> E_aux (E_list (List.map exp_of_mpat mpats), (l,annot))
+  | MP_cons (mpat1, mpat2)          -> E_aux (E_cons (exp_of_mpat mpat1, exp_of_mpat mpat2), (l,annot))
+  | MP_string_append mpats          -> List.fold_right string_append (List.map (fun m -> strip_exp (exp_of_mpat m)) mpats) empty_string
+  | MP_typ (mpat, typ)              -> E_aux (E_cast (typ, exp_of_mpat mpat), (l,annot))
+  | MP_as (mpat, id)                -> E_aux (E_case (E_aux (E_id id, (l,annot)), [
+                                                    Pat_aux (Pat_exp (pat_of_mpat mpat, exp_of_mpat mpat), (l,annot))
+                                                ]), (l,annot)) (* TODO FIXME location information? *)
 
 
 and fexps_of_mfpats mfpats flag annot =