Don't apply dataToTag's caseRules for data families

Commit 193664d42dbceadaa1e4689dfa17ff1cf5a405a0 added a
special caseRule for `dataToTag`, but this transformation completely
broke when `dataToTag` was applied to somewith with a type headed by
a data family, leading to #14680. For now at least, the simplest
solution is to simply not apply this transformation when the type is
headed by a data family.

Test Plan: make test TEST=T14680

Reviewers: simonpj, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #14680

Differential Revision: https://phabricator.haskell.org/D4371

3 files changed, 30 insertions, 2 deletions

diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index db795890c7..49cd9fa153 100644
--- a/compiler/prelude/PrelRules.hs
+++ b/compiler/prelude/PrelRules.hs
@@ -37,8 +37,8 @@ import CoreOpt     ( exprIsLiteral_maybe )
 import PrimOp      ( PrimOp(..), tagToEnumKey )
 import TysWiredIn
 import TysPrim
-import TyCon       ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon
-                   , unwrapNewTyCon_maybe, tyConDataCons )
+import TyCon       ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon
+                   , isNewTyCon, unwrapNewTyCon_maybe, tyConDataCons )
 import DataCon     ( DataCon, dataConTagZ, dataConTyCon, dataConWorkId )
 import CoreUtils   ( cheapEqExpr, exprIsHNF, exprType )
 import CoreUnfold  ( exprIsConApp_maybe )
@@ -1449,6 +1449,8 @@ caseRules dflags (App (App (Var f) type_arg) v)
 -- See Note [caseRules for dataToTag]
 caseRules _ (App (App (Var f) (Type ty)) v)       -- dataToTag x
   | Just DataToTagOp <- isPrimOpId_maybe f
+  , Just (tc, _) <- tcSplitTyConApp_maybe ty
+  , isAlgTyCon tc
   = Just (v, tx_con_dtt ty
            , \v -> App (App (Var f) (Type ty)) (Var v))
 
@@ -1549,4 +1551,10 @@ into
 
 Note the need for some wildcard binders in
 the 'cons' case.
+
+For the time, we only apply this transformation when the type of `x` is a type
+headed by a normal tycon. In particular, we do not apply this in the case of a
+data family tycon, since that would require carefully applying coercion(s)
+between the data family and the data family instance's representation type,
+which caseRules isn't currently engineered to handle (#14680).
 -}
diff --git a/testsuite/tests/indexed-types/should_compile/T14680.hs b/testsuite/tests/indexed-types/should_compile/T14680.hs
new file mode 100644
index 0000000000..9694c0a2ea
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/T14680.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -O1 #-}
+module T14680 where
+
+import GHC.Base (getTag)
+import GHC.Exts (Int(..), tagToEnum#)
+
+data family TyFamilyEnum
+data instance TyFamilyEnum = TyFamilyEnum1 | TyFamilyEnum2 | TyFamilyEnum3
+
+suc :: TyFamilyEnum -> TyFamilyEnum
+suc a_aaf8
+        = case getTag a_aaf8 of
+             a_aaf9
+               -> if 2 ==  I# a_aaf9
+                  then error "succ{TyFamilyEnum}: tried to take `succ' of last tag in enumeration"
+                  else case I# a_aaf9 + 1 of
+                         I# i_aafa -> tagToEnum# i_aafa :: TyFamilyEnum
diff --git a/testsuite/tests/indexed-types/should_compile/all.T b/testsuite/tests/indexed-types/should_compile/all.T
index 9250fa2317..8e89ecfd78 100644
--- a/testsuite/tests/indexed-types/should_compile/all.T
+++ b/testsuite/tests/indexed-types/should_compile/all.T
@@ -272,3 +272,4 @@ test('T14131', normal, compile, [''])
 test('T14162', normal, compile, [''])
 test('T14237', normal, compile, [''])
 test('T14554', normal, compile, [''])
+test('T14680', normal, compile, [''])