From a0f3d26671e320bec12af77e91c974781a9ae56f Mon Sep 17 00:00:00 2001
From: Oskar Goldhahn <oskar.goldhahn@ntnu.no>
Date: Thu, 25 Jun 2026 14:33:28 +0200
Subject: [PATCH] emit error when overrinding a subtype with a type that is not
 a subtype with compatible base type and predicate

---
 src/ecThCloning.ml        |  2 ++
 src/ecThCloning.mli       |  2 ++
 src/ecTheoryReplay.ml     | 23 ++++++++++++++++++++---
 src/ecUserMessages.ml     | 11 +++++++++++
 tests/subtype-override.ec | 15 +++++++++++++++
 5 files changed, 50 insertions(+), 3 deletions(-)
 create mode 100644 tests/subtype-override.ec

diff --git a/src/ecThCloning.ml b/src/ecThCloning.ml
index 121a10858..c84c8ed02 100644
--- a/src/ecThCloning.ml
+++ b/src/ecThCloning.ml
@@ -15,6 +15,8 @@ type incompatible =
 | DifferentType of EcTypes.ty * EcTypes.ty
 | OpBody (* of (EcPath.path * EcDecl.operator) * (EcPath.path * EcDecl.operator) *)
 | TyBody (* of (EcPath.path * EcDecl.tydecl) * (EcPath.path * EcDecl.tydecl) *)
+| SubtypeType of (EcTypes.ty * EcTypes.ty option)
+| SubtypePred of (EcAst.form * EcAst.form)
 
 type ovkind =
 | OVK_Type
diff --git a/src/ecThCloning.mli b/src/ecThCloning.mli
index 4720f2cbc..9b36f6788 100644
--- a/src/ecThCloning.mli
+++ b/src/ecThCloning.mli
@@ -9,6 +9,8 @@ type incompatible =
 | DifferentType of EcTypes.ty * EcTypes.ty
 | OpBody (* of (EcPath.path * EcDecl.operator) * (EcPath.path * EcDecl.operator) *)
 | TyBody (* of (EcPath.path * EcDecl.tydecl) * (EcPath.path * EcDecl.tydecl) *)
+| SubtypeType of (EcTypes.ty * EcTypes.ty option)
+| SubtypePred of (EcAst.form * EcAst.form)
 
 type ovkind =
 | OVK_Type
diff --git a/src/ecTheoryReplay.ml b/src/ecTheoryReplay.ml
index 9d2e25be3..6b3b4afef 100644
--- a/src/ecTheoryReplay.ml
+++ b/src/ecTheoryReplay.ml
@@ -191,8 +191,16 @@ end = struct
       let hyps = EcEnv.LDecl.init env params in
 
       match ty_body1, ty_body2 with
-      | Abstract, _ -> ()
-
+      | Abstract, _ -> begin
+        match tyd1.tyd_subtype, tyd2.tyd_subtype with
+        | Some (ty1, f1), Some (ty2, f2) ->
+          if not (EcReduction.EqTest.for_type (toenv hyps) ty1 ty2) then
+            raise (Incompatible (SubtypeType (ty1, Some ty2)));
+          if not (EcReduction.is_conv ~ri:ri_compatible hyps f1 f2) then
+            raise (Incompatible (SubtypePred (f1, f2)))
+        |  Some (ty1, _), None -> raise (Incompatible (SubtypeType (ty1, None)))
+        | _, _ -> ()
+        end
       | _, _ -> tybody hyps ty_body1 ty_body2
 
     with CoreIncompatible -> raise (Incompatible TyBody)
@@ -427,13 +435,21 @@ let rec replay_tyd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, otyd
                           (fun x -> (EcIdent.create (unloc x)))
                           nargs in
             let ue    = EcUnify.UniEnv.create (Some nargs) in
+            let subtype =
+              match unloc ntyd with
+              | PTnamed (s) -> begin
+                match EcEnv.Ty.lookup_opt s.pl_desc env with
+                | Some (_, { tyd_subtype = Some (ty, f) }) -> Some (ty, f)
+                | _ -> None
+                end
+              | _ -> None in
             let ntyd  = EcTyping.transty EcTyping.tp_tydecl env ue ntyd in
             let decl  =
               { tyd_params   = nargs;
                 tyd_type     = Concrete ntyd;
                 tyd_loca     = otyd.tyd_loca;
                 tyd_clinline = (mode <> `Alias);
-                tyd_subtype  = None; }
+                tyd_subtype  = subtype; }
 
             in (decl, ntyd)
 
@@ -459,6 +475,7 @@ let rec replay_tyd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, otyd
 
         | `Direct ty -> begin
           assert (List.is_empty otyd.tyd_params);
+          assert (otyd.tyd_subtype = None);
           let decl  =
             { tyd_params   = [];
               tyd_type     = Concrete ty;
diff --git a/src/ecUserMessages.ml b/src/ecUserMessages.ml
index dc8e0947d..763bec43a 100644
--- a/src/ecUserMessages.ml
+++ b/src/ecUserMessages.ml
@@ -839,6 +839,17 @@ end = struct
       Format.fprintf fmt "incompatible body"
     | TyBody  ->
       Format.fprintf fmt "incompatible type declaration"
+    | SubtypeType (ty1, None) ->
+      Format.fprintf fmt "incompatible type. Not a subtype of %a"
+        (EcPrinting.pp_type (EcPrinting.PPEnv.ofenv env)) ty1
+    | SubtypeType (ty1, Some ty2) ->
+      Format.fprintf fmt "incompatible type. The type is a subtype of %a instead of %a"
+        (EcPrinting.pp_type (EcPrinting.PPEnv.ofenv env)) ty2
+        (EcPrinting.pp_type (EcPrinting.PPEnv.ofenv env)) ty1
+    | SubtypePred (f1, f2) ->
+      Format.fprintf fmt "incompatible predicate for subtypes. The predicate for the subtype is %a instead of %a"
+        (EcPrinting.pp_form  (EcPrinting.PPEnv.ofenv env)) f2
+        (EcPrinting.pp_form  (EcPrinting.PPEnv.ofenv env)) f1
 
   let pp_clone_error env fmt error =
     let msg x = Format.fprintf fmt x in
diff --git a/tests/subtype-override.ec b/tests/subtype-override.ec
new file mode 100644
index 000000000..f27b7b301
--- /dev/null
+++ b/tests/subtype-override.ec
@@ -0,0 +1,15 @@
+require Subtype.
+
+theory T1.
+  subtype s = {b: bool | b}.
+  realize inhabited by exists true.
+end T1.
+
+subtype s = {b: bool | !b}.
+realize inhabited by exists false.
+
+fail clone T1 as T2 with
+type s   <- s,
+op insub <- insub,
+op val   <- val
+proof *.