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
e0dadc87
Commit
e0dadc87
authored
Jan 11, 2014
by
yoeight
Committed by
eir@cis.upenn.edu
Feb 09, 2014
Browse files
Apply changes relative to TH.Pred becoming a TH.Type's synonym (issue #7021)
Signed-off-by:
Richard Eisenberg
<
eir@cis.upenn.edu
>
parent
6122efca
Changes
3
Hide whitespace changes
Inline
Side-by-side
compiler/deSugar/DsMeta.hs
View file @
e0dadc87
...
...
@@ -277,7 +277,7 @@ repFamilyDecl (L loc (FamilyDecl { fdInfo = info,
fdKindSig
=
opt_kind
}))
=
do
{
tc1
<-
lookupLOcc
tc
-- See note [Binders and occurrences]
;
dec
<-
addTyClTyVarBinds
tvs
$
\
bndrs
->
case
(
opt_kind
,
info
)
of
case
(
opt_kind
,
info
)
of
(
Nothing
,
ClosedTypeFamily
eqns
)
->
do
{
eqns1
<-
mapM
repTyFamEqn
eqns
;
eqns2
<-
coreList
tySynEqnQTyConName
eqns1
...
...
@@ -286,13 +286,13 @@ repFamilyDecl (L loc (FamilyDecl { fdInfo = info,
do
{
eqns1
<-
mapM
repTyFamEqn
eqns
;
eqns2
<-
coreList
tySynEqnQTyConName
eqns1
;
ki1
<-
repLKind
ki
;
repClosedFamilyKind
tc1
bndrs
ki1
eqns2
}
;
repClosedFamilyKind
tc1
bndrs
ki1
eqns2
}
(
Nothing
,
_
)
->
do
{
info'
<-
repFamilyInfo
info
;
repFamilyNoKind
info'
tc1
bndrs
}
(
Just
ki
,
_
)
->
do
{
info'
<-
repFamilyInfo
info
;
ki1
<-
repLKind
ki
;
ki1
<-
repLKind
ki
;
repFamilyKind
info'
tc1
bndrs
ki1
}
;
return
(
loc
,
dec
)
}
...
...
@@ -389,7 +389,7 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
repTyFamInstD
::
TyFamInstDecl
Name
->
DsM
(
Core
TH
.
DecQ
)
repTyFamInstD
decl
@
(
TyFamInstDecl
{
tfid_eqn
=
eqn
})
=
do
{
let
tc_name
=
tyFamInstDeclLName
decl
;
tc
<-
lookupLOcc
tc_name
-- See note [Binders and occurrences]
;
tc
<-
lookupLOcc
tc_name
-- See note [Binders and occurrences]
;
eqn1
<-
repTyFamEqn
eqn
;
repTySynInst
tc
eqn1
}
...
...
@@ -763,19 +763,27 @@ repLPred :: LHsType Name -> DsM (Core TH.PredQ)
repLPred
(
L
_
p
)
=
repPred
p
repPred
::
HsType
Name
->
DsM
(
Core
TH
.
PredQ
)
repPred
(
HsParTy
ty
)
repPred
(
HsParTy
ty
)
=
repLPred
ty
repPred
ty
|
Just
(
cls
,
tys
)
<-
splitHsClassTy_maybe
ty
=
do
cls1
<-
lookupOcc
cls
tys1
<-
repList
typeQTyConName
repLTy
tys
repClassP
cls1
tys1
tyco
<-
repNamedTyCon
cls1
tys'
<-
mapM
repLTy
tys
repTapps
tyco
tys'
repPred
(
HsEqTy
tyleft
tyright
)
=
do
tyleft1
<-
repLTy
tyleft
tyright1
<-
repLTy
tyright
repEqualP
tyleft1
tyright1
repTequality
tyleft1
tyright1
repPred
(
HsTupleTy
_
lps
)
=
do
tupTy
<-
repTupleTyCon
size
foldM
go
tupTy
lps
where
size
=
length
lps
go
ty'
lp
=
repTapp
ty'
=<<
repLPred
lp
repPred
ty
=
notHandled
"Exotic predicate type"
(
ppr
ty
)
...
...
@@ -1772,12 +1780,6 @@ repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
repCtxt
::
Core
[
TH
.
PredQ
]
->
DsM
(
Core
TH
.
CxtQ
)
repCtxt
(
MkC
tys
)
=
rep2
cxtName
[
tys
]
repClassP
::
Core
TH
.
Name
->
Core
[
TH
.
TypeQ
]
->
DsM
(
Core
TH
.
PredQ
)
repClassP
(
MkC
cla
)
(
MkC
tys
)
=
rep2
classPName
[
cla
,
tys
]
repEqualP
::
Core
TH
.
TypeQ
->
Core
TH
.
TypeQ
->
DsM
(
Core
TH
.
PredQ
)
repEqualP
(
MkC
ty1
)
(
MkC
ty2
)
=
rep2
equalPName
[
ty1
,
ty2
]
repConstr
::
Core
TH
.
Name
->
HsConDeclDetails
Name
->
DsM
(
Core
TH
.
ConQ
)
repConstr
con
(
PrefixCon
ps
)
...
...
@@ -1816,6 +1818,9 @@ 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
]
repTPromotedList
::
[
Core
TH
.
TypeQ
]
->
DsM
(
Core
TH
.
TypeQ
)
repTPromotedList
[]
=
repPromotedNilTyCon
repTPromotedList
(
t
:
ts
)
=
do
{
tcon
<-
repPromotedConsTyCon
...
...
@@ -2069,8 +2074,6 @@ templateHaskellNames = [
roleAnnotDName
,
-- Cxt
cxtName
,
-- Pred
classPName
,
equalPName
,
-- Strict
isStrictName
,
notStrictName
,
unpackedName
,
-- Con
...
...
@@ -2080,7 +2083,7 @@ templateHaskellNames = [
-- VarStrictType
varStrictTypeName
,
-- Type
forallTName
,
varTName
,
conTName
,
appTName
,
forallTName
,
varTName
,
conTName
,
appTName
,
equalityTName
,
tupleTName
,
unboxedTupleTName
,
arrowTName
,
listTName
,
sigTName
,
litTName
,
promotedTName
,
promotedTupleTName
,
promotedNilTName
,
promotedConsTName
,
-- TyLit
...
...
@@ -2323,11 +2326,6 @@ roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey
cxtName
::
Name
cxtName
=
libFun
(
fsLit
"cxt"
)
cxtIdKey
-- data Pred = ...
classPName
,
equalPName
::
Name
classPName
=
libFun
(
fsLit
"classP"
)
classPIdKey
equalPName
=
libFun
(
fsLit
"equalP"
)
equalPIdKey
-- data Strict = ...
isStrictName
,
notStrictName
,
unpackedName
::
Name
isStrictName
=
libFun
(
fsLit
"isStrict"
)
isStrictKey
...
...
@@ -2351,7 +2349,7 @@ varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey
-- data Type = ...
forallTName
,
varTName
,
conTName
,
tupleTName
,
unboxedTupleTName
,
arrowTName
,
listTName
,
appTName
,
sigTName
,
litTName
,
listTName
,
appTName
,
sigTName
,
equalityTName
,
litTName
,
promotedTName
,
promotedTupleTName
,
promotedNilTName
,
promotedConsTName
::
Name
forallTName
=
libFun
(
fsLit
"forallT"
)
forallTIdKey
...
...
@@ -2363,6 +2361,7 @@ arrowTName = libFun (fsLit "arrowT") arrowTIdKey
listTName
=
libFun
(
fsLit
"listT"
)
listTIdKey
appTName
=
libFun
(
fsLit
"appT"
)
appTIdKey
sigTName
=
libFun
(
fsLit
"sigT"
)
sigTIdKey
equalityTName
=
libFun
(
fsLit
"equalityT"
)
equalityTIdKey
litTName
=
libFun
(
fsLit
"litT"
)
litTIdKey
promotedTName
=
libFun
(
fsLit
"promotedT"
)
promotedTIdKey
promotedTupleTName
=
libFun
(
fsLit
"promotedTupleT"
)
promotedTupleTIdKey
...
...
@@ -2681,11 +2680,6 @@ roleAnnotDIdKey = mkPreludeMiscIdUnique 352
cxtIdKey
::
Unique
cxtIdKey
=
mkPreludeMiscIdUnique
360
-- data Pred = ...
classPIdKey
,
equalPIdKey
::
Unique
classPIdKey
=
mkPreludeMiscIdUnique
361
equalPIdKey
=
mkPreludeMiscIdUnique
362
-- data Strict = ...
isStrictKey
,
notStrictKey
,
unpackedKey
::
Unique
isStrictKey
=
mkPreludeMiscIdUnique
363
...
...
@@ -2709,7 +2703,7 @@ varStrictTKey = mkPreludeMiscIdUnique 375
-- data Type = ...
forallTIdKey
,
varTIdKey
,
conTIdKey
,
tupleTIdKey
,
unboxedTupleTIdKey
,
arrowTIdKey
,
listTIdKey
,
appTIdKey
,
sigTIdKey
,
litTIdKey
,
listTIdKey
,
appTIdKey
,
sigTIdKey
,
equalityTIdKey
,
litTIdKey
,
promotedTIdKey
,
promotedTupleTIdKey
,
promotedNilTIdKey
,
promotedConsTIdKey
::
Unique
forallTIdKey
=
mkPreludeMiscIdUnique
380
...
...
@@ -2721,6 +2715,7 @@ arrowTIdKey = mkPreludeMiscIdUnique 385
listTIdKey
=
mkPreludeMiscIdUnique
386
appTIdKey
=
mkPreludeMiscIdUnique
387
sigTIdKey
=
mkPreludeMiscIdUnique
388
equalityTIdKey
=
mkPreludeMiscIdUnique
362
litTIdKey
=
mkPreludeMiscIdUnique
389
promotedTIdKey
=
mkPreludeMiscIdUnique
390
promotedTupleTIdKey
=
mkPreludeMiscIdUnique
391
...
...
compiler/hsSyn/Convert.lhs
View file @
e0dadc87
...
...
@@ -22,6 +22,7 @@ import SrcLoc
import Type
import qualified Coercion ( Role(..) )
import TysWiredIn
import TysPrim (eqPrimTyCon)
import BasicTypes as Hs
import ForeignCall
import Unique
...
...
@@ -894,16 +895,7 @@ cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
cvtPred :: TH.Pred -> CvtM (LHsType RdrName)
cvtPred (TH.ClassP cla tys)
= do { cla' <- if isVarName cla then tName cla else tconName cla
; tys' <- mapM cvtType tys
; mk_apps (HsTyVar cla') tys'
}
cvtPred (TH.EqualP ty1 ty2)
= do { ty1' <- cvtType ty1
; ty2' <- cvtType ty2
; returnL $ HsEqTy ty1' ty2'
}
cvtPred = cvtType
cvtType :: TH.Type -> CvtM (LHsType RdrName)
cvtType = cvtTypeKind "type"
...
...
@@ -983,6 +975,10 @@ cvtTypeKind ty_str ty
ConstraintT
-> returnL (HsTyVar (getRdrName constraintKindTyCon))
EqualityT
| [x',y'] <- tys' -> returnL (HsEqTy x' y')
| otherwise -> mk_apps (HsTyVar (getRdrName eqPrimTyCon)) tys'
_ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
}
...
...
compiler/typecheck/TcSplice.lhs
View file @
e0dadc87
...
...
@@ -343,7 +343,7 @@ tcTypedBracket brack@(TExpBr expr) res_ty
-- Throw away the typechecked expression but return its type.
-- We'll typecheck it again when we splice it in somewhere
; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $
tcInferRhoNC expr
tcInferRhoNC expr
-- NC for no context; tcBracket does that
; meta_ty <- tcTExpTy expr_ty
...
...
@@ -1016,7 +1016,7 @@ reifyInstances th_nm th_tys
; let matches = lookupFamInstEnv inst_envs tc tys
; traceTc "reifyInstances2" (ppr matches)
; mapM (reifyFamilyInstance . fim_instance) matches }
_ -> bale_out (hang (ptext (sLit "reifyInstances:") <+> quotes (ppr ty))
_ -> bale_out (hang (ptext (sLit "reifyInstances:") <+> quotes (ppr ty))
2 (ptext (sLit "is not a class constraint or type family application"))) }
where
doc = ClassInstanceCtx
...
...
@@ -1309,7 +1309,7 @@ reifyClassInstance i
------------------------------
reifyFamilyInstance :: FamInst -> TcM TH.Dec
reifyFamilyInstance (FamInst { fi_flavor = flavor
reifyFamilyInstance (FamInst { fi_flavor = flavor
, fi_fam = fam
, fi_tys = lhs
, fi_rhs = rhs })
...
...
@@ -1399,7 +1399,7 @@ reifyFamFlavour tc
| Just ax <- isClosedSynFamilyTyCon_maybe tc
= do { eqns <- brListMapM reifyAxBranch $ coAxiomBranches ax
; return $ Right eqns }
| otherwise
= panic "TcSplice.reifyFamFlavour: not a type family"
...
...
@@ -1443,14 +1443,35 @@ reifyPred ty
| isIPPred ty = noTH (sLit "implicit parameters") (ppr ty)
| otherwise
= case classifyPredType ty of
ClassPred cls tys -> do { tys' <- reifyTypes tys
; return $ TH.ClassP (reifyName cls) tys' }
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.Equal
P
ty1' ty2'
; return $
TH.AppT (TH.AppT
TH.Equal
ityT
ty1'
)
ty2'
}
TuplePred _ -> noTH (sLit "tuple predicates") (ppr ty)
IrredPred _ -> noTH (sLit "irreducible predicates") (ppr ty)
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)
------------------------------
...
...
@@ -1565,4 +1586,4 @@ will appear in TH syntax like this
\begin{code}
#endif /* GHCI */
\end{code}
\ No newline at end of file
\end{code}
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