Remove Variance from parser and cleanup stale code

tests/libtest/tallyingTest.ml

 open OUnit
 open Types
 
-let parse_typ ?(variance=`Covariant) s =
+let parse_typ s =
   let st = Stream.of_string s in
   let astpat = Parser.pat st in
-  let nodepat = Typer.typ ~variance Builtin.env astpat in
+  let nodepat = Typer.typ Builtin.env astpat in
   Types.descr nodepat
 ;;
 
@@ -34,11 +34,7 @@ end)
 
 module MSet = OUnitDiff.SetMake (struct
   type t = Tallying.CS.m
-  let compare =
-    (* the abstract field is ignored in the comparison *)
-    let a = Types.abstract Abstract.any in
-    let cmp t1 t2 = Types.compare (diff t1 a) (diff t2 a) in
-    Tallying.CS.M.compare (*cmp *)
+  let compare = Tallying.CS.M.compare
   let pp_printer = Tallying.CS.pp_m
   let pp_print_sep = OUnitDiff.pp_comma_separator
 end)
@@ -58,18 +54,10 @@ let mk_s ll =
   ) Tallying.CS.S.empty ll
 
 let mk_union_res l1 l2 =
-  let aux_merge k v1 v2 = match (k,v1,v2) with
-    |(k,None,None) -> assert false
-    |(k,Some v,None) -> Some v
-    |(k,None,Some v) -> Some v
-    |((_,v),Some x,Some y) when Types.equiv x y -> Some x
-    |((true,v),Some x,Some y) -> assert false
-    |((false,v),Some x,Some y) -> assert false
-  in
   let aux l =
     List.fold_left (fun acc -> function
-      |P(V v,s) -> Tallying.CS.M.merge (*aux_merge*) acc (Tallying.CS.M.singleton ((*true,*)Var.mk v) (Types.empty, parse_typ s))
-      |N(s,V v) -> Tallying.CS.M.merge (*aux_merge*) acc (Tallying.CS.M.singleton ((*false,*)Var.mk v) (parse_typ s, Types.any))
+      |P(V v,s) -> Tallying.CS.M.merge acc (Tallying.CS.M.singleton (Var.mk v) (Types.empty, parse_typ s))
+      |N(s,V v) -> Tallying.CS.M.merge acc (Tallying.CS.M.singleton (Var.mk v) (parse_typ s, Types.any))
     ) Tallying.CS.M.empty l
   in
   match l1,l2 with

types/var.ml

 
 type t = { 
-  mutable variance : [ `Covariant | `ContraVariant | `Both | `None ] ;
   fresh : bool;
   id : String.t;
 }
-let make_id ?(fresh=false) ?(variance=`None) id = 
-   { id = id ; variance = variance; fresh = fresh }
+let make_id ?(fresh=false) id = 
+   { id = id ; fresh = fresh }
 
-let dump ppf t =
-  let to_string = function
-    |`ContraVariant -> "contravariant"
-    |`Covariant -> "covariant"
-    |`Both -> "invariant"
-    |`None -> "indetermined"
-  in
-  Format.fprintf ppf "{id=%s;variance=%s;fresh=%b}" t.id (to_string t.variance) t.fresh
+let dump ppf t = Format.fprintf ppf "{id=%s;fresh=%b}" t.id t.fresh
 
 let compare x y = Pervasives.compare x.id y.id
 let equal x y = Pervasives.compare x.id y.id = 0
@@ -28,17 +20,6 @@ let print ppf (`Var x) = Format.fprintf ppf "`$%s" x.id
 let compare (`Var x) (`Var y) = compare x y
 let equal v1 v2 = (compare v1 v2) = 0
 
-let ch_variance variance (`Var t) =
-  match t.variance,variance with
-  |`None,_ -> t.variance <- variance
-  |`Both ,_ -> ()
-  |`ContraVariant,`ContraVariant 
-  |`Covariant,`Covariant -> ()
-  |_,_ -> t.variance <- `Both
-
-let set_variance variance (`Var t) = t.variance <- variance
-
-let variance (`Var t) = t.variance
 let id (`Var t) = t.id
 let is_fresh (`Var t) = t.fresh
 
@@ -76,14 +57,14 @@ module Make (X : Custom.T) = struct
     |`Var x -> dump ppf (`Var x)
 end
 
-let mk ?fresh ?variance id = 
-  `Var (make_id ?fresh ?variance id)
+let mk ?fresh id = 
+  `Var (make_id ?fresh id)
 
-let fresh : ?pre: string -> ?variance:[ `None| `Both | `ContraVariant | `Covariant ] -> unit -> [> var ] =
+let fresh : ?pre: string -> unit -> [> var ] =
   let counter = ref 0 in
-  fun ?(pre="_fresh_") -> fun ?variance -> fun _ ->
+  fun ?(pre="_fresh_") -> fun _ ->
     let id = (Printf.sprintf "%s%d" pre !counter) in
-    let v = mk ~fresh:true ?variance id in
+    let v = mk ~fresh:true id in
     incr counter;
     v
 

typing/typer.ml

@@ -314,57 +314,42 @@ module IType = struct
     all_delayed := []; 
     List.iter check_one_delayed l
 
-  let rec derecurs variance env p =
-    let neg = function
-      |`Covariant -> `ContraVariant
-      |`ContraVariant -> `Covariant
-      |cv -> cv
-    in
+  let rec derecurs env p =
     match p.descr with
-    | TVar s -> begin
-        try
-          let v = Hashtbl.find env.penv_var s in
-          Var.ch_variance variance v;
-          mk_type (Types.var v)
-        with Not_found -> begin
-          let v = Var.mk ~variance s in
-          Hashtbl.add env.penv_var s v;
-          mk_type (Types.var v)
-        end
-    end
+    | TVar s -> mk_type (Types.var (Var.mk s))
     | PatVar ids -> derecurs_var env p.loc ids
-    | Recurs (p,b) -> derecurs variance (fst (derecurs_def variance env b)) p
+    | Recurs (p,b) -> derecurs (fst (derecurs_def env b)) p
     | Internal t -> mk_type t
     | NsT ns -> 
 	mk_type (Types.atom (Atoms.any_in_ns (parse_ns env.penv_tenv p.loc ns)))
-    | Or (p1,p2) -> mk_or (derecurs variance env p1) (derecurs variance env p2)
-    | And (p1,p2) -> mk_and (derecurs variance env p1) (derecurs variance env p2)
-    | Diff (p1,p2) -> mk_diff (derecurs variance env p1) (derecurs (neg variance) env p2)
-    | Prod (p1,p2) -> mk_prod (derecurs variance env p1) (derecurs variance env p2)
-    | XmlT (p1,p2) -> mk_xml (derecurs variance env p1) (derecurs variance env p2)
-    | Arrow (p1,p2) -> mk_arrow (derecurs (neg variance) env p1) (derecurs variance env p2)
-    | Optional p -> mk_optional (derecurs variance env p)
+    | Or (p1,p2) -> mk_or (derecurs env p1) (derecurs env p2)
+    | And (p1,p2) -> mk_and (derecurs env p1) (derecurs env p2)
+    | Diff (p1,p2) -> mk_diff (derecurs env p1) (derecurs env p2)
+    | Prod (p1,p2) -> mk_prod (derecurs env p1) (derecurs env p2)
+    | XmlT (p1,p2) -> mk_xml (derecurs env p1) (derecurs env p2)
+    | Arrow (p1,p2) -> mk_arrow (derecurs env p1) (derecurs env p2)
+    | Optional p -> mk_optional (derecurs env p)
     | Record (o,r) -> 
 	let aux = function
-	  | (p,Some e) -> (derecurs variance env p, Some (derecurs variance env e))
-	  | (p,None) -> derecurs variance env p, None in
+	  | (p,Some e) -> (derecurs env p, Some (derecurs env e))
+	  | (p,None) -> derecurs env p, None in
 	mk_record o (parse_record env.penv_tenv p.loc aux r)
     | Constant (x,c) -> 
 	mk_constant (ident env.penv_tenv p.loc x) (const env.penv_tenv p.loc c)
     | Cst c -> mk_type (Types.constant (const env.penv_tenv p.loc c))
-    | Regexp r -> rexp (derecurs_regexp variance env r)
-    | Concat (p1,p2) ->  mk_concat (derecurs variance env p1) (derecurs variance env p2)
-    | Merge (p1,p2) -> mk_merge (derecurs variance env p1) (derecurs variance env p2)
+    | Regexp r -> rexp (derecurs_regexp env r)
+    | Concat (p1,p2) ->  mk_concat (derecurs env p1) (derecurs env p2)
+    | Merge (p1,p2) -> mk_merge (derecurs env p1) (derecurs env p2)
 	  
-  and derecurs_regexp variance env = function
+  and derecurs_regexp env = function
     | Epsilon -> mk_epsilon
-    | Elem p -> mk_elem (derecurs variance env p)
-    | Guard p -> mk_guard (derecurs variance env p)
-    | Seq (p1,p2) -> mk_seq (derecurs_regexp variance env p1) (derecurs_regexp variance env p2)
-    | Alt (p1,p2) -> mk_alt (derecurs_regexp variance env p1) (derecurs_regexp variance env p2)
-    | Star p -> mk_star (derecurs_regexp variance env p)
-    | WeakStar p -> mk_weakstar (derecurs_regexp variance env p)
-    | SeqCapture (loc,x,p) -> mk_seqcapt (ident env.penv_tenv loc x) (derecurs_regexp variance env p)
+    | Elem p -> mk_elem (derecurs env p)
+    | Guard p -> mk_guard (derecurs env p)
+    | Seq (p1,p2) -> mk_seq (derecurs_regexp env p1) (derecurs_regexp env p2)
+    | Alt (p1,p2) -> mk_alt (derecurs_regexp env p1) (derecurs_regexp env p2)
+    | Star p -> mk_star (derecurs_regexp env p)
+    | WeakStar p -> mk_weakstar (derecurs_regexp env p)
+    | SeqCapture (loc,x,p) -> mk_seqcapt (ident env.penv_tenv loc x) (derecurs_regexp env p)
 	  
   and derecurs_var env loc ids =
     match ids with
@@ -377,7 +362,7 @@ module IType = struct
       | ids ->
 	  mk_type (find_global_type env.penv_tenv loc ids)
 	      
-  and derecurs_def variance env b =
+  and derecurs_def env b =
     let seen = ref IdSet.empty in
     let b = 
       List.map 
@@ -393,11 +378,11 @@ module IType = struct
 
     let n = List.fold_left (fun env (v,p,s) -> Env.add v s env) env.penv_derec b in
     let env = { env with penv_derec = n } in
-    List.iter (fun (v,p,s) -> link s (derecurs variance env p)) b;
+    List.iter (fun (v,p,s) -> link s (derecurs env p)) b;
     (env, b)
 
-  let derec ?(variance=`Covariant) penv p =
-    let d = derecurs variance penv p in
+  let derec penv p =
+    let d = derecurs penv p in
     elim_concats ();
     check_delayed ();
     internalize d;
@@ -413,7 +398,7 @@ module IType = struct
 	    ("Capture variable not allowed: " ^ (Ident.to_string x))
 
   let type_defs env b =
-    let _,b' = derecurs_def `Covariant (penv env) b in
+    let _,b' = derecurs_def (penv env) b in
     elim_concats ();
     check_delayed ();
     let aux loc d =
@@ -437,9 +422,9 @@ module IType = struct
     try type_defs env b
     with exn -> clean_on_err (); raise exn
 
-  let typ ?(variance=`Covariant) env t = 
+  let typ env t = 
     try
-      let d = derec ~variance (penv env) t in
+      let d = derec (penv env) t in
       check_no_fv t.loc d;
       try typ_node d
       with Patterns.Error s -> raise_loc_generic t.loc s

typing/typer.mli

@@ -22,7 +22,7 @@ val find_value: id -> t -> Types.t
 val enter_type: id -> Types.t -> t -> t
 val iter_values: t -> (id -> Types.t -> unit) -> unit
 
-val typ: ?variance:[ `Covariant|`ContraVariant|`Both|`None] -> t -> Ast.ppat -> Types.Node.t
+val typ: t -> Ast.ppat -> Types.Node.t
 val pat: t -> Ast.ppat -> Patterns.node
 
 val dump_types: Format.formatter -> t -> unit