summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/GHC/Tc/Deriv/Generate.hs12
-rw-r--r--libraries/base/Data/Data.hs17
-rw-r--r--testsuite/tests/deriving/should_compile/T14682.stderr2
3 files changed, 19 insertions, 12 deletions
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index e0f113df15..2bda9d40c6 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -1480,7 +1480,7 @@ kind1, kind2 :: Kind
kind1 = typeToTypeKind
kind2 = liftedTypeKind `mkVisFunTyMany` kind1
-gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
+gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstrTag_RDR,
mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
constr_RDR, dataType_RDR,
@@ -1508,7 +1508,7 @@ dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
-mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
+mkConstrTag_RDR = varQual_RDR gENERICS (fsLit "mkConstrTag")
constr_RDR = tcQual_RDR gENERICS (fsLit "Constr")
mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType")
@@ -2128,12 +2128,12 @@ genAuxBindSpecOriginal dflags loc spec
gen_bind (DerivDataConstr dc dataC_RDR dataT_RDR)
= mkHsVarBind loc dataC_RDR rhs
where
- rhs = nlHsApps mkConstr_RDR constr_args
+ rhs = nlHsApps mkConstrTag_RDR constr_args
constr_args
- = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
- nlHsVar dataT_RDR -- DataType
- , nlHsLit (mkHsString (occNameString dc_occ)) -- String name
+ = [ nlHsVar dataT_RDR -- DataType
+ , nlHsLit (mkHsString (occNameString dc_occ)) -- Constructor name
+ , nlHsIntLit (toInteger (dataConTag dc)) -- Constructor tag
, nlList labels -- Field labels
, nlHsVar fixity ] -- Fixity
diff --git a/libraries/base/Data/Data.hs b/libraries/base/Data/Data.hs
index 4ede199e39..0d4ef944a1 100644
--- a/libraries/base/Data/Data.hs
+++ b/libraries/base/Data/Data.hs
@@ -85,6 +85,7 @@ module Data.Data (
Fixity(..),
-- ** Constructors
mkConstr,
+ mkConstrTag,
mkIntegralConstr,
mkRealConstr,
mkCharConstr,
@@ -120,6 +121,7 @@ import Data.Eq
import Data.Maybe
import Data.Monoid
import Data.Ord
+import Data.List (findIndex)
import Data.Typeable
import Data.Version( Version(..) )
import GHC.Base hiding (Any, IntRep, FloatRep)
@@ -628,10 +630,9 @@ mkDataType str cs = DataType
, datarep = AlgRep cs
}
-
-- | Constructs a constructor
-mkConstr :: DataType -> String -> [String] -> Fixity -> Constr
-mkConstr dt str fields fix =
+mkConstrTag :: DataType -> String -> Int -> [String] -> Fixity -> Constr
+mkConstrTag dt str idx fields fix =
Constr
{ conrep = AlgConstr idx
, constring = str
@@ -639,9 +640,15 @@ mkConstr dt str fields fix =
, confixity = fix
, datatype = dt
}
+
+-- | Constructs a constructor
+mkConstr :: DataType -> String -> [String] -> Fixity -> Constr
+mkConstr dt str fields fix = mkConstrTag dt str idx fields fix
where
- idx = head [ i | (c,i) <- dataTypeConstrs dt `zip` [1..],
- showConstr c == str ]
+ idx = case findIndex (\c -> showConstr c == str) (dataTypeConstrs dt) of
+ Just i -> i+1 -- ConTag starts at 1
+ Nothing -> errorWithoutStackTrace $
+ "Data.Data.mkConstr: couldn't find constructor " ++ str
-- | Gets the constructors of an algebraic datatype
diff --git a/testsuite/tests/deriving/should_compile/T14682.stderr b/testsuite/tests/deriving/should_compile/T14682.stderr
index 064f6a025a..c6454ccc30 100644
--- a/testsuite/tests/deriving/should_compile/T14682.stderr
+++ b/testsuite/tests/deriving/should_compile/T14682.stderr
@@ -74,7 +74,7 @@ Derived class instances:
$tFoo :: Data.Data.DataType
$cFoo :: Data.Data.Constr
$tFoo = Data.Data.mkDataType "Foo" [$cFoo]
- $cFoo = Data.Data.mkConstr $tFoo "Foo" [] Data.Data.Prefix
+ $cFoo = Data.Data.mkConstrTag $tFoo "Foo" 1 [] Data.Data.Prefix
Derived type family instances: