Don't apply dataToTag's caseRules for data families
authorRyan Scott <ryan.gl.scott@gmail.com>
Sat, 3 Feb 2018 16:40:43 +0000 (11:40 -0500)
committerBen Gamari <ben@smart-cactus.org>
Sat, 3 Feb 2018 17:30:45 +0000 (12:30 -0500)
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

(cherry picked from commit d8a0e6d322deaa3743c95a11a6b7272577d1f86e)

compiler/prelude/PrelRules.hs
testsuite/tests/indexed-types/should_compile/T14680.hs [new file with mode: 0644]
testsuite/tests/indexed-types/should_compile/all.T

index 8838c4a..80a1145 100644 (file)
@@ -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 )
 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 (file)
index 0000000..9694c0a
--- /dev/null
@@ -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
index 6407324..d470a9b 100644 (file)
@@ -271,3 +271,4 @@ test('T12938', normal, compile, [''])
 test('T14131', normal, compile, [''])
 test('T14162', normal, compile, [''])
 test('T14237', normal, compile, [''])
+test('T14680', normal, compile, [''])