+exception BadConstraint of string Lazy.t;;
+
+let type0 = []
+
+let le_constraints = ref [] (* strict,a,b *)
+
+let rec le_path_uri avoid strict a b =
+ (not strict && NUri.eq a b) ||
+ List.exists
+ (fun (strict',x,y) ->
+ NUri.eq y b && not (List.exists (NUri.eq x) avoid) &&
+ le_path_uri (x::avoid) (strict && not strict') a x
+ ) !le_constraints
+;;
+
+let leq_path a b = le_path_uri [b] (fst a) (snd a) b;;
+
+let universe_leq a b =
+ match a, b with
+ | a,[(false,b)] -> List.for_all (fun a -> leq_path a b) a
+ | _,_ ->
+ raise (BadConstraint
+ (lazy "trying to check if a universe is less or equal than an inferred universe"))
+
+let universe_eq a b = universe_leq b a && universe_leq a b
+
+let pp_constraint b x y =
+ NUri.name_of_uri x ^ (if b then " < " else " <= ") ^ NUri.name_of_uri y
+;;
+
+let pp_constraints () =
+ String.concat "\n" (List.map (fun (b,x,y) -> pp_constraint b x y) !le_constraints)
+;;
+
+let universes = ref [];;
+
+let add_constraint strict a b =
+ match a,b with
+ | [false,a2],[false,b2] ->
+ if not (le_path_uri [] strict a2 b2) then (
+ if le_path_uri [] (not strict) b2 a2 then
+ (raise(BadConstraint(lazy("universe inconsistency adding "^pp_constraint strict a2 b2
+ ^ " to:\n" ^ pp_constraints ()))));
+ universes := a2 :: b2 ::
+ List.filter (fun x -> not (NUri.eq x a2 || NUri.eq x b2)) !universes;
+ le_constraints := (strict,a2,b2) :: !le_constraints)
+ | _ -> raise (BadConstraint
+ (lazy "trying to add a constraint on an inferred universe"))
+;;
+
+let sup l =
+ match l with
+ | [false,_] -> Some l
+ | l ->
+ let bigger_than acc (s1,n1) = List.filter (le_path_uri [] s1 n1) acc in
+ let solutions = List.fold_left bigger_than !universes l in
+ let rec aux = function
+ | [] -> None
+ | u :: tl ->
+ if List.exists (fun x -> le_path_uri [] true x u) solutions then aux tl
+ else Some [false,u]
+ in
+ aux solutions
+;;
+
+