Commit d081fcfc authored by bollmann's avatar bollmann Committed by Erik de Castro Lopo

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
parent 14ac3725
......@@ -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
......
......@@ -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
......
......@@ -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
~~~~~~~~~~~~~~
......
{-# 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 []
......@@ -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])
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment