Handle `type data` properly in tyThingParent_maybe

Unlike most other data constructors, data constructors declared with `type data`
are represented in `TyThing`s as `ATyCon` rather than `ADataCon`. The `ATyCon`
case in `tyThingParent_maybe` previously did not consider the possibility of
the underlying `TyCon` being a promoted data constructor, which led to the
oddities observed in #22817. This patch adds a dedicated special case in
`tyThingParent_maybe`'s `ATyCon` case for `type data` data constructors to fix
these oddities.

Fixes #22817.

(cherry picked from commit 20598ef6d9e26e2e0af9ac42a42e7be00d7cc4f3)

6 files changed, 42 insertions, 8 deletions

diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index 97726a279c..1d6bfb9212 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -2055,6 +2055,9 @@ Type data declarations have the syntax of `data` declarations (but not
 `newtype` declarations), either ordinary algebraic data types or GADTs,
 preceded by `type`, with the following restrictions:
 
+(R0) 'data' decls only, not 'newtype' decls.  This is checked by
+     the parser.
+
 (R1) There are no data type contexts (even with the DatatypeContexts
      extension).
 
@@ -2077,7 +2080,7 @@ preceded by `type`, with the following restrictions:
 
 The main parts of the implementation are:
 
-* The parser recognizes `type data` (but not `type newtype`).
+* (R0): The parser recognizes `type data` (but not `type newtype`).
 
 * During the initial construction of the AST,
   GHC.Parser.PostProcess.checkNewOrData sets the `Bool` argument of the
@@ -2112,10 +2115,13 @@ The main parts of the implementation are:
   `dcPromotedField` is a `TyCon` (for `Zero`, say) that you can use
   in a type.
 
-* After a `type data` declaration has been type-checked, the type-checker
-  environment entry for each constructor (`Zero` and `Succ` in our
-  example) is just the promoted type constructor, not the bundle required
-  for a data constructor.  (GHC.Types.TyThing.implicitTyConThings)
+* After a `type data` declaration has been type-checked, the
+  type-checker environment entry (a `TyThing`) for each constructor
+  (`Zero` and `Succ` in our example) is
+  - just an `ATyCon` for the promoted type constructor,
+  - not the bundle (`ADataCon` for the data con, `AnId` for the work id,
+    wrap id) required for a normal data constructor
+  See GHC.Types.TyThing.implicitTyConThings.
 
 * GHC.Core.TyCon.isDataKindsPromotedDataCon ignores promoted constructors
   from `type data`, which do not use the distinguishing quote mark added
diff --git a/compiler/GHC/Types/TyThing.hs b/compiler/GHC/Types/TyThing.hs
index 15fff48509..08d13b1257 100644
--- a/compiler/GHC/Types/TyThing.hs
+++ b/compiler/GHC/Types/TyThing.hs
@@ -239,9 +239,19 @@ tyThingParent_maybe :: TyThing -> Maybe TyThing
 tyThingParent_maybe (AConLike cl) = case cl of
     RealDataCon dc  -> Just (ATyCon (dataConTyCon dc))
     PatSynCon{}     -> Nothing
-tyThingParent_maybe (ATyCon tc)   = case tyConAssoc_maybe tc of
-                                      Just tc -> Just (ATyCon tc)
-                                      Nothing -> Nothing
+tyThingParent_maybe (ATyCon tc)
+  | -- Special case for `type data` data constructors.  They appear as an
+    -- ATyCon (not ADataCon) but we want to display them here as if they were
+    -- a DataCon (i.e. with the parent declaration) (#22817).
+    -- See Note [Type data declarations] in GHC.Rename.Module.
+    Just dc <- isPromotedDataCon_maybe tc
+  , let parent_tc = dataConTyCon dc
+  , isTypeDataTyCon parent_tc
+  = Just (ATyCon parent_tc)
+  | Just tc <- tyConAssoc_maybe tc
+  = Just (ATyCon tc)
+  | otherwise
+  = Nothing
 tyThingParent_maybe (AnId id)     = case idDetails id of
                                       RecSelId { sel_tycon = RecSelData tc } ->
                                           Just (ATyCon tc)
diff --git a/testsuite/tests/ghci/scripts/T22817.hs b/testsuite/tests/ghci/scripts/T22817.hs
new file mode 100644
index 0000000000..ea32bd906e
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T22817.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE TypeData #-}
+module T22817 where
+
+type data BoolKind = FalseType | TrueType
diff --git a/testsuite/tests/ghci/scripts/T22817.script b/testsuite/tests/ghci/scripts/T22817.script
new file mode 100644
index 0000000000..f436495708
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T22817.script
@@ -0,0 +1,4 @@
+:load T22817
+:info BoolKind
+:info FalseType
+:info TrueType
diff --git a/testsuite/tests/ghci/scripts/T22817.stdout b/testsuite/tests/ghci/scripts/T22817.stdout
new file mode 100644
index 0000000000..0a93b5d07f
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T22817.stdout
@@ -0,0 +1,9 @@
+type BoolKind :: *
+type data BoolKind = FalseType | TrueType
+  	-- Defined at T22817.hs:4:1
+type BoolKind :: *
+type data BoolKind = FalseType | ...
+  	-- Defined at T22817.hs:4:22
+type BoolKind :: *
+type data BoolKind = ... | TrueType
+  	-- Defined at T22817.hs:4:34
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 716b2db4c6..6dad147225 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -371,3 +371,4 @@ test('T17830', [filter_stdout_lines(r'======.*')], ghci_script, ['T17830.script'
 test('T21294a', normal, ghci_script, ['T21294a.script'])
 test('T21507', normal, ghci_script, ['T21507.script'])
 test('T22695', normal, ghci_script, ['T22695.script'])
+test('T22817', normal, ghci_script, ['T22817.script'])