+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+(* $Id$ *)
+
+module C = NCic
+module Ref = NReference
+
+exception CircularDependency of string Lazy.t;;
+exception ObjectNotFound of string Lazy.t;;
+exception BadDependency of string Lazy.t;;
+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 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 ()))));
+ le_constraints := (strict,a2,b2) :: !le_constraints)
+ | _ -> raise (BadConstraint
+ (lazy "trying to add a constraint on an inferred universe"))
+;;
+
+let typecheck_obj,already_set = ref (fun _ -> assert false), ref false;;
+let set_typecheck_obj f =
+ if !already_set then
+ assert false
+ else
+ begin
+ typecheck_obj := f;
+ already_set := true
+ end
+;;
+