diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 4731e5737c94f28fffd7ca38cd6ca69383653e90..dd5c9f3191ceba538cfea8e28c12135ad04b1f05 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -1818,6 +1818,7 @@ reify_tc_app tc tys r_tc | isUnboxedSumTyCon tc = TH.UnboxedSumT (arity `div` 2) | isUnboxedTupleTyCon tc = TH.UnboxedTupleT (arity `div` 2) + | isPromotedTupleTyCon tc = TH.PromotedTupleT (arity `div` 2) -- See Note [Unboxed tuple RuntimeRep vars] in TyCon | isTupleTyCon tc = if isPromotedDataCon tc then TH.PromotedTupleT arity @@ -1828,6 +1829,7 @@ reify_tc_app tc tys | tc `hasKey` heqTyConKey = TH.EqualityT | tc `hasKey` eqPrimTyConKey = TH.EqualityT | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon) + | isPromotedDataCon tc = TH.PromotedT (reifyName tc) | otherwise = TH.ConT (reifyName tc) -- See Note [Kind annotations on TyConApps] @@ -1841,11 +1843,9 @@ reify_tc_app tc tys needs_kind_sig | GT <- compareLength tys tc_binders - , tcIsTyVarTy tc_res_kind - = True + = tcIsTyVarTy tc_res_kind | otherwise - = not $ - isEmptyVarSet $ + = not . isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType $ mkTyConKind (dropList tys tc_binders) tc_res_kind diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index 054eb2bfb128bc151705edbfc5966b21ad4b7a91..ebb18f0a4b2c2b0788c8a687e2e83fc93e4fe3a1 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -45,7 +45,7 @@ module TyCon( isFunTyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, - isUnboxedSumTyCon, + isUnboxedSumTyCon, isPromotedTupleTyCon, isTypeSynonymTyCon, mightBeUnsaturatedTyCon, isPromotedDataCon, isPromotedDataCon_maybe, @@ -121,11 +121,12 @@ module TyCon( #include "HsVersions.h" -import {-# SOURCE #-} TyCoRep ( Kind, Type, PredType, pprType ) -import {-# SOURCE #-} TysWiredIn ( runtimeRepTyCon, constraintKind - , vecCountTyCon, vecElemTyCon, liftedTypeKind - , mkFunKind, mkForAllKind ) -import {-# SOURCE #-} DataCon ( DataCon, dataConExTyVars, dataConFieldLabels ) +import {-# SOURCE #-} TyCoRep ( Kind, Type, PredType, pprType ) +import {-# SOURCE #-} TysWiredIn ( runtimeRepTyCon, constraintKind + , vecCountTyCon, vecElemTyCon, liftedTypeKind + , mkFunKind, mkForAllKind ) +import {-# SOURCE #-} DataCon ( DataCon, dataConExTyVars, dataConFieldLabels + , dataConTyCon ) import Binary import Var @@ -1958,6 +1959,13 @@ isUnboxedSumTyCon (AlgTyCon { algTcRhs = rhs }) = True isUnboxedSumTyCon _ = False +-- | Is this the 'TyCon' for a /promoted/ tuple? +isPromotedTupleTyCon :: TyCon -> Bool +isPromotedTupleTyCon tyCon + | Just dataCon <- isPromotedDataCon_maybe tyCon + , isTupleTyCon (dataConTyCon dataCon) = True + | otherwise = False + -- | Is this a PromotedDataCon? isPromotedDataCon :: TyCon -> Bool isPromotedDataCon (PromotedDataCon {}) = True diff --git a/docs/users_guide/8.2.1-notes.rst b/docs/users_guide/8.2.1-notes.rst index 1699ebb39f8cc77d6e5c44e20fda537071b837ec..984889f99136cef989ebfd3db596354826c1f86d 100644 --- a/docs/users_guide/8.2.1-notes.rst +++ b/docs/users_guide/8.2.1-notes.rst @@ -119,6 +119,8 @@ Template Haskell - Add support for type signatures in patterns. (:ghc-ticket:`12164`) +- Make quoting and reification return the same types. (:ghc-ticket:`11629`) + Runtime system ~~~~~~~~~~~~~~ diff --git a/testsuite/tests/th/T11629.hs b/testsuite/tests/th/T11629.hs new file mode 100644 index 0000000000000000000000000000000000000000..b22365fe601ce97ae99c06921d8e804af0dda61b --- /dev/null +++ b/testsuite/tests/th/T11629.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +module T11629 where + +import Control.Monad +import Language.Haskell.TH + +class C (a :: Bool) +class D (a :: (Bool, Bool)) +class E (a :: [Bool]) + +instance C True +instance C 'False + +instance D '(True, False) +instance D '(False, True) + +instance E '[True, False] +instance E '[False, True] + +do + let getType (InstanceD _ _ ty _) = ty + getType _ = error "getType: only defined for InstanceD" + + failMsg a ty1 ty2 = fail $ "example " ++ a + ++ ": ty1 /= ty2, where\n ty1 = " + ++ show ty1 ++ "\n ty2 = " ++ show ty2 + + withoutSig (ForallT tvs cxt ty) = ForallT tvs cxt (withoutSig ty) + withoutSig (AppT ty1 ty2) = AppT (withoutSig ty1) (withoutSig ty2) + withoutSig (SigT ty ki) = withoutSig ty + withoutSig ty = ty + + -- test #1: type quotations and reified types should agree. + ty1 <- [t| C True |] + ty2 <- [t| C 'False |] + ClassI _ insts <- reify ''C + let [ty1', ty2'] = map getType insts + + when (ty1 /= ty1') $ failMsg "A" ty1 ty1' + when (ty2 /= ty2') $ failMsg "B" ty2 ty2' + + -- test #2: type quotations and reified types should agree wrt + -- promoted tuples. + ty3 <- [t| D '(True, False) |] + ty4 <- [t| D (False, True) |] + ClassI _ insts <- reify ''D + let [ty3', ty4'] = map (withoutSig . getType) insts + + when (ty3 /= ty3') $ failMsg "C" ty3 ty3' + -- The following won't work. See https://ghc.haskell.org/trac/ghc/ticket/12853 + -- when (ty4 /= ty4') $ failMsg "D" ty4 ty4' + + -- test #3: type quotations and reified types should agree wrt to + -- promoted lists. + ty5 <- [t| E '[True, False] |] + ty6 <- [t| E [False, True] |] + + ClassI _ insts <- reify ''E + let [ty5', ty6'] = map (withoutSig . getType) insts + + when (ty5 /= ty5') $ failMsg "C" ty5 ty5' + when (ty6 /= ty6') $ failMsg "D" ty6 ty6' + + return [] diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 4f66960a6161cc973ce2f641f4faab42097c23de..b96ea78a0dda31b1c0d1e7957a859683f50df691 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -424,6 +424,8 @@ test('T11809', normal, compile, ['-v0']) test('T11797', normal, compile, ['-v0 -dsuppress-uniques']) test('T11941', normal, compile_fail, ['-v0']) test('T11484', normal, compile, ['-v0']) +test('T11629', normal, compile, ['-v0']) + test('T8761', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('T12130', extra_clean(['T12130a.hi','T12130a.o']), multimod_compile, ['T12130', '-v0 ' + config.ghc_th_way_flags])