HsConPatDetails, hsConPatArgs,
HsRecFields(..), HsRecField(..), hsRecFields,
- HsQuasiQuote(..),
-
mkPrefixConPat, mkCharLitPat, mkNilPat, mkCoPat, mkCoPatCoI,
isBangHsBind, hsPatNeedsParens,
patsAreAllCons, isConPat, isSigPat, isWildPat,
- patsAreAllLits, isLitPat, isIrrefutableHsPat
+ patsAreAllLits, isLitPat, isIrrefutableHsPat,
+
+ pprParendLPat
) where
import {-# SOURCE #-} HsExpr (SyntaxExpr, LHsExpr, pprLExpr)
-- { x = 3, y = True }
-- Used for both expressions and patterns
= HsRecFields { rec_flds :: [HsRecField id arg],
- rec_dotdot :: Maybe Int }
- -- Nothing => the normal case
- -- Just n => the group uses ".." notation,
- -- and the first n elts of rec_flds
- -- were the user-written ones
- -- (In the latter case, the remaining elts of
- -- rec_flds are the non-user-written ones)
+ rec_dotdot :: Maybe Int } -- Note [DotDot fields]
+
+-- Note [DotDot fields]
+-- ~~~~~~~~~~~~~~~~~~~~
+-- The rec_dotdot field means this:
+-- Nothing => the normal case
+-- Just n => the group uses ".." notation,
+--
+-- In the latter case:
+--
+-- *before* renamer: rec_flds are exactly the n user-written fields
+--
+-- *after* renamer: rec_flds includes *all* fields, with
+-- the first 'n' being the user-written ones
+-- and the remainder being 'filled in' implicitly
data HsRecField id arg = HsRecField {
hsRecFieldId :: Located id,
- hsRecFieldArg :: arg,
+ hsRecFieldArg :: arg, -- Filled in by renamer
hsRecPun :: Bool -- Note [Punning]
}
-- If you write T { x, y = v+1 }, the HsRecFields will be
-- HsRecField x x True ...
-- HsRecField y (v+1) False ...
--- That is, for "punned" field x is immediately expanded to x=x
--- but with a punning flag so we can detect it later
+-- That is, for "punned" field x is expanded (in the renamer)
+-- to x=x; but with a punning flag so we can detect it later
-- (e.g. when pretty printing)
+--
+-- If the original field was qualified, we un-qualify it, thus
+-- T { A.x } means T { A.x = x }
hsRecFields :: HsRecFields id arg -> [id]
hsRecFields rbinds = map (unLoc . hsRecFieldId) (rec_flds rbinds)
\end{code}
-\begin{code}
-data HsQuasiQuote id = HsQuasiQuote
- id
- id
- SrcSpan
- FastString
-
-instance OutputableBndr id => Outputable (HsQuasiQuote id) where
- ppr = ppr_qq
-
-ppr_qq :: OutputableBndr id => HsQuasiQuote id -> SDoc
-ppr_qq (HsQuasiQuote name quoter _ quote) =
- char '$' <> brackets (ppr name) <>
- ptext (sLit "[:") <> ppr quoter <> ptext (sLit "|") <>
- ppr quote <> ptext (sLit "|]")
-\end{code}
-
-
%************************************************************************
%* *
%* Printing patterns
else
ppr var
+pprParendLPat :: (OutputableBndr name) => LPat name -> SDoc
+pprParendLPat (L _ p) = pprParendPat p
+
+pprParendPat :: (OutputableBndr name) => Pat name -> SDoc
+pprParendPat p | patNeedsParens p = parens (pprPat p)
+ | otherwise = pprPat p
+
+patNeedsParens :: Pat name -> Bool
+patNeedsParens (ConPatIn _ d) = not (null (hsConPatArgs d))
+patNeedsParens (ConPatOut { pat_args = d }) = not (null (hsConPatArgs d))
+patNeedsParens (SigPatIn {}) = True
+patNeedsParens (SigPatOut {}) = True
+patNeedsParens (ViewPat {}) = True
+patNeedsParens (CoPat {}) = True
+patNeedsParens _ = False
+
pprPat :: (OutputableBndr name) => Pat name -> SDoc
pprPat (VarPat var) = pprPatBndr var
-pprPat (VarPatOut var bs) = parens (pprPatBndr var <+> braces (ppr bs))
+pprPat (VarPatOut var bs) = pprPatBndr var <+> braces (ppr bs)
pprPat (WildPat _) = char '_'
-pprPat (LazyPat pat) = char '~' <> ppr pat
-pprPat (BangPat pat) = char '!' <> ppr pat
-pprPat (AsPat name pat) = parens (hcat [ppr name, char '@', ppr pat])
-pprPat (ViewPat expr pat _) = parens (hcat [pprLExpr expr, text " -> ", ppr pat])
+pprPat (LazyPat pat) = char '~' <> pprParendLPat pat
+pprPat (BangPat pat) = char '!' <> pprParendLPat pat
+pprPat (AsPat name pat) = hcat [ppr name, char '@', pprParendLPat pat]
+pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat]
pprPat (ParPat pat) = parens (ppr pat)
pprPat (ListPat pats _) = brackets (interpp'SP pats)
pprPat (PArrPat pats _) = pabrackets (interpp'SP pats)
pprLHsBinds binds, pprConArgs details]
else pprUserCon con details
-pprPat (LitPat s) = ppr s
+pprPat (LitPat s) = ppr s
pprPat (NPat l Nothing _) = ppr l
pprPat (NPat l (Just _) _) = char '-' <> ppr l
-pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k]
-pprPat (QuasiQuotePat (HsQuasiQuote name quoter _ quote))
- = char '$' <> brackets (ppr name) <>
- ptext (sLit "[:") <> ppr quoter <> ptext (sLit "|") <>
- ppr quote <> ptext (sLit "|]")
-pprPat (TypePat ty) = ptext (sLit "{|") <> ppr ty <> ptext (sLit "|}")
-pprPat (CoPat co pat _) = parens (pprHsWrapper (ppr pat) co)
-pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty
-pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty
+pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k]
+pprPat (QuasiQuotePat qq) = ppr qq
+pprPat (TypePat ty) = ptext (sLit "{|") <> ppr ty <> ptext (sLit "|}")
+pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co
+pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty
+pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty
pprUserCon :: (Outputable con, OutputableBndr id) => con -> HsConPatDetails id -> SDoc
pprUserCon c (InfixCon p1 p2) = ppr p1 <+> ppr c <+> ppr p2
pprUserCon c details = ppr c <+> pprConArgs details
pprConArgs :: OutputableBndr id => HsConPatDetails id -> SDoc
-pprConArgs (PrefixCon pats) = interppSP pats
-pprConArgs (InfixCon p1 p2) = interppSP [p1,p2]
+pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
+pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
pprConArgs (RecCon rpats) = ppr rpats
instance (OutputableBndr id, Outputable arg)
=> Outputable (HsRecField id arg) where
ppr (HsRecField { hsRecFieldId = f, hsRecFieldArg = arg,
hsRecPun = pun })
- = ppr f <+> (if pun then empty else equals <+> ppr arg)
+ = ppr f <+> (ppUnless pun $ equals <+> ppr arg)
-- add parallel array brackets around a document
--
projects / ghc-hetmet.git / blobdiff