diff options
| author | Pierre-Marie Pédrot | 2015-10-02 16:27:58 +0200 |
|---|---|---|
| committer | Pierre-Marie Pédrot | 2015-10-02 16:33:15 +0200 |
| commit | 944c8de0bfe4048e0733a487e6388db4dfc9075a (patch) | |
| tree | af037ad2d990da53529356fec44860ad9ca87577 /kernel/environ.ml | |
| parent | 16c88c9be5c37ee2e4fe04f7342365964031e7dd (diff) | |
| parent | 8860362de4a26286b0cb20cf4e02edc5209bdbd1 (diff) | |
Merge branch 'v8.5'
Diffstat (limited to 'kernel/environ.ml')
| -rw-r--r-- | kernel/environ.ml | 42 |
1 files changed, 30 insertions, 12 deletions
diff --git a/kernel/environ.ml b/kernel/environ.ml index bf12d6c6dc..1cc07c0ab8 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -181,26 +181,44 @@ let fold_named_context_reverse f ~init env = (* Universe constraints *) -let add_constraints c env = - if Univ.Constraint.is_empty c then - env - else - let s = env.env_stratification in +let map_universes f env = + let s = env.env_stratification in { env with env_stratification = - { s with env_universes = Univ.merge_constraints c s.env_universes } } + { s with env_universes = f s.env_universes } } + +let add_constraints c env = + if Univ.Constraint.is_empty c then env + else map_universes (Univ.merge_constraints c) env let check_constraints c env = Univ.check_constraints c env.env_stratification.env_universes -let set_engagement c env = (* Unsafe *) - { env with env_stratification = - { env.env_stratification with env_engagement = c } } - let push_constraints_to_env (_,univs) env = add_constraints univs env -let push_context ctx env = add_constraints (Univ.UContext.constraints ctx) env -let push_context_set ctx env = add_constraints (Univ.ContextSet.constraints ctx) env +let add_universes strict ctx g = + let g = Array.fold_left + (* Be lenient, module typing reintroduces universes and constraints due to includes *) + (fun g v -> try Univ.add_universe v strict g with Univ.AlreadyDeclared -> g) + g (Univ.Instance.to_array (Univ.UContext.instance ctx)) + in + Univ.merge_constraints (Univ.UContext.constraints ctx) g + +let push_context ?(strict=false) ctx env = + map_universes (add_universes strict ctx) env + +let add_universes_set strict ctx g = + let g = Univ.LSet.fold + (fun v g -> try Univ.add_universe v strict g with Univ.AlreadyDeclared -> g) + (Univ.ContextSet.levels ctx) g + in Univ.merge_constraints (Univ.ContextSet.constraints ctx) g + +let push_context_set ?(strict=false) ctx env = + map_universes (add_universes_set strict ctx) env + +let set_engagement c env = (* Unsafe *) + { env with env_stratification = + { env.env_stratification with env_engagement = c } } (* Global constants *) |