Commit e951f219 authored by Sebastian Graf's avatar Sebastian Graf Committed by Marge Bot

Use FlexibleInstances for `Outputable (* p)` instead of match-all instances...

Use FlexibleInstances for `Outputable (* p)` instead of match-all instances with equality constraints

In #17304, Richard and Simon dicovered that using `-XFlexibleInstances`
for `Outputable` instances of AST data types means users can provide orphan
`Outputable` instances for passes other than `GhcPass`.

Type inference doesn't currently to suffer, and Richard gave an example
in #17304 that shows how rare a case would be where the slightly worse
type inference would matter.

So I went ahead with the refactoring, attempting to fix #17304.
parent e0e04856
Pipeline #11912 failed with stages
in 47 seconds
......@@ -118,7 +118,7 @@ deriving instance Data (HsModule GhcPs)
deriving instance Data (HsModule GhcRn)
deriving instance Data (HsModule GhcTc)
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsModule p) where
instance (OutputableBndrId p) => Outputable (HsModule (GhcPass p)) where
ppr (HsModule Nothing _ imports decls _ mbDoc)
= pp_mb mbDoc $$ pp_nonnull imports
......
......@@ -11,6 +11,7 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module GHC.Hs.PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
......@@ -617,17 +618,15 @@ Specifically,
it's just an error thunk
-}
instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (HsLocalBindsLR idL idR) where
instance (OutputableBndrId pl, OutputableBndrId pr)
=> Outputable (HsLocalBindsLR (GhcPass pl) (GhcPass pr)) where
ppr (HsValBinds _ bs) = ppr bs
ppr (HsIPBinds _ bs) = ppr bs
ppr (EmptyLocalBinds _) = empty
ppr (XHsLocalBindsLR x) = ppr x
instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (HsValBindsLR idL idR) where
instance (OutputableBndrId pl, OutputableBndrId pr)
=> Outputable (HsValBindsLR (GhcPass pl) (GhcPass pr)) where
ppr (ValBinds _ binds sigs)
= pprDeclList (pprLHsBindsForUser binds sigs)
......@@ -642,15 +641,15 @@ instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
pp_rec Recursive = text "rec"
pp_rec NonRecursive = text "nonrec"
pprLHsBinds :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR)
=> LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
pprLHsBinds binds
| isEmptyLHsBinds binds = empty
| otherwise = pprDeclList (map ppr (bagToList binds))
pprLHsBindsForUser :: (OutputableBndrId (GhcPass idL),
OutputableBndrId (GhcPass idR),
OutputableBndrId (GhcPass id2))
pprLHsBindsForUser :: (OutputableBndrId idL,
OutputableBndrId idR,
OutputableBndrId 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
......@@ -725,12 +724,11 @@ plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1))
plusHsValBinds _ _
= panic "HsBinds.plusHsValBinds"
instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (HsBindLR idL idR) where
instance (OutputableBndrId pl, OutputableBndrId pr)
=> Outputable (HsBindLR (GhcPass pl) (GhcPass pr)) where
ppr mbind = ppr_monobind mbind
ppr_monobind :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
ppr_monobind :: (OutputableBndrId idL, OutputableBndrId idR)
=> HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc
ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
......@@ -766,16 +764,16 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
pprLHsBinds val_binds
ppr_monobind (XHsBindsLR x) = ppr x
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ABExport p) where
instance OutputableBndrId p => Outputable (ABExport (GhcPass p)) where
ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
= vcat [ ppr gbl <+> text "<=" <+> ppr lcl
, nest 2 (pprTcSpecPrags prags)
, nest 2 (text "wrap:" <+> ppr wrap)]
ppr (XABExport x) = ppr x
instance (idR ~ GhcPass pr,OutputableBndrId idL, OutputableBndrId idR,
Outputable (XXPatSynBind idL idR))
=> Outputable (PatSynBind idL idR) where
instance (OutputableBndrId l, OutputableBndrId r,
Outputable (XXPatSynBind (GhcPass l) (GhcPass r)))
=> Outputable (PatSynBind (GhcPass l) (GhcPass r)) where
ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat,
psb_dir = dir })
= ppr_lhs <+> ppr_rhs
......@@ -866,13 +864,13 @@ data IPBind id
type instance XCIPBind (GhcPass p) = NoExtField
type instance XXIPBind (GhcPass p) = NoExtCon
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsIPBinds p) where
instance OutputableBndrId p
=> Outputable (HsIPBinds (GhcPass p)) where
ppr (IPBinds ds bs) = pprDeeperList vcat (map ppr bs)
$$ whenPprDebug (ppr ds)
ppr (XHsIPBinds x) = ppr x
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (IPBind p) where
instance OutputableBndrId p => Outputable (IPBind (GhcPass p)) where
ppr (IPBind _ lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
where name = case lr of
Left (L _ ip) -> pprBndr LetBind ip
......@@ -1168,10 +1166,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 (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Sig p) where
instance OutputableBndrId p => Outputable (Sig (GhcPass p)) where
ppr sig = ppr_sig sig
ppr_sig :: (OutputableBndrId (GhcPass p)) => Sig (GhcPass p) -> SDoc
ppr_sig :: (OutputableBndrId 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)
......@@ -1204,8 +1202,8 @@ ppr_sig (CompleteMatchSig _ src cs mty)
opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty
ppr_sig (XSig x) = ppr x
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (FixitySig p) where
instance OutputableBndrId p
=> Outputable (FixitySig (GhcPass p)) where
ppr (FixitySig _ names fixity) = sep [ppr fixity, pprops]
where
pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)
......
This diff is collapsed.
This diff is collapsed.
{-# LANGUAGE CPP, KindSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module GHC.Hs.PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
......@@ -28,24 +29,24 @@ data MatchGroup (a :: *) (body :: *)
data GRHSs (a :: *) (body :: *)
data SyntaxExpr (i :: *)
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsExpr p)
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p)
instance OutputableBndrId p => Outputable (HsExpr (GhcPass p))
instance OutputableBndrId p => Outputable (HsCmd (GhcPass p))
type LHsExpr a = Located (HsExpr a)
pprLExpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc
pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc
pprExpr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> SDoc
pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc
pprSplice :: (OutputableBndrId (GhcPass p)) => HsSplice (GhcPass p) -> SDoc
pprSplice :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc
pprSpliceDecl :: (OutputableBndrId (GhcPass p))
pprSpliceDecl :: (OutputableBndrId p)
=> HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc
pprPatBind :: forall bndr p body. (OutputableBndrId (GhcPass bndr),
OutputableBndrId (GhcPass p),
pprPatBind :: forall bndr p body. (OutputableBndrId bndr,
OutputableBndrId p,
Outputable body)
=> LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc
pprFunBind :: (OutputableBndrId (GhcPass idR), Outputable body)
pprFunBind :: (OutputableBndrId idR, Outputable body)
=> MatchGroup (GhcPass idR) body -> SDoc
......@@ -1162,13 +1162,13 @@ type OutputableX p = -- See Note [OutputableX]
-- ----------------------------------------------------------------------
-- |Constraint type to bundle up the requirement for 'OutputableBndr' on both
-- the @id@ and the 'NameOrRdrName' type for it
type OutputableBndrId id =
( OutputableBndr (NameOrRdrName (IdP id))
, OutputableBndr (IdP id)
, OutputableBndr (NameOrRdrName (IdP (NoGhcTc id)))
, OutputableBndr (IdP (NoGhcTc id))
, NoGhcTc id ~ NoGhcTc (NoGhcTc id)
, OutputableX id
, OutputableX (NoGhcTc id)
-- the @p@ and the 'NameOrRdrName' type for it
type OutputableBndrId pass =
( OutputableBndr (NameOrRdrName (IdP (GhcPass pass)))
, OutputableBndr (IdP (GhcPass pass))
, OutputableBndr (NameOrRdrName (IdP (NoGhcTc (GhcPass pass))))
, OutputableBndr (IdP (NoGhcTc (GhcPass pass)))
, NoGhcTc (GhcPass pass) ~ NoGhcTc (NoGhcTc (GhcPass pass))
, OutputableX (GhcPass pass)
, OutputableX (NoGhcTc (GhcPass pass))
)
......@@ -8,6 +8,7 @@ GHC.Hs.ImpExp: Abstract syntax: imports, exports, interfaces
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
......@@ -125,8 +126,8 @@ simpleImportDecl mn = ImportDecl {
ideclHiding = Nothing
}
instance (p ~ GhcPass pass,OutputableBndrId p)
=> Outputable (ImportDecl p) where
instance OutputableBndrId p
=> Outputable (ImportDecl (GhcPass p)) where
ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod'
, ideclPkgQual = pkg
, ideclSource = from, ideclSafe = safe
......@@ -322,7 +323,7 @@ replaceWrappedName (IEType (L l _)) n = IEType (L l n)
replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2
replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n')
instance (p ~ GhcPass pass,OutputableBndrId p) => Outputable (IE p) where
instance OutputableBndrId p => Outputable (IE (GhcPass p)) where
ppr (IEVar _ var) = ppr (unLoc var)
ppr (IEThingAbs _ thing) = ppr (unLoc thing)
ppr (IEThingAll _ thing) = hcat [ppr (unLoc thing), text "(..)"]
......
......@@ -9,6 +9,7 @@
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module GHC.Hs.PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
......@@ -227,7 +228,7 @@ instance Ord OverLitVal where
compare (HsIsString _ _) (HsFractional _) = GT
-- Instance specific to GhcPs, need the SourceText
instance p ~ GhcPass pass => Outputable (HsLit p) where
instance Outputable (HsLit (GhcPass 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)
......@@ -249,8 +250,8 @@ 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 (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsOverLit p) where
instance OutputableBndrId p
=> Outputable (HsOverLit (GhcPass p)) where
ppr (OverLit {ol_val=val, ol_witness=witness})
= ppr val <+> (whenPprDebug (parens (pprExpr witness)))
ppr (XOverLit x) = ppr x
......
......@@ -504,7 +504,7 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl
************************************************************************
-}
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p) where
instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where
ppr = pprPat
pprPatBndr :: OutputableBndr name => name -> SDoc
......@@ -516,11 +516,11 @@ pprPatBndr var -- Print with type info if -dppr-debug is on
else
pprPrefixOcc var
pprParendLPat :: (OutputableBndrId (GhcPass p))
pprParendLPat :: (OutputableBndrId p)
=> PprPrec -> LPat (GhcPass p) -> SDoc
pprParendLPat p = pprParendPat p . unLoc
pprParendPat :: (OutputableBndrId (GhcPass p))
pprParendPat :: (OutputableBndrId p)
=> PprPrec -> Pat (GhcPass p) -> SDoc
pprParendPat p pat = sdocWithDynFlags $ \ dflags ->
if need_parens dflags pat
......@@ -535,7 +535,7 @@ pprParendPat p pat = sdocWithDynFlags $ \ dflags ->
-- But otherwise the CoPat is discarded, so it
-- is the pattern inside that matters. Sigh.
pprPat :: (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc
pprPat :: (OutputableBndrId p) => Pat (GhcPass p) -> SDoc
pprPat (VarPat _ lvar) = pprPatBndr (unLoc lvar)
pprPat (WildPat _) = char '_'
pprPat (LazyPat _ pat) = char '~' <> pprParendLPat appPrec pat
......@@ -577,12 +577,12 @@ pprPat (ConPatOut { pat_con = con
pprPat (XPat x) = ppr x
pprUserCon :: (OutputableBndr con, OutputableBndrId (GhcPass p))
pprUserCon :: (OutputableBndr con, OutputableBndrId 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 :: (OutputableBndrId (GhcPass p))
pprConArgs :: (OutputableBndrId p)
=> HsConPatDetails (GhcPass p) -> SDoc
pprConArgs (PrefixCon pats) = fsep (map (pprParendLPat appPrec) pats)
pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1
......@@ -696,7 +696,7 @@ looksLazyPat (VarPat {}) = False
looksLazyPat (WildPat {}) = False
looksLazyPat _ = True
isIrrefutableHsPat :: (OutputableBndrId (GhcPass p)) => LPat (GhcPass p) -> Bool
isIrrefutableHsPat :: (OutputableBndrId p) => LPat (GhcPass 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
......
{-# LANGUAGE CPP, KindSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module GHC.Hs.PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
......@@ -15,4 +16,4 @@ type role Pat nominal
data Pat (i :: *)
type LPat i = Pat i
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p)
instance (OutputableBndrId p) => Outputable (Pat (GhcPass p))
......@@ -901,8 +901,8 @@ data ConDeclField pass -- Record fields have Haddoc docs on them
type instance XConDeclField (GhcPass _) = NoExtField
type instance XXConDeclField (GhcPass _) = NoExtCon
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (ConDeclField p) where
instance OutputableBndrId p
=> Outputable (ConDeclField (GhcPass p)) where
ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty
ppr (XConDeclField x) = ppr x
......@@ -1377,8 +1377,8 @@ data FieldOcc pass = FieldOcc { extFieldOcc :: XCFieldOcc pass
| XFieldOcc
(XXFieldOcc pass)
deriving instance (p ~ GhcPass pass, Eq (XCFieldOcc p)) => Eq (FieldOcc p)
deriving instance (p ~ GhcPass pass, Ord (XCFieldOcc p)) => Ord (FieldOcc p)
deriving instance Eq (XCFieldOcc (GhcPass p)) => Eq (FieldOcc (GhcPass p))
deriving instance Ord (XCFieldOcc (GhcPass p)) => Ord (FieldOcc (GhcPass p))
type instance XCFieldOcc GhcPs = NoExtField
type instance XCFieldOcc GhcRn = Name
......@@ -1420,10 +1420,10 @@ type instance XAmbiguous GhcTc = Id
type instance XXAmbiguousFieldOcc (GhcPass _) = NoExtCon
instance p ~ GhcPass pass => Outputable (AmbiguousFieldOcc p) where
instance Outputable (AmbiguousFieldOcc (GhcPass p)) where
ppr = ppr . rdrNameAmbiguousFieldOcc
instance p ~ GhcPass pass => OutputableBndr (AmbiguousFieldOcc p) where
instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where
pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc
pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc
......@@ -1459,30 +1459,30 @@ ambiguousFieldOcc (XFieldOcc nec) = noExtCon nec
************************************************************************
-}
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsType p) where
instance OutputableBndrId p => Outputable (HsType (GhcPass p)) where
ppr ty = pprHsType ty
instance Outputable HsTyLit where
ppr = ppr_tylit
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (LHsQTyVars p) where
instance OutputableBndrId p
=> Outputable (LHsQTyVars (GhcPass p)) where
ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs
ppr (XLHsQTyVars x) = ppr x
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsTyVarBndr p) where
instance OutputableBndrId p
=> Outputable (HsTyVarBndr (GhcPass p)) where
ppr (UserTyVar _ n) = ppr n
ppr (KindedTyVar _ n k) = parens $ hsep [ppr n, dcolon, ppr k]
ppr (XTyVarBndr nec) = noExtCon nec
instance (p ~ GhcPass pass,Outputable thing)
=> Outputable (HsImplicitBndrs p thing) where
instance Outputable thing
=> Outputable (HsImplicitBndrs (GhcPass p) thing) where
ppr (HsIB { hsib_body = ty }) = ppr ty
ppr (XHsImplicitBndrs x) = ppr x
instance (p ~ GhcPass pass,Outputable thing)
=> Outputable (HsWildCardBndrs p thing) where
instance Outputable thing
=> Outputable (HsWildCardBndrs (GhcPass p) thing) where
ppr (HsWC { hswc_body = ty }) = ppr ty
ppr (XHsWildCardBndrs x) = ppr x
......@@ -1491,7 +1491,7 @@ pprAnonWildCard = char '_'
-- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@
-- only when @-dppr-debug@ is enabled.
pprHsForAll :: (OutputableBndrId (GhcPass p))
pprHsForAll :: (OutputableBndrId p)
=> ForallVisFlag -> [LHsTyVarBndr (GhcPass p)]
-> LHsContext (GhcPass p) -> SDoc
pprHsForAll = pprHsForAllExtra Nothing
......@@ -1503,7 +1503,7 @@ 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 :: (OutputableBndrId (GhcPass p))
pprHsForAllExtra :: (OutputableBndrId p)
=> Maybe SrcSpan -> ForallVisFlag
-> [LHsTyVarBndr (GhcPass p)]
-> LHsContext (GhcPass p) -> SDoc
......@@ -1517,7 +1517,7 @@ pprHsForAllExtra extra fvf qtvs cxt
-- | Version of 'pprHsForAll' or 'pprHsForAllExtra' that will always print
-- @forall.@ when passed @Just []@. Prints nothing if passed 'Nothing'
pprHsExplicitForAll :: (OutputableBndrId (GhcPass p))
pprHsExplicitForAll :: (OutputableBndrId p)
=> ForallVisFlag
-> Maybe [LHsTyVarBndr (GhcPass p)] -> SDoc
pprHsExplicitForAll fvf (Just qtvs) = forAllLit <+> interppSP qtvs
......@@ -1530,14 +1530,14 @@ ppr_forall_separator :: ForallVisFlag -> SDoc
ppr_forall_separator ForallVis = space <> arrow
ppr_forall_separator ForallInvis = dot
pprLHsContext :: (OutputableBndrId (GhcPass p))
pprLHsContext :: (OutputableBndrId p)
=> LHsContext (GhcPass p) -> SDoc
pprLHsContext lctxt
| null (unLoc lctxt) = empty
| otherwise = pprLHsContextAlways lctxt
-- For use in a HsQualTy, which always gets printed if it exists.
pprLHsContextAlways :: (OutputableBndrId (GhcPass p))
pprLHsContextAlways :: (OutputableBndrId p)
=> LHsContext (GhcPass p) -> SDoc
pprLHsContextAlways (L _ ctxt)
= case ctxt of
......@@ -1546,7 +1546,7 @@ pprLHsContextAlways (L _ ctxt)
_ -> parens (interpp'SP ctxt) <+> darrow
-- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@
pprLHsContextExtra :: (OutputableBndrId (GhcPass p))
pprLHsContextExtra :: (OutputableBndrId p)
=> Bool -> LHsContext (GhcPass p) -> SDoc
pprLHsContextExtra show_extra lctxt@(L _ ctxt)
| not show_extra = pprLHsContext lctxt
......@@ -1555,7 +1555,7 @@ pprLHsContextExtra show_extra lctxt@(L _ ctxt)
where
ctxt' = map ppr ctxt ++ [char '_']
pprConDeclFields :: (OutputableBndrId (GhcPass p))
pprConDeclFields :: (OutputableBndrId p)
=> [LConDeclField (GhcPass p)] -> SDoc
pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
where
......@@ -1581,13 +1581,13 @@ seems like the Right Thing anyway.)
-- Printing works more-or-less as for Types
pprHsType :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc
pprHsType :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc
pprHsType ty = ppr_mono_ty ty
ppr_mono_lty :: (OutputableBndrId (GhcPass p)) => LHsType (GhcPass p) -> SDoc
ppr_mono_lty :: (OutputableBndrId p) => LHsType (GhcPass p) -> SDoc
ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
ppr_mono_ty :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc
ppr_mono_ty :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc
ppr_mono_ty (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty })
= sep [pprHsForAll fvf tvs noLHsContext, ppr_mono_lty ty]
......@@ -1644,7 +1644,7 @@ ppr_mono_ty (HsDocTy _ ty doc)
ppr_mono_ty (XHsType t) = ppr t
--------------------------
ppr_fun_ty :: (OutputableBndrId (GhcPass p))
ppr_fun_ty :: (OutputableBndrId p)
=> LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc
ppr_fun_ty ty1 ty2
= let p1 = ppr_mono_lty ty1
......
......@@ -6,6 +6,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ViewPatterns #-}
......@@ -2119,7 +2120,7 @@ patBuilderBang bang p =
cL (bang `combineSrcSpans` getLoc p) $
PatBuilderBang bang p
instance p ~ GhcPs => Outputable (PatBuilder p) where
instance Outputable (PatBuilder GhcPs) where
ppr (PatBuilderPat p) = ppr p
ppr (PatBuilderBang _ (L _ p)) = text "!" <+> ppr p
ppr (PatBuilderPar (L _ p)) = parens (ppr p)
......@@ -2128,8 +2129,8 @@ instance p ~ GhcPs => Outputable (PatBuilder p) where
ppr (PatBuilderVar v) = ppr v
ppr (PatBuilderOverLit l) = ppr l
instance p ~ GhcPs => DisambECP (PatBuilder p) where
type Body (PatBuilder p) = PatBuilder
instance DisambECP (PatBuilder GhcPs) where
type Body (PatBuilder GhcPs) = PatBuilder
ecpFromCmd' (dL-> L l c) =
addFatalError l $
text "Command syntax in pattern:" <+> ppr c
......@@ -2140,13 +2141,13 @@ instance p ~ GhcPs => DisambECP (PatBuilder p) where
text "Lambda-syntax in pattern." $$
text "Pattern matching on functions is not possible."
mkHsLetPV l _ _ = addFatalError l $ text "(let ... in ...)-syntax in pattern"
type InfixOp (PatBuilder p) = RdrName
type InfixOp (PatBuilder GhcPs) = RdrName
superInfixOp m = m
mkHsOpAppPV l p1 op p2 = do
warnSpaceAfterBang op (getLoc p2)
return $ cL l $ PatBuilderOpApp p1 op p2
mkHsCasePV l _ _ = addFatalError l $ text "(case ... of ...)-syntax in pattern"
type FunArg (PatBuilder p) = PatBuilder p
type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs
superFunArg m = m
mkHsAppPV l p1 p2 = return $ cL l (PatBuilderApp p1 p2)
mkHsIfPV l _ _ _ _ _ = addFatalError l $ text "(if ... then ... else ...)-syntax in pattern"
......
......@@ -74,6 +74,6 @@ annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) = NamedTarget name
annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name
annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod
annCtxt :: (OutputableBndrId (GhcPass p)) => AnnDecl (GhcPass p) -> SDoc
annCtxt :: (OutputableBndrId p) => AnnDecl (GhcPass p) -> SDoc
annCtxt ann
= hang (text "In the annotation:") 2 (ppr ann)
......@@ -498,7 +498,7 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds
recursivePatSynErr ::
OutputableBndrId (GhcPass p) =>
OutputableBndrId p =>
SrcSpan -- ^ The location of the first pattern synonym binding
-- (for error reporting)
-> LHsBinds (GhcPass p)
......@@ -1722,7 +1722,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 :: (OutputableBndrId (GhcPass p), Outputable body)
patMonoBindsCtxt :: (OutputableBndrId p, Outputable body)
=> LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc
patMonoBindsCtxt pat grhss
= hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)
......@@ -942,11 +942,11 @@ data InstBindings a
-- Used only to improve error messages
}
instance (OutputableBndrId (GhcPass a))
instance (OutputableBndrId a)
=> Outputable (InstInfo (GhcPass a)) where
ppr = pprInstInfoDetails
pprInstInfoDetails :: (OutputableBndrId (GhcPass a))
pprInstInfoDetails :: (OutputableBndrId a)
=> InstInfo (GhcPass a) -> SDoc
pprInstInfoDetails info
= hang (pprInstanceHdr (iSpec info) <+> text "where")
......
......@@ -778,7 +778,7 @@ exportErrCtxt herald exp =
text "In the" <+> text (herald ++ ":") <+> ppr exp
addExportErrCtxt :: (OutputableBndrId (GhcPass p))
addExportErrCtxt :: (OutputableBndrId p)
=> IE (GhcPass p) -> TcM a -> TcM a
addExportErrCtxt ie = addErrCtxt exportCtxt
where
......
Subproject commit f0b5a2043ff6c527e55fab228d37ee698ce87262
Subproject commit fad111e9d3de1a2e86837d3e6f72fe0cf2f6c0ac
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment