Parser: merge "why" and "whyml" formats, move to Mlw

Makefile.in

@@ -154,7 +154,7 @@ LIB_DRIVER = call_provers driver_ast driver_parser driver_lexer driver \
 
 LIB_MLW = ity expr dexpr pdecl pmodule
 
-LIB_PARSER = ptree glob parser typing lexer
+LIB_PARSER = ptree glob typing parser lexer
 
 LIB_TRANSFORM = simplify_formula inlining split_goal induction \
 		detect_polymorphism \
@@ -173,10 +173,6 @@ LIB_TRANSFORM = simplify_formula inlining split_goal induction \
 LIB_PRINTER = alt_ergo why3printer smtv1 smtv2 coq pvs isabelle \
 	      simplify gappa cvc3 yices mathematica
 
-LIB_WHYML = mlw_ty mlw_expr mlw_decl mlw_pretty mlw_wp mlw_module \
-	    mlw_dexpr mlw_typing mlw_driver mlw_exec mlw_ocaml \
-	    mlw_main mlw_interp
-
 LIB_SESSION = compress xml termcode session session_tools strategy \
               strategy_parser session_scheduler
 
@@ -187,10 +183,9 @@ LIBMODULES =  $(addprefix src/util/, $(LIB_UTIL)) \
 	      $(addprefix src/parser/, $(LIB_PARSER)) \
 	      $(addprefix src/transform/, $(LIB_TRANSFORM)) \
 	      $(addprefix src/printer/, $(LIB_PRINTER)) \
-	      $(addprefix src/whyml/, $(LIB_WHYML)) \
 	      $(addprefix src/session/, $(LIB_SESSION))
 
-LIBDIRS = util core driver mlw parser transform printer whyml session
+LIBDIRS = util core driver mlw parser transform printer session
 LIBINCLUDES = $(addprefix -I src/, $(LIBDIRS))
 
 LIBDEP = $(addsuffix .dep, $(LIBMODULES))
@@ -453,7 +448,10 @@ install_no_local::
 
 TOOLSGENERATED = src/tools/why3wc.ml
 
-TOOLS_BIN = why3config why3execute why3extract why3prove \
+# TODO
+#TOOLS_BIN = why3config why3execute why3extract why3prove \
+#	    why3realize why3replay why3wc
+TOOLS_BIN = why3config why3prove \
 	    why3realize why3replay why3wc
 
 TOOLS_FILES = main $(TOOLS_BIN)
@@ -1384,8 +1382,9 @@ $(WHY3DOCDEP): $(WHY3DOCGENERATED)
 
 # build targets
 
-byte: bin/why3doc.byte
-opt:  bin/why3doc.opt
+# TODO
+#byte: bin/why3doc.byte
+#opt:  bin/why3doc.opt
 
 bin/why3doc.opt: lib/why3/why3.cmxa $(WHY3DOCCMX)
 	$(if $(QUIET),@echo 'Linking  $@' &&) \
@@ -1412,7 +1411,8 @@ clean_old_install::
 install_no_local::
 	cp -f bin/why3doc.@OCAMLBEST@ $(TOOLDIR)/why3doc$(EXE)
 
-install_local:: bin/why3doc
+# TODO
+#install_local:: bin/why3doc
 
 ########
 # bench
@@ -1602,8 +1602,6 @@ MODULESTODOC = \
 	core/env core/task \
 	driver/whyconf driver/driver \
 	session/session session/session_tools session/session_scheduler \
-	whyml/mlw_ty whyml/mlw_expr whyml/mlw_decl whyml/mlw_module \
-	whyml/mlw_main
 #	transform/introduction \
 #	ide/db
 

src/mlw/dexpr.ml

@@ -795,6 +795,8 @@ let check_spec dsp ecty e =
   if check_rwd && bad_write eeff ueff then
     Loc.errorm ?loc:(e_locate_effect (fun eff -> bad_write eff ueff) e)
       "this@ expression@ produces@ an@ unlisted@ write@ effect";
+  (* TODO FIXME : revise the requirements for explicit "raises".
+     Should we only require them at the top level? *)
   if ecty.cty_args <> [] && bad_raise eeff ueff then Sexn.iter (fun xs ->
     Loc.errorm ?loc:(e_locate_effect (fun eff -> Sexn.mem xs eff.eff_raises) e)
       "this@ expression@ raises@ unlisted@ exception@ %a"

src/mlw/pdecl.ml

@@ -368,3 +368,7 @@ let known_add_decl kn0 d =
   let unk = Mid.set_diff d.pd_syms kn in
   if Sid.is_empty unk then kn else
     raise (Decl.UnknownIdent (Sid.choose unk))
+
+(** {2 Pretty-printing} *)
+
+let print_pdecl _fmt _d = assert false (* TODO *)

src/mlw/pdecl.mli

@@ -82,3 +82,7 @@ type known_map = pdecl Mid.t
 val known_id : known_map -> ident -> unit
 val known_add_decl : known_map -> pdecl -> known_map
 val merge_known : known_map -> known_map -> known_map
+
+(** {2 Pretty-printing *)
+
+val print_pdecl : Format.formatter -> pdecl -> unit

src/mlw/pmodule.ml

@@ -297,10 +297,11 @@ let add_pdecl_with_tuples _uc _md = assert false (*TODO*)
 
 (** {2 WhyML language} *)
 
-type mlw_file = pmodule Mstr.t * theory Mstr.t
+type mlw_file = pmodule Mstr.t
 
 let mlw_language =
-  (Env.register_language Env.base_language snd : mlw_file Env.language)
+  let conv mm = Mstr.map (fun m -> m.mod_theory) mm in
+  (Env.register_language Env.base_language conv : mlw_file Env.language)
 
 (* TODO
 let () = Env.add_builtin mlw_language (function
@@ -314,7 +315,7 @@ exception ModuleNotFound of Env.pathname * string
 
 let read_module env path s =
   let path = if path = [] then ["why3"; s] else path in
-  let mm, _ = Env.read_library mlw_language env path in
+  let mm = Env.read_library mlw_language env path in
   Mstr.find_exn (ModuleNotFound (path,s)) s mm
 
 let print_path fmt sl =

src/mlw/pmodule.mli

@@ -120,7 +120,7 @@ val add_pdecl_with_tuples : pmodule_uc -> pdecl -> pmodule_uc
 
 open Env
 
-type mlw_file = pmodule Mstr.t * theory Mstr.t
+type mlw_file = pmodule Mstr.t
 
 val mlw_language : mlw_file language
 

src/parser/lexer.mli

@@ -8,5 +8,3 @@
 (*  on linking described in file LICENSE.                           *)
 (*                                                                  *)
 (********************************************************************)
-
-val parse_program_file : Ptree.incremental -> Lexing.lexbuf -> unit

src/parser/lexer.mll

@@ -75,7 +75,6 @@
         "ghost", GHOST;
         "invariant", INVARIANT;
         "loop", LOOP;
-        "model", MODEL;
         "module", MODULE;
         "mutable", MUTABLE;
         "private", PRIVATE;
@@ -157,8 +156,6 @@ rule token = parse
       { LEFTPAR_STAR_RIGHTPAR }
   | "(*"
       { Lexlib.comment lexbuf; token lexbuf }
-  | "~'" (lident as id)
-      { OPAQUE_QUOTE_LIDENT id }
   | "'" (lident as id)
       { QUOTE_LIDENT id }
   | "'" (uident as id)
@@ -225,27 +222,38 @@ rule token = parse
       { raise (IllegalCharacter c) }
 
 {
-  let parse_logic_file env path lb =
-    open_file token (Lexing.from_string "") (Typing.open_file env path);
-    Loc.with_location (logic_file token) lb;
-    Typing.close_file ()
+  let debug = Debug.register_info_flag "print_modules"
+    ~desc:"Print@ program@ modules@ after@ typechecking."
 
-  let parse_program_file inc lb =
-    open_file token (Lexing.from_string "") inc;
-    Loc.with_location (program_file token) lb
+  open Stdlib
+  open Ident
+  open Theory
+  open Pmodule
 
   let read_channel env path file c =
     let lb = Lexing.from_channel c in
     Loc.set_file file lb;
-    parse_logic_file env path lb
+    Typing.open_file ~pure:false env path;
+    let mm = Loc.with_location (mlw_file token) lb in
+    if path = [] && Debug.test_flag debug then begin
+      let add_m _ m mm = Mid.add m.mod_theory.th_name m mm in
+      let mm = Mstr.fold add_m mm Mid.empty in
+      let print_m _ m = Format.eprintf
+        "@[<hov 2>module %a@\n%a@]@\nend@\n@." Pretty.print_th m.mod_theory
+        (Pp.print_list Pp.newline2 Pdecl.print_pdecl) m.mod_decls in
+      Mid.iter print_m mm
+    end;
+    mm
 
-  let () = Env.register_format Env.base_language "why" ["why"] read_channel
-    ~desc:"WhyML@ logical@ language"
-}
+  let () = Env.register_format mlw_language "whyml" ["mlw"] read_channel
+    ~desc:"WhyML@ programming@ and@ specification@ language"
 
-(*
-Local Variables:
-compile-command: "unset LANG; make -C ../.. test"
-End:
-*)
+  let read_channel env path file c =
+    let lb = Lexing.from_channel c in
+    Loc.set_file file lb;
+    Typing.open_file ~pure:true env path;
+    Loc.with_location (mlw_file token) lb
 
+  let () = Env.register_format mlw_language "whyml_spec" ["why"] read_channel
+    ~desc:"WhyML@ specification@ sublanguage"
+}

src/parser/parser.mly

@@ -10,21 +10,6 @@
 (********************************************************************)
 
 %{
-module Incremental = struct
-  let stack = Stack.create ()
-  let open_file inc = Stack.push inc stack
-  let close_file () = ignore (Stack.pop stack)
-  let open_theory id = (Stack.top stack).Ptree.open_theory id
-  let close_theory () = (Stack.top stack).Ptree.close_theory ()
-  let open_module id = (Stack.top stack).Ptree.open_module id
-  let close_module () = (Stack.top stack).Ptree.close_module ()
-  let open_namespace n = (Stack.top stack).Ptree.open_namespace n
-  let close_namespace l b = (Stack.top stack).Ptree.close_namespace l b
-  let new_decl loc d = (Stack.top stack).Ptree.new_decl loc d
-  let new_pdecl loc d = (Stack.top stack).Ptree.new_pdecl loc d
-  let use_clone loc use = (Stack.top stack).Ptree.use_clone loc use
-end
-
   open Ptree
 
   let infix  s = "infix "  ^ s
@@ -111,7 +96,7 @@ end
 %token <Ptree.real_constant> FLOAT
 %token <string> STRING
 %token <Loc.position> POSITION
-%token <string> QUOTE_UIDENT QUOTE_LIDENT OPAQUE_QUOTE_LIDENT
+%token <string> QUOTE_UIDENT QUOTE_LIDENT
 
 (* keywords *)
 
@@ -125,7 +110,7 @@ end
 
 %token ABSTRACT ABSURD ANY ASSERT ASSUME BEGIN CHECK
 %token DIVERGES DO DONE DOWNTO ENSURES EXCEPTION FOR
-%token FUN GHOST INVARIANT LOOP MODEL MODULE MUTABLE
+%token FUN GHOST INVARIANT LOOP MODULE MUTABLE
 %token PRIVATE RAISE RAISES READS REC REQUIRES RETURNS
 %token TO TRY VAL VARIANT WHILE WRITES
 
@@ -173,51 +158,33 @@ end
 
 (* Entry points *)
 
-%start <Ptree.incremental -> unit> open_file
-%start <unit> logic_file program_file
+%start <Pmodule.pmodule Stdlib.Mstr.t> mlw_file
 %%
 
 (* Theories, modules, namespaces *)
 
-open_file:
-(* Dummy token. Menhir does not accept epsilon. *)
-| EOF { Incremental.open_file }
-
-logic_file:
-| theory* EOF   { Incremental.close_file () }
-
-program_file:
-| theory_or_module* EOF { Incremental.close_file () }
-
-theory:
-| theory_head theory_decl* END  { Incremental.close_theory () }
+mlw_file:
+| theory_or_module* EOF { Typing.close_file () }
+(* TODO
+| module_decl* EOF { Typing.close_file () }
+*)
 
 theory_or_module:
-| theory                        { () }
-| module_head module_decl* END  { Incremental.close_module () }
-
-theory_head:
-| THEORY labels(uident)  { Incremental.open_theory $2 }
+| module_head module_decl* END
+    { Typing.close_module (floc $startpos($3) $endpos($3)) }
 
 module_head:
-| MODULE labels(uident)  { Incremental.open_module $2 }
-
-theory_decl:
-| decl            { Incremental.new_decl  (floc $startpos $endpos) $1 }
-| use_clone       { Incremental.use_clone (floc $startpos $endpos) $1 }
-| namespace_head theory_decl* END
-    { Incremental.close_namespace (floc $startpos($1) $endpos($1)) $1 }
+| THEORY labels(uident)  { Typing.open_module $2 ~theory:true  }
+| MODULE labels(uident)  { Typing.open_module $2 ~theory:false }
 
 module_decl:
-| decl            { Incremental.new_decl  (floc $startpos $endpos) $1 }
-| pdecl           { Incremental.new_pdecl (floc $startpos $endpos) $1 }
-| use_clone       { Incremental.use_clone (floc $startpos $endpos) $1 }
+| decl            { Typing.add_decl  (floc $startpos $endpos) $1 }
+| use_clone       { Typing.use_clone (floc $startpos $endpos) $1 }
 | namespace_head module_decl* END
-    { Incremental.close_namespace (floc $startpos($1) $endpos($1)) $1 }
+    { Typing.close_namespace (floc $startpos($1) $endpos($1)) ~import:$1 }
 
 namespace_head:
-| NAMESPACE boption(IMPORT) uident
-   { Incremental.open_namespace $3.id_str; $2 }
+| NAMESPACE boption(IMPORT) uident  { Typing.open_namespace $3; $2 }
 
 (* Use and clone *)
 
@@ -252,7 +219,6 @@ ns:
 
 decl:
 | TYPE with_list1(type_decl)                { Dtype $2 }
-| TYPE late_invariant                       { Dtype [$2] }
 | CONSTANT  constant_decl                   { Dlogic [$2] }
 | FUNCTION  function_decl  with_logic_decl* { Dlogic ($2::$3) }
 | PREDICATE predicate_decl with_logic_decl* { Dlogic ($2::$3) }
@@ -262,6 +228,7 @@ decl:
 | LEMMA labels(ident) COLON term            { Dprop (Decl.Plemma, $2, $4) }
 | GOAL  labels(ident) COLON term            { Dprop (Decl.Pgoal, $2, $4) }
 | META sident comma_list1(meta_arg)         { Dmeta ($2, $3) }
+| pdecl                                     { $1 }
 
 meta_arg:
 | TYPE      ty      { Mty $2 }
@@ -275,40 +242,44 @@ meta_arg:
 (* Type declarations *)
 
 type_decl:
-| labels(lident) ty_var* typedefn
-  { let model, vis, def, inv = $3 in
-    let vis = if model then Abstract else vis in
+| labels(lident) ty_var* typedefn invariant*
+  { let (vis, mut), def = $3 in
     { td_ident = $1; td_params = $2;
-      td_model = model; td_vis = vis; td_def = def;
-      td_inv = inv; td_loc = floc $startpos $endpos } }
-
-late_invariant:
-| labels(lident) ty_var* invariant+
-  { { td_ident = $1; td_params = $2;
-      td_model = false; td_vis = Public; td_def = TDabstract;
-      td_inv = $3; td_loc = floc $startpos $endpos } }
+      td_vis = vis; td_mut = mut;
+      td_inv = $4; td_def = def;
+      td_loc = floc $startpos $endpos } }
 
 ty_var:
 | labels(quote_lident) { $1 }
 
+(* TODO: should global "mutable" imply "private"?
+  "type t 'a = mutable { x : int }"
+    - if "x" is immutable then the type can only be private
+    - if "x" is automatically mutable then I don't like it
+    - if there are known mutable fields, then a global "mutable"
+      is redundant, unless it also means "private" *)
+(* TODO: what should be the syntax for mutable private records
+    without known fields? *)
 typedefn:
 | (* epsilon *)
-    { false, Public, TDabstract, [] }
-| model abstract bar_list1(type_case) invariant*
-    { $1, $2, TDalgebraic $3, $4 }
-| model abstract LEFTBRC semicolon_list1(type_field) RIGHTBRC invariant*
-    { $1, $2, TDrecord $4, $6 }
-| model abstract ty invariant*
-    { $1, $2, TDalias $3, $4 }
-
-model:
-| EQUAL         { false }
-| MODEL         { true }
+    { (Public, false), TDabstract }
+| EQUAL vis_mut bar_list1(type_case)
+    { $2, TDalgebraic $3 }
+| EQUAL vis_mut LEFTBRC semicolon_list1(type_field) RIGHTBRC
+    { $2, TDrecord $4 }
+| EQUAL vis_mut ty
+    { $2, TDalias $3 }
+
+vis_mut:
+| (* epsilon *)     { Public, false }
+| MUTABLE           { Public, true  }
+| abstract          { $1, false }
+| abstract MUTABLE  { $1, true }
+| MUTABLE abstract  { $2, true }
 
 abstract:
-| (* epsilon *) { Public }
-| PRIVATE       { Private }
-| ABSTRACT      { Abstract }
+| PRIVATE           { Private }
+| ABSTRACT          { Abstract }
 
 type_field:
 | field_modifiers labels(lident) cast
@@ -370,8 +341,7 @@ ty:
 
 ty_arg:
 | lqualid                           { PTtyapp ($1, []) }
-| quote_lident                      { PTtyvar ($1, false) }
-| opaque_quote_lident               { PTtyvar ($1, true) }
+| quote_lident                      { PTtyvar $1 }
 | LEFTPAR comma_list2(ty) RIGHTPAR  { PTtuple $2 }
 | LEFTPAR RIGHTPAR                  { PTtuple [] }
 | LEFTPAR ty RIGHTPAR               { PTparen $2 }
@@ -886,10 +856,6 @@ uident:
 
 lident:
 | LIDENT          { mk_id $1 $startpos $endpos }
-| lident_keyword  { mk_id $1 $startpos $endpos }
-
-lident_keyword:
-| MODEL           { "model" }
 
 quote_uident:
 | QUOTE_UIDENT  { mk_id ("'" ^ $1) $startpos $endpos }
@@ -897,9 +863,6 @@ quote_uident:
 quote_lident:
 | QUOTE_LIDENT  { mk_id $1 $startpos $endpos }
 
-opaque_quote_lident:
-| OPAQUE_QUOTE_LIDENT { mk_id $1 $startpos $endpos }
-
 (* Idents + symbolic operation names *)
 
 ident_rich:

src/parser/ptree.ml

@@ -42,10 +42,8 @@ type qualid =
   | Qident of ident
   | Qdot of qualid * ident
 
-type opacity = bool
-
 type pty =
-  | PTtyvar of ident * opacity
+  | PTtyvar of ident
   | PTtyapp of qualid * pty list
   | PTtuple of pty list
   | PTarrow of pty * pty
@@ -127,7 +125,7 @@ type type_def =
   | TDalgebraic of (loc * ident * param list) list
   | TDrecord    of field list
 
-type visibility = Public | Private | Abstract
+type visibility = Public | Private | Abstract (* = Private + ghost fields *)
 
 type invariant = term list
 
@@ -135,10 +133,10 @@ type type_decl = {
   td_loc    : loc;
   td_ident  : ident;
   td_params : ident list;
-  td_model  : bool;
-  td_vis    : visibility;
+  td_vis    : visibility; (* records only *)
+  td_mut    : bool;       (* records or abstract types *)
+  td_inv    : invariant;  (* records only *)
   td_def    : type_def;
-  td_inv    : invariant;
 }
 
 type logic_decl = {
@@ -166,13 +164,6 @@ type metarg =
 
 type use_clone = use * clone_subst list option
 
-type decl =
-  | Dtype of type_decl list
-  | Dlogic of logic_decl list
-  | Dind of Decl.ind_sign * ind_decl list
-  | Dprop of Decl.prop_kind * ident * term
-  | Dmeta of ident * metarg list
-
 (* program files *)
 
 type assertion_kind = Aassert | Aassume | Acheck
@@ -259,23 +250,14 @@ and fundef = ident * top_ghost * lambda
 
 and lambda = binder list * pty option * expr * spec
 
-type pdecl =
+type decl =
+  | Dtype of type_decl list
+  | Dlogic of logic_decl list
+  | Dind of Decl.ind_sign * ind_decl list
+  | Dprop of Decl.prop_kind * ident * term
+  | Dmeta of ident * metarg list
   | Dval of ident * top_ghost * type_v
   | Dlet of ident * top_ghost * expr
   | Dfun of ident * top_ghost * lambda
   | Drec of fundef list
   | Dexn of ident * pty
-
-(* incremental parsing *)
-
-type incremental = {
-  open_theory     : ident -> unit;
-  close_theory    : unit -> unit;
-  open_module     : ident -> unit;
-  close_module    : unit -> unit;
-  open_namespace  : string -> unit;
-  close_namespace : loc -> bool (*import:*) -> unit;
-  new_decl        : loc -> decl -> unit;
-  new_pdecl       : loc -> pdecl -> unit;
-  use_clone       : loc -> use_clone -> unit;
-}

src/parser/typing.ml

@@ -18,6 +18,11 @@ open Decl
 open Theory
 open Dterm
 open Env
+(*
+open Pdecl
+open Pmodule
+open Dexpr
+*)
 
 (** debug flags *)
 
@@ -31,7 +36,6 @@ let debug_type_only  = Debug.register_flag "type_only"
 
 exception UnboundTypeVar of string
 exception DuplicateTypeVar of string
-exception ClashTheory of string
 
 (** lazy declaration of tuples *)
 
@@ -99,12 +103,9 @@ let find_namespace_ns ns q =
 
 (** Parsing types *)
 
-let ty_of_pty ?(noop=true) uc pty =
+let ty_of_pty uc pty =
   let rec get_ty = function
-    | PTtyvar ({id_loc = loc}, true) when noop ->
-        Loc.errorm ~loc "Opaqueness@ annotations@ are@ only@ \
-          allowed@ in@ function@ and@ predicate@ prototypes"
-    | PTtyvar ({id_str = x}, _) ->
+    | PTtyvar {id_str = x} ->
         ty_var (tv_of_string x)
     | PTtyapp (q, tyl) ->
         let ts = find_tysymbol uc q in
@@ -120,16 +121,6 @@ let ty_of_pty ?(noop=true) uc pty =
   in
   get_ty pty
 
-let opaque_tvs args =
-  let rec opaque_tvs acc = function
-    | PTtyvar (id, true) -> Stv.add (tv_of_string id.id_str) acc
-    | PTtyvar (_, false) -> acc
-    | PTtyapp (_, pl)
-    | PTtuple pl -> List.fold_left opaque_tvs acc pl
-    | PTarrow (ty1, ty2) -> opaque_tvs (opaque_tvs acc ty1) ty2
-    | PTparen ty -> opaque_tvs acc ty in
-  List.fold_left (fun acc (_,_,_,ty) -> opaque_tvs acc ty) Stv.empty args
-
 (** typing using destructive type variables
 
     parsed trees        intermediate trees       typed trees
@@ -204,8 +195,6 @@ let chainable_op uc op =
       && not (ty_equal ty2 ty_bool)
   | _ -> false
 
-type global_vs = Ptree.qualid -> vsymbol option
-
 let mk_closure loc ls =
   let mk dt = Dterm.dterm ~loc dt in
   let mk_v i _ =
@@ -353,11 +342,13 @@ let rec dterm uc gvars denv {term_desc = desc; term_loc = loc} =
   | Ptree.Tcast (e1, ty) ->
       DTcast (dterm uc gvars denv e1, ty_of_pty uc ty))
 
+(* TODO
 (** Export for program parsing *)
 
 let type_term uc gvars t =
   let t = dterm uc gvars denv_empty t in
   Dterm.term ~strict:true ~keep_loc:true t
+*)
 
 let type_fmla uc gvars f =
   let f = dterm uc gvars denv_empty f in
@@ -365,11 +356,11 @@ let type_fmla uc gvars f =
 
 (** Typing declarations *)
 
-let tyl_of_params ?(noop=false) uc pl =
+let tyl_of_params uc pl =
   let ty_of_param (loc,_,gh,ty) =
     if gh then Loc.errorm ~loc
       "ghost parameters are not allowed in pure declarations";
-    ty_of_pty ~noop uc ty in
+    ty_of_pty uc ty in
   List.map ty_of_param pl
 
 let add_types dl th =
@@ -400,7 +391,7 @@ let add_types dl th =
       let ts = match d.td_def with
         | TDalias ty ->
             let rec apply = function
-              | PTtyvar (v, _) ->
+              | PTtyvar v ->
                   begin
                     try ty_var (Hstr.find vars v.id_str) with Not_found ->
                       Loc.error ~loc:v.id_loc (UnboundTypeVar v.id_str)
@@ -456,7 +447,6 @@ let add_types dl th =
       | TDalgebraic cl ->
           let ht = Hstr.create 17 in
           let constr = List.length cl in
-          let opaque = Stv.of_list ts.ts_args in
           let ty = ty_app ts (List.map ty_var ts.ts_args) in
           let projection (_,id,_,_) fty = match id with
             | None -> None
@@ -468,16 +458,16 @@ let add_types dl th =
                   Some pj
                 with Not_found ->
                   let fn = create_user_id id in
-                  let pj = create_fsymbol ~opaque fn [ty] fty in
+                  let pj = create_fsymbol fn [ty] fty in
                   Hstr.replace csymbols x loc;