1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149

(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i*)
open CErrors
open Util
open Pp
open Names
open Cic
open Declarations
(*i*)

let error_not_a_constant l =
  user_err Pp.(str ("\""^(Label.to_string l)^"\" is not a constant"))

let error_not_a_functor () = user_err Pp.(str "Application of not a functor")

let error_incompatible_modtypes _ _ = user_err Pp.(str "Incompatible module types")

let error_not_match l _ =
  user_err Pp.(str ("Signature components for label "^Label.to_string l^" do not match"))

let error_no_such_label l = user_err Pp.(str ("No such label "^Label.to_string l))

let error_no_such_label_sub l l1 =
  let l1 = ModPath.to_string l1 in
  user_err Pp.(str ("The field "^
         Label.to_string l^" is missing in "^l1^"."))

let error_not_a_module_loc ?loc s =
  user_err ?loc  (str ("\""^Label.to_string s^"\" is not a module"))

let error_not_a_module s = error_not_a_module_loc s

let error_with_module () =
  user_err Pp.(str "Unsupported 'with' constraint in module implementation")

let is_functor = function
  | MoreFunctor _ -> true
  | NoFunctor _ -> false

let destr_functor = function
  | MoreFunctor (arg_id,arg_t,body_t) -> (arg_id,arg_t,body_t)
  | NoFunctor _ -> error_not_a_functor ()

let module_body_of_type mp mtb =
  { mtb with mod_mp = mp; mod_expr = Abstract; mod_retroknowledge = ModBodyRK [] }

let rec add_structure mp sign resolver env =
  let add_one env (l,elem) =
    let kn = KerName.make2 mp l in
    let con = Constant.make1 kn in
    let mind = mind_of_delta resolver (MutInd.make1 kn) in
      match elem with
        | SFBconst cb ->
           (* let con =  constant_of_delta resolver con in*)
              Environ.add_constant con cb env
        | SFBmind mib ->
           (* let mind =  mind_of_delta resolver mind in*)
            Environ.add_mind mind mib env
        | SFBmodule mb -> add_module mb env
              (* adds components as well *)
        | SFBmodtype mtb -> Environ.add_modtype mtb.mod_mp mtb env
  in
  List.fold_left add_one env sign

and add_module mb env =
  let mp = mb.mod_mp in
  let env = Environ.shallow_add_module mp mb env in
  match mb.mod_type with
  | NoFunctor struc -> add_structure mp struc mb.mod_delta env
  | MoreFunctor _ -> env

let add_module_type mp mtb env = add_module (module_body_of_type mp mtb) env

let strengthen_const mp_from l cb resolver =
  match cb.const_body with
    | Def _ -> cb
    | _ ->
      let con = Constant.make2 mp_from l in
      let u =
        match cb.const_universes with
      | Monomorphic_const _ -> Univ.Instance.empty
      | Polymorphic_const auctx -> Univ.make_abstract_instance auctx
      in
      { cb with
        const_body = Def (Declarations.from_val (Const (con,u))) }

let rec strengthen_mod mp_from mp_to mb =
  if Declarations.mp_in_delta mb.mod_mp mb.mod_delta then mb
  else
    let mk_expr mp_to = Algebraic (NoFunctor (MEident mp_to)) in
    strengthen_body mk_expr mp_from mp_to mb

and strengthen_body : 'a. (_ -> 'a) -> _ -> _ -> 'a generic_module_body -> 'a generic_module_body =
  fun mk_expr mp_from mp_to mb ->
  match mb.mod_type with
  | MoreFunctor _ -> mb
  | NoFunctor sign ->
    let resolve_out,sign_out = strengthen_sig mp_from sign mp_to mb.mod_delta
    in
    { mb with
      mod_expr = mk_expr mp_to;
      mod_type = NoFunctor sign_out;
      mod_delta = resolve_out }

and strengthen_sig mp_from sign mp_to resolver =
  match sign with
    | [] -> empty_delta_resolver,[]
    | (l,SFBconst cb) :: rest ->
        let item' = l,SFBconst (strengthen_const mp_from l cb resolver) in
        let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
        resolve_out,item'::rest'
    | (_,SFBmind _ as item):: rest ->
        let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
          resolve_out,item::rest'
    | (l,SFBmodule mb) :: rest ->
        let mp_from' = MPdot (mp_from,l) in
        let mp_to' = MPdot(mp_to,l) in
        let mb_out = strengthen_mod mp_from' mp_to' mb in
        let item' = l,SFBmodule (mb_out) in
        let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
        resolve_out (*add_delta_resolver resolve_out mb.mod_delta*),
        item':: rest'
    | (l,SFBmodtype mty as item) :: rest ->
        let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
        resolve_out,item::rest'

let strengthen mtb mp =
  strengthen_body ignore mtb.mod_mp mp mtb

let subst_and_strengthen mb mp =
  strengthen_mod mb.mod_mp mp (subst_module (map_mp mb.mod_mp mp) mb)

let module_type_of_module mp mb =
  let mtb =
    { mb with
      mod_expr = ();
      mod_type_alg = None;
      mod_retroknowledge = ModTypeRK }
  in
  match mp with
  | Some mp -> strengthen {mtb with mod_mp = mp} mp
  | None -> mtb