Commit 1d82d5dc authored by Pietro Abate's avatar Pietro Abate
Browse files

Remove Variance from parser and cleanup stale code

parent a94cbb16
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
......
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
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment