summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2018-03-28 23:35:43 +0200
committerAlan Zimmerman <alan.zimm@gmail.com>2018-04-07 15:01:20 +0200
commit5819ae2173d4b16f1fde067d39c3c215a6adfe97 (patch)
treecfa6fe74b75dcf43126ab2b22ce9c860a5a3fb47
parent718a018128a0ba2ae20001c10bc8ca4d929a1d33 (diff)
downloadhaskell-5819ae2173d4b16f1fde067d39c3c215a6adfe97.tar.gz
Remove HasSourceText and SourceTextX classes
Updates haddock submodule to match. Test Plan : Validate Differential Revision: https://phabricator.haskell.org/D4199
Diffstat
-rw-r--r--compiler/deSugar/Coverage.hs4
-rw-r--r--compiler/deSugar/DsMeta.hs6
-rw-r--r--compiler/hsSyn/HsBinds.hs38
-rw-r--r--compiler/hsSyn/HsDecls.hs127
-rw-r--r--compiler/hsSyn/HsExpr.hs195
-rw-r--r--compiler/hsSyn/HsExpr.hs-boot28
-rw-r--r--compiler/hsSyn/HsExtension.hs97
-rw-r--r--compiler/hsSyn/HsLit.hs35
-rw-r--r--compiler/hsSyn/HsPat.hs22
-rw-r--r--compiler/hsSyn/HsPat.hs-boot5
-rw-r--r--compiler/hsSyn/HsSyn.hs4
-rw-r--r--compiler/hsSyn/HsTypes.hs73
-rw-r--r--compiler/hsSyn/HsUtils.hs63
-rw-r--r--compiler/parser/Parser.y29
-rw-r--r--compiler/rename/RnExpr.hs2
-rw-r--r--compiler/typecheck/Inst.hs6
-rw-r--r--compiler/typecheck/TcAnnotations.hs2
-rw-r--r--compiler/typecheck/TcBinds.hs4
-rw-r--r--compiler/typecheck/TcEnv.hs6
-rw-r--r--compiler/typecheck/TcInstDcls.hs2
-rw-r--r--compiler/typecheck/TcMatches.hs10
-rw-r--r--compiler/typecheck/TcTypeable.hs8
m---------utils/haddock0
23 files changed, 343 insertions, 423 deletions
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index 1c118a84b6..b3534206ff 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -754,8 +754,8 @@ addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
| otherwise = addTickLHsExprRHS e
addTickApplicativeArg
- :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc)
- -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc)
+ :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
+ -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
addTickApplicativeArg isGuard (op, arg) =
liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
where
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index bcc6464918..c8f70e03e7 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -2390,16 +2390,16 @@ repLiteral lit
mk_integer :: Integer -> DsM (HsLit GhcRn)
mk_integer i = do integer_ty <- lookupType integerTyConName
- return $ HsInteger noSourceText i integer_ty
+ return $ HsInteger NoSourceText i integer_ty
mk_rational :: FractionalLit -> DsM (HsLit GhcRn)
mk_rational r = do rat_ty <- lookupType rationalTyConName
return $ HsRat def r rat_ty
mk_string :: FastString -> DsM (HsLit GhcRn)
-mk_string s = return $ HsString noSourceText s
+mk_string s = return $ HsString NoSourceText s
mk_char :: Char -> DsM (HsLit GhcRn)
-mk_char c = return $ HsChar noSourceText c
+mk_char c = return $ HsChar NoSourceText c
repOverloadedLiteral :: HsOverLit GhcRn -> DsM (Core TH.Lit)
repOverloadedLiteral (OverLit { ol_val = val})
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index 40617e33ef..0724420e83 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -14,6 +14,7 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
module HsBinds where
@@ -560,14 +561,14 @@ Specifically,
it's just an error thunk
-}
-instance (SourceTextX idL, SourceTextX idR,
+instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (HsLocalBindsLR idL idR) where
ppr (HsValBinds bs) = ppr bs
ppr (HsIPBinds bs) = ppr bs
ppr EmptyLocalBinds = empty
-instance (SourceTextX idL, SourceTextX idR,
+instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (HsValBindsLR idL idR) where
ppr (ValBindsIn binds sigs)
@@ -584,17 +585,16 @@ instance (SourceTextX idL, SourceTextX idR,
pp_rec Recursive = text "rec"
pp_rec NonRecursive = text "nonrec"
-pprLHsBinds :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR)
- => LHsBindsLR idL idR -> SDoc
+pprLHsBinds :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
+ => LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
pprLHsBinds binds
| isEmptyLHsBinds binds = empty
| otherwise = pprDeclList (map ppr (bagToList binds))
-pprLHsBindsForUser :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR,
- SourceTextX id2, OutputableBndrId id2)
- => LHsBindsLR idL idR -> [LSig id2] -> [SDoc]
+pprLHsBindsForUser :: (OutputableBndrId (GhcPass idL),
+ OutputableBndrId (GhcPass idR),
+ OutputableBndrId (GhcPass id2))
+ => LHsBindsLR (GhcPass idL) (GhcPass idR) -> [LSig (GhcPass id2)] -> [SDoc]
-- pprLHsBindsForUser is different to pprLHsBinds because
-- a) No braces: 'let' and 'where' include a list of HsBindGroups
-- and we don't want several groups of bindings each
@@ -658,14 +658,13 @@ plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
plusHsValBinds _ _
= panic "HsBinds.plusHsValBinds"
-instance (SourceTextX idL, SourceTextX idR,
+instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (HsBindLR idL idR) where
ppr mbind = ppr_monobind mbind
-ppr_monobind :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR)
- => HsBindLR idL idR -> SDoc
+ppr_monobind :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
+ => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc
ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
= pprPatBind pat grhss
@@ -705,8 +704,7 @@ instance (OutputableBndrId p) => Outputable (ABExport p) where
, nest 2 (pprTcSpecPrags prags)
, nest 2 (text "wrap:" <+> ppr wrap)]
-instance (SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR)
+instance (idR ~ GhcPass pr,OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (PatSynBind idL idR) where
ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat,
psb_dir = dir })
@@ -777,11 +775,12 @@ data IPBind id
= IPBind (Either (Located HsIPName) (IdP id)) (LHsExpr id)
deriving instance (DataId name) => Data (IPBind name)
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsIPBinds p) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (HsIPBinds p) where
ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
$$ whenPprDebug (ppr ds)
-instance (SourceTextX p, OutputableBndrId p ) => Outputable (IPBind p) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (IPBind p) where
ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
where name = case lr of
Left (L _ ip) -> pprBndr LetBind ip
@@ -1054,11 +1053,10 @@ signatures. Since some of the signatures contain a list of names, testing for
equality is not enough -- we have to check if they overlap.
-}
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (Sig pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Sig p) where
ppr sig = ppr_sig sig
-ppr_sig :: (SourceTextX pass, OutputableBndrId pass ) => Sig pass -> SDoc
+ppr_sig :: (OutputableBndrId (GhcPass p)) => Sig (GhcPass p) -> SDoc
ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (ClassOpSig is_deflt vars ty)
| is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty)
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 6f1d5be849..f29e7e2b0a 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -10,7 +10,7 @@
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
-- | Abstract syntax of global declarations.
--
@@ -253,8 +253,7 @@ appendGroups
hs_vects = vects1 ++ vects2,
hs_docs = docs1 ++ docs2 }
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsDecl p) where
ppr (TyClD dcl) = ppr dcl
ppr (ValD binds) = ppr binds
ppr (DefD def) = ppr def
@@ -270,8 +269,7 @@ instance (SourceTextX pass, OutputableBndrId pass)
ppr (DocD doc) = ppr doc
ppr (RoleAnnotD ra) = ppr ra
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsGroup pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsGroup p) where
ppr (HsGroup { hs_valds = val_decls,
hs_tyclds = tycl_decls,
hs_derivds = deriv_decls,
@@ -315,8 +313,8 @@ data SpliceDecl id
SpliceExplicitFlag
deriving instance (DataId id) => Data (SpliceDecl id)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (SpliceDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (SpliceDecl p) where
ppr (SpliceDecl (L _ e) f) = pprSpliceDecl e f
{-
@@ -640,8 +638,7 @@ hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
-- Pretty-printing TyClDecl
-- ~~~~~~~~~~~~~~~~~~~~~~~~
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (TyClDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyClDecl p) where
ppr (FamDecl { tcdFam = decl }) = ppr decl
ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity
@@ -672,8 +669,8 @@ instance (SourceTextX pass, OutputableBndrId pass)
<+> pp_vanilla_decl_head lclas tyvars fixity (unLoc context)
<+> pprFundeps (map unLoc fds)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (TyClGroup pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (TyClGroup p) where
ppr (TyClGroup { group_tyclds = tyclds
, group_roles = roles
, group_instds = instds
@@ -683,11 +680,11 @@ instance (SourceTextX pass, OutputableBndrId pass)
ppr roles $$
ppr instds
-pp_vanilla_decl_head :: (SourceTextX pass, OutputableBndrId pass)
- => Located (IdP pass)
- -> LHsQTyVars pass
+pp_vanilla_decl_head :: (OutputableBndrId (GhcPass p))
+ => Located (IdP (GhcPass p))
+ -> LHsQTyVars (GhcPass p)
-> LexicalFixity
- -> HsContext pass
+ -> HsContext (GhcPass p)
-> SDoc
pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context
= hsep [pprHsContext context, pp_tyvars tyvars]
@@ -971,12 +968,12 @@ resultVariableName :: FamilyResultSig a -> Maybe (IdP a)
resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig
resultVariableName _ = Nothing
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (FamilyDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (FamilyDecl p) where
ppr = pprFamilyDecl TopLevel
-pprFamilyDecl :: (SourceTextX pass, OutputableBndrId pass)
- => TopLevelFlag -> FamilyDecl pass -> SDoc
+pprFamilyDecl :: (OutputableBndrId (GhcPass p))
+ => TopLevelFlag -> FamilyDecl (GhcPass p) -> SDoc
pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
, fdTyVars = tyvars
, fdFixity = fixity
@@ -1093,8 +1090,8 @@ data HsDerivingClause pass
}
deriving instance (DataId id) => Data (HsDerivingClause id)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsDerivingClause pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (HsDerivingClause p) where
ppr (HsDerivingClause { deriv_clause_strategy = dcs
, deriv_clause_tys = L _ dct })
= hsep [ text "deriving"
@@ -1244,9 +1241,9 @@ hsConDeclTheta :: Maybe (LHsContext pass) -> [LHsType pass]
hsConDeclTheta Nothing = []
hsConDeclTheta (Just (L _ theta)) = theta
-pp_data_defn :: (SourceTextX p, OutputableBndrId p)
- => (HsContext p -> SDoc) -- Printing the header
- -> HsDataDefn p
+pp_data_defn :: (OutputableBndrId (GhcPass p))
+ => (HsContext (GhcPass p) -> SDoc) -- Printing the header
+ -> HsDataDefn (GhcPass p)
-> SDoc
pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
, dd_cType = mb_ct
@@ -1268,26 +1265,24 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
Just kind -> dcolon <+> ppr kind
pp_derivings (L _ ds) = vcat (map ppr ds)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsDataDefn pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (HsDataDefn p) where
ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d
instance Outputable NewOrData where
ppr NewType = text "newtype"
ppr DataType = text "data"
-pp_condecls :: (SourceTextX pass, OutputableBndrId pass)
- => [LConDecl pass] -> SDoc
+pp_condecls :: (OutputableBndrId (GhcPass p)) => [LConDecl (GhcPass p)] -> SDoc
pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax
= hang (text "where") 2 (vcat (map ppr cs))
pp_condecls cs -- In H98 syntax
= equals <+> sep (punctuate (text " |") (map ppr cs))
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (ConDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ConDecl p) where
ppr = pprConDecl
-pprConDecl :: (SourceTextX pass, OutputableBndrId pass) => ConDecl pass -> SDoc
+pprConDecl :: (OutputableBndrId (GhcPass p)) => ConDecl (GhcPass p) -> SDoc
pprConDecl (ConDeclH98 { con_name = L _ con
, con_ex_tvs = ex_tvs
, con_mb_cxt = mcxt
@@ -1516,12 +1511,12 @@ data InstDecl pass -- Both class and family instances
{ tfid_inst :: TyFamInstDecl pass }
deriving instance (DataId id) => Data (InstDecl id)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (TyFamInstDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (TyFamInstDecl p) where
ppr = pprTyFamInstDecl TopLevel
-pprTyFamInstDecl :: (SourceTextX pass, OutputableBndrId pass)
- => TopLevelFlag -> TyFamInstDecl pass -> SDoc
+pprTyFamInstDecl :: (OutputableBndrId (GhcPass p))
+ => TopLevelFlag -> TyFamInstDecl (GhcPass p) -> SDoc
pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn })
= text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn
@@ -1529,16 +1524,16 @@ ppr_instance_keyword :: TopLevelFlag -> SDoc
ppr_instance_keyword TopLevel = text "instance"
ppr_instance_keyword NotTopLevel = empty
-ppr_fam_inst_eqn :: (SourceTextX pass, OutputableBndrId pass)
- => TyFamInstEqn pass -> SDoc
+ppr_fam_inst_eqn :: (OutputableBndrId (GhcPass p))
+ => TyFamInstEqn (GhcPass p) -> SDoc
ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = tycon
, feqn_pats = pats
, feqn_fixity = fixity
, feqn_rhs = rhs }})
= pprFamInstLHS tycon pats fixity [] Nothing <+> equals <+> ppr rhs
-ppr_fam_deflt_eqn :: (SourceTextX pass, OutputableBndrId pass)
- => LTyFamDefltEqn pass -> SDoc
+ppr_fam_deflt_eqn :: (OutputableBndrId (GhcPass p))
+ => LTyFamDefltEqn (GhcPass p) -> SDoc
ppr_fam_deflt_eqn (L _ (FamEqn { feqn_tycon = tycon
, feqn_pats = tvs
, feqn_fixity = fixity
@@ -1546,12 +1541,12 @@ ppr_fam_deflt_eqn (L _ (FamEqn { feqn_tycon = tycon
= text "type" <+> pp_vanilla_decl_head tycon tvs fixity []
<+> equals <+> ppr rhs
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (DataFamInstDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (DataFamInstDecl p) where
ppr = pprDataFamInstDecl TopLevel
-pprDataFamInstDecl :: (SourceTextX pass, OutputableBndrId pass)
- => TopLevelFlag -> DataFamInstDecl pass -> SDoc
+pprDataFamInstDecl :: (OutputableBndrId (GhcPass p))
+ => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc
pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_tycon = tycon
, feqn_pats = pats
@@ -1570,12 +1565,12 @@ pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }}}})
= ppr nd
-pprFamInstLHS :: (SourceTextX pass, OutputableBndrId pass)
- => Located (IdP pass)
- -> HsTyPats pass
+pprFamInstLHS :: (OutputableBndrId (GhcPass p))
+ => Located (IdP (GhcPass p))
+ -> HsTyPats (GhcPass p)
-> LexicalFixity
- -> HsContext pass
- -> Maybe (LHsKind pass)
+ -> HsContext (GhcPass p)
+ -> Maybe (LHsKind (GhcPass p))
-> SDoc
pprFamInstLHS thing typats fixity context mb_kind_sig
-- explicit type patterns
@@ -1595,8 +1590,8 @@ pprFamInstLHS thing typats fixity context mb_kind_sig
| otherwise
= empty
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (ClsInstDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (ClsInstDecl p) where
ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds
, cid_sigs = sigs, cid_tyfam_insts = ats
, cid_overlap_mode = mbOverlap
@@ -1634,8 +1629,7 @@ ppOverlapPragma mb =
maybe_stext (SourceText src) _ = text src <+> text "#-}"
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (InstDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (InstDecl p) where
ppr (ClsInstD { cid_inst = decl }) = ppr decl
ppr (TyFamInstD { tfid_inst = decl }) = ppr decl
ppr (DataFamInstD { dfid_inst = decl }) = ppr decl
@@ -1687,8 +1681,8 @@ data DerivDecl pass = DerivDecl
}
deriving instance (DataId pass) => Data (DerivDecl pass)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (DerivDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (DerivDecl p) where
ppr (DerivDecl { deriv_type = ty
, deriv_strategy = ds
, deriv_overlap_mode = o })
@@ -1722,9 +1716,8 @@ data DefaultDecl pass
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataId pass) => Data (DefaultDecl pass)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (DefaultDecl pass) where
-
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (DefaultDecl p) where
ppr (DefaultDecl tys)
= text "default" <+> parens (interpp'SP tys)
@@ -1826,8 +1819,8 @@ data ForeignExport = CExport (Located CExportSpec) -- contains the calling
-- pretty printing of foreign declarations
--
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (ForeignDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (ForeignDecl p) where
ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport })
= hang (text "foreign import" <+> ppr fimport <+> ppr n)
2 (dcolon <+> ppr ty)
@@ -1933,14 +1926,13 @@ collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
pprFullRuleName :: Located (SourceText, RuleName) -> SDoc
pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (RuleDecls pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (RuleDecls p) where
ppr (HsRules st rules)
= pprWithSourceText st (text "{-# RULES")
<+> vcat (punctuate semi (map ppr rules)) <+> text "#-}"
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (RuleDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleDecl p) where
ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs)
= sep [pprFullRuleName name <+> ppr act,
nest 4 (pp_forall <+> pprExpr (unLoc lhs)),
@@ -1949,8 +1941,7 @@ instance (SourceTextX pass, OutputableBndrId pass)
pp_forall | null ns = empty
| otherwise = forAllLit <+> fsep (map ppr ns) <> dot
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (RuleBndr pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleBndr p) where
ppr (RuleBndr name) = ppr name
ppr (RuleBndrSig name ty) = parens (ppr name <> dcolon <> ppr ty)
@@ -2037,8 +2028,7 @@ lvectInstDecl (L _ (HsVectInstIn _)) = True
lvectInstDecl (L _ (HsVectInstOut _)) = True
lvectInstDecl _ = False
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (VectDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (VectDecl p) where
ppr (HsVect _ v rhs)
= sep [text "{-# VECTORISE" <+> ppr v,
nest 4 $
@@ -2159,8 +2149,7 @@ data AnnDecl pass = HsAnnotation
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataId pass) => Data (AnnDecl pass)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (AnnDecl pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (AnnDecl p) where
ppr (HsAnnotation _ provenance expr)
= hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index 5e43645854..51d47b9fc8 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -11,6 +11,7 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE TypeFamilies #-}
-- | Abstract Haskell syntax for expressions.
module HsExpr where
@@ -82,7 +83,7 @@ type PostTcExpr = HsExpr GhcTc
type PostTcTable = [(Name, PostTcExpr)]
noPostTcExpr :: PostTcExpr
-noPostTcExpr = HsLit (HsString noSourceText (fsLit "noPostTcExpr"))
+noPostTcExpr = HsLit (HsString NoSourceText (fsLit "noPostTcExpr"))
noPostTcTable :: PostTcTable
noPostTcTable = []
@@ -113,13 +114,13 @@ deriving instance (DataId p) => Data (SyntaxExpr p)
-- | This is used for rebindable-syntax pieces that are too polymorphic
-- for tcSyntaxOp (trS_fmap and the mzip in ParStmt)
-noExpr :: SourceTextX p => HsExpr p
-noExpr = HsLit (HsString (sourceText "noExpr") (fsLit "noExpr"))
+noExpr :: HsExpr (GhcPass p)
+noExpr = HsLit (HsString (SourceText "noExpr") (fsLit "noExpr"))
-noSyntaxExpr :: SourceTextX p => SyntaxExpr p
+noSyntaxExpr :: SyntaxExpr (GhcPass p)
-- Before renaming, and sometimes after,
-- (if the syntax slot makes no sense)
-noSyntaxExpr = SyntaxExpr { syn_expr = HsLit (HsString noSourceText
+noSyntaxExpr = SyntaxExpr { syn_expr = HsLit (HsString NoSourceText
(fsLit "noSyntaxExpr"))
, syn_arg_wraps = []
, syn_res_wrap = WpHole }
@@ -133,7 +134,8 @@ mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar $ noLoc name
-- don't care about filling in syn_arg_wraps because we're clearly
-- not past the typechecker
-instance (SourceTextX p, OutputableBndrId p) => Outputable (SyntaxExpr p) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (SyntaxExpr p) where
ppr (SyntaxExpr { syn_expr = expr
, syn_arg_wraps = arg_wraps
, syn_res_wrap = res_wrap })
@@ -799,16 +801,16 @@ RenamedSource that the API Annotations cannot be used directly with
RenamedSource, so this allows a simple mapping to be used based on the location.
-}
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsExpr p) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsExpr p) where
ppr expr = pprExpr expr
-----------------------
-- pprExpr, pprLExpr, pprBinds call pprDeeper;
-- the underscore versions do not
-pprLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
+pprLExpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc
pprLExpr (L _ e) = pprExpr e
-pprExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc
+pprExpr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> SDoc
pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e
| otherwise = pprDeeper (ppr_expr e)
@@ -824,16 +826,16 @@ isQuietHsExpr (HsAppTypeOut _ _) = True
isQuietHsExpr (OpApp _ _ _ _) = True
isQuietHsExpr _ = False
-pprBinds :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR)
- => HsLocalBindsLR idL idR -> SDoc
+pprBinds :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
+ => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
pprBinds b = pprDeeper (ppr b)
-----------------------
-ppr_lexpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
+ppr_lexpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc
ppr_lexpr e = ppr_expr (unLoc e)
-ppr_expr :: forall p. (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc
+ppr_expr :: forall p. (OutputableBndrId (GhcPass p))
+ => HsExpr (GhcPass p) -> SDoc
ppr_expr (HsVar (L _ v)) = pprPrefixOcc v
ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv)
ppr_expr (HsConLikeOut c) = pprPrefixOcc c
@@ -891,6 +893,8 @@ ppr_expr (SectionL expr op)
pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
4 (hsep [pp_expr, text "x_ )"])
+
+ pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc
pp_infixly v = (sep [pp_expr, pprInfixOcc v])
ppr_expr (SectionR op expr)
@@ -905,6 +909,8 @@ ppr_expr (SectionR op expr)
pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"])
4 (pp_expr <> rparen)
+
+ pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc
pp_infixly v = sep [pprInfixOcc v, pp_expr]
ppr_expr (ExplicitTuple exprs boxity)
@@ -1055,11 +1061,12 @@ ppr_expr (HsRecFld f) = ppr f
-- We must tiresomely make the "id" parameter to the LHsWcType existential
-- because it's different in the HsAppType case and the HsAppTypeOut case
-- | Located Haskell Wildcard Type Expression
-data LHsWcTypeX = forall p. (SourceTextX p, OutputableBndrId p)
- => LHsWcTypeX (LHsWcType p)
+data LHsWcTypeX = forall p. (OutputableBndrId (GhcPass p))
+ => LHsWcTypeX (LHsWcType (GhcPass p))
-ppr_apps :: (SourceTextX p, OutputableBndrId p) => HsExpr p
- -> [Either (LHsExpr p) LHsWcTypeX]
+ppr_apps :: (OutputableBndrId (GhcPass p))
+ => HsExpr (GhcPass p)
+ -> [Either (LHsExpr (GhcPass p)) LHsWcTypeX]
-> SDoc
ppr_apps (HsApp (L _ fun) arg) args
= ppr_apps fun (Left arg : args)
@@ -1089,16 +1096,17 @@ fixities should do the job, except in debug mode (-dppr-debug) so we
can see the structure of the parse tree.
-}
-pprDebugParendExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
+pprDebugParendExpr :: (OutputableBndrId (GhcPass p))
+ => LHsExpr (GhcPass p) -> SDoc
pprDebugParendExpr expr
= getPprStyle (\sty ->
if debugStyle sty then pprParendLExpr expr
else pprLExpr expr)
-pprParendLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
+pprParendLExpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc
pprParendLExpr (L _ e) = pprParendExpr e
-pprParendExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc
+pprParendExpr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> SDoc
pprParendExpr expr
| hsExprNeedsParens expr = parens (pprExpr expr)
| otherwise = pprExpr expr
@@ -1269,16 +1277,16 @@ data HsCmdTop p
(CmdSyntaxTable p) -- See Note [CmdSyntaxTable]
deriving instance (DataId p) => Data (HsCmdTop p)
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmd p) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p) where
ppr cmd = pprCmd cmd
-----------------------
-- pprCmd and pprLCmd call pprDeeper;
-- the underscore versions do not
-pprLCmd :: (SourceTextX p, OutputableBndrId p) => LHsCmd p -> SDoc
+pprLCmd :: (OutputableBndrId (GhcPass p)) => LHsCmd (GhcPass p) -> SDoc
pprLCmd (L _ c) = pprCmd c
-pprCmd :: (SourceTextX p, OutputableBndrId p) => HsCmd p -> SDoc
+pprCmd :: (OutputableBndrId (GhcPass p)) => HsCmd (GhcPass p) -> SDoc
pprCmd c | isQuietHsCmd c = ppr_cmd c
| otherwise = pprDeeper (ppr_cmd c)
@@ -1292,10 +1300,10 @@ isQuietHsCmd (HsCmdApp _ _) = True
isQuietHsCmd _ = False
-----------------------
-ppr_lcmd :: (SourceTextX p, OutputableBndrId p) => LHsCmd p -> SDoc
+ppr_lcmd :: (OutputableBndrId (GhcPass p)) => LHsCmd (GhcPass p) -> SDoc
ppr_lcmd c = ppr_cmd (unLoc c)
-ppr_cmd :: forall p. (SourceTextX p, OutputableBndrId p) => HsCmd p -> SDoc
+ppr_cmd :: forall p. (OutputableBndrId (GhcPass p)) => HsCmd (GhcPass p) -> SDoc
ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c)
ppr_cmd (HsCmdApp c e)
@@ -1356,11 +1364,11 @@ ppr_cmd (HsCmdArrForm op _ _ args)
= hang (text "(|" <> ppr_lexpr op)
4 (sep (map (pprCmdArg.unLoc) args) <> text "|)")
-pprCmdArg :: (SourceTextX p, OutputableBndrId p) => HsCmdTop p -> SDoc
+pprCmdArg :: (OutputableBndrId (GhcPass p)) => HsCmdTop (GhcPass p) -> SDoc
pprCmdArg (HsCmdTop cmd _ _ _)
= ppr_lcmd cmd
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmdTop p) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmdTop p) where
ppr = pprCmdArg
{-
@@ -1421,7 +1429,7 @@ data Match p body
}
deriving instance (Data body,DataId p) => Data (Match p body)
-instance (SourceTextX idR, OutputableBndrId idR, Outputable body)
+instance (idR ~ GhcPass pr, OutputableBndrId idR, Outputable body)
=> Outputable (Match idR body) where
ppr = pprMatch
@@ -1516,28 +1524,28 @@ deriving instance (Data body,DataId id) => Data (GRHS id body)
-- We know the list must have at least one @Match@ in it.
-pprMatches :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => MatchGroup idR body -> SDoc
+pprMatches :: (OutputableBndrId (GhcPass idR), Outputable body)
+ => MatchGroup (GhcPass idR) body -> SDoc
pprMatches MG { mg_alts = matches }
= vcat (map pprMatch (map unLoc (unLoc matches)))
-- Don't print the type; it's only a place-holder before typechecking
-- Exported to HsBinds, which can't see the defn of HsMatchContext
-pprFunBind :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => MatchGroup idR body -> SDoc
+pprFunBind :: (OutputableBndrId (GhcPass idR), Outputable body)
+ => MatchGroup (GhcPass idR) body -> SDoc
pprFunBind matches = pprMatches matches
-- Exported to HsBinds, which can't see the defn of HsMatchContext
-pprPatBind :: forall bndr p body. (SourceTextX p, SourceTextX bndr,
- OutputableBndrId bndr,
- OutputableBndrId p,
+pprPatBind :: forall bndr p body. (OutputableBndrId (GhcPass bndr),
+ OutputableBndrId (GhcPass p),
Outputable body)
- => LPat bndr -> GRHSs p body -> SDoc
+ => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc
pprPatBind pat (grhss)
- = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (IdP p)) grhss)]
+ = sep [ppr pat,
+ nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (IdP (GhcPass p))) grhss)]
-pprMatch :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => Match idR body -> SDoc
+pprMatch :: (OutputableBndrId (GhcPass idR), Outputable body)
+ => Match (GhcPass idR) body -> SDoc
pprMatch match
= sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats)
, nest 2 (pprGRHSs ctxt (m_grhss match)) ]
@@ -1572,8 +1580,8 @@ pprMatch match
(pat1:pats1) = m_pats match
(pat2:pats2) = pats1
-pprGRHSs :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => HsMatchContext idL -> GRHSs idR body -> SDoc
+pprGRHSs :: (OutputableBndrId (GhcPass idR), Outputable body)
+ => HsMatchContext idL -> GRHSs (GhcPass idR) body -> SDoc
pprGRHSs ctxt (GRHSs grhss (L _ binds))
= vcat (map (pprGRHS ctxt . unLoc) grhss)
-- Print the "where" even if the contents of the binds is empty. Only
@@ -1581,8 +1589,8 @@ pprGRHSs ctxt (GRHSs grhss (L _ binds))
$$ ppUnless (eqEmptyLocalBinds binds)
(text "where" $$ nest 4 (pprBinds binds))
-pprGRHS :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => HsMatchContext idL -> GRHS idR body -> SDoc
+pprGRHS :: (OutputableBndrId (GhcPass idR), Outputable body)
+ => HsMatchContext idL -> GRHS (GhcPass idR) body -> SDoc
pprGRHS ctxt (GRHS [] body)
= pp_rhs ctxt body
@@ -1676,7 +1684,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
--
| ApplicativeStmt
[ ( SyntaxExpr idR
- , ApplicativeArg idL idR) ]
+ , ApplicativeArg idL) ]
-- [(<$>, e1), (<*>, e2), ..., (<*>, en)]
(Maybe (SyntaxExpr idR)) -- 'join', if necessary
(PostTc idR Type) -- Type of the body
@@ -1782,7 +1790,7 @@ data ParStmtBlock idL idR
deriving instance (DataId idL, DataId idR) => Data (ParStmtBlock idL idR)
-- | Applicative Argument
-data ApplicativeArg idL idR
+data ApplicativeArg idL
= ApplicativeArgOne -- A single statement (BindStmt or BodyStmt)
(LPat idL) -- WildPat if it was a BodyStmt (see below)
(LHsExpr idL)
@@ -1795,7 +1803,7 @@ data ApplicativeArg idL idR
(HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn)
(LPat idL) -- (v1,...,vn)
-deriving instance (DataId idL, DataId idR) => Data (ApplicativeArg idL idR)
+deriving instance (DataId idL) => Data (ApplicativeArg idL)
{-
Note [The type of bind in Stmts]
@@ -1962,19 +1970,20 @@ Bool flag that is True when the original statement was a BodyStmt, so
that we can pretty-print it correctly.
-}
-instance (SourceTextX idL, OutputableBndrId idL)
- => Outputable (ParStmtBlock idL idR) where
+instance (Outputable (StmtLR idL idL (LHsExpr idL)))
+ => Outputable (ParStmtBlock idL idR) where
ppr (ParStmtBlock stmts _ _) = interpp'SP stmts
-instance (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR, Outputable body)
+instance (idL ~ GhcPass pl,idR ~ GhcPass pr,
+ OutputableBndrId idL, OutputableBndrId idR,
+ Outputable body)
=> Outputable (StmtLR idL idR body) where
ppr stmt = pprStmt stmt
-pprStmt :: forall idL idR body . (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR,
+pprStmt :: forall idL idR body . (OutputableBndrId (GhcPass idL),
+ OutputableBndrId (GhcPass idR),
Outputable body)
- => (StmtLR idL idR body) -> SDoc
+ => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc
pprStmt (LastStmt expr ret_stripped _)
= whenPprDebug (text "[last]") <+>
(if ret_stripped then text "return" else empty) <+>
@@ -2009,17 +2018,18 @@ pprStmt (ApplicativeStmt args mb_join _)
-- ppr directly rather than transforming here, because we need to
-- inject a "return" which is hard when we're polymorphic in the id
-- type.
- flattenStmt :: ExprLStmt idL -> [SDoc]
+ flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc]
flattenStmt (L _ (ApplicativeStmt args _ _)) = concatMap flattenArg args
flattenStmt stmt = [ppr stmt]
+ flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc]
flattenArg (_, ApplicativeArgOne pat expr isBody)
| isBody = -- See Note [Applicative BodyStmt]
[ppr (BodyStmt expr noSyntaxExpr noSyntaxExpr (panic "pprStmt")
- :: ExprStmt idL)]
+ :: ExprStmt (GhcPass idL))]
| otherwise =
[ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt")
- :: ExprStmt idL)]
+ :: ExprStmt (GhcPass idL))]
flattenArg (_, ApplicativeArgMany stmts _ _) =
concatMap flattenStmt stmts
@@ -2034,10 +2044,10 @@ pprStmt (ApplicativeStmt args mb_join _)
pp_arg (_, ApplicativeArgOne pat expr isBody)
| isBody = -- See Note [Applicative BodyStmt]
ppr (BodyStmt expr noSyntaxExpr noSyntaxExpr (panic "pprStmt")
- :: ExprStmt idL)
+ :: ExprStmt (GhcPass idL))
| otherwise =
ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt")
- :: ExprStmt idL)
+ :: ExprStmt (GhcPass idL))
pp_arg (_, ApplicativeArgMany stmts return pat) =
ppr pat <+>
text "<-" <+>
@@ -2045,8 +2055,9 @@ pprStmt (ApplicativeStmt args mb_join _)
(stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)]))
(error "pprStmt"))
-pprTransformStmt :: (SourceTextX p, OutputableBndrId p)
- => [IdP p] -> LHsExpr p -> Maybe (LHsExpr p) -> SDoc
+pprTransformStmt :: (OutputableBndrId (GhcPass p))
+ => [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
+ -> Maybe (LHsExpr (GhcPass p)) -> SDoc
pprTransformStmt bndrs using by
= sep [ text "then" <+> whenPprDebug (braces (ppr bndrs))
, nest 2 (ppr using)
@@ -2062,8 +2073,8 @@ pprBy :: Outputable body => Maybe body -> SDoc
pprBy Nothing = empty
pprBy (Just e) = text "by" <+> ppr e
-pprDo :: (SourceTextX p, OutputableBndrId p, Outputable body)
- => HsStmtContext any -> [LStmt p body] -> SDoc
+pprDo :: (OutputableBndrId (GhcPass p), Outputable body)
+ => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc
pprDo DoExpr stmts = text "do" <+> ppr_do_stmts stmts
pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts
pprDo ArrowExpr stmts = text "do" <+> ppr_do_stmts stmts
@@ -2073,14 +2084,14 @@ pprDo PArrComp stmts = paBrackets $ pprComp stmts
pprDo MonadComp stmts = brackets $ pprComp stmts
pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt
-ppr_do_stmts :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR, Outputable body)
- => [LStmtLR idL idR body] -> SDoc
+ppr_do_stmts :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR),
+ Outputable body)
+ => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc
-- Print a bunch of do stmts
ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts)
-pprComp :: (SourceTextX p, OutputableBndrId p, Outputable body)
- => [LStmt p body] -> SDoc
+pprComp :: (OutputableBndrId (GhcPass p), Outputable body)
+ => [LStmt (GhcPass p) body] -> SDoc
pprComp quals -- Prints: body | qual1, ..., qualn
| Just (initStmts, L _ (LastStmt body _ _)) <- snocView quals
= if null initStmts
@@ -2094,8 +2105,8 @@ pprComp quals -- Prints: body | qual1, ..., qualn
| otherwise
= pprPanic "pprComp" (pprQuals quals)
-pprQuals :: (SourceTextX p, OutputableBndrId p, Outputable body)
- => [LStmt p body] -> SDoc
+pprQuals :: (OutputableBndrId (GhcPass p), Outputable body)
+ => [LStmt (GhcPass p) body] -> SDoc
-- Show list comprehension qualifiers separated by commas
pprQuals quals = interpp'SP quals
@@ -2262,30 +2273,31 @@ splices. In contrast, when pretty printing the output of the type checker, we
sense, although I hate to add another constructor to HsExpr.
-}
-instance (SourceTextX p, OutputableBndrId p)
+instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsSplicedThing p) where
ppr (HsSplicedExpr e) = ppr_expr e
ppr (HsSplicedTy t) = ppr t
ppr (HsSplicedPat p) = ppr p
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsSplice p) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsSplice p) where
ppr s = pprSplice s
-pprPendingSplice :: (SourceTextX p, OutputableBndrId p)
- => SplicePointName -> LHsExpr p -> SDoc
+pprPendingSplice :: (OutputableBndrId (GhcPass p))
+ => SplicePointName -> LHsExpr (GhcPass p) -> SDoc
pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e)
-pprSpliceDecl :: (SourceTextX p, OutputableBndrId p)
- => HsSplice p -> SpliceExplicitFlag -> SDoc
+pprSpliceDecl :: (OutputableBndrId (GhcPass p))
+ => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc
pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e
pprSpliceDecl e ExplicitSplice = text "$(" <> ppr_splice_decl e <> text ")"
pprSpliceDecl e ImplicitSplice = ppr_splice_decl e
-ppr_splice_decl :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc
+ppr_splice_decl :: (OutputableBndrId (GhcPass p))
+ => HsSplice (GhcPass p) -> SDoc
ppr_splice_decl (HsUntypedSplice _ n e) = ppr_splice empty n e empty
ppr_splice_decl e = pprSplice e
-pprSplice :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc
+pprSplice :: (OutputableBndrId (GhcPass p)) => HsSplice (GhcPass p) -> SDoc
pprSplice (HsTypedSplice HasParens n e)
= ppr_splice (text "$$(") n e (text ")")
pprSplice (HsTypedSplice HasDollar n e)
@@ -2306,8 +2318,8 @@ ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <>
char '[' <> ppr quoter <> vbar <>
ppr quote <> text "|]"
-ppr_splice :: (SourceTextX p, OutputableBndrId p)
- => SDoc -> (IdP p) -> LHsExpr p -> SDoc -> SDoc
+ppr_splice :: (OutputableBndrId (GhcPass p))
+ => SDoc -> (IdP (GhcPass p)) -> LHsExpr (GhcPass p) -> SDoc -> SDoc
ppr_splice herald n e trail
= herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail
@@ -2326,11 +2338,12 @@ isTypedBracket :: HsBracket id -> Bool
isTypedBracket (TExpBr {}) = True
isTypedBracket _ = False
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsBracket p) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (HsBracket p) where
ppr = pprHsBracket
-pprHsBracket :: (SourceTextX p, OutputableBndrId p) => HsBracket p -> SDoc
+pprHsBracket :: (OutputableBndrId (GhcPass p)) => HsBracket (GhcPass p) -> SDoc
pprHsBracket (ExpBr e) = thBrackets empty (ppr e)
pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p)
pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp)
@@ -2375,7 +2388,7 @@ data ArithSeqInfo id
(LHsExpr id)
deriving instance (DataId id) => Data (ArithSeqInfo id)
-instance (SourceTextX p, OutputableBndrId p)
+instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (ArithSeqInfo p) where
ppr (From e1) = hcat [ppr e1, pp_dotdot]
ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot]
@@ -2595,19 +2608,21 @@ matchContextErrString (StmtCtxt ListComp) = text "list comprehension"
matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension"
matchContextErrString (StmtCtxt PArrComp) = text "array comprehension"
-pprMatchInCtxt :: (SourceTextX idR, OutputableBndrId idR,
+pprMatchInCtxt :: (OutputableBndrId (GhcPass idR),
-- TODO:AZ these constraints do not make sense
- Outputable (NameOrRdrName (NameOrRdrName (IdP idR))),
- Outputable body)
- => Match idR body -> SDoc
+ Outputable (NameOrRdrName (NameOrRdrName (IdP (GhcPass idR)))),
+ Outputable body)
+ => Match (GhcPass idR) body -> SDoc
pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match)
<> colon)
4 (pprMatch match)
-pprStmtInCtxt :: (SourceTextX idL, SourceTextX idR,
- OutputableBndrId idL, OutputableBndrId idR,
+pprStmtInCtxt :: (OutputableBndrId (GhcPass idL),
+ OutputableBndrId (GhcPass idR),
Outputable body)
- => HsStmtContext (IdP idL) -> StmtLR idL idR body -> SDoc
+ => HsStmtContext (IdP (GhcPass idL))
+ -> StmtLR (GhcPass idL) (GhcPass idR) body
+ -> SDoc
pprStmtInCtxt ctxt (LastStmt e _ _)
| isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts"
= hang (text "In the expression:") 2 (ppr e)
diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot
index bac8a5a183..0229039935 100644
--- a/compiler/hsSyn/HsExpr.hs-boot
+++ b/compiler/hsSyn/HsExpr.hs-boot
@@ -5,6 +5,7 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE TypeFamilies #-}
module HsExpr where
@@ -12,7 +13,7 @@ import SrcLoc ( Located )
import Outputable ( SDoc, Outputable )
import {-# SOURCE #-} HsPat ( LPat )
import BasicTypes ( SpliceExplicitFlag(..))
-import HsExtension ( OutputableBndrId, DataId, SourceTextX )
+import HsExtension ( OutputableBndrId, DataId, GhcPass )
import Data.Data hiding ( Fixity )
type role HsExpr nominal
@@ -35,25 +36,24 @@ instance (Data body,DataId p) => Data (MatchGroup p body)
instance (Data body,DataId p) => Data (GRHSs p body)
instance (DataId p) => Data (SyntaxExpr p)
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsExpr p)
-instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmd p)
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsExpr p)
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p)
type LHsExpr a = Located (HsExpr a)
-pprLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc
+pprLExpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc
-pprExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc
+pprExpr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> SDoc
-pprSplice :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc
+pprSplice :: (OutputableBndrId (GhcPass p)) => HsSplice (GhcPass p) -> SDoc
-pprSpliceDecl :: (SourceTextX p, OutputableBndrId p)
- => HsSplice p -> SpliceExplicitFlag -> SDoc
+pprSpliceDecl :: (OutputableBndrId (GhcPass p))
+ => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc
-pprPatBind :: forall bndr p body. (SourceTextX p, SourceTextX bndr,
- OutputableBndrId bndr,
- OutputableBndrId p,
+pprPatBind :: forall bndr p body. (OutputableBndrId (GhcPass bndr),
+ OutputableBndrId (GhcPass p),
Outputable body)
- => LPat bndr -> GRHSs p body -> SDoc
+ => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc
-pprFunBind :: (SourceTextX idR, OutputableBndrId idR, Outputable body)
- => MatchGroup idR body -> SDoc
+pprFunBind :: (OutputableBndrId (GhcPass idR), Outputable body)
+ => MatchGroup (GhcPass idR) body -> SDoc
diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs
index 80dfa67ea3..8efd005c8f 100644
--- a/compiler/hsSyn/HsExtension.hs
+++ b/compiler/hsSyn/HsExtension.hs
@@ -124,91 +124,20 @@ type ForallX (c :: * -> Constraint) (x :: *) =
)
--- Provide the specific extension types for the parser phase.
-type instance XHsChar GhcPs = SourceText
-type instance XHsCharPrim GhcPs = SourceText
-type instance XHsString GhcPs = SourceText
-type instance XHsStringPrim GhcPs = SourceText
-type instance XHsInt GhcPs = ()
-type instance XHsIntPrim GhcPs = SourceText
-type instance XHsWordPrim GhcPs = SourceText
-type instance XHsInt64Prim GhcPs = SourceText
-type instance XHsWord64Prim GhcPs = SourceText
-type instance XHsInteger GhcPs = SourceText
-type instance XHsRat GhcPs = ()
-type instance XHsFloatPrim GhcPs = ()
-type instance XHsDoublePrim GhcPs = ()
-
--- Provide the specific extension types for the renamer phase.
-type instance XHsChar GhcRn = SourceText
-type instance XHsCharPrim GhcRn = SourceText
-type instance XHsString GhcRn = SourceText
-type instance XHsStringPrim GhcRn = SourceText
-type instance XHsInt GhcRn = ()
-type instance XHsIntPrim GhcRn = SourceText
-type instance XHsWordPrim GhcRn = SourceText
-type instance XHsInt64Prim GhcRn = SourceText
-type instance XHsWord64Prim GhcRn = SourceText
-type instance XHsInteger GhcRn = SourceText
-type instance XHsRat GhcRn = ()
-type instance XHsFloatPrim GhcRn = ()
-type instance XHsDoublePrim GhcRn = ()
-
--- Provide the specific extension types for the typechecker phase.
-type instance XHsChar GhcTc = SourceText
-type instance XHsCharPrim GhcTc = SourceText
-type instance XHsString GhcTc = SourceText
-type instance XHsStringPrim GhcTc = SourceText
-type instance XHsInt GhcTc = ()
-type instance XHsIntPrim GhcTc = SourceText
-type instance XHsWordPrim GhcTc = SourceText
-type instance XHsInt64Prim GhcTc = SourceText
-type instance XHsWord64Prim GhcTc = SourceText
-type instance XHsInteger GhcTc = SourceText
-type instance XHsRat GhcTc = ()
-type instance XHsFloatPrim GhcTc = ()
-type instance XHsDoublePrim GhcTc = ()
-
-
--- ---------------------------------------------------------------------
-
--- | The 'SourceText' fields have been moved into the extension fields, thus
--- placing a requirement in the extension field to contain a 'SourceText' so
--- that the pretty printing and round tripping of source can continue to
--- operate.
---
--- The 'HasSourceText' class captures this requirement for the relevant fields.
-class HasSourceText a where
- -- Provide setters to mimic existing constructors
- noSourceText :: a
- sourceText :: String -> a
-
- setSourceText :: SourceText -> a
- getSourceText :: a -> SourceText
-
--- | Provide a summary constraint that lists all the extension points requiring
--- the 'HasSourceText' class, so that it can be changed in one place as the
--- named extensions change throughout the AST.
-type SourceTextX x =
- ( HasSourceText (XHsChar x)
- , HasSourceText (XHsCharPrim x)
- , HasSourceText (XHsString x)
- , HasSourceText (XHsStringPrim x)
- , HasSourceText (XHsIntPrim x)
- , HasSourceText (XHsWordPrim x)
- , HasSourceText (XHsInt64Prim x)
- , HasSourceText (XHsWord64Prim x)
- , HasSourceText (XHsInteger x)
- )
-
-
--- | 'SourceText' trivially implements 'HasSourceText'
-instance HasSourceText SourceText where
- noSourceText = NoSourceText
- sourceText s = SourceText s
+type instance XHsChar (GhcPass _) = SourceText
+type instance XHsCharPrim (GhcPass _) = SourceText
+type instance XHsString (GhcPass _) = SourceText
+type instance XHsStringPrim (GhcPass _) = SourceText
+type instance XHsInt (GhcPass _) = ()
+type instance XHsIntPrim (GhcPass _) = SourceText
+type instance XHsWordPrim (GhcPass _) = SourceText
+type instance XHsInt64Prim (GhcPass _) = SourceText
+type instance XHsWord64Prim (GhcPass _) = SourceText
+type instance XHsInteger (GhcPass _) = SourceText
+type instance XHsRat (GhcPass _) = ()
+type instance XHsFloatPrim (GhcPass _) = ()
+type instance XHsDoublePrim (GhcPass _) = ()
- setSourceText s = s
- getSourceText a = a
-- ----------------------------------------------------------------------
diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs
index d46ef9b448..271a415914 100644
--- a/compiler/hsSyn/HsLit.hs
+++ b/compiler/hsSyn/HsLit.hs
@@ -8,7 +8,6 @@
{-# LANGUAGE CPP, DeriveDataTypeable #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module PlaceHolder
@@ -195,35 +194,28 @@ instance Ord OverLitVal where
compare (HsIsString _ _) (HsFractional _) = GT
-- Instance specific to GhcPs, need the SourceText
-instance (SourceTextX x) => Outputable (HsLit x) where
- ppr (HsChar st c) = pprWithSourceText (getSourceText st) (pprHsChar c)
- ppr (HsCharPrim st c)
- = pp_st_suffix (getSourceText st) primCharSuffix (pprPrimChar c)
- ppr (HsString st s)
- = pprWithSourceText (getSourceText st) (pprHsString s)
- ppr (HsStringPrim st s)
- = pprWithSourceText (getSourceText st) (pprHsBytes s)
+instance p ~ GhcPass pass => Outputable (HsLit p) where
+ ppr (HsChar st c) = pprWithSourceText st (pprHsChar c)
+ ppr (HsCharPrim st c) = pp_st_suffix st primCharSuffix (pprPrimChar c)
+ ppr (HsString st s) = pprWithSourceText st (pprHsString s)
+ ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s)
ppr (HsInt _ i)
= pprWithSourceText (il_text i) (integer (il_value i))
- ppr (HsInteger st i _) = pprWithSourceText (getSourceText st) (integer i)
+ ppr (HsInteger st i _) = pprWithSourceText st (integer i)
ppr (HsRat _ f _) = ppr f
ppr (HsFloatPrim _ f) = ppr f <> primFloatSuffix
ppr (HsDoublePrim _ d) = ppr d <> primDoubleSuffix
- ppr (HsIntPrim st i)
- = pprWithSourceText (getSourceText st) (pprPrimInt i)
- ppr (HsWordPrim st w)
- = pprWithSourceText (getSourceText st) (pprPrimWord w)
- ppr (HsInt64Prim st i)
- = pp_st_suffix (getSourceText st) primInt64Suffix (pprPrimInt64 i)
- ppr (HsWord64Prim st w)
- = pp_st_suffix (getSourceText st) primWord64Suffix (pprPrimWord64 w)
+ ppr (HsIntPrim st i) = pprWithSourceText st (pprPrimInt i)
+ ppr (HsWordPrim st w) = pprWithSourceText st (pprPrimWord w)
+ ppr (HsInt64Prim st i) = pp_st_suffix st primInt64Suffix (pprPrimInt64 i)
+ ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w)
pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc
pp_st_suffix NoSourceText _ doc = doc
pp_st_suffix (SourceText st) suffix _ = text st <> suffix
-- in debug mode, print the expression that it's resolved to, too
-instance (SourceTextX p, OutputableBndrId p)
+instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsOverLit p) where
ppr (OverLit {ol_val=val, ol_witness=witness})
= ppr val <+> (whenPprDebug (parens (pprExpr witness)))
@@ -239,11 +231,10 @@ instance Outputable OverLitVal where
-- mainly for too reasons:
-- * We do not want to expose their internal representation
-- * The warnings become too messy
-pmPprHsLit :: (SourceTextX x) => HsLit x -> SDoc
+pmPprHsLit :: HsLit (GhcPass x) -> SDoc
pmPprHsLit (HsChar _ c) = pprHsChar c
pmPprHsLit (HsCharPrim _ c) = pprHsChar c
-pmPprHsLit (HsString st s) = pprWithSourceText (getSourceText st)
- (pprHsString s)
+pmPprHsLit (HsString st s) = pprWithSourceText st (pprHsString s)
pmPprHsLit (HsStringPrim _ s) = pprHsBytes s
pmPprHsLit (HsInt _ i) = integer (il_value i)
pmPprHsLit (HsIntPrim _ i) = integer i
diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index e25ff7bbcc..cfd923c0aa 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -414,8 +414,7 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl
************************************************************************
-}
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (Pat pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p) where
ppr = pprPat
pprPatBndr :: OutputableBndr name => name -> SDoc
@@ -427,10 +426,10 @@ pprPatBndr var -- Print with type info if -dppr-debug is on
else
pprPrefixOcc var
-pprParendLPat :: (SourceTextX pass, OutputableBndrId pass) => LPat pass -> SDoc
+pprParendLPat :: (OutputableBndrId (GhcPass p)) => LPat (GhcPass p) -> SDoc
pprParendLPat (L _ p) = pprParendPat p
-pprParendPat :: (SourceTextX pass, OutputableBndrId pass) => Pat pass -> SDoc
+pprParendPat :: (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc
pprParendPat p = sdocWithDynFlags $ \ dflags ->
if need_parens dflags p
then parens (pprPat p)
@@ -444,7 +443,7 @@ pprParendPat p = sdocWithDynFlags $ \ dflags ->
-- But otherwise the CoPat is discarded, so it
-- is the pattern inside that matters. Sigh.
-pprPat :: (SourceTextX pass, OutputableBndrId pass) => Pat pass -> SDoc
+pprPat :: (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc
pprPat (VarPat (L _ var)) = pprPatBndr var
pprPat (WildPat _) = char '_'
pprPat (LazyPat pat) = char '~' <> pprParendLPat pat
@@ -481,12 +480,13 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
else pprUserCon (unLoc con) details
-pprUserCon :: (SourceTextX p, OutputableBndr con, OutputableBndrId p)
- => con -> HsConPatDetails p -> SDoc
+pprUserCon :: (OutputableBndr con, OutputableBndrId (GhcPass p))
+ => con -> HsConPatDetails (GhcPass p) -> SDoc
pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
pprUserCon c details = pprPrefixOcc c <+> pprConArgs details
-pprConArgs :: (SourceTextX p, OutputableBndrId p) => HsConPatDetails p -> SDoc
+pprConArgs :: (OutputableBndrId (GhcPass p))
+ => HsConPatDetails (GhcPass p) -> SDoc
pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
pprConArgs (RecCon rpats) = ppr rpats
@@ -525,9 +525,9 @@ mkPrefixConPat dc pats tys
mkNilPat :: Type -> OutPat p
mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
-mkCharLitPat :: (SourceTextX p) => SourceText -> Char -> OutPat p
+mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p)
mkCharLitPat src c = mkPrefixConPat charDataCon
- [noLoc $ LitPat (HsCharPrim (setSourceText src) c)] []
+ [noLoc $ LitPat (HsCharPrim src c)] []
{-
************************************************************************
@@ -587,7 +587,7 @@ looksLazyLPat (L _ (VarPat {})) = False
looksLazyLPat (L _ (WildPat {})) = False
looksLazyLPat _ = True
-isIrrefutableHsPat :: (SourceTextX p, OutputableBndrId p) => LPat p -> Bool
+isIrrefutableHsPat :: (OutputableBndrId p) => LPat p -> Bool
-- (isIrrefutableHsPat p) is true if matching against p cannot fail,
-- in the sense of falling through to the next pattern.
-- (NB: this is not quite the same as the (silly) defn
diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot
index 8cb82ed22e..55c63fe7a4 100644
--- a/compiler/hsSyn/HsPat.hs-boot
+++ b/compiler/hsSyn/HsPat.hs-boot
@@ -4,17 +4,18 @@
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE TypeFamilies #-}
module HsPat where
import SrcLoc( Located )
import Data.Data hiding (Fixity)
import Outputable
-import HsExtension ( SourceTextX, DataId, OutputableBndrId )
+import HsExtension ( DataId, OutputableBndrId, GhcPass )
type role Pat nominal
data Pat (i :: *)
type LPat i = Located (Pat i)
instance (DataId p) => Data (Pat p)
-instance (SourceTextX pass, OutputableBndrId pass) => Outputable (Pat pass)
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p)
diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs
index 62bfa2e5c5..7631c95a7d 100644
--- a/compiler/hsSyn/HsSyn.hs
+++ b/compiler/hsSyn/HsSyn.hs
@@ -15,6 +15,7 @@ therefore, is almost nothing but re-exporting.
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TypeFamilies #-}
module HsSyn (
module HsBinds,
@@ -112,8 +113,7 @@ data HsModule name
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataId name) => Data (HsModule name)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsModule pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsModule p) where
ppr (HsModule Nothing _ imports decls _ mbDoc)
= pp_mb mbDoc $$ pp_nonnull imports
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index 15c570f0ea..a2c863e0d5 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -8,13 +8,13 @@ HsTypes: Abstract syntax: user-defined types
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
module HsTypes (
HsType(..), LHsType, HsKind, LHsKind,
@@ -620,8 +620,8 @@ data HsAppType pass
| HsAppPrefix (LHsType pass) -- anything else, including things like (+)
deriving instance (DataId pass) => Data (HsAppType pass)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsAppType pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (HsAppType p) where
ppr = ppr_app_ty
{-
@@ -765,8 +765,8 @@ data ConDeclField pass -- Record fields have Haddoc docs on them
-- For details on above see note [Api annotations] in ApiAnnotation
deriving instance (DataId pass) => Data (ConDeclField pass)
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (ConDeclField pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (ConDeclField p) where
ppr (ConDeclField fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty
-- HsConDetails is used for patterns/expressions *and* for data type
@@ -1148,19 +1148,18 @@ ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel
************************************************************************
-}
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsType pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsType p) where
ppr ty = pprHsType ty
instance Outputable HsTyLit where
ppr = ppr_tylit
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (LHsQTyVars pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (LHsQTyVars p) where
ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs
-instance (SourceTextX pass, OutputableBndrId pass)
- => Outputable (HsTyVarBndr pass) where
+instance (p ~ GhcPass pass, OutputableBndrId p)
+ => Outputable (HsTyVarBndr p) where
ppr (UserTyVar n) = ppr n
ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k]
@@ -1173,8 +1172,8 @@ instance (Outputable thing) => Outputable (HsWildCardBndrs pass thing) where
instance Outputable (HsWildCardInfo pass) where
ppr (AnonWildCard _) = char '_'
-pprHsForAll :: (SourceTextX pass, OutputableBndrId pass)
- => [LHsTyVarBndr pass] -> LHsContext pass -> SDoc
+pprHsForAll :: (OutputableBndrId (GhcPass p))
+ => [LHsTyVarBndr (GhcPass p)] -> LHsContext (GhcPass p) -> SDoc
pprHsForAll = pprHsForAllExtra Nothing
-- | Version of 'pprHsForAll' that can also print an extra-constraints
@@ -1184,44 +1183,43 @@ pprHsForAll = pprHsForAllExtra Nothing
-- function for this is needed, as the extra-constraints wildcard is removed
-- from the actual context and type, and stored in a separate field, thus just
-- printing the type will not print the extra-constraints wildcard.
-pprHsForAllExtra :: (SourceTextX pass, OutputableBndrId pass)
- => Maybe SrcSpan -> [LHsTyVarBndr pass] -> LHsContext pass
- -> SDoc
+pprHsForAllExtra :: (OutputableBndrId (GhcPass p))
+ => Maybe SrcSpan -> [LHsTyVarBndr (GhcPass p)]
+ -> LHsContext (GhcPass p) -> SDoc
pprHsForAllExtra extra qtvs cxt
= pprHsForAllTvs qtvs <+> pprHsContextExtra show_extra (unLoc cxt)
where
show_extra = isJust extra
-pprHsForAllTvs :: (SourceTextX pass, OutputableBndrId pass)
- => [LHsTyVarBndr pass] -> SDoc
+pprHsForAllTvs :: (OutputableBndrId (GhcPass p))
+ => [LHsTyVarBndr (GhcPass p)] -> SDoc
pprHsForAllTvs qtvs
| null qtvs = whenPprDebug (forAllLit <+> dot)
| otherwise = forAllLit <+> interppSP qtvs <> dot
-pprHsContext :: (SourceTextX pass, OutputableBndrId pass)
- => HsContext pass -> SDoc
+pprHsContext :: (OutputableBndrId (GhcPass p)) => HsContext (GhcPass p) -> SDoc
pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe
-pprHsContextNoArrow :: (SourceTextX pass, OutputableBndrId pass)
- => HsContext pass -> SDoc
+pprHsContextNoArrow :: (OutputableBndrId (GhcPass p))
+ => HsContext (GhcPass p) -> SDoc
pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe
-pprHsContextMaybe :: (SourceTextX pass, OutputableBndrId pass)
- => HsContext pass -> Maybe SDoc
+pprHsContextMaybe :: (OutputableBndrId (GhcPass p))
+ => HsContext (GhcPass p) -> Maybe SDoc
pprHsContextMaybe [] = Nothing
pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty pred
pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt)
-- For use in a HsQualTy, which always gets printed if it exists.
-pprHsContextAlways :: (SourceTextX pass, OutputableBndrId pass)
- => HsContext pass -> SDoc
+pprHsContextAlways :: (OutputableBndrId (GhcPass p))
+ => HsContext (GhcPass p) -> SDoc
pprHsContextAlways [] = parens empty <+> darrow
pprHsContextAlways [L _ ty] = ppr_mono_ty ty <+> darrow
pprHsContextAlways cxt = parens (interpp'SP cxt) <+> darrow
-- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@
-pprHsContextExtra :: (SourceTextX pass, OutputableBndrId pass)
- => Bool -> HsContext pass -> SDoc
+pprHsContextExtra :: (OutputableBndrId (GhcPass p))
+ => Bool -> HsContext (GhcPass p) -> SDoc
pprHsContextExtra show_extra ctxt
| not show_extra
= pprHsContext ctxt
@@ -1232,8 +1230,8 @@ pprHsContextExtra show_extra ctxt
where
ctxt' = map ppr ctxt ++ [char '_']
-pprConDeclFields :: (SourceTextX pass, OutputableBndrId pass)
- => [LConDeclField pass] -> SDoc
+pprConDeclFields :: (OutputableBndrId (GhcPass p))
+ => [LConDeclField (GhcPass p)] -> SDoc
pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
where
ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,
@@ -1257,15 +1255,13 @@ seems like the Right Thing anyway.)
-- Printing works more-or-less as for Types
-pprHsType :: (SourceTextX pass, OutputableBndrId pass) => HsType pass -> SDoc
+pprHsType :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc
pprHsType ty = ppr_mono_ty ty
-ppr_mono_lty :: (SourceTextX pass, OutputableBndrId pass)
- => LHsType pass -> SDoc
+ppr_mono_lty :: (OutputableBndrId (GhcPass p)) => LHsType (GhcPass p) -> SDoc
ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
-ppr_mono_ty :: (SourceTextX pass, OutputableBndrId pass)
- => HsType pass -> SDoc
+ppr_mono_ty :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc
ppr_mono_ty (HsForAllTy { hst_bndrs = tvs, hst_body = ty })
= sep [pprHsForAllTvs tvs, ppr_mono_lty ty]
@@ -1325,8 +1321,8 @@ ppr_mono_ty (HsDocTy ty doc)
-- postfix operators
--------------------------
-ppr_fun_ty :: (SourceTextX pass, OutputableBndrId pass)
- => LHsType pass -> LHsType pass -> SDoc
+ppr_fun_ty :: (OutputableBndrId (GhcPass p))
+ => LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc
ppr_fun_ty ty1 ty2
= let p1 = ppr_mono_lty ty1
p2 = ppr_mono_lty ty2
@@ -1334,8 +1330,7 @@ ppr_fun_ty ty1 ty2
sep [p1, text "->" <+> p2]
--------------------------
-ppr_app_ty :: (SourceTextX pass, OutputableBndrId pass)
- => HsAppType pass -> SDoc
+ppr_app_ty :: (OutputableBndrId (GhcPass p)) => HsAppType (GhcPass p) -> SDoc
ppr_app_ty (HsAppInfix (L _ n)) = pprInfixOcc n
ppr_app_ty (HsAppPrefix (L _ (HsTyVar NotPromoted (L _ n))))
= pprPrefixOcc n
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index 55fa0e4a0a..6a6b3bbd70 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -240,17 +240,17 @@ mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs)
-> Pat GhcPs
mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs
-mkLastStmt :: SourceTextX idR
- => Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
+mkLastStmt :: Located (bodyR (GhcPass idR))
+ -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
mkBodyStmt :: Located (bodyR GhcPs)
-> StmtLR idL GhcPs (Located (bodyR GhcPs))
-mkBindStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
- => LPat idL -> Located (bodyR idR)
- -> StmtLR idL idR (Located (bodyR idR))
+mkBindStmt :: (PostTc (GhcPass idR) Type ~ PlaceHolder)
+ => LPat (GhcPass idL) -> Located (bodyR (GhcPass idR))
+ -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc)
-> StmtLR GhcTc GhcTc (Located (bodyR GhcTc))
-emptyRecStmt :: StmtLR idL GhcPs bodyR
+emptyRecStmt :: StmtLR (GhcPass idL) GhcPs bodyR
emptyRecStmtName :: StmtLR GhcRn GhcRn bodyR
emptyRecStmtId :: StmtLR GhcTc GhcTc bodyR
mkRecStmt :: [LStmtLR idL GhcPs bodyR] -> StmtLR idL GhcPs bodyR
@@ -268,27 +268,30 @@ mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
where
last_stmt = L (getLoc expr) $ mkLastStmt expr
-mkHsIf :: SourceTextX p => LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
+mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
+ -> HsExpr (GhcPass p)
mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
mkNPat lit neg = NPat lit neg noSyntaxExpr placeHolderType
mkNPlusKPat id lit = NPlusKPat id lit (unLoc lit) noSyntaxExpr noSyntaxExpr placeHolderType
-mkTransformStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
- => [ExprLStmt idL] -> LHsExpr idR
- -> StmtLR idL idR (LHsExpr idL)
-mkTransformByStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
- => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
- -> StmtLR idL idR (LHsExpr idL)
-mkGroupUsingStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
- => [ExprLStmt idL] -> LHsExpr idR
- -> StmtLR idL idR (LHsExpr idL)
-mkGroupByUsingStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
- => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
- -> StmtLR idL idR (LHsExpr idL)
-
-emptyTransStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder)
- => StmtLR idL idR (LHsExpr idR)
+mkTransformStmt :: (PostTc (GhcPass idR) Type ~ PlaceHolder)
+ => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR)
+ -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL))
+mkTransformByStmt :: (PostTc (GhcPass idR) Type ~ PlaceHolder)
+ => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR)
+ -> LHsExpr (GhcPass idR)
+ -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL))
+mkGroupUsingStmt :: (PostTc (GhcPass idR) Type ~ PlaceHolder)
+ => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR)
+ -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL))
+mkGroupByUsingStmt :: (PostTc (GhcPass idR) Type ~ PlaceHolder)
+ => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR)
+ -> LHsExpr (GhcPass idR)
+ -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL))
+
+emptyTransStmt :: (PostTc (GhcPass idR) Type ~ PlaceHolder)
+ => StmtLR idL (GhcPass idR) (LHsExpr (GhcPass idR))
emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form"
, trS_stmts = [], trS_bndrs = []
, trS_by = Nothing, trS_using = noLoc noExpr
@@ -306,8 +309,8 @@ mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr PlaceHolder
mkTcBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr unitTy
-- don't use placeHolderTypeTc above, because that panics during zonking
-emptyRecStmt' :: forall idL idR body. SourceTextX idR =>
- PostTc idR Type -> StmtLR idL idR body
+emptyRecStmt' :: forall idL idR body.
+ PostTc (GhcPass idR) Type -> StmtLR (GhcPass idL) (GhcPass idR) body
emptyRecStmt' tyVal =
RecStmt
{ recS_stmts = [], recS_later_ids = []
@@ -354,12 +357,12 @@ unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
-- A name (uniquified later) to
-- identify the quasi-quote
-mkHsString :: SourceTextX p => String -> HsLit p
-mkHsString s = HsString noSourceText (mkFastString s)
+mkHsString :: String -> HsLit (GhcPass p)
+mkHsString s = HsString NoSourceText (mkFastString s)
-mkHsStringPrimLit :: SourceTextX p => FastString -> HsLit p
+mkHsStringPrimLit :: FastString -> HsLit (GhcPass p)
mkHsStringPrimLit fs
- = HsStringPrim noSourceText (fastStringToByteString fs)
+ = HsStringPrim NoSourceText (fastStringToByteString fs)
-------------
userHsLTyVarBndrs :: SrcSpan -> [Located (IdP name)] -> [LHsTyVarBndr name]
@@ -643,8 +646,8 @@ typeToLHsType ty
, hst_body = go tau })
go (TyVarTy tv) = nlHsTyVar (getRdrName tv)
go (AppTy t1 t2) = nlHsAppTy (go t1) (go t2)
- go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy noSourceText n)
- go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy noSourceText s)
+ go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy NoSourceText n)
+ go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy NoSourceText s)
go ty@(TyConApp tc args)
| any isInvisibleTyConBinder (tyConBinders tc)
-- We must produce an explicit kind signature here to make certain
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 12413f2187..8079c7ee7f 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -3403,19 +3403,19 @@ consym :: { Located RdrName }
-- Literals
literal :: { Located (HsLit GhcPs) }
- : CHAR { sL1 $1 $ HsChar (sst $ getCHARs $1) $ getCHAR $1 }
- | STRING { sL1 $1 $ HsString (sst $ getSTRINGs $1)
- $ getSTRING $1 }
- | PRIMINTEGER { sL1 $1 $ HsIntPrim (sst $ getPRIMINTEGERs $1)
- $ getPRIMINTEGER $1 }
- | PRIMWORD { sL1 $1 $ HsWordPrim (sst $ getPRIMWORDs $1)
- $ getPRIMWORD $1 }
- | PRIMCHAR { sL1 $1 $ HsCharPrim (sst $ getPRIMCHARs $1)
- $ getPRIMCHAR $1 }
- | PRIMSTRING { sL1 $1 $ HsStringPrim (sst $ getPRIMSTRINGs $1)
- $ getPRIMSTRING $1 }
- | PRIMFLOAT { sL1 $1 $ HsFloatPrim def $ getPRIMFLOAT $1 }
- | PRIMDOUBLE { sL1 $1 $ HsDoublePrim def $ getPRIMDOUBLE $1 }
+ : CHAR { sL1 $1 $ HsChar (getCHARs $1) $ getCHAR $1 }
+ | STRING { sL1 $1 $ HsString (getSTRINGs $1)
+ $ getSTRING $1 }
+ | PRIMINTEGER { sL1 $1 $ HsIntPrim (getPRIMINTEGERs $1)
+ $ getPRIMINTEGER $1 }
+ | PRIMWORD { sL1 $1 $ HsWordPrim (getPRIMWORDs $1)
+ $ getPRIMWORD $1 }
+ | PRIMCHAR { sL1 $1 $ HsCharPrim (getPRIMCHARs $1)
+ $ getPRIMCHAR $1 }
+ | PRIMSTRING { sL1 $1 $ HsStringPrim (getPRIMSTRINGs $1)
+ $ getPRIMSTRING $1 }
+ | PRIMFLOAT { sL1 $1 $ HsFloatPrim def $ getPRIMFLOAT $1 }
+ | PRIMDOUBLE { sL1 $1 $ HsDoublePrim def $ getPRIMDOUBLE $1 }
-----------------------------------------------------------------------------
-- Layout
@@ -3812,7 +3812,4 @@ oll l =
asl :: [Located a] -> Located b -> Located a -> P()
asl [] (L ls _) (L l _) = addAnnotation l AnnSemi ls
asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls
-
-sst ::HasSourceText a => SourceText -> a
-sst = setSourceText
}
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 3cb24173ec..ced46a367e 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -1876,7 +1876,7 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
-- typechecker and the desugarer (I tried it that way first!).
mkApplicativeStmt
:: HsStmtContext Name
- -> [ApplicativeArg GhcRn GhcRn] -- ^ The args
+ -> [ApplicativeArg GhcRn] -- ^ The args
-> Bool -- ^ True <=> need a join
-> [ExprLStmt GhcRn] -- ^ The body statements
-> RnM ([ExprLStmt GhcRn], FreeVars)
diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs
index 560dc222f6..457c79583d 100644
--- a/compiler/typecheck/Inst.hs
+++ b/compiler/typecheck/Inst.hs
@@ -575,17 +575,17 @@ newNonTrivialOverloadedLit _ lit _
= pprPanic "newNonTrivialOverloadedLit" (ppr lit)
------------
-mkOverLit ::(HasDefaultX p, SourceTextX p) => OverLitVal -> TcM (HsLit p)
+mkOverLit ::(HasDefaultX (GhcPass p)) => OverLitVal -> TcM (HsLit (GhcPass p))
mkOverLit (HsIntegral i)
= do { integer_ty <- tcMetaTy integerTyConName
- ; return (HsInteger (setSourceText $ il_text i)
+ ; return (HsInteger (il_text i)
(il_value i) integer_ty) }
mkOverLit (HsFractional r)
= do { rat_ty <- tcMetaTy rationalTyConName
; return (HsRat def r rat_ty) }
-mkOverLit (HsIsString src s) = return (HsString (setSourceText src) s)
+mkOverLit (HsIsString src s) = return (HsString src s)
{-
************************************************************************
diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs
index edf696e3c9..07d72a105a 100644
--- a/compiler/typecheck/TcAnnotations.hs
+++ b/compiler/typecheck/TcAnnotations.hs
@@ -72,6 +72,6 @@ annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) = NamedTarget name
annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name
annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod
-annCtxt :: (SourceTextX p, OutputableBndrId p) => AnnDecl p -> SDoc
+annCtxt :: (OutputableBndrId (GhcPass p)) => AnnDecl (GhcPass p) -> SDoc
annCtxt ann
= hang (text "In the annotation:") 2 (ppr ann)
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 1b02a34093..3e4a48fe21 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -1823,7 +1823,7 @@ isClosedBndrGroup type_env binds
-- This one is called on LHS, when pat and grhss are both Name
-- and on RHS, when pat is TcId and grhss is still Name
-patMonoBindsCtxt :: (SourceTextX p, OutputableBndrId p, Outputable body)
- => LPat p -> GRHSs GhcRn body -> SDoc
+patMonoBindsCtxt :: (OutputableBndrId (GhcPass p), Outputable body)
+ => LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc
patMonoBindsCtxt pat grhss
= hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)
diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
index 5d59a83869..e1d53aae5c 100644
--- a/compiler/typecheck/TcEnv.hs
+++ b/compiler/typecheck/TcEnv.hs
@@ -898,10 +898,12 @@ data InstBindings a
-- Used only to improve error messages
}
-instance (SourceTextX a, OutputableBndrId a) => Outputable (InstInfo a) where
+instance (OutputableBndrId (GhcPass a))
+ => Outputable (InstInfo (GhcPass a)) where
ppr = pprInstInfoDetails
-pprInstInfoDetails :: (SourceTextX a, OutputableBndrId a) => InstInfo a -> SDoc
+pprInstInfoDetails :: (OutputableBndrId (GhcPass a))
+ => InstInfo (GhcPass a) -> SDoc
pprInstInfoDetails info
= hang (pprInstanceHdr (iSpec info) <+> text "where")
2 (details (iBinds info))
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index e5043eaddc..0ef0641f4d 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -1335,7 +1335,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
wrapId (mkWpTyApps
[ getRuntimeRep meth_tau, meth_tau])
nO_METHOD_BINDING_ERROR_ID
- error_msg dflags = L inst_loc (HsLit (HsStringPrim noSourceText
+ error_msg dflags = L inst_loc (HsLit (HsStringPrim NoSourceText
(unsafeMkByteString (error_string dflags))))
meth_tau = funResultTy (piResultTys (idType sel_id) inst_tys)
error_string dflags = showSDoc dflags
diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
index d938de0e22..8a06c154cd 100644
--- a/compiler/typecheck/TcMatches.hs
+++ b/compiler/typecheck/TcMatches.hs
@@ -1011,10 +1011,10 @@ join :: tn -> res_ty
tcApplicativeStmts
:: HsStmtContext Name
- -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn GhcRn)]
+ -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType -- rhs_ty
-> (TcRhoType -> TcM t) -- thing_inside
- -> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId GhcTcId)], Type, t)
+ -> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], Type, t)
tcApplicativeStmts ctxt pairs rhs_ty thing_inside
= do { body_ty <- newFlexiTyVarTy liftedTypeKind
@@ -1052,8 +1052,8 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
; ops' <- goOps t_i ops
; return (op' : ops') }
- goArg :: (ApplicativeArg GhcRn GhcRn, Type, Type)
- -> TcM (ApplicativeArg GhcTcId GhcTcId)
+ goArg :: (ApplicativeArg GhcRn, Type, Type)
+ -> TcM (ApplicativeArg GhcTcId)
goArg (ApplicativeArgOne pat rhs isBody, pat_ty, exp_ty)
= setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $
@@ -1074,7 +1074,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
}
; return (ApplicativeArgMany stmts' ret' pat') }
- get_arg_bndrs :: ApplicativeArg GhcTcId GhcTcId -> [Id]
+ get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id]
get_arg_bndrs (ApplicativeArgOne pat _ _) = collectPatBinders pat
get_arg_bndrs (ApplicativeArgMany _ _ pat) = collectPatBinders pat
diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs
index 4c2a69a6c0..f42610bba0 100644
--- a/compiler/typecheck/TcTypeable.hs
+++ b/compiler/typecheck/TcTypeable.hs
@@ -12,7 +12,7 @@ module TcTypeable(mkTypeableBinds) where
import GhcPrelude
-import BasicTypes ( Boxity(..), neverInlinePragma )
+import BasicTypes ( Boxity(..), neverInlinePragma, SourceText(..) )
import TcBinds( addTypecheckedBinds )
import IfaceEnv( newGlobalBinder )
import TyCoRep( Type(..), TyLit(..) )
@@ -631,12 +631,12 @@ mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep
]
int :: Int -> HsLit GhcTc
- int n = HsIntPrim (sourceText $ show n) (toInteger n)
+ int n = HsIntPrim (SourceText $ show n) (toInteger n)
word64 :: DynFlags -> Word64 -> HsLit GhcTc
word64 dflags n
- | wORD_SIZE dflags == 4 = HsWord64Prim noSourceText (toInteger n)
- | otherwise = HsWordPrim noSourceText (toInteger n)
+ | wORD_SIZE dflags == 4 = HsWord64Prim NoSourceText (toInteger n)
+ | otherwise = HsWordPrim NoSourceText (toInteger n)
{-
Note [Representing TyCon kinds: KindRep]
diff --git a/utils/haddock b/utils/haddock
-Subproject 067d52fd4be15a1842cbb05f42d9d482de0ad3a
+Subproject d0de7f1219172a6b52e7a02a716aed8c1dc8aaa
View Lorry Controller Status