Commit 8e303d72 authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

Refactor previous commit on fixing #7021.

parent 182ff9e8
......@@ -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
......
......@@ -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
......
[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)) []]]
......@@ -318,4 +318,6 @@ test('T8577',
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'])
\ No newline at end of file
test('T8759a', normal, compile_fail, ['-v0'])
test('T7021',
extra_clean(['T7021a.hi', 'T7021a.o']), multimod_compile, ['T7021','-v0'])
\ No newline at end of file
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