[Git][ghc/ghc][wip/match-pat] 3 commits: Move OutputablePrec next to Outputable
Vladislav Zavialov (@int-index)
gitlab at gitlab.haskell.org
Mon Aug 28 12:10:19 UTC 2023
Vladislav Zavialov pushed to branch wip/match-pat at Glasgow Haskell Compiler / GHC
Commits:
b98e8b67 by Vladislav Zavialov at 2023-08-28T14:47:38+03:00
Move OutputablePrec next to Outputable
- - - - -
96abde97 by Vladislav Zavialov at 2023-08-28T15:02:08+03:00
Merge OutputablePrec into Outputable
- - - - -
43bd961b by Vladislav Zavialov at 2023-08-28T15:09:50+03:00
Update methodNamesMatch, isAliasMG, zonkMatch
- - - - -
15 changed files:
- compiler/GHC/Core/TyCo/Ppr.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Lit.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/HsToCore/Pmc/Ppr.hs
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/SrcLoc.hs
- compiler/GHC/Utils/Outputable.hs
Changes:
=====================================
compiler/GHC/Core/TyCo/Ppr.hs
=====================================
@@ -50,8 +50,6 @@ import GHC.Types.Var.Env
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import GHC.Types.Basic ( PprPrec(..), topPrec, sigPrec, opPrec
- , funPrec, appPrec, maybeParen )
{-
%************************************************************************
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -486,7 +486,8 @@ data XXExprGhcTc
********************************************************************* -}
instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) where
- ppr expr = pprExpr expr
+ ppr = pprExpr
+ pprPrec = pprParendExpr
-----------------------
-- pprExpr, pprLExpr, pprBinds call pprDeeper;
@@ -790,12 +791,6 @@ pprDebugParendExpr p expr
True -> pprParendLExpr p expr
False -> pprLExpr expr
-instance OutputableBndrId p => OutputablePrec (LocatedA (HsExpr (GhcPass p))) where
- pprParend = pprParendLExpr
-
-instance OutputableBndrId p => OutputablePrec (HsExpr (GhcPass p)) where
- pprParend = pprParendExpr
-
pprParendLExpr :: (OutputableBndrId p)
=> PprPrec -> LHsExpr (GhcPass p) -> SDoc
pprParendLExpr p (L _ e) = pprParendExpr p e
@@ -1346,7 +1341,7 @@ type instance XXMatchGroup (GhcPass _) p b = DataConCantHappen
type instance XCMatch (GhcPass _) p b = EpAnn [AddEpAnn]
type instance XXMatch (GhcPass _) p b = DataConCantHappen
-instance (OutputableBndrId pr, Outputable body, OutputablePrec pat)
+instance (OutputableBndrId pr, Outputable body, Outputable pat)
=> Outputable (Match (GhcPass pr) pat body) where
ppr = pprMatch
@@ -1392,7 +1387,7 @@ type instance XCGRHS (GhcPass _) _ = EpAnn GrhsAnn
type instance XXGRHS (GhcPass _) b = DataConCantHappen
-pprMatches :: (OutputableBndrId idR, Outputable body, OutputablePrec pat)
+pprMatches :: (OutputableBndrId idR, Outputable body, Outputable pat)
=> MatchGroup (GhcPass idR) pat body -> SDoc
pprMatches MG { mg_alts = matches }
= vcat (map pprMatch (map unLoc (unLoc matches)))
@@ -1411,10 +1406,10 @@ pprPatBind pat grhss
= sep [ppr pat,
nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (GhcPass p)) grhss)]
-pprMatch :: (OutputableBndrId idR, Outputable body, OutputablePrec pat)
+pprMatch :: (OutputableBndrId idR, Outputable body, Outputable pat)
=> Match (GhcPass idR) pat body -> SDoc
pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss })
- = sep [ sep (herald : map (nest 2 . pprParend appPrec) other_pats)
+ = sep [ sep (herald : map (nest 2 . pprPrec appPrec) other_pats)
, nest 2 (pprGRHSs ctxt grhss) ]
where
(herald, other_pats)
@@ -1434,9 +1429,9 @@ pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss })
| null rest -> (pp_infix, []) -- x &&& y = e
| otherwise -> (parens pp_infix, rest) -- (x &&& y) z = e
where
- pp_infix = pprParend opPrec p1
+ pp_infix = pprPrec opPrec p1
<+> pprInfixOcc fun
- <+> pprParend opPrec p2
+ <+> pprPrec opPrec p2
_ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)
LambdaExpr -> (char '\\', pats)
@@ -1444,10 +1439,10 @@ pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss })
-- We don't simply return (empty, pats) to avoid introducing an
-- additional `nest 2` via the empty herald
LamCaseAlt LamCases ->
- maybe (empty, []) (first $ pprParend appPrec) (uncons pats)
+ maybe (empty, []) (first $ pprPrec appPrec) (uncons pats)
ArrowMatchCtxt (ArrowLamCaseAlt LamCases) ->
- maybe (empty, []) (first $ pprParend appPrec) (uncons pats)
+ maybe (empty, []) (first $ pprPrec appPrec) (uncons pats)
ArrowMatchCtxt KappaExpr -> (char '\\', pats)
@@ -2009,7 +2004,7 @@ matchDoContextErrString (MDoExpr m) = prependQualified m (text "'mdo' block")
matchDoContextErrString ListComp = text "list comprehension"
matchDoContextErrString MonadComp = text "monad comprehension"
-pprMatchInCtxt :: (OutputableBndrId idR, Outputable body, OutputablePrec pat)
+pprMatchInCtxt :: (OutputableBndrId idR, Outputable body, Outputable pat)
=> Match (GhcPass idR) pat body -> SDoc
pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match)
<> colon)
=====================================
compiler/GHC/Hs/Lit.hs
=====================================
@@ -25,7 +25,6 @@ import GHC.Prelude
import {-# SOURCE #-} GHC.Hs.Expr( pprExpr )
-import GHC.Types.Basic (PprPrec(..), topPrec )
import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} )
import GHC.Types.SourceText
import GHC.Core.Type
=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -284,6 +284,7 @@ instance (Outputable p, OutputableBndr p, Outputable arg)
instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where
ppr = pprPat
+ pprPrec = pprParendPat
-- See Note [Rebindable syntax and HsExpansion].
instance (Outputable a, Outputable b) => Outputable (HsPatExpansion a b) where
@@ -300,12 +301,6 @@ pprPatBndr var
-- but is it worth it?
False -> pprPrefixOcc var
-instance OutputableBndrId p => OutputablePrec (Pat (GhcPass p)) where
- pprParend = pprParendPat
-
-instance OutputableBndrId p => OutputablePrec (LocatedA (Pat (GhcPass p))) where
- pprParend = pprParendLPat
-
pprParendLPat :: (OutputableBndrId p)
=> PprPrec -> LPat (GhcPass p) -> SDoc
pprParendLPat p = pprParendPat p . unLoc
=====================================
compiler/GHC/HsToCore/Pmc/Ppr.hs
=====================================
@@ -11,7 +11,6 @@ import GHC.Prelude
import GHC.Data.List.Infinite (Infinite (..))
import qualified GHC.Data.List.Infinite as Inf
-import GHC.Types.Basic
import GHC.Types.Id
import GHC.Types.Var.Env
import GHC.Types.Unique.DFM
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -1408,6 +1408,7 @@ instance (Outputable a) => Outputable (SrcSpanAnn' a) where
instance (Outputable a, Outputable e)
=> Outputable (GenLocated (SrcSpanAnn' a) e) where
ppr = pprLocated
+ pprPrec = pprPrecLocated
instance (Outputable a, OutputableBndr e)
=> OutputableBndr (GenLocated (SrcSpanAnn' a) e) where
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -987,7 +987,7 @@ methodNamesCmd (HsCmdLamCase _ _ matches)
-- The type checker will complain later
---------------------------------------------------
-methodNamesMatch :: MatchGroup GhcRn (LPat GhcRn) (LHsCmd GhcRn) -> FreeVars
+methodNamesMatch :: MatchGroup GhcRn pat (LHsCmd GhcRn) -> FreeVars
methodNamesMatch (MG { mg_alts = L _ ms })
= plusFVs (map do_one ms)
where
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -542,7 +542,7 @@ checkCanonicalInstances cls poly_ty mbinds = do
-- test whether MatchGroup represents a trivial \"lhsName = rhsName\"
-- binding, and return @Just rhsName@ if this is the case
- isAliasMG :: MatchGroup GhcRn (LPat GhcRn) (LHsExpr GhcRn) -> Maybe Name
+ isAliasMG :: MatchGroup GhcRn pat (LHsExpr GhcRn) -> Maybe Name
isAliasMG MG {mg_alts = (L _ [L _ (Match { m_pats = []
, m_grhss = grhss })])}
| GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss
=====================================
compiler/GHC/Rename/Splice.hs
=====================================
@@ -31,7 +31,7 @@ import GHC.Rename.Unbound ( isUnboundName )
import GHC.Rename.Module ( rnSrcDecls, findSplice )
import GHC.Rename.Pat ( rnPat )
import GHC.Types.Error
-import GHC.Types.Basic ( TopLevelFlag, isTopLevel, maxPrec )
+import GHC.Types.Basic ( TopLevelFlag, isTopLevel )
import GHC.Types.SourceText ( SourceText(..) )
import GHC.Utils.Outputable
import GHC.Unit.Module
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -76,7 +76,6 @@ import GHC.Types.Fixity (LexicalFixity(..))
import GHC.Types.Name
import GHC.Types.Id
import GHC.Types.SrcLoc
-import GHC.Types.Basic
import Control.Monad
import Control.Arrow ( second )
@@ -216,8 +215,8 @@ type AnnoBody body
type AnnoPatBody pat body
= ( AnnoBody body
- , OutputablePrec (LocatedA (pat GhcRn))
- , OutputablePrec (LocatedA (pat GhcTc))
+ , Outputable (LocatedA (pat GhcRn))
+ , Outputable (LocatedA (pat GhcTc))
, Anno (Match GhcRn (LocatedA (pat GhcRn)) (LocatedA (body GhcRn))) ~ SrcSpanAnnA
, Anno (Match GhcTc (LocatedA (pat GhcTc)) (LocatedA (body GhcTc))) ~ SrcSpanAnnA
, Anno [LocatedA (Match GhcRn (LocatedA (pat GhcRn)) (LocatedA (body GhcRn)))] ~ SrcSpanAnnL
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -873,7 +873,7 @@ zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns
-> LMatch GhcTc (LocatedA (pat GhcTc)) (LocatedA (body GhcTc))
-> ZonkTcM (LMatch GhcTc (LocatedA (pat GhcTc)) (LocatedA (body GhcTc)))
zonkMatch zPat zBody (L loc match@(Match { m_pats = pats
- , m_grhss = grhss }))
+ , m_grhss = grhss }))
= runZonkBndrT (traverse zPat pats) $ \ new_pats ->
do { new_grhss <- zonkGRHSs zBody grhss
; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) }
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -51,6 +51,7 @@ import GHC.Data.Bag
import GHC.Utils.Lexeme
import GHC.Utils.Misc
import GHC.Data.FastString
+import GHC.Utils.Outputable
import GHC.Utils.Panic
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
=====================================
compiler/GHC/Types/Basic.hs
=====================================
@@ -50,11 +50,6 @@ module GHC.Types.Basic (
CbvMark(..), isMarkedCbv,
- PprPrec(..), topPrec, sigPrec, opPrec, funPrec,
- starPrec, appPrec, maxPrec,
- maybeParen,
- OutputablePrec(..),
-
TupleSort(..), tupleSortBoxity, boxityTupleSort,
tupleParens,
@@ -810,99 +805,6 @@ pprSafeOverlap :: Bool -> SDoc
pprSafeOverlap True = text "[safe]"
pprSafeOverlap False = empty
-{-
-************************************************************************
-* *
- Precedence
-* *
-************************************************************************
--}
-
--- | A general-purpose pretty-printing precedence type.
-newtype PprPrec = PprPrec Int deriving (Eq, Ord, Show)
--- See Note [Precedence in types]
-
-topPrec, sigPrec, funPrec, opPrec, starPrec, appPrec, maxPrec :: PprPrec
-topPrec = PprPrec 0 -- No parens
-sigPrec = PprPrec 1 -- Explicit type signatures
-funPrec = PprPrec 2 -- Function args; no parens for constructor apps
- -- See [Type operator precedence] for why both
- -- funPrec and opPrec exist.
-opPrec = PprPrec 2 -- Infix operator
-starPrec = PprPrec 3 -- Star syntax for the type of types, i.e. the * in (* -> *)
- -- See Note [Star kind precedence]
-appPrec = PprPrec 4 -- Constructor args; no parens for atomic
-maxPrec = appPrec -- Maximum precendence
-
-maybeParen :: PprPrec -> PprPrec -> SDoc -> SDoc
-maybeParen ctxt_prec inner_prec pretty
- | ctxt_prec < inner_prec = pretty
- | otherwise = parens pretty
-
-class Outputable a => OutputablePrec a where
- pprParend :: PprPrec -> a -> SDoc
-
-{- Note [Precedence in types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Many pretty-printing functions have type
- ppr_ty :: PprPrec -> Type -> SDoc
-
-The PprPrec gives the binding strength of the context. For example, in
- T ty1 ty2
-we will pretty-print 'ty1' and 'ty2' with the call
- (ppr_ty appPrec ty)
-to indicate that the context is that of an argument of a TyConApp.
-
-We use this consistently for Type and HsType.
-
-Note [Type operator precedence]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We don't keep the fixity of type operators in the operator. So the
-pretty printer follows the following precedence order:
-
- TyConPrec Type constructor application
- TyOpPrec/FunPrec Operator application and function arrow
-
-We have funPrec and opPrec to represent the precedence of function
-arrow and type operators respectively, but currently we implement
-funPrec == opPrec, so that we don't distinguish the two. Reason:
-it's hard to parse a type like
- a ~ b => c * d -> e - f
-
-By treating opPrec = funPrec we end up with more parens
- (a ~ b) => (c * d) -> (e - f)
-
-But the two are different constructors of PprPrec so we could make
-(->) bind more or less tightly if we wanted.
-
-Note [Star kind precedence]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We parenthesize the (*) kind to avoid two issues:
-
-1. Printing invalid or incorrect code.
- For example, instead of type F @(*) x = x
- GHC used to print type F @* x = x
- However, (@*) is a type operator, not a kind application.
-
-2. Printing kinds that are correct but hard to read.
- Should Either * Int be read as Either (*) Int
- or as (*) Either Int ?
- This depends on whether -XStarIsType is enabled, but it would be
- easier if we didn't have to check for the flag when reading the code.
-
-At the same time, we cannot parenthesize (*) blindly.
-Consider this Haskell98 kind: ((* -> *) -> *) -> *
-With parentheses, it is less readable: (((*) -> (*)) -> (*)) -> (*)
-
-The solution is to assign a special precedence to (*), 'starPrec', which is
-higher than 'funPrec' but lower than 'appPrec':
-
- F * * * becomes F (*) (*) (*)
- F A * B becomes F A (*) B
- Proxy * becomes Proxy (*)
- a * -> * becomes a (*) -> *
--}
-
{-
************************************************************************
* *
=====================================
compiler/GHC/Types/SrcLoc.hs
=====================================
@@ -88,6 +88,7 @@ module GHC.Types.SrcLoc (
getLoc, unLoc,
unRealSrcSpan, getRealSrcSpan,
pprLocated,
+ pprPrecLocated,
pprLocatedAlways,
-- ** Combining and comparing Located values
@@ -797,13 +798,18 @@ instance (Outputable e) => Outputable (GenLocated RealSrcSpan e) where
whenPprDebug (braces (pprUserSpan False (RealSrcSpan l Strict.Nothing)))
$$ ppr e
-
pprLocated :: (Outputable l, Outputable e) => GenLocated l e -> SDoc
pprLocated (L l e) =
-- Print spans without the file name etc
whenPprDebug (braces (ppr l))
$$ ppr e
+pprPrecLocated :: (Outputable l, Outputable e) => PprPrec -> GenLocated l e -> SDoc
+pprPrecLocated prec (L l e) =
+ -- Print spans without the file name etc
+ whenPprDebug (braces (ppr l))
+ $$ pprPrec prec e
+
-- | Always prints the location, even without -dppr-debug
pprLocatedAlways :: (Outputable l, Outputable e) => GenLocated l e -> SDoc
pprLocatedAlways (L l e) =
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -28,6 +28,11 @@ module GHC.Utils.Outputable (
IsOutput(..), IsLine(..), IsDoc(..),
HLine, HDoc,
+ -- * Precedence
+ PprPrec(..), topPrec, sigPrec, opPrec, funPrec,
+ starPrec, appPrec, maxPrec,
+ maybeParen,
+
-- * Pretty printing combinators
SDoc, runSDoc, PDoc(..),
docToSDoc,
@@ -898,13 +903,108 @@ coloured col sdoc = sdocOption sdocShouldUseColor $ \case
keyword :: SDoc -> SDoc
keyword = coloured Col.colBold
+{-
+************************************************************************
+* *
+ Precedence
+* *
+************************************************************************
+-}
+
+-- | A general-purpose pretty-printing precedence type.
+newtype PprPrec = PprPrec Int deriving (Eq, Ord, Show)
+-- See Note [Precedence in types]
+
+topPrec, sigPrec, funPrec, opPrec, starPrec, appPrec, maxPrec :: PprPrec
+topPrec = PprPrec 0 -- No parens
+sigPrec = PprPrec 1 -- Explicit type signatures
+funPrec = PprPrec 2 -- Function args; no parens for constructor apps
+ -- See [Type operator precedence] for why both
+ -- funPrec and opPrec exist.
+opPrec = PprPrec 2 -- Infix operator
+starPrec = PprPrec 3 -- Star syntax for the type of types, i.e. the * in (* -> *)
+ -- See Note [Star kind precedence]
+appPrec = PprPrec 4 -- Constructor args; no parens for atomic
+maxPrec = appPrec -- Maximum precendence
+
+maybeParen :: PprPrec -> PprPrec -> SDoc -> SDoc
+maybeParen ctxt_prec inner_prec pretty
+ | ctxt_prec < inner_prec = pretty
+ | otherwise = parens pretty
+
+{- Note [Precedence in types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Many pretty-printing functions have type
+ ppr_ty :: PprPrec -> Type -> SDoc
+
+The PprPrec gives the binding strength of the context. For example, in
+ T ty1 ty2
+we will pretty-print 'ty1' and 'ty2' with the call
+ (ppr_ty appPrec ty)
+to indicate that the context is that of an argument of a TyConApp.
+
+We use this consistently for Type and HsType.
+
+Note [Type operator precedence]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We don't keep the fixity of type operators in the operator. So the
+pretty printer follows the following precedence order:
+
+ TyConPrec Type constructor application
+ TyOpPrec/FunPrec Operator application and function arrow
+
+We have funPrec and opPrec to represent the precedence of function
+arrow and type operators respectively, but currently we implement
+funPrec == opPrec, so that we don't distinguish the two. Reason:
+it's hard to parse a type like
+ a ~ b => c * d -> e - f
+
+By treating opPrec = funPrec we end up with more parens
+ (a ~ b) => (c * d) -> (e - f)
+
+But the two are different constructors of PprPrec so we could make
+(->) bind more or less tightly if we wanted.
+
+Note [Star kind precedence]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We parenthesize the (*) kind to avoid two issues:
+
+1. Printing invalid or incorrect code.
+ For example, instead of type F @(*) x = x
+ GHC used to print type F @* x = x
+ However, (@*) is a type operator, not a kind application.
+
+2. Printing kinds that are correct but hard to read.
+ Should Either * Int be read as Either (*) Int
+ or as (*) Either Int ?
+ This depends on whether -XStarIsType is enabled, but it would be
+ easier if we didn't have to check for the flag when reading the code.
+
+At the same time, we cannot parenthesize (*) blindly.
+Consider this Haskell98 kind: ((* -> *) -> *) -> *
+With parentheses, it is less readable: (((*) -> (*)) -> (*)) -> (*)
+
+The solution is to assign a special precedence to (*), 'starPrec', which is
+higher than 'funPrec' but lower than 'appPrec':
+
+ F * * * becomes F (*) (*) (*)
+ F A * B becomes F A (*) B
+ Proxy * becomes Proxy (*)
+ a * -> * becomes a (*) -> *
+-}
+
-----------------------------------------------------------------------
-- The @Outputable@ class
-----------------------------------------------------------------------
-- | Class designating that some type has an 'SDoc' representation
class Outputable a where
+ {-# MINIMAL pprPrec | ppr #-}
ppr :: a -> SDoc
+ pprPrec :: PprPrec -> a -> SDoc
+
+ pprPrec _prec = ppr
+ ppr = pprPrec topPrec
-- There's no Outputable for Char; it's too easy to use Outputable
-- on String and have ppr "hello" rendered as "h,e,l,l,o".
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bb482b9a9d7d797997204c30bcc4f692c51e6ce6...43bd961b172d4567898e2a488118bfc6466a486d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bb482b9a9d7d797997204c30bcc4f692c51e6ce6...43bd961b172d4567898e2a488118bfc6466a486d
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230828/803e78e1/attachment-0001.html>
More information about the ghc-commits
mailing list