diff options
| -rw-r--r-- | compiler/GHC/Tc/Deriv/Generate.hs | 12 | ||||
| -rw-r--r-- | libraries/base/Data/Data.hs | 17 | ||||
| -rw-r--r-- | testsuite/tests/deriving/should_compile/T14682.stderr | 2 |
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: |