RTTI: Substitute the [rk] skolems into kinds

(Fixes #10616 and #10617)

Co-authored-by: Roland Senn <rsx@bluewin.ch>

8 files changed, 49 insertions, 5 deletions

diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index c514cd105b..343f021a45 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -573,7 +573,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
 
        (ids, offsets, occs') = syncOccs mbPointers occs
 
-       free_tvs = tyCoVarsOfTypesList (result_ty:map idType ids)
+       free_tvs = tyCoVarsOfTypesWellScoped (result_ty:map idType ids)
 
    -- It might be that getIdValFromApStack fails, because the AP_STACK
    -- has been accidentally evaluated, or something else has gone wrong.
@@ -623,10 +623,11 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
    newTyVars :: UniqSupply -> [TcTyVar] -> TCvSubst
      -- Similarly, clone the type variables mentioned in the types
      -- we have here, *and* make them all RuntimeUnk tyvars
-   newTyVars us tvs
-     = mkTvSubstPrs [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv)))
-                    | (tv, uniq) <- tvs `zip` uniqsFromSupply us
-                    , let name = setNameUnique (tyVarName tv) uniq ]
+   newTyVars us tvs = foldl' new_tv emptyTCvSubst (tvs `zip` uniqsFromSupply us)
+   new_tv subst (tv,uniq) = extendTCvSubstWithClone subst tv new_tv
+    where
+     new_tv = mkRuntimeUnkTyVar (setNameUnique (tyVarName tv) uniq)
+                                (substTy subst (tyVarKind tv))
 
    isPointer id | [rep] <- typePrimRep (idType id)
                 , isGcPtrRep rep                   = True
diff --git a/testsuite/tests/ghci.debugger/scripts/T10616.hs b/testsuite/tests/ghci.debugger/scripts/T10616.hs
new file mode 100644
index 0000000000..f4339ab279
--- /dev/null
+++ b/testsuite/tests/ghci.debugger/scripts/T10616.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE PolyKinds  #-}
+
+data D a = A | B
+
+f d@A = const True d
+f B = False
diff --git a/testsuite/tests/ghci.debugger/scripts/T10616.script b/testsuite/tests/ghci.debugger/scripts/T10616.script
new file mode 100644
index 0000000000..a711d4e6ac
--- /dev/null
+++ b/testsuite/tests/ghci.debugger/scripts/T10616.script
@@ -0,0 +1,4 @@
+:l T10616.hs
+:break f
+f A
+:continue
diff --git a/testsuite/tests/ghci.debugger/scripts/T10616.stdout b/testsuite/tests/ghci.debugger/scripts/T10616.stdout
new file mode 100644
index 0000000000..a88ee3f583
--- /dev/null
+++ b/testsuite/tests/ghci.debugger/scripts/T10616.stdout
@@ -0,0 +1,6 @@
+Breakpoint 0 activated at T10616.hs:5:9-20
+Breakpoint 1 activated at T10616.hs:6:7-11
+Stopped in Main.f, T10616.hs:5:9-20
+_result :: Bool = _
+d :: D a = A
+True
diff --git a/testsuite/tests/ghci.debugger/scripts/T10617.hs b/testsuite/tests/ghci.debugger/scripts/T10617.hs
new file mode 100644
index 0000000000..bc649a7c63
--- /dev/null
+++ b/testsuite/tests/ghci.debugger/scripts/T10617.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE GADTs, StandaloneKindSignatures, PolyKinds, RankNTypes #-}
+
+import GHC.Types (Type)
+
+type AppTreeT :: forall k. k -> Type
+data AppTreeT a where
+  Con :: AppTreeT a
+  App :: AppTreeT a -> AppTreeT b -> AppTreeT (a b)
+
+tmt :: AppTreeT (Maybe Bool)
+tmt = App (Con :: AppTreeT Maybe) Con
+
+f :: AppTreeT a -> Bool
+f (App (c@Con) _) = const True c
+f _ = False
diff --git a/testsuite/tests/ghci.debugger/scripts/T10617.script b/testsuite/tests/ghci.debugger/scripts/T10617.script
new file mode 100644
index 0000000000..cc5320695e
--- /dev/null
+++ b/testsuite/tests/ghci.debugger/scripts/T10617.script
@@ -0,0 +1,4 @@
+:l T10617.hs
+:break f
+f tmt
+:continue
diff --git a/testsuite/tests/ghci.debugger/scripts/T10617.stdout b/testsuite/tests/ghci.debugger/scripts/T10617.stdout
new file mode 100644
index 0000000000..4539e6323e
--- /dev/null
+++ b/testsuite/tests/ghci.debugger/scripts/T10617.stdout
@@ -0,0 +1,6 @@
+Breakpoint 0 activated at T10617.hs:14:21-32
+Breakpoint 1 activated at T10617.hs:15:7-11
+Stopped in Main.f, T10617.hs:14:21-32
+_result :: Bool = _
+c :: AppTreeT a1 = Con
+True
diff --git a/testsuite/tests/ghci.debugger/scripts/all.T b/testsuite/tests/ghci.debugger/scripts/all.T
index 3f1fc88644..4ed1fc046e 100644
--- a/testsuite/tests/ghci.debugger/scripts/all.T
+++ b/testsuite/tests/ghci.debugger/scripts/all.T
@@ -111,6 +111,8 @@ test('getargs', extra_files(['../getargs.hs']), ghci_script, ['getargs.script'])
 test('T7386', normal, ghci_script, ['T7386.script'])
 test('T8487', normal, ghci_script, ['T8487.script'])
 test('T8557', normal, ghci_script, ['T8557.script'])
+test('T10616', normal, ghci_script, ['T10616.script'])
+test('T10617', normal, ghci_script, ['T10617.script'])
 test('T12449', normal, ghci_script, ['T12449.script'])
 test('T12458', normal, ghci_script, ['T12458.script'])
 test('T13825-debugger',