diff options
| -rw-r--r-- | compiler/typecheck/TcSplice.hs | 8 | ||||
| -rw-r--r-- | compiler/types/TyCon.hs | 20 | ||||
| -rw-r--r-- | docs/users_guide/8.2.1-notes.rst | 2 | ||||
| -rw-r--r-- | testsuite/tests/th/T11629.hs | 67 | ||||
| -rw-r--r-- | testsuite/tests/th/all.T | 2 |
5 files changed, 89 insertions, 10 deletions
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 4731e5737c..dd5c9f3191 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 054eb2bfb1..ebb18f0a4b 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 1699ebb39f..984889f991 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 0000000000..b22365fe60 --- /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 4f66960a61..b96ea78a0d 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]) |