Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Alex D
GHC
Commits
8e303d72
Commit
8e303d72
authored
Feb 09, 2014
by
eir@cis.upenn.edu
Browse files
Refactor previous commit on fixing #7021.
parent
182ff9e8
Changes
4
Hide whitespace changes
Inline
Side-by-side
compiler/deSugar/DsMeta.hs
View file @
8e303d72
...
...
@@ -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
3
62
litTIdKey
=
mkPreludeMiscIdUnique
3
8
9
promotedTIdKey
=
mkPreludeMiscIdUnique
39
0
promotedTupleTIdKey
=
mkPreludeMiscIdUnique
39
1
promotedNilTIdKey
=
mkPreludeMiscIdUnique
39
2
promotedConsTIdKey
=
mkPreludeMiscIdUnique
39
3
equalityTIdKey
=
mkPreludeMiscIdUnique
3
89
litTIdKey
=
mkPreludeMiscIdUnique
39
0
promotedTIdKey
=
mkPreludeMiscIdUnique
39
1
promotedTupleTIdKey
=
mkPreludeMiscIdUnique
39
2
promotedNilTIdKey
=
mkPreludeMiscIdUnique
39
3
promotedConsTIdKey
=
mkPreludeMiscIdUnique
39
4
-- data TyLit = ...
numTyLitIdKey
,
strTyLitIdKey
::
Unique
numTyLitIdKey
=
mkPreludeMiscIdUnique
39
4
strTyLitIdKey
=
mkPreludeMiscIdUnique
39
5
numTyLitIdKey
=
mkPreludeMiscIdUnique
39
5
strTyLitIdKey
=
mkPreludeMiscIdUnique
39
6
-- data TyVarBndr = ...
plainTVIdKey
,
kindedTVIdKey
::
Unique
plainTVIdKey
=
mkPreludeMiscIdUnique
39
6
kindedTVIdKey
=
mkPreludeMiscIdUnique
39
7
plainTVIdKey
=
mkPreludeMiscIdUnique
39
7
kindedTVIdKey
=
mkPreludeMiscIdUnique
39
8
-- data Role = ...
nominalRIdKey
,
representationalRIdKey
,
phantomRIdKey
,
inferRIdKey
::
Unique
...
...
compiler/typecheck/TcSplice.lhs
View file @
8e303d72
...
...
@@ -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
...
...
testsuite/tests/th/T8625.stdout
View file @
8e303d72
[InstanceD [Equal
P
(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] [Equal
P
(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
Equal
ityT
(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
Equal
ityT
(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)) []]]
testsuite/tests/th/all.T
View file @
8e303d72
...
...
@@ -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
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment