Make quoting and reification return the same types

Previously TH was incorrectly returning a `Dec` using a `ConT` instead
of `PromotedT`.

Test Plan: validate

Reviewers: mainland, jstolarek, osa1, goldfire, thomie, bollmann,
bgamari, RyanGlScott, austin

Reviewed By: RyanGlScott

Subscribers: erikd

Differential Revision: https://phabricator.haskell.org/D2188

GHC Trac Issues: #11629

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

compiler/types/TyCon.hs

@@ -45,7 +45,7 @@ module TyCon(
         isFunTyCon,
         isPrimTyCon,
         isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon,
-        isUnboxedSumTyCon,
+        isUnboxedSumTyCon, isPromotedTupleTyCon,
         isTypeSynonymTyCon,
         mightBeUnsaturatedTyCon,
         isPromotedDataCon, isPromotedDataCon_maybe,
@@ -125,7 +125,8 @@ 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 #-} 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

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
 ~~~~~~~~~~~~~~
 

testsuite/tests/th/T11629.hs

+{-# 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 []

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])