eConstr.ml

(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *         Copyright INRIA, CNRS and contributors             *)
(* <O___,, * (see version control and CREDITS file for authors & dates) *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

open CErrors
open Util
open Names
open Constr
open Context

module NamedDecl = Context.Named.Declaration

module ESorts = struct
  include Evd.MiniEConstr.ESorts

  let equal sigma s1 s2 =
    Sorts.equal (kind sigma s1) (kind sigma s2)

  let is_small sigma s = Sorts.is_small (kind sigma s)
  let is_prop sigma s = Sorts.is_prop (kind sigma s)
  let is_sprop sigma s = Sorts.is_sprop (kind sigma s)
  let is_set sigma s = Sorts.is_set (kind sigma s)

  let prop = make Sorts.prop
  let sprop = make Sorts.sprop
  let set = make Sorts.set
  let type1 = make Sorts.type1

  let super sigma s =
    make (Sorts.super (kind sigma s))

  let relevance_of_sort sigma s =
    let r = Sorts.relevance_of_sort (unsafe_to_sorts s) in
    UState.nf_relevance (Evd.evar_universe_context sigma) r

  let family sigma s = Sorts.family (kind sigma s)

end

module EInstance = struct
  include Evd.MiniEConstr.EInstance

  let equal sigma i1 i2 =
    UVars.Instance.equal (kind sigma i1) (kind sigma i2)
end

include (Evd.MiniEConstr : module type of Evd.MiniEConstr
         with module ESorts := ESorts
          and module EInstance := EInstance)

type types = t
type constr = t
type existential = t pexistential
type case_return = t pcase_return
type case_branch = t pcase_branch
type case_invert = t pcase_invert
type case = (t, t, EInstance.t) pcase
type fixpoint = (t, t) pfixpoint
type cofixpoint = (t, t) pcofixpoint
type unsafe_judgment = (constr, types) Environ.punsafe_judgment
type unsafe_type_judgment = (types, ESorts.t) Environ.punsafe_type_judgment
type named_declaration = (constr, types) Context.Named.Declaration.pt
type rel_declaration = (constr, types) Context.Rel.Declaration.pt
type compacted_declaration = (constr, types) Context.Compacted.Declaration.pt
type named_context = (constr, types) Context.Named.pt
type compacted_context = compacted_declaration list
type rel_context = (constr, types) Context.Rel.pt

type 'a puniverses = 'a * EInstance.t

let in_punivs a = (a, EInstance.empty)

let mkSProp = of_kind (Sort (ESorts.make Sorts.sprop))
let mkProp = of_kind (Sort (ESorts.make Sorts.prop))
let mkSet = of_kind (Sort (ESorts.make Sorts.set))
let mkType u = of_kind (Sort (ESorts.make (Sorts.sort_of_univ u)))
let mkRel n = of_kind (Rel n)
let mkVar id = of_kind (Var id)
let mkMeta n = of_kind (Meta n)
let mkEvar e = of_kind (Evar e)
let mkSort s = of_kind (Sort s)
let mkCast (b, k, t) = of_kind (Cast (b, k, t))
let mkProd (na, t, u) = of_kind (Prod (na, t, u))
let mkLambda (na, t, c) = of_kind (Lambda (na, t, c))
let mkLetIn (na, b, t, c) = of_kind (LetIn (na, b, t, c))
let mkApp (f, arg) = of_kind (App (f, arg))
let mkConstU pc = of_kind (Const pc)
let mkIndU pi = of_kind (Ind pi)
let mkConstructU pc = of_kind (Construct pc)
let mkConstructUi ((ind,u),i) = of_kind (Construct ((ind,i),u))
let mkCase (ci, u, pms, c, iv, r, p) = of_kind (Case (ci, u, pms, c, iv, r, p))
let mkFix f = of_kind (Fix f)
let mkCoFix f = of_kind (CoFix f)
let mkProj (p, c) = of_kind (Proj (p, c))
let mkArrow t1 r t2 = of_kind (Prod (make_annot Anonymous r, t1, t2))
let mkArrowR t1 t2 = mkArrow t1 Sorts.Relevant t2
let mkInt i = of_kind (Int i)
let mkFloat f = of_kind (Float f)
let mkArray (u,t,def,ty) = of_kind (Array (u,t,def,ty))

let mkRef (gr,u) = let open GlobRef in match gr with
  | ConstRef c -> mkConstU (c,u)
  | IndRef ind -> mkIndU (ind,u)
  | ConstructRef c -> mkConstructU (c,u)
  | VarRef x -> mkVar x

let mkLEvar = Evd.MiniEConstr.mkLEvar

let type1 = mkSort ESorts.type1

let applist (f, arg) = mkApp (f, Array.of_list arg)
let applistc f arg = mkApp (f, Array.of_list arg)

let isRel sigma c = match kind sigma c with Rel _ -> true | _ -> false
let isVar sigma c = match kind sigma c with Var _ -> true | _ -> false
let isInd sigma c = match kind sigma c with Ind _ -> true | _ -> false
let isEvar sigma c = match kind sigma c with Evar _ -> true | _ -> false
let isMeta sigma c = match kind sigma c with Meta _ -> true | _ -> false
let isSort sigma c = match kind sigma c with Sort _ -> true | _ -> false
let isCast sigma c = match kind sigma c with Cast _ -> true | _ -> false
let isApp sigma c = match kind sigma c with App _ -> true | _ -> false
let isLambda sigma c = match kind sigma c with Lambda _ -> true | _ -> false
let isLetIn sigma c = match kind sigma c with LetIn _ -> true | _ -> false
let isProd sigma c = match kind sigma c with Prod _ -> true | _ -> false
let isConst sigma c = match kind sigma c with Const _ -> true | _ -> false
let isConstruct sigma c = match kind sigma c with Construct _ -> true | _ -> false
let isFix sigma c = match kind sigma c with Fix _ -> true | _ -> false
let isCoFix sigma c = match kind sigma c with CoFix _ -> true | _ -> false
let isCase sigma c = match kind sigma c with Case _ -> true | _ -> false
let isProj sigma c = match kind sigma c with Proj _ -> true | _ -> false

let rec isType sigma c = match kind sigma c with
  | Sort s -> (match ESorts.kind sigma s with
      | Sorts.Type _ -> true
      | _ -> false )
  | Cast (c,_,_) -> isType sigma c
  | _ -> false

let isVarId sigma id c =
  match kind sigma c with Var id' -> Id.equal id id' | _ -> false
let isRelN sigma n c =
  match kind sigma c with Rel n' -> Int.equal n n' | _ -> false

let isRef sigma c = match kind sigma c with
  | Const _ | Ind _ | Construct _ | Var _ -> true
  | _ -> false

let isRefX env sigma x c =
  let open GlobRef in
  match x, kind sigma c with
  | ConstRef c, Const (c', _) -> Environ.QConstant.equal env c c'
  | IndRef i, Ind (i', _) -> Environ.QInd.equal env i i'
  | ConstructRef i, Construct (i', _) -> Environ.QConstruct.equal env i i'
  | VarRef id, Var id' -> Id.equal id id'
  | _ -> false

let is_lib_ref env sigma x c =
  match Coqlib.lib_ref_opt x with
  | Some x -> isRefX env sigma x c
  | None -> false

let destRel sigma c = match kind sigma c with
| Rel p -> p
| _ -> raise DestKO

let destVar sigma c = match kind sigma c with
| Var p -> p
| _ -> raise DestKO

let destInd sigma c = match kind sigma c with
| Ind p -> p
| _ -> raise DestKO

let destEvar sigma c = match kind sigma c with
| Evar p -> p
| _ -> raise DestKO

let destMeta sigma c = match kind sigma c with
| Meta p -> p
| _ -> raise DestKO

let destSort sigma c = match kind sigma c with
| Sort p -> p
| _ -> raise DestKO

let destCast sigma c = match kind sigma c with
| Cast (c, k, t) -> (c, k, t)
| _ -> raise DestKO

let destApp sigma c = match kind sigma c with
| App (f, a) -> (f, a)
| _ -> raise DestKO

let destLambda sigma c = match kind sigma c with
| Lambda (na, t, c) -> (na, t, c)
| _ -> raise DestKO

let destLetIn sigma c = match kind sigma c with
| LetIn (na, b, t, c) -> (na, b, t, c)
| _ -> raise DestKO

let destProd sigma c = match kind sigma c with
| Prod (na, t, c) -> (na, t, c)
| _ -> raise DestKO

let destConst sigma c = match kind sigma c with
| Const p -> p
| _ -> raise DestKO

let destConstruct sigma c = match kind sigma c with
| Construct p -> p
| _ -> raise DestKO

let destFix sigma c = match kind sigma c with
| Fix p -> p
| _ -> raise DestKO

let destCoFix sigma c = match kind sigma c with
| CoFix p -> p
| _ -> raise DestKO

let destCase sigma c = match kind sigma c with
| Case (ci, u, pms, t, iv, c, p) -> (ci, u, pms, t, iv, c, p)
| _ -> raise DestKO

let destProj sigma c = match kind sigma c with
| Proj (p, c) -> (p, c)
| _ -> raise DestKO

let destRef sigma c = let open GlobRef in match kind sigma c with
  | Var x -> VarRef x, EInstance.empty
  | Const (c,u) -> ConstRef c, u
  | Ind (ind,u) -> IndRef ind, u
  | Construct (c,u) -> ConstructRef c, u
  | _ -> raise DestKO

let decompose_app sigma c =
  match kind sigma c with
  | App (f,cl) -> (f, cl)
  | _ -> (c,[||])

let decompose_app_list sigma c =
  match kind sigma c with
    | App (f,cl) -> (f, Array.to_list cl)
    | _ -> (c,[])

let decompose_lambda sigma c =
  let rec lamdec_rec l c = match kind sigma c with
    | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) c
    | Cast (c,_,_)     -> lamdec_rec l c
    | _                -> l,c
  in
  lamdec_rec [] c

let decompose_lambda_decls sigma c =
  let open Rel.Declaration in
  let rec lamdec_rec l c =
    match kind sigma c with
    | Lambda (x,t,c)  -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) c
    | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) c
    | Cast (c,_,_)    -> lamdec_rec l c
    | _               -> l,c
  in
  lamdec_rec Context.Rel.empty c

let decompose_lambda_n_assum sigma n c =
  let open Rel.Declaration in
  if n < 0 then
    anomaly Pp.(str "decompose_lambda_n_assum: integer parameter must be positive.");
  let rec lamdec_rec l n c =
    if Int.equal n 0 then l,c
    else
      match kind sigma c with
      | Lambda (x,t,c)  -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c
      | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) n c
      | Cast (c,_,_)    -> lamdec_rec l n c
      | c -> anomaly Pp.(str "decompose_lambda_n_assum: not enough abstractions.")
  in
  lamdec_rec Context.Rel.empty n c

let decompose_lambda_n_decls sigma n =
  let open Rel.Declaration in
  if n < 0 then
    anomaly Pp.(str "decompose_lambda_n_decls: integer parameter must be positive.");
  let rec lamdec_rec l n c =
    if Int.equal n 0 then l,c
    else
      match kind sigma c with
      | Lambda (x,t,c)  -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c
      | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c
      | Cast (c,_,_)    -> lamdec_rec l n c
      | c -> anomaly Pp.(str "decompose_lambda_n_decls: not enough abstractions.")
  in
  lamdec_rec Context.Rel.empty n

let rec to_lambda sigma n prod =
  if Int.equal n 0 then
    prod
  else
    match kind sigma prod with
      | Prod (na,ty,bd) -> mkLambda (na,ty,to_lambda sigma (n-1) bd)
      | Cast (c,_,_) -> to_lambda sigma n c
      | _   -> anomaly Pp.(str "Not enough products.")

let decompose_prod sigma c =
  let rec proddec_rec l c = match kind sigma c with
    | Prod (x,t,c) -> proddec_rec ((x,t)::l) c
    | Cast (c,_,_) -> proddec_rec l c
    | _            -> l,c
  in
  proddec_rec [] c

let decompose_prod_decls sigma c =
  let open Rel.Declaration in
  let rec proddec_rec l c =
    match kind sigma c with
    | Prod (x,t,c)    -> proddec_rec (Context.Rel.add (LocalAssum (x,t)) l) c
    | LetIn (x,b,t,c) -> proddec_rec (Context.Rel.add (LocalDef (x,b,t)) l) c
    | Cast (c,_,_)    -> proddec_rec l c
    | _               -> l,c
  in
  proddec_rec Context.Rel.empty c

let decompose_prod_n_decls sigma n c =
  let open Rel.Declaration in
  if n < 0 then
    anomaly Pp.(str "decompose_prod_n_decls: integer parameter must be positive.");
  let rec prodec_rec l n c =
    if Int.equal n 0 then l,c
    else
      match kind sigma c with
      | Prod (x,t,c)    -> prodec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c
      | LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c
      | Cast (c,_,_)    -> prodec_rec l n c
      | c -> anomaly Pp.(str "decompose_prod_n_decls: not enough assumptions.")
  in
  prodec_rec Context.Rel.empty n c

let prod_decls sigma t = fst (decompose_prod_decls sigma t)

let existential_type = Evd.existential_type

let lift n c = of_constr (Vars.lift n (unsafe_to_constr c))

let of_branches : Constr.case_branch array -> case_branch array =
  match Evd.MiniEConstr.unsafe_eq with
  | Refl -> fun x -> x

let unsafe_to_branches : case_branch array -> Constr.case_branch array =
  match Evd.MiniEConstr.unsafe_eq with
  | Refl -> fun x -> x

let of_return : Constr.case_return -> case_return =
  match Evd.MiniEConstr.unsafe_eq with
  | Refl -> fun x -> x

let unsafe_to_return : case_return -> Constr.case_return =
  match Evd.MiniEConstr.unsafe_eq with
  | Refl -> fun x -> x

let map_branches f br =
  let f c = unsafe_to_constr (f (of_constr c)) in
  of_branches (Constr.map_branches f (unsafe_to_branches br))
let map_return_predicate f p =
  let f c = unsafe_to_constr (f (of_constr c)) in
  of_return (Constr.map_return_predicate f (unsafe_to_return p))

let map_instance sigma f evk args =
  let rec map ctx args = match ctx, SList.view args with
  | [], None -> SList.empty
  | decl :: ctx, Some (Some c, rem) ->
    let c' = f c in
    let rem' = map ctx rem in
    if c' == c && rem' == rem then args
    else if Constr.isVarId (NamedDecl.get_id decl) c' then SList.default rem'
    else SList.cons c' rem'
  | decl :: ctx, Some (None, rem) ->
    let c = Constr.mkVar (NamedDecl.get_id decl) in
    let c' = f c in
    let rem' = map ctx rem in
    if c' == c && rem' == rem then args
    else SList.cons c' rem'
  | [], Some _ | _ :: _, None -> assert false
  in
  let EvarInfo evi = Evd.find sigma evk in
  let ctx = Evd.evar_filtered_context evi in
  map ctx args

let map sigma f c =
  let f c = unsafe_to_constr (f (of_constr c)) in
  let c = unsafe_to_constr @@ whd_evar sigma c in
  match Constr.kind c with
  | Evar (evk, args) ->
    let args' = map_instance sigma f evk args in
    if args' == args then of_constr c else of_constr @@ Constr.mkEvar (evk, args')
  | _ -> of_constr (Constr.map f c)

let map_with_binders sigma g f l c =
  let f l c = unsafe_to_constr (f l (of_constr c)) in
  let c = unsafe_to_constr @@ whd_evar sigma c in
  match Constr.kind c with
  | Evar (evk, args) ->
    let args' = map_instance sigma (fun c -> f l c) evk args in
    if args' == args then of_constr c else of_constr @@ Constr.mkEvar (evk, args')
  | _ -> of_constr (Constr.map_with_binders g f l c)

let map_existential sigma f ((evk, args) as ev : existential) =
  let f c = unsafe_to_constr (f (of_constr c)) in
  let args : Constr.t SList.t = match Evd.MiniEConstr.unsafe_eq with Refl -> args in
  let args' = map_instance sigma f evk args in
  if args' == args then ev
  else
    let args' : t SList.t = match Evd.MiniEConstr.unsafe_eq with Refl -> args' in
    (evk, args')

let iter sigma f c =
  let f c = f (of_constr c) in
  let c = unsafe_to_constr @@ whd_evar sigma c in
  match Constr.kind c with
  | Evar ((evk, _) as ev) ->
    let args = Evd.expand_existential0 sigma ev in
    List.iter (fun c -> f c) args
  | _ -> Constr.iter f c

let expand_case env _sigma (ci, u, pms, p, iv, c, bl) =
  let u = EInstance.unsafe_to_instance u in
  let pms = unsafe_to_constr_array pms in
  let p = unsafe_to_return p in
  let iv = unsafe_to_case_invert iv in
  let c = unsafe_to_constr c in
  let bl = unsafe_to_branches bl in
  let (ci, p, iv, c, bl) = Inductive.expand_case env (ci, u, pms, p, iv, c, bl) in
  let p = of_constr p in
  let c = of_constr c in
  let iv = of_case_invert iv in
  let bl = of_constr_array bl in
  (ci, p, iv, c, bl)

let annotate_case env sigma (ci, u, pms, p, iv, c, bl as case) =
  let (_, p, _, _, bl) = expand_case env sigma case in
  let p =
    (* Too bad we need to fetch this data in the environment, should be in the
      case_info instead. *)
    let (_, mip) = Inductive.lookup_mind_specif env ci.ci_ind in
    decompose_lambda_n_decls sigma (mip.Declarations.mind_nrealdecls + 1) p
  in
  let mk_br c n = decompose_lambda_n_decls sigma n c in
  let bl = Array.map2 mk_br bl ci.ci_cstr_ndecls in
  (ci, u, pms, p, iv, c, bl)

let expand_branch env _sigma u pms (ind, i) (nas, _br) =
  let open Declarations in
  let u = EInstance.unsafe_to_instance u in
  let pms = unsafe_to_constr_array pms in
  let (mib, mip) = Inductive.lookup_mind_specif env ind in
  let paramdecl = Vars.subst_instance_context u mib.mind_params_ctxt in
  let paramsubst = Vars.subst_of_rel_context_instance paramdecl pms in
  let (ctx, _) = mip.mind_nf_lc.(i - 1) in
  let (ctx, _) = List.chop mip.mind_consnrealdecls.(i - 1) ctx in
  let ans = Inductive.instantiate_context u paramsubst nas ctx in
  let ans : rel_context = match Evd.MiniEConstr.unsafe_eq with Refl -> ans in
  ans

let contract_case env _sigma (ci, p, iv, c, bl) =
  let p = unsafe_to_constr p in
  let iv = unsafe_to_case_invert iv in
  let c = unsafe_to_constr c in
  let bl = unsafe_to_constr_array bl in
  let (ci, u, pms, p, iv, c, bl) = Inductive.contract_case env (ci, p, iv, c, bl) in
  let u = EInstance.make u in
  let pms = of_constr_array pms in
  let p = of_return p in
  let iv = of_case_invert iv in
  let c = of_constr c in
  let bl = of_branches bl in
  (ci, u, pms, p, iv, c, bl)

let iter_with_full_binders env sigma g f n c =
  let open Context.Rel.Declaration in
  match kind sigma c with
  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
    | Construct _ | Int _ | Float _) -> ()
  | Cast (c,_,t) -> f n c; f n t
  | Prod (na,t,c) -> f n t; f (g (LocalAssum (na, t)) n) c
  | Lambda (na,t,c) -> f n t; f (g (LocalAssum (na, t)) n) c
  | LetIn (na,b,t,c) -> f n b; f n t; f (g (LocalDef (na, b, t)) n) c
  | App (c,l) -> f n c; Array.Fun1.iter f n l
  | Evar ((_,l) as ev) ->
    let l = Evd.expand_existential sigma ev in
    List.iter (fun c -> f n c) l
  | Case (ci,u,pms,p,iv,c,bl) ->
    let (ci, _, pms, p, iv, c, bl) = annotate_case env sigma (ci, u, pms, p, iv, c, bl) in
    let f_ctx (ctx, c) = f (List.fold_right g ctx n) c in
    Array.Fun1.iter f n pms; f_ctx p; iter_invert (f n) iv; f n c; Array.iter f_ctx bl
  | Proj (p,c) -> f n c
  | Fix (_,(lna,tl,bl)) ->
    Array.iter (f n) tl;
    let n' = Array.fold_left2_i (fun i n na t -> g (LocalAssum (na, lift i t)) n) n lna tl in
    Array.iter (f n') bl
  | CoFix (_,(lna,tl,bl)) ->
    Array.iter (f n) tl;
    let n' = Array.fold_left2_i (fun i n na t -> g (LocalAssum (na,lift i t)) n) n lna tl in
    Array.iter (f n') bl
  | Array (_u,t,def,ty) -> Array.Fun1.iter f n t; f n def; f n ty

let iter_with_binders sigma g f n c =
  let f l c = f l (of_constr c) in
  let c = unsafe_to_constr @@ whd_evar sigma c in
  match Constr.kind c with
  | Evar ((evk, _) as ev) ->
    let args = Evd.expand_existential0 sigma ev in
    List.iter (fun c -> f n c) args
  | _ -> Constr.iter_with_binders g f n c

let fold sigma f acc c =
  let f acc c = f acc (of_constr c) in
  let c = unsafe_to_constr @@ whd_evar sigma c in
  match Constr.kind c with
  | Evar ((evk, _) as ev) ->
    let args = Evd.expand_existential0 sigma ev in
    List.fold_left f acc args
  | _ -> Constr.fold f acc c

let fold_with_binders sigma g f e acc c =
  let f e acc c = f e acc (of_constr c) in
  let c = unsafe_to_constr @@ whd_evar sigma c in
  match Constr.kind c with
  | Evar ((evk, _) as ev) ->
    let args = Evd.expand_existential0 sigma ev in
    List.fold_left (fun acc c -> f e acc c) acc args
  | _ -> Constr.fold_constr_with_binders g f e acc c

let compare_gen k eq_inst eq_sort eq_constr eq_evars nargs c1 c2 =
  (c1 == c2) || Constr.compare_head_gen_with k k eq_inst eq_sort eq_constr eq_evars nargs c1 c2

let eq_existential sigma eq (evk1, args1) (evk2, args2) =
  if Evar.equal evk1 evk2 then
    let args1 = Evd.expand_existential sigma (evk1, args1) in
    let args2 = Evd.expand_existential sigma (evk2, args2) in
    List.equal eq args1 args2
  else false

let eq_constr sigma c1 c2 =
  let kind c = kind sigma c in
  let eq_inst _ i1 i2 = EInstance.equal sigma i1 i2 in
  let eq_sorts s1 s2 = ESorts.equal sigma s1 s2 in
  let eq_existential eq e1 e2 = eq_existential sigma (eq 0) e1 e2 in
  let rec eq_constr nargs c1 c2 =
    compare_gen kind eq_inst eq_sorts (eq_existential eq_constr) eq_constr nargs c1 c2
  in
  eq_constr 0 c1 c2

let eq_constr_nounivs sigma c1 c2 =
  let kind c = kind sigma c in
  let eq_existential eq e1 e2 = eq_existential sigma (eq 0) e1 e2 in
  let rec eq_constr nargs c1 c2 =
    compare_gen kind (fun _ _ _ -> true) (fun _ _ -> true) (eq_existential eq_constr) eq_constr nargs c1 c2
  in
  eq_constr 0 c1 c2

let compare_constr sigma cmp c1 c2 =
  let kind c = kind sigma c in
  let eq_inst _ i1 i2 = EInstance.equal sigma i1 i2 in
  let eq_sorts s1 s2 = ESorts.equal sigma s1 s2 in
  let eq_existential eq e1 e2 = eq_existential sigma (eq 0) e1 e2 in
  let cmp nargs c1 c2 = cmp c1 c2 in
  compare_gen kind eq_inst eq_sorts (eq_existential cmp) cmp 0 c1 c2

let cmp_inductives cv_pb (mind,ind as spec) nargs u1 u2 cstrs =
  let open UnivProblem in
  match mind.Declarations.mind_variance with
  | None -> enforce_eq_instances_univs false u1 u2 cstrs
  | Some variances ->
    let num_param_arity = Conversion.inductive_cumulativity_arguments spec in
    if not (Int.equal num_param_arity nargs) then enforce_eq_instances_univs false u1 u2 cstrs
    else compare_cumulative_instances cv_pb  variances u1 u2 cstrs

let cmp_constructors (mind, ind, cns as spec) nargs u1 u2 cstrs =
  let open UnivProblem in
  match mind.Declarations.mind_variance with
  | None -> enforce_eq_instances_univs false u1 u2 cstrs
  | Some _ ->
    let num_cnstr_args = Conversion.constructor_cumulativity_arguments spec in
    if not (Int.equal num_cnstr_args nargs)
    then enforce_eq_instances_univs false u1 u2 cstrs
    else
      let qs1, us1 = UVars.Instance.to_array u1
      and qs2, us2 = UVars.Instance.to_array u2 in
      let cstrs = enforce_eq_qualities qs1 qs2 cstrs in
      Array.fold_left2 (fun cstrs u1 u2 -> UnivProblem.(Set.add (UWeak (u1,u2)) cstrs))
        cstrs us1 us2

let eq_universes env sigma cstrs cv_pb refargs l l' =
  if EInstance.is_empty l then (assert (EInstance.is_empty l'); true)
  else
    let l = EInstance.kind sigma l
    and l' = EInstance.kind sigma l' in
    let open GlobRef in
    let open UnivProblem in
    match refargs with
    | Some (ConstRef c, 1) when Environ.is_array_type env c ->
      cstrs := compare_cumulative_instances cv_pb [|UVars.Variance.Irrelevant|] l l' !cstrs;
      true
    | None | Some (ConstRef _, _) ->
      cstrs := enforce_eq_instances_univs true l l' !cstrs; true
    | Some (VarRef _, _) -> assert false (* variables don't have instances *)
    | Some (IndRef ind, nargs) ->
      let mind = Environ.lookup_mind (fst ind) env in
      cstrs := cmp_inductives cv_pb (mind,snd ind) nargs l l' !cstrs;
      true
    | Some (ConstructRef ((mi,ind),ctor), nargs) ->
      let mind = Environ.lookup_mind mi env in
      cstrs := cmp_constructors (mind,ind,ctor) nargs l l' !cstrs;
      true

let test_constr_universes env sigma leq ?(nargs=0) m n =
  let open UnivProblem in
  let kind c = kind sigma c in
  if m == n then Some Set.empty
  else
    let cstrs = ref Set.empty in
    let cv_pb = if leq then Conversion.CUMUL else Conversion.CONV in
    let eq_universes refargs l l' = eq_universes env sigma cstrs Conversion.CONV refargs l l'
    and leq_universes refargs l l' = eq_universes env sigma cstrs cv_pb refargs l l' in
    let eq_sorts s1 s2 =
      let s1 = ESorts.kind sigma s1 in
      let s2 = ESorts.kind sigma s2 in
      if Sorts.equal s1 s2 then true
      else (cstrs := Set.add
              (UEq (s1, s2)) !cstrs;
            true)
    in
    let leq_sorts s1 s2 =
      let s1 = ESorts.kind sigma s1 in
      let s2 = ESorts.kind sigma s2 in
      if Sorts.equal s1 s2 then true
      else
        (cstrs := Set.add
           (ULe (s1, s2)) !cstrs;
         true)
    in
    let eq_existential eq e1 e2 = eq_existential sigma (eq 0) e1 e2 in
    let rec eq_constr' nargs m n = compare_gen kind eq_universes eq_sorts (eq_existential eq_constr') eq_constr' nargs m n in
    let res =
      if leq then
        let rec compare_leq nargs m n =
          Constr.compare_head_gen_leq_with kind kind leq_universes leq_sorts (eq_existential eq_constr')
            eq_constr' leq_constr' nargs m n
        and leq_constr' nargs m n = m == n || compare_leq nargs m n in
        compare_leq nargs m n
      else
        Constr.compare_head_gen_with kind kind eq_universes eq_sorts (eq_existential eq_constr') eq_constr' nargs m n
    in
    if res then Some !cstrs else None

let eq_constr_universes env sigma ?nargs m n =
  test_constr_universes env sigma false ?nargs m n
let leq_constr_universes env sigma ?nargs m n =
  test_constr_universes env sigma true ?nargs m n

let compare_head_gen_proj env sigma equ eqs eqev eqc' nargs m n =
  let kind c = kind sigma c in
  match kind m, kind n with
  | Proj (p, c), App (f, args)
  | App (f, args), Proj (p, c) ->
      (match kind f with
      | Const (p', u) when Environ.QConstant.equal env (Projection.constant p) p' ->
          let npars = Projection.npars p in
          if Array.length args == npars + 1 then
            eqc' 0 c args.(npars)
          else false
      | _ -> false)
  | _ -> Constr.compare_head_gen_with kind kind equ eqs eqev eqc' nargs m n

let eq_constr_universes_proj env sigma m n =
  let open UnivProblem in
  if m == n then Some Set.empty
  else
    let cstrs = ref Set.empty in
    let eq_universes ref l l' = eq_universes env sigma cstrs Conversion.CONV ref l l' in
    let eq_sorts s1 s2 =
      let s1 = ESorts.kind sigma s1 in
      let s2 = ESorts.kind sigma s2 in
      if Sorts.equal s1 s2 then true
      else
        (cstrs := Set.add
           (UEq (s1, s2)) !cstrs;
         true)
    in
    let eq_existential eq e1 e2 = eq_existential sigma (eq 0) e1 e2 in
    let rec eq_constr' nargs m n =
      m == n || compare_head_gen_proj env sigma eq_universes eq_sorts (eq_existential eq_constr') eq_constr' nargs m n
    in
    let res = eq_constr' 0 m n in
    if res then Some !cstrs else None

let add_universes_of_instance sigma (qs,us) u =
  let u = EInstance.kind sigma u in
  let qs', us' = UVars.Instance.levels u in
  let qs = Sorts.Quality.(Set.fold (fun q qs -> match q with
      | QVar q -> Sorts.QVar.Set.add q qs
      | QConstant _ -> qs)
      qs' qs)
  in
  qs, Univ.Level.Set.union us us'

let fold_annot_relevance f acc na =
  f acc na.Context.binder_relevance

let fold_case_under_context_relevance f acc (nas,_) =
  Array.fold_left (fold_annot_relevance f) acc nas

let fold_rec_declaration_relevance f acc (nas,_,_) =
  Array.fold_left (fold_annot_relevance f) acc nas

let fold_constr_relevance sigma f acc c =
  match kind sigma c with
  | Rel _ | Var _ | Meta _ | Evar _
  |  Sort _ | Cast _ | App _
  | Const _ | Ind _ | Construct _ | Proj _
  | Int _ | Float _ | Array _ -> acc

  | Prod (na,_,_) | Lambda (na,_,_) | LetIn (na,_,_,_) ->
    fold_annot_relevance f acc na

  | Case (ci,_u,_params,ret,_iv,_v,brs) ->
    let acc = f acc ci.ci_relevance in
    let acc = fold_case_under_context_relevance f acc ret in
    let acc = CArray.fold_left (fold_case_under_context_relevance f) acc brs in
    acc

  | Fix (_,data)
  | CoFix (_,data) ->
    fold_rec_declaration_relevance f acc data

let add_relevance sigma (qs,us as v) r =
  let open Sorts in
  (* NB this normalizes above_prop to Relevant which makes it disappear *)
  match UState.nf_relevance (Evd.evar_universe_context sigma) r with
  | Irrelevant | Relevant -> v
  | RelevanceVar q -> QVar.Set.add q qs, us

let universes_of_constr sigma c =
  let open Univ in
  let rec aux s c =
    let s = fold_constr_relevance sigma (add_relevance sigma) s c in
    match kind sigma c with
    | Const (_, u) | Ind (_, u) | Construct (_,u) -> add_universes_of_instance sigma s u
    | Sort u -> begin match ESorts.kind sigma u with
        | Type u ->
          Util.on_snd (Level.Set.fold Level.Set.add (Universe.levels u)) s
        | QSort (q, u) ->
          let qs, us = s in
          Sorts.QVar.Set.add q qs, Level.Set.union us (Universe.levels u)
        | SProp | Prop | Set -> s
      end
    | Evar (k, args) ->
      let concl = Evd.evar_concl (Evd.find_undefined sigma k) in
      fold sigma aux (aux s concl) c
    | Array (u,_,_,_) ->
      let s = add_universes_of_instance sigma s u in
      fold sigma aux s c
    | Case (_,u,_,_,_,_,_) ->
      let s = add_universes_of_instance sigma s u in
      fold sigma aux s c
    | _ -> fold sigma aux s c
  in aux (Sorts.QVar.Set.empty,Level.Set.empty) c

open Context
open Environ

let cast_list : type a b. (a,b) eq -> a list -> b list =
  fun Refl x -> x

let cast_vect : type a b. (a,b) eq -> a array -> b array =
  fun Refl x -> x

let cast_rel_decl :
  type a b. (a,b) eq -> (a, a) Rel.Declaration.pt -> (b, b) Rel.Declaration.pt =
  fun Refl x -> x

let cast_rel_context :
  type a b. (a,b) eq -> (a, a) Rel.pt -> (b, b) Rel.pt =
  fun Refl x -> x

let cast_rec_decl :
  type a b. (a,b) eq -> (a, a) Constr.prec_declaration -> (b, b) Constr.prec_declaration =
  fun Refl x -> x

let cast_named_decl :
  type a b. (a,b) eq -> (a, a) Named.Declaration.pt -> (b, b) Named.Declaration.pt =
  fun Refl x -> x

let cast_named_context :
  type a b. (a,b) eq -> (a, a) Named.pt -> (b, b) Named.pt =
  fun Refl x -> x


module Vars =
struct
exception LocalOccur
let to_constr = unsafe_to_constr
let to_rel_decl = unsafe_to_rel_decl

type instance = t array
type instance_list = t list
type substl = t list

(** Operations that commute with evar-normalization *)
let lift = lift
let liftn n m c = of_constr (Vars.liftn n m (to_constr c))

let substnl subst n c = of_constr (Vars.substnl (cast_list unsafe_eq subst) n (to_constr c))
let substl subst c = of_constr (Vars.substl (cast_list unsafe_eq subst) (to_constr c))
let subst1 c r = of_constr (Vars.subst1 (to_constr c) (to_constr r))

let substnl_decl subst n d = of_rel_decl (Vars.substnl_decl (cast_list unsafe_eq subst) n (to_rel_decl d))
let substl_decl subst d = of_rel_decl (Vars.substl_decl (cast_list unsafe_eq subst) (to_rel_decl d))
let subst1_decl c d = of_rel_decl (Vars.subst1_decl (to_constr c) (to_rel_decl d))

type substituend = Vars.substituend
let make_substituend c = Vars.make_substituend (unsafe_to_constr c)
let lift_substituend n s = of_constr (Vars.lift_substituend n s)

let replace_vars = replace_vars

(* (subst_var str t) substitute (Var str) by (Rel 1) in t *)
let subst_var sigma str t = replace_vars sigma [(str, mkRel 1)] t

(* (subst_vars [id1;...;idn] t) substitute (Var idj) by (Rel j) in t *)
let substn_vars sigma p vars c =
  let _,subst =
    List.fold_left (fun (n,l) var -> ((n+1),(var, mkRel n)::l)) (p,[]) vars
  in replace_vars sigma (List.rev subst) c

let subst_vars sigma subst c = substn_vars sigma 1 subst c

let subst_univs_level_constr subst c =
  of_constr (Vars.subst_univs_level_constr subst (to_constr c))

let subst_instance_context subst ctx =
  cast_rel_context (sym unsafe_eq) (Vars.subst_instance_context subst (cast_rel_context unsafe_eq ctx))

let subst_instance_constr subst c =
  of_constr (Vars.subst_instance_constr subst (to_constr c))

(** Operations that dot NOT commute with evar-normalization *)
let noccurn sigma n term =
  let rec occur_rec n c = match kind sigma c with
    | Rel m -> if Int.equal m n then raise LocalOccur
    | Evar (_, l) -> SList.Skip.iter (fun c -> occur_rec n c) l
    | _ -> iter_with_binders sigma succ occur_rec n c
  in
  try occur_rec n term; true with LocalOccur -> false

let noccur_between sigma n m term =
  let rec occur_rec n c = match kind sigma c with
    | Rel p -> if n<=p && p<n+m then raise LocalOccur
    | Evar (_, l) -> SList.Skip.iter (fun c -> occur_rec n c) l
    | _        -> iter_with_binders sigma succ occur_rec n c
  in
  try occur_rec n term; true with LocalOccur -> false

let closedn sigma n c =
  let rec closed_rec n c = match kind sigma c with
    | Rel m -> if m>n then raise LocalOccur
    | Evar (_, l) -> SList.Skip.iter (fun c -> closed_rec n c) l
    | _ -> iter_with_binders sigma succ closed_rec n c
  in
  try closed_rec n c; true with LocalOccur -> false

let closed0 sigma c = closedn sigma 0 c

let subst_of_rel_context_instance ctx subst =
  cast_list (sym unsafe_eq)
    (Vars.subst_of_rel_context_instance (cast_rel_context unsafe_eq ctx) (cast_vect unsafe_eq subst))
let subst_of_rel_context_instance_list ctx subst =
  cast_list (sym unsafe_eq)
    (Vars.subst_of_rel_context_instance_list (cast_rel_context unsafe_eq ctx) (cast_list unsafe_eq subst))

let liftn_rel_context n k ctx =
  cast_rel_context (sym unsafe_eq)
    (Vars.liftn_rel_context n k (cast_rel_context unsafe_eq ctx))

let lift_rel_context n ctx =
  cast_rel_context (sym unsafe_eq)
    (Vars.lift_rel_context n (cast_rel_context unsafe_eq ctx))

let substnl_rel_context subst n ctx =
  cast_rel_context (sym unsafe_eq)
    (Vars.substnl_rel_context (cast_list unsafe_eq subst) n (cast_rel_context unsafe_eq ctx))

let substl_rel_context subst ctx =
  cast_rel_context (sym unsafe_eq)
    (Vars.substl_rel_context (cast_list unsafe_eq subst) (cast_rel_context unsafe_eq ctx))

let smash_rel_context ctx =
  cast_rel_context (sym unsafe_eq)
      (Vars.smash_rel_context (cast_rel_context unsafe_eq ctx))

let esubst : (int -> 'a -> t) -> 'a Esubst.subs -> t -> t =
match unsafe_eq with
| Refl -> Vars.esubst

end

(* Constructs either [forall x:t, c] or [let x:=b:t in c] *)
let mkProd_or_LetIn decl c =
  let open Context.Rel.Declaration in
  match decl with
  | LocalAssum (na,t) -> mkProd (na, t, c)
  | LocalDef (na,b,t) -> mkLetIn (na, b, t, c)

(* Constructs either [forall x:t, c] or [c] in which [x] is replaced by [b] *)
let mkProd_wo_LetIn decl c =
  let open Context.Rel.Declaration in
  match decl with
  | LocalAssum (na,t) -> mkProd (na, t, c)
  | LocalDef (_,b,_) -> Vars.subst1 b c

let mkLambda_or_LetIn decl c =
  let open Context.Rel.Declaration in
  match decl with
  | LocalAssum (na,t) -> mkLambda (na, t, c)
  | LocalDef (na,b,t) -> mkLetIn (na, b, t, c)

let mkLambda_wo_LetIn decl c =
  let open Context.Rel.Declaration in
  match decl with
  | LocalAssum (na,t) -> mkLambda (na, t, c)
  | LocalDef (_,b,_) -> Vars.subst1 b c

let mkNamedProd sigma id typ c = mkProd (map_annot Name.mk_name id, typ, Vars.subst_var sigma id.binder_name c)
let mkNamedLambda sigma id typ c = mkLambda (map_annot Name.mk_name id, typ, Vars.subst_var sigma id.binder_name c)
let mkNamedLetIn sigma id c1 t c2 = mkLetIn (map_annot Name.mk_name id, c1, t, Vars.subst_var sigma id.binder_name c2)

let mkNamedProd_or_LetIn sigma decl c =
  let open Context.Named.Declaration in
  match decl with
  | LocalAssum (id,t) -> mkNamedProd sigma id t c
  | LocalDef (id,b,t) -> mkNamedLetIn sigma id b t c

let mkNamedLambda_or_LetIn sigma decl c =
  let open Context.Named.Declaration in
  match decl with
  | LocalAssum (id,t) -> mkNamedLambda sigma id t c
  | LocalDef (id,b,t) -> mkNamedLetIn sigma id b t c

let mkNamedProd_wo_LetIn sigma decl c =
  let open Context.Named.Declaration in
  match decl with
  | LocalAssum (id,t) -> mkNamedProd sigma id t c
  | LocalDef (id,b,t) -> Vars.subst1 b c

let it_mkProd init = List.fold_left (fun c (n,t)  -> mkProd (n, t, c)) init
let it_mkLambda init = List.fold_left (fun c (n,t)  -> mkLambda (n, t, c)) init

let compose_lam l b = it_mkLambda b l

let it_mkProd_or_LetIn t ctx = List.fold_left (fun c d -> mkProd_or_LetIn d c) t ctx
let it_mkLambda_or_LetIn t ctx = List.fold_left (fun c d -> mkLambda_or_LetIn d c) t ctx

let it_mkProd_wo_LetIn t ctx = List.fold_left (fun c d -> mkProd_wo_LetIn d c) t ctx
let it_mkLambda_wo_LetIn t ctx = List.fold_left (fun c d -> mkLambda_wo_LetIn d c) t ctx

let it_mkNamedProd_or_LetIn sigma t ctx = List.fold_left (fun c d -> mkNamedProd_or_LetIn sigma d c) t ctx
let it_mkNamedLambda_or_LetIn sigma t ctx = List.fold_left (fun c d -> mkNamedLambda_or_LetIn sigma d c) t ctx

let it_mkNamedProd_wo_LetIn sigma t ctx = List.fold_left (fun c d -> mkNamedProd_wo_LetIn sigma d c) t ctx

let rec isArity sigma c =
  match kind sigma c with
  | Prod (_,_,c)    -> isArity sigma c
  | LetIn (_,b,_,c) -> isArity sigma (Vars.subst1 b c)
  | Cast (c,_,_)      -> isArity sigma c
  | Sort _          -> true
  | _               -> false

type arity = rel_context * ESorts.t

let mkArity (ctx, s) = it_mkProd_or_LetIn (mkSort s) ctx

let destArity sigma =
  let open Context.Rel.Declaration in
  let rec prodec_rec l c =
    match kind sigma c with
    | Prod (x,t,c)    -> prodec_rec (LocalAssum (x,t) :: l) c
    | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t) :: l) c
    | Cast (c,_,_)      -> prodec_rec l c
    | Sort s          -> l,s
    | _               -> anomaly ~label:"destArity" (Pp.str "not an arity.")
  in
  prodec_rec []

let push_rel d e = push_rel (cast_rel_decl unsafe_eq d) e
let push_rel_context d e = push_rel_context (cast_rel_context unsafe_eq d) e
let push_rec_types d e = push_rec_types (cast_rec_decl unsafe_eq d) e
let push_named d e = push_named (cast_named_decl unsafe_eq d) e
let push_named_context d e = push_named_context (cast_named_context unsafe_eq d) e
let push_named_context_val d e = push_named_context_val (cast_named_decl unsafe_eq d) e

let rel_context e = cast_rel_context (sym unsafe_eq) (rel_context e)
let named_context e = cast_named_context (sym unsafe_eq) (named_context e)

let val_of_named_context e = val_of_named_context (cast_named_context unsafe_eq e)
let named_context_of_val e = cast_named_context (sym unsafe_eq) (named_context_of_val e)

let of_existential : Constr.existential -> existential =
  let gen : type a b. (a,b) eq -> 'c * b SList.t -> 'c * a SList.t = fun Refl x -> x in
  gen unsafe_eq

let lookup_rel i e = cast_rel_decl (sym unsafe_eq) (lookup_rel i e)
let lookup_named n e = cast_named_decl (sym unsafe_eq) (lookup_named n e)
let lookup_named_val n e = cast_named_decl (sym unsafe_eq) (lookup_named_ctxt n e)

let map_rel_context_in_env f env sign =
  let rec aux env acc = function
    | d::sign ->
        aux (push_rel d env) (Context.Rel.Declaration.map_constr (f env) d :: acc) sign
    | [] ->
        acc
  in
  aux env [] (List.rev sign)

let match_named_context_val :
  named_context_val -> (named_declaration * named_context_val) option =
  match unsafe_eq with
  | Refl -> match_named_context_val

let identity_subst_val : named_context_val -> t SList.t = fun ctx ->
  SList.defaultn (List.length ctx.Environ.env_named_ctx) SList.empty

let fresh_global ?loc ?rigid ?names env sigma reference =
  let (evd,t) = Evd.fresh_global ?loc ?rigid ?names env sigma reference in
  evd, t

let is_global = isRefX

(** Kind of type *)

type kind_of_type =
  | SortType   of ESorts.t
  | CastType   of types * t
  | ProdType   of Name.t Context.binder_annot * t * t
  | LetInType  of Name.t Context.binder_annot * t * t * t
  | AtomicType of t * t array

let kind_of_type sigma t = match kind sigma t with
  | Sort s -> SortType s
  | Cast (c,_,t) -> CastType (c, t)
  | Prod (na,t,c) -> ProdType (na, t, c)
  | LetIn (na,b,t,c) -> LetInType (na, b, t, c)
  | App (c,l) -> AtomicType (c, l)
  | (Rel _ | Meta _ | Var _ | Evar _ | Const _
  | Proj _ | Case _ | Fix _ | CoFix _ | Ind _)
    -> AtomicType (t,[||])
  | (Lambda _ | Construct _ | Int _ | Float _ | Array _) -> failwith "Not a type"

module Unsafe =
struct
let to_sorts = ESorts.unsafe_to_sorts
let to_instance = EInstance.unsafe_to_instance
let to_constr = unsafe_to_constr
let to_constr_array = unsafe_to_constr_array
let to_rel_decl = unsafe_to_rel_decl
let to_named_decl = unsafe_to_named_decl
let to_named_context =
  let gen : type a b. (a, b) eq -> (a,a) Context.Named.pt -> (b,b) Context.Named.pt
    = fun Refl x -> x
  in
  gen unsafe_eq
let to_rel_context =
  let gen : type a b. (a, b) eq -> (a,a) Context.Rel.pt -> (b,b) Context.Rel.pt
    = fun Refl x -> x
  in
  gen unsafe_eq
let to_case_invert = unsafe_to_case_invert

let eq = unsafe_eq
end

module UnsafeMonomorphic = struct
  let mkConst c = of_kind (Const (in_punivs c))
  let mkInd i = of_kind (Ind (in_punivs i))
  let mkConstruct c = of_kind (Construct (in_punivs c))
end

(* deprecated *)

let decompose_lambda_assum = decompose_lambda_decls
let decompose_prod_assum = decompose_prod_decls
let decompose_prod_n_assum = decompose_prod_n_decls
let prod_assum = prod_decls
let decompose_lam = decompose_lambda
let decompose_lam_n_assum = decompose_lambda_n_assum
let decompose_lam_n_decls = decompose_lambda_n_decls
let decompose_lam_assum = decompose_lambda_assum

include UnsafeMonomorphic