module GHC.Hs.Pat (
Pat(..), LPat,
EpAnnSumPat(..),
ConPatTc (..),
ConLikeP,
HsPatExpansion(..),
XXPatGhcTc(..),
HsConPatDetails, hsConPatArgs,
HsRecFields(..), HsFieldBind(..), LHsFieldBind,
HsRecField, LHsRecField,
HsRecUpdField, LHsRecUpdField,
hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs,
hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr,
mkPrefixConPat, mkCharLitPat, mkNilPat,
isSimplePat,
looksLazyPatBind,
isBangedLPat,
gParPat, patNeedsParens, parenthesizePat,
isIrrefutableHsPat,
collectEvVarsPat, collectEvVarsPats,
pprParendLPat, pprConArgs,
pprLPat
) where
import GHC.Prelude
import Language.Haskell.Syntax.Pat
import Language.Haskell.Syntax.Expr ( HsExpr )
import GHC.Hs.Expr (pprLExpr, pprSplice)
import GHC.Hs.Binds
import GHC.Hs.Lit
import Language.Haskell.Syntax.Extension
import GHC.Parser.Annotation
import GHC.Hs.Extension
import GHC.Hs.Type
import GHC.Tc.Types.Evidence
import GHC.Types.Basic
import GHC.Types.SourceText
import GHC.Core.Ppr ( )
import GHC.Builtin.Types
import GHC.Types.Var
import GHC.Types.Name.Reader ( RdrName )
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Utils.Outputable
import GHC.Core.Type
import GHC.Types.SrcLoc
import GHC.Data.Bag
import GHC.Data.Maybe
import GHC.Types.Name (Name)
import GHC.Driver.Session
import qualified GHC.LanguageExtensions as LangExt
import Data.Data
type instance XWildPat GhcPs = NoExtField
type instance XWildPat GhcRn = NoExtField
type instance XWildPat GhcTc = Type
type instance XVarPat (GhcPass _) = NoExtField
type instance XLazyPat GhcPs = EpAnn [AddEpAnn]
type instance XLazyPat GhcRn = NoExtField
type instance XLazyPat GhcTc = NoExtField
type instance XAsPat GhcPs = EpAnn [AddEpAnn]
type instance XAsPat GhcRn = NoExtField
type instance XAsPat GhcTc = NoExtField
type instance XParPat (GhcPass _) = EpAnnCO
type instance XBangPat GhcPs = EpAnn [AddEpAnn]
type instance XBangPat GhcRn = NoExtField
type instance XBangPat GhcTc = NoExtField
type instance XListPat GhcPs = EpAnn AnnList
type instance XListPat GhcRn = NoExtField
type instance XListPat GhcTc = Type
type instance XTuplePat GhcPs = EpAnn [AddEpAnn]
type instance XTuplePat GhcRn = NoExtField
type instance XTuplePat GhcTc = [Type]
type instance XSumPat GhcPs = EpAnn EpAnnSumPat
type instance XSumPat GhcRn = NoExtField
type instance XSumPat GhcTc = [Type]
type instance XConPat GhcPs = EpAnn [AddEpAnn]
type instance XConPat GhcRn = NoExtField
type instance XConPat GhcTc = ConPatTc
type instance XViewPat GhcPs = EpAnn [AddEpAnn]
type instance XViewPat GhcRn = Maybe (HsExpr GhcRn)
type instance XViewPat GhcTc = Type
type instance XSplicePat GhcPs = NoExtField
type instance XSplicePat GhcRn = NoExtField
type instance XSplicePat GhcTc = DataConCantHappen
type instance XLitPat (GhcPass _) = NoExtField
type instance XNPat GhcPs = EpAnn [AddEpAnn]
type instance XNPat GhcRn = EpAnn [AddEpAnn]
type instance XNPat GhcTc = Type
type instance XNPlusKPat GhcPs = EpAnn EpaLocation
type instance XNPlusKPat GhcRn = NoExtField
type instance XNPlusKPat GhcTc = Type
type instance XSigPat GhcPs = EpAnn [AddEpAnn]
type instance XSigPat GhcRn = NoExtField
type instance XSigPat GhcTc = Type
type instance XXPat GhcPs = DataConCantHappen
type instance XXPat GhcRn = HsPatExpansion (Pat GhcRn) (Pat GhcRn)
type instance XXPat GhcTc = XXPatGhcTc
type instance ConLikeP GhcPs = RdrName
type instance ConLikeP GhcRn = Name
type instance ConLikeP GhcTc = ConLike
type instance XHsFieldBind _ = EpAnn [AddEpAnn]
data EpAnnSumPat = EpAnnSumPat
{ sumPatParens :: [AddEpAnn]
, sumPatVbarsBefore :: [EpaLocation]
, sumPatVbarsAfter :: [EpaLocation]
} deriving Data
data XXPatGhcTc
=
CoPat
{
co_cpt_wrap :: HsWrapper
,
co_pat_inner :: Pat GhcTc
,
co_pat_ty :: Type
}
| ExpansionPat (Pat GhcRn) (Pat GhcTc)
data HsPatExpansion a b
= HsPatExpanded a b
deriving Data
data ConPatTc
= ConPatTc
{
cpt_arg_tys :: [Type]
,
cpt_tvs :: [TyVar]
,
cpt_dicts :: [EvVar]
,
cpt_binds :: TcEvBinds
,
cpt_wrap :: HsWrapper
}
hsRecFieldId :: HsRecField GhcTc arg -> Id
hsRecFieldId = hsRecFieldSel
hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName
hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . reLoc . hfbLHS
hsRecUpdFieldId :: HsFieldBind (LAmbiguousFieldOcc GhcTc) arg -> Located Id
hsRecUpdFieldId = fmap foExt . reLoc . hsRecUpdFieldOcc
hsRecUpdFieldOcc :: HsFieldBind (LAmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc
hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hfbLHS
instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where
ppr = pprPat
instance (Outputable a, Outputable b) => Outputable (HsPatExpansion a b) where
ppr (HsPatExpanded a b) = ifPprDebug (vcat [ppr a, ppr b]) (ppr a)
pprLPat :: (OutputableBndrId p) => LPat (GhcPass p) -> SDoc
pprLPat (L _ e) = pprPat e
pprPatBndr :: OutputableBndr name => name -> SDoc
pprPatBndr var
= getPprDebug $ \case
True -> parens (pprBndr LambdaBind var)
False -> pprPrefixOcc var
pprParendLPat :: (OutputableBndrId p)
=> PprPrec -> LPat (GhcPass p) -> SDoc
pprParendLPat p = pprParendPat p . unLoc
pprParendPat :: forall p. OutputableBndrId p
=> PprPrec
-> Pat (GhcPass p)
-> SDoc
pprParendPat p pat = sdocOption sdocPrintTypecheckerElaboration $ \ print_tc_elab ->
if need_parens print_tc_elab pat
then parens (pprPat pat)
else pprPat pat
where
need_parens print_tc_elab pat
| GhcTc <- ghcPass @p
, XPat (CoPat {}) <- pat
= print_tc_elab
| otherwise
= patNeedsParens p pat
pprPat :: forall p. (OutputableBndrId p) => Pat (GhcPass p) -> SDoc
pprPat (VarPat _ lvar) = pprPatBndr (unLoc lvar)
pprPat (WildPat _) = char '_'
pprPat (LazyPat _ pat) = char '~' <> pprParendLPat appPrec pat
pprPat (BangPat _ pat) = char '!' <> pprParendLPat appPrec pat
pprPat (AsPat _ name pat) = hcat [pprPrefixOcc (unLoc name), char '@',
pprParendLPat appPrec pat]
pprPat (ViewPat _ expr pat) = hcat [pprLExpr expr, text " -> ", ppr pat]
pprPat (ParPat _ _ pat _) = parens (ppr pat)
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]
where ppr_n = case ghcPass @p of
GhcPs -> ppr n
GhcRn -> ppr n
GhcTc -> ppr n
pprPat (SplicePat _ splice) = pprSplice splice
pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr ty
pprPat (ListPat _ pats) = brackets (interpp'SP pats)
pprPat (TuplePat _ pats bx)
| [pat] <- pats
, Boxed <- bx
= hcat [text (mkTupleStr Boxed 1), pprParendLPat appPrec pat]
| otherwise
= tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats)
pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity)
pprPat (ConPat { pat_con = con
, pat_args = details
, pat_con_ext = ext
}
)
= case ghcPass @p of
GhcPs -> pprUserCon (unLoc con) details
GhcRn -> pprUserCon (unLoc con) details
GhcTc -> sdocOption sdocPrintTypecheckerElaboration $ \case
False -> pprUserCon (unLoc con) details
True ->
ppr con
<> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
, ppr binds ])
<+> pprConArgs details
where ConPatTc { cpt_tvs = tvs
, cpt_dicts = dicts
, cpt_binds = binds
} = ext
pprPat (XPat ext) = case ghcPass @p of
#if __GLASGOW_HASKELL__ < 811
GhcPs -> dataConCantHappen ext
#endif
GhcRn -> case ext of
HsPatExpanded orig _ -> pprPat orig
GhcTc -> case ext of
CoPat co pat _ ->
pprHsWrapper co $ \parens ->
if parens
then pprParendPat appPrec pat
else pprPat pat
ExpansionPat orig _ -> pprPat orig
pprUserCon :: (OutputableBndr con, OutputableBndrId p,
Outputable (Anno (IdGhcP 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 p,
Outputable (Anno (IdGhcP p)))
=> HsConPatDetails (GhcPass p) -> SDoc
pprConArgs (PrefixCon ts pats) = fsep (pprTyArgs ts : map (pprParendLPat appPrec) pats)
where pprTyArgs tyargs = fsep (map (\ty -> char '@' <> ppr ty) tyargs)
pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1
, pprParendLPat appPrec p2 ]
pprConArgs (RecCon rpats) = ppr rpats
mkPrefixConPat :: DataCon ->
[LPat GhcTc] -> [Type] -> LPat GhcTc
mkPrefixConPat dc pats tys
= noLocA $ ConPat { pat_con = noLocA (RealDataCon dc)
, pat_args = PrefixCon [] pats
, pat_con_ext = ConPatTc
{ cpt_tvs = []
, cpt_dicts = []
, cpt_binds = emptyTcEvBinds
, cpt_arg_tys = tys
, cpt_wrap = idHsWrapper
}
}
mkNilPat :: Type -> LPat GhcTc
mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
mkCharLitPat :: SourceText -> Char -> LPat GhcTc
mkCharLitPat src c = mkPrefixConPat charDataCon
[noLocA $ LitPat noExtField (HsCharPrim src c)] []
isBangedLPat :: LPat (GhcPass p) -> Bool
isBangedLPat = isBangedPat . unLoc
isBangedPat :: Pat (GhcPass p) -> Bool
isBangedPat (ParPat _ _ p _) = isBangedLPat p
isBangedPat (BangPat {}) = True
isBangedPat _ = False
looksLazyPatBind :: HsBind GhcTc -> Bool
looksLazyPatBind (PatBind { pat_lhs = p })
= looksLazyLPat p
looksLazyPatBind (XHsBindsLR (AbsBinds { abs_binds = binds }))
= anyBag (looksLazyPatBind . unLoc) binds
looksLazyPatBind _
= False
looksLazyLPat :: LPat (GhcPass p) -> Bool
looksLazyLPat = looksLazyPat . unLoc
looksLazyPat :: Pat (GhcPass p) -> Bool
looksLazyPat (ParPat _ _ p _) = looksLazyLPat p
looksLazyPat (AsPat _ _ p) = looksLazyLPat p
looksLazyPat (BangPat {}) = False
looksLazyPat (VarPat {}) = False
looksLazyPat (WildPat {}) = False
looksLazyPat _ = True
isIrrefutableHsPat :: forall p. (OutputableBndrId p)
=> DynFlags -> LPat (GhcPass p) -> Bool
isIrrefutableHsPat dflags =
isIrrefutableHsPat' (xopt LangExt.Strict dflags)
isIrrefutableHsPat' :: forall p. (OutputableBndrId p)
=> Bool
-> LPat (GhcPass p) -> Bool
isIrrefutableHsPat' is_strict = goL
where
goL :: LPat (GhcPass p) -> Bool
goL = go . unLoc
go :: Pat (GhcPass p) -> Bool
go (WildPat {}) = True
go (VarPat {}) = True
go (LazyPat _ p')
| is_strict
= isIrrefutableHsPat' False p'
| otherwise = True
go (BangPat _ pat) = goL pat
go (ParPat _ _ pat _) = goL pat
go (AsPat _ _ pat) = goL pat
go (ViewPat _ _ pat) = goL pat
go (SigPat _ pat _) = goL pat
go (TuplePat _ pats _) = all goL pats
go (SumPat {}) = False
go (ListPat {}) = False
go (ConPat
{ pat_con = con
, pat_args = details })
= case ghcPass @p of
GhcPs -> False
GhcRn -> False
GhcTc -> case con of
L _ (PatSynCon _pat) -> False
L _ (RealDataCon con) ->
isJust (tyConSingleDataCon_maybe (dataConTyCon con))
&& all goL (hsConPatArgs details)
go (LitPat {}) = False
go (NPat {}) = False
go (NPlusKPat {}) = False
go (SplicePat {}) = False
go (XPat ext) = case ghcPass @p of
#if __GLASGOW_HASKELL__ < 811
GhcPs -> dataConCantHappen ext
#endif
GhcRn -> case ext of
HsPatExpanded _ pat -> go pat
GhcTc -> case ext of
CoPat _ pat _ -> go pat
ExpansionPat _ pat -> go pat
isSimplePat :: LPat (GhcPass x) -> Maybe (IdP (GhcPass x))
isSimplePat p = case unLoc p of
ParPat _ _ x _ -> isSimplePat x
SigPat _ x _ -> isSimplePat x
LazyPat _ x -> isSimplePat x
BangPat _ x -> isSimplePat x
VarPat _ x -> Just (unLoc x)
_ -> Nothing
patNeedsParens :: forall p. IsPass p => PprPrec -> Pat (GhcPass p) -> Bool
patNeedsParens p = go @p
where
go :: forall q. IsPass q => Pat (GhcPass q) -> Bool
go (NPlusKPat {}) = p > opPrec
go (SplicePat {}) = False
go (ConPat { pat_args = ds })
= conPatNeedsParens p ds
go (SigPat {}) = p >= sigPrec
go (ViewPat {}) = True
go (XPat ext) = case ghcPass @q of
#if __GLASGOW_HASKELL__ < 901
GhcPs -> dataConCantHappen ext
#endif
GhcRn -> case ext of
HsPatExpanded orig _ -> go orig
GhcTc -> case ext of
CoPat _ inner _ -> go inner
ExpansionPat orig _ -> go orig
go (WildPat {}) = False
go (VarPat {}) = False
go (LazyPat {}) = False
go (BangPat {}) = False
go (ParPat {}) = False
go (AsPat {}) = False
go (TuplePat _ [_] Boxed)
= p >= appPrec
go (TuplePat{}) = False
go (SumPat {}) = False
go (ListPat {}) = False
go (LitPat _ l) = hsLitNeedsParens p l
go (NPat _ lol _ _) = hsOverLitNeedsParens p (unLoc lol)
conPatNeedsParens :: PprPrec -> HsConDetails t a b -> Bool
conPatNeedsParens p = go
where
go (PrefixCon ts args) = p >= appPrec && (not (null args) || not (null ts))
go (InfixCon {}) = p >= opPrec
go (RecCon {}) = False
gParPat :: LPat (GhcPass pass) -> Pat (GhcPass pass)
gParPat p = ParPat noAnn noHsTok p noHsTok
parenthesizePat :: IsPass p
=> PprPrec
-> LPat (GhcPass p)
-> LPat (GhcPass p)
parenthesizePat p lpat@(L loc pat)
| patNeedsParens p pat = L loc (gParPat lpat)
| otherwise = lpat
collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar
collectEvVarsPats = unionManyBags . map collectEvVarsPat
collectEvVarsLPat :: LPat GhcTc -> Bag EvVar
collectEvVarsLPat = collectEvVarsPat . unLoc
collectEvVarsPat :: Pat GhcTc -> Bag EvVar
collectEvVarsPat pat =
case pat of
LazyPat _ p -> collectEvVarsLPat p
AsPat _ _ p -> collectEvVarsLPat p
ParPat _ _ p _ -> collectEvVarsLPat p
BangPat _ p -> collectEvVarsLPat p
ListPat _ ps -> unionManyBags $ map collectEvVarsLPat ps
TuplePat _ ps _ -> unionManyBags $ map collectEvVarsLPat ps
SumPat _ p _ _ -> collectEvVarsLPat p
ConPat
{ pat_args = args
, pat_con_ext = ConPatTc
{ cpt_dicts = dicts
}
}
-> unionBags (listToBag dicts)
$ unionManyBags
$ map collectEvVarsLPat
$ hsConPatArgs args
SigPat _ p _ -> collectEvVarsLPat p
XPat ext -> case ext of
CoPat _ p _ -> collectEvVarsPat p
ExpansionPat _ p -> collectEvVarsPat p
_other_pat -> emptyBag
type instance Anno (Pat (GhcPass p)) = SrcSpanAnnA
type instance Anno (HsOverLit (GhcPass p)) = SrcAnn NoEpAnns
type instance Anno ConLike = SrcSpanAnnN
type instance Anno (HsFieldBind lhs rhs) = SrcSpanAnnA