[commit: ghc] master: Make quoting and reification return the same types (d081fcf)
git at git.haskell.org
git at git.haskell.org
Thu Nov 24 19:14:53 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/d081fcfc08cfeb3fb729ed2b1df7119ea5b4cf97/ghc
>---------------------------------------------------------------
commit d081fcfc08cfeb3fb729ed2b1df7119ea5b4cf97
Author: Dominik Bollmann <bollmann at seas.upenn.edu>
Date: Fri Nov 25 06:14:09 2016 +1100
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
>---------------------------------------------------------------
d081fcfc08cfeb3fb729ed2b1df7119ea5b4cf97
compiler/typecheck/TcSplice.hs | 8 ++---
compiler/types/TyCon.hs | 20 ++++++++----
docs/users_guide/8.2.1-notes.rst | 2 ++
testsuite/tests/th/T11629.hs | 67 ++++++++++++++++++++++++++++++++++++++++
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 4731e57..dd5c9f3 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 054eb2b..ebb18f0 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 1699ebb..984889f 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 0000000..b22365f
--- /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 4f66960..b96ea78 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])
More information about the ghc-commits
mailing list