Skip to content
GitLab
Commit e0dadc87 authored by yoeight's avatar yoeight Committed by eir@cis.upenn.edu
Browse files

Apply changes relative to TH.Pred becoming a TH.Type's synonym (issue #7021) 



Signed-off-by: eir@cis.upenn.edu's avatarRichard Eisenberg <eir@cis.upenn.edu>
parent 6122efca
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.EqualP ty1' ty2'
; return $ TH.AppT (TH.AppT TH.EqualityT 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}
Supports Markdown
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