[commit: ghc] master: Refactor previous commit on fixing #7021. (8e303d7)
git at git.haskell.org
git at git.haskell.org
Mon Feb 10 01:39:32 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/8e303d725eba0d6e0f9e52c64da21a0f299fa422/ghc
>---------------------------------------------------------------
commit 8e303d725eba0d6e0f9e52c64da21a0f299fa422
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date: Sun Feb 9 13:29:02 2014 -0500
Refactor previous commit on fixing #7021.
>---------------------------------------------------------------
8e303d725eba0d6e0f9e52c64da21a0f299fa422
compiler/deSugar/DsMeta.hs | 32 +++++++++++++++++---------------
compiler/typecheck/TcSplice.lhs | 34 ++--------------------------------
testsuite/tests/th/T8625.stdout | 4 ++--
testsuite/tests/th/all.T | 2 ++
4 files changed, 23 insertions(+), 49 deletions(-)
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 6a52e55..7fe77c5 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -767,6 +767,7 @@ repPred (HsParTy ty)
= repLPred ty
repPred ty
| Just (cls, tys) <- splitHsClassTy_maybe ty
+ -- works even when cls is not a class (ConstraintKinds)
= do
cls1 <- lookupOcc cls
tyco <- repNamedTyCon cls1
@@ -776,14 +777,15 @@ repPred (HsEqTy tyleft tyright)
= do
tyleft1 <- repLTy tyleft
tyright1 <- repLTy tyright
- repTequality tyleft1 tyright1
+ eq <- repTequality
+ repTapps eq [tyleft1, tyright1]
repPred (HsTupleTy _ lps)
= do
tupTy <- repTupleTyCon size
- foldM go tupTy lps
+ tys' <- mapM repLTy lps
+ repTapps tupTy tys'
where
size = length lps
- go ty' lp = repTapp ty' =<< repLPred lp
repPred ty
= notHandled "Exotic predicate type" (ppr ty)
@@ -1818,8 +1820,8 @@ repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)
repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
-repTequality :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
-repTequality (MkC t1) (MkC t2) = rep2 equalityTName [t1, t2]
+repTequality :: DsM (Core TH.TypeQ)
+repTequality = rep2 equalityTName []
repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
repTPromotedList [] = repPromotedNilTyCon
@@ -2715,22 +2717,22 @@ arrowTIdKey = mkPreludeMiscIdUnique 385
listTIdKey = mkPreludeMiscIdUnique 386
appTIdKey = mkPreludeMiscIdUnique 387
sigTIdKey = mkPreludeMiscIdUnique 388
-equalityTIdKey = mkPreludeMiscIdUnique 362
-litTIdKey = mkPreludeMiscIdUnique 389
-promotedTIdKey = mkPreludeMiscIdUnique 390
-promotedTupleTIdKey = mkPreludeMiscIdUnique 391
-promotedNilTIdKey = mkPreludeMiscIdUnique 392
-promotedConsTIdKey = mkPreludeMiscIdUnique 393
+equalityTIdKey = mkPreludeMiscIdUnique 389
+litTIdKey = mkPreludeMiscIdUnique 390
+promotedTIdKey = mkPreludeMiscIdUnique 391
+promotedTupleTIdKey = mkPreludeMiscIdUnique 392
+promotedNilTIdKey = mkPreludeMiscIdUnique 393
+promotedConsTIdKey = mkPreludeMiscIdUnique 394
-- data TyLit = ...
numTyLitIdKey, strTyLitIdKey :: Unique
-numTyLitIdKey = mkPreludeMiscIdUnique 394
-strTyLitIdKey = mkPreludeMiscIdUnique 395
+numTyLitIdKey = mkPreludeMiscIdUnique 395
+strTyLitIdKey = mkPreludeMiscIdUnique 396
-- data TyVarBndr = ...
plainTVIdKey, kindedTVIdKey :: Unique
-plainTVIdKey = mkPreludeMiscIdUnique 396
-kindedTVIdKey = mkPreludeMiscIdUnique 397
+plainTVIdKey = mkPreludeMiscIdUnique 397
+kindedTVIdKey = mkPreludeMiscIdUnique 398
-- data Role = ...
nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 84e1670..9129ed8 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -1426,6 +1426,7 @@ reify_tc_app tc tys
| tc `hasKey` listTyConKey = TH.ListT
| tc `hasKey` nilDataConKey = TH.PromotedNilT
| tc `hasKey` consDataConKey = TH.PromotedConsT
+ | tc `hasKey` eqTyConKey = TH.EqualityT
| otherwise = TH.ConT (reifyName tc)
removeKinds :: Kind -> [TypeRep.Type] -> [TypeRep.Type]
removeKinds (FunTy k1 k2) (h:t)
@@ -1441,38 +1442,7 @@ reifyPred ty
-- We could reify the implicit paramter as a class but it seems
-- nicer to support them properly...
| isIPPred ty = noTH (sLit "implicit parameters") (ppr ty)
- | otherwise
- = case classifyPredType ty of
- ClassPred cls tys -> do { tys' <- reifyTypes tys
- ; let { name = reifyName cls
- ; typ = foldl TH.AppT (TH.ConT name) tys'
- }
- ; return typ
- }
- EqPred ty1 ty2 -> do { ty1' <- reifyType ty1
- ; ty2' <- reifyType ty2
- ; return $ TH.AppT (TH.AppT TH.EqualityT ty1') ty2'
- }
- TuplePred xs -> do { xs' <- reifyTypes xs
- ; let { size = length xs'
- ; typ = foldl TH.AppT (TH.TupleT size) xs'
- }
- ; return typ }
- IrredPred _
- | Just (ty1, ty2) <- splitAppTy_maybe ty
- -> do { ty1' <- reifyType ty1
- ; ty2' <- reifyType ty2
- ; return $ TH.AppT ty1' ty2'
- }
- | Just (tyCon, tys) <- splitTyConApp_maybe ty
- -> do { tys' <- reifyTypes tys
- ; let { name = reifyName (tyConName tyCon)
- ; typ = foldl TH.AppT (TH.ConT name) tys'
- }
- ; return typ
- }
- | otherwise -> noTH (sLit "unsupported irreducible predicates") (ppr ty)
-
+ | otherwise = reifyType ty
------------------------------
reifyName :: NamedThing n => n -> TH.Name
diff --git a/testsuite/tests/th/T8625.stdout b/testsuite/tests/th/T8625.stdout
index e6ce48b..4453d69 100644
--- a/testsuite/tests/th/T8625.stdout
+++ b/testsuite/tests/th/T8625.stdout
@@ -1,2 +1,2 @@
-[InstanceD [EqualP (VarT y_0) (AppT (AppT ArrowT (VarT t_1)) (VarT t_1))] (AppT (ConT Ghci1.Member) (ConT GHC.Types.Bool)) []]
-[SigD f_2 (ForallT [PlainTV y_3,PlainTV t_4] [EqualP (VarT y_3) (AppT (AppT ArrowT (VarT t_4)) (VarT t_4))] (AppT (AppT ArrowT (VarT y_3)) (VarT t_4))),FunD f_2 [Clause [VarP x_5] (NormalB (VarE x_5)) []]]
+[InstanceD [AppT (AppT EqualityT (VarT y_0)) (AppT (AppT ArrowT (VarT t_1)) (VarT t_1))] (AppT (ConT Ghci1.Member) (ConT GHC.Types.Bool)) []]
+[SigD f_2 (ForallT [PlainTV y_3,PlainTV t_4] [AppT (AppT EqualityT (VarT y_3)) (AppT (AppT ArrowT (VarT t_4)) (VarT t_4))] (AppT (AppT ArrowT (VarT y_3)) (VarT t_4))),FunD f_2 [Clause [VarP x_5] (NormalB (VarE x_5)) []]]
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 3e88970..e57b394 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -319,3 +319,5 @@ test('T8633', normal, compile_and_run, [''])
test('T8625', normal, ghci_script, ['T8625.script'])
test('T8759', normal, compile_fail, ['-v0'])
test('T8759a', normal, compile_fail, ['-v0'])
+test('T7021',
+ extra_clean(['T7021a.hi', 'T7021a.o']), multimod_compile, ['T7021','-v0'])
\ No newline at end of file
More information about the ghc-commits
mailing list