Commit e5062571 authored by Andrei Paskevich's avatar Andrei Paskevich

Theory, Pmodule: introduce import_scope

This allows to import an existing scope to the current namespace.
Not sure if we need this in the surface language, though.
parent b9c0ca44
......@@ -320,6 +320,13 @@ let close_scope uc ~import =
| [], [_], [_] -> raise NoOpenedNamespace
| _ -> assert false
let import_scope uc ql = match uc.uc_import with
| i1 :: sti ->
let e0 = ns_find_ns i1 ql in
let i1 = merge_ns false e0 i1 in
{ uc with uc_import = i1::sti }
| _ -> assert false
(* Base constructors *)
let known_ty kn ty =
......
......@@ -137,8 +137,9 @@ type theory_uc = private {
val create_theory : ?path:string list -> preid -> theory_uc
val close_theory : theory_uc -> theory
val open_scope : theory_uc -> string -> theory_uc
val close_scope : theory_uc -> import:bool -> theory_uc
val open_scope : theory_uc -> string -> theory_uc
val close_scope : theory_uc -> import:bool -> theory_uc
val import_scope : theory_uc -> string list -> theory_uc
val get_namespace : theory_uc -> namespace
......
......@@ -797,7 +797,7 @@ module Translate = struct
(* unit module declarations *)
let rec mdecl pids info = function
| Udecl pd -> pdecl pids info pd
| Uscope (_, _, l) -> List.concat (List.map (mdecl pids info) l)
| Uscope (_, l) -> List.concat (List.map (mdecl pids info) l)
| Uuse _ | Uclone _ | Umeta _ -> []
let abstract_or_alias_type itd =
......@@ -811,7 +811,7 @@ module Translate = struct
let rec empty_munit = function
| Udecl pd -> empty_pdecl pd
| Uclone mi -> List.for_all empty_munit mi.mi_mod.mod_units
| Uscope (_, _, l) -> List.for_all empty_munit l
| Uscope (_, l) -> List.for_all empty_munit l
| Uuse _ | Umeta _ -> true
let is_empty_clone mi =
......
......@@ -161,7 +161,7 @@ and mod_unit =
| Uuse of pmodule
| Uclone of mod_inst
| Umeta of meta * meta_arg list
| Uscope of string * bool * mod_unit list
| Uscope of string * mod_unit list
and mod_inst = {
mi_mod : pmodule;
......@@ -228,7 +228,7 @@ let close_module, restore_module =
let open_scope uc s = match uc.muc_import with
| ns :: _ -> { uc with
muc_theory = Theory.open_scope uc.muc_theory s;
muc_units = [Uscope (s, false, uc.muc_units)];
muc_units = [Uscope (s, uc.muc_units)];
muc_import = ns :: uc.muc_import;
muc_export = empty_ns :: uc.muc_export; }
| [] -> assert false
......@@ -236,20 +236,27 @@ let open_scope uc s = match uc.muc_import with
let close_scope uc ~import =
let th = Theory.close_scope uc.muc_theory ~import in
match List.rev uc.muc_units, uc.muc_import, uc.muc_export with
| [Uscope (_,_,ul1)], _ :: sti, _ :: ste -> (* empty scope *)
| [Uscope (_,ul1)], _ :: sti, _ :: ste -> (* empty scope *)
{ uc with muc_theory = th; muc_units = ul1;
muc_import = sti; muc_export = ste; }
| Uscope (s,_,ul1) :: ul0, _ :: i1 :: sti, e0 :: e1 :: ste ->
| Uscope (s,ul1) :: ul0, _ :: i1 :: sti, e0 :: e1 :: ste ->
let i1 = if import then merge_ns false e0 i1 else i1 in
let i1 = add_ns false s e0 i1 in
let e1 = add_ns true s e0 e1 in
{ uc with
muc_theory = th;
muc_units = Uscope (s, import, ul0) :: ul1;
muc_units = Uscope (s,ul0) :: ul1;
muc_import = i1 :: sti;
muc_export = e1 :: ste; }
| _ -> assert false
let import_scope uc ql = match uc.muc_import with
| i1 :: sti ->
let th = Theory.import_scope uc.muc_theory ql in
let i1 = merge_ns false (ns_find_ns i1 ql) i1 in
{ uc with muc_theory = th; muc_import = i1::sti }
| _ -> assert false
let use_export uc ({mod_theory = mth} as m) =
let th = Theory.use_export uc.muc_theory mth in
let uc = if Sid.mem mth.th_name uc.muc_used then uc
......@@ -1105,7 +1112,7 @@ let clone_export uc m inst =
| MApr pr -> MApr (cl_find_pr cl pr)
| a -> a) al)
with Not_found -> uc end
| Uscope (n,_import,ul) ->
| Uscope (n,ul) ->
let uc = open_scope uc n in
let uc = List.fold_left add_unit uc ul in
close_scope ~import:false uc in
......@@ -1183,14 +1190,13 @@ let rec print_unit fmt = function
print_mname mi.mi_mod
| Umeta (m,al) -> Format.fprintf fmt "@[<hov 2>meta %s %a@]"
m.meta_name (Pp.print_list Pp.comma Pretty.print_meta_arg) al
| Uscope (s,i,[Uuse m]) -> Format.fprintf fmt "use%s %a%s"
(if i then " import" else "") print_mname m
| Uscope (s,[Uuse m]) -> Format.fprintf fmt "use %a%s" print_mname m
(if s = m.mod_theory.th_name.id_string then "" else " as " ^ s)
| Uscope (s,i,[Uclone mi]) -> Format.fprintf fmt "clone%s %a%s with ..."
(if i then " import" else "") print_mname mi.mi_mod
| Uscope (s,[Uclone mi]) -> Format.fprintf fmt "clone %a%s with ..."
print_mname mi.mi_mod
(if s = mi.mi_mod.mod_theory.th_name.id_string then "" else " as " ^ s)
| Uscope (s,i,ul) -> Format.fprintf fmt "@[<hov 2>scope%s %s@\n%a@]@\nend"
(if i then " import" else "") s (Pp.print_list Pp.newline2 print_unit) ul
| Uscope (s,ul) -> Format.fprintf fmt "@[<hov 2>scope %s@\n%a@]@\nend"
s (Pp.print_list Pp.newline2 print_unit) ul
let print_module fmt m = Format.fprintf fmt
"@[<hov 2>module %s@\n%a@]@\nend" m.mod_theory.th_name.id_string
......
......@@ -67,7 +67,7 @@ and mod_unit =
| Uuse of pmodule
| Uclone of mod_inst
| Umeta of meta * meta_arg list
| Uscope of string * bool * mod_unit list
| Uscope of string * mod_unit list
and mod_inst = {
mi_mod : pmodule;
......@@ -99,8 +99,9 @@ type pmodule_uc = private {
val create_module : Env.env -> ?path:string list -> preid -> pmodule_uc
val close_module : pmodule_uc -> pmodule
val open_scope : pmodule_uc -> string -> pmodule_uc
val close_scope : pmodule_uc -> import:bool -> pmodule_uc
val open_scope : pmodule_uc -> string -> pmodule_uc
val close_scope : pmodule_uc -> import:bool -> pmodule_uc
val import_scope : pmodule_uc -> string list -> pmodule_uc
val restore_path : ident -> string list * string * string list
(** [restore_path id] returns the triple (library path, module,
......
......@@ -190,7 +190,7 @@ let extract_to =
let rec use_iter f l =
List.iter
(function Uuse t -> f t | Uscope (_,_,l) -> use_iter f l | _ -> ()) l
(function Uuse t -> f t | Uscope (_,l) -> use_iter f l | _ -> ()) l
let rec do_extract_module ?fname m =
let extract_use m' =
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment