[commit: ghc] master: Don't apply dataToTag's caseRules for data families (d8a0e6d)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/d8a0e6d322deaa3743c95a11a6b7272577d1f86e/ghc

>---------------------------------------------------------------

commit d8a0e6d322deaa3743c95a11a6b7272577d1f86e
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Sat Feb 3 11:40:43 2018 -0500

    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


>---------------------------------------------------------------

d8a0e6d322deaa3743c95a11a6b7272577d1f86e
 compiler/prelude/PrelRules.hs                         | 12 ++++++++++--
 .../tests/indexed-types/should_compile/T14680.hs      | 19 +++++++++++++++++++
 testsuite/tests/indexed-types/should_compile/all.T    |  1 +
 3 files changed, 30 insertions(+), 2 deletions(-)

diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index db79589..49cd9fa 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 0000000..9694c0a
--- /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 9250fa2..8e89ecf 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, [''])