module HsPat (
Pat(..), InPat, OutPat, LPat,
HsConDetails(..),
HsConPatDetails, hsConPatArgs,
HsRecFields(..), HsRecField(..), LHsRecField, hsRecFields,
mkPrefixConPat, mkCharLitPat, mkNilPat,
isStrictHsBind, looksLazyPatBind,
isStrictLPat, hsPatNeedsParens,
isIrrefutableHsPat,
pprParendLPat, pprConArgs
) where
import HsExpr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprUntypedSplice)
import HsBinds
import HsLit
import PlaceHolder ( PostTc,DataId )
import HsTypes
import TcEvidence
import BasicTypes
import PprCore ( )
import TysWiredIn
import Var
import ConLike
import DataCon
import TyCon
import Outputable
import Type
import SrcLoc
import FastString
import Data.Data hiding (TyCon,Fixity)
import Data.Maybe
type InPat id = LPat id
type OutPat id = LPat id
type LPat id = Located (Pat id)
data Pat id
=
WildPat (PostTc id Type)
| VarPat id
| LazyPat (LPat id)
| AsPat (Located id) (LPat id)
| ParPat (LPat id)
| BangPat (LPat id)
| ListPat [LPat id]
(PostTc id Type)
(Maybe (PostTc id Type, SyntaxExpr id))
| TuplePat [LPat id]
Boxity
[PostTc id Type]
| PArrPat [LPat id]
(PostTc id Type)
| ConPatIn (Located id)
(HsConPatDetails id)
| ConPatOut {
pat_con :: Located ConLike,
pat_arg_tys :: [Type],
pat_tvs :: [TyVar],
pat_dicts :: [EvVar],
pat_binds :: TcEvBinds,
pat_args :: HsConPatDetails id,
pat_wrap :: HsWrapper
}
| ViewPat (LHsExpr id)
(LPat id)
(PostTc id Type)
| SplicePat (HsSplice id)
| QuasiQuotePat (HsQuasiQuote id)
| LitPat HsLit
| NPat
(HsOverLit id)
(Maybe (SyntaxExpr id))
(SyntaxExpr id)
| NPlusKPat (Located id)
(HsOverLit id)
(SyntaxExpr id)
(SyntaxExpr id)
| SigPatIn (LPat id)
(HsWithBndrs id (LHsType id))
| SigPatOut (LPat id)
Type
| CoPat HsWrapper
(Pat id)
Type
deriving (Typeable)
deriving instance (DataId id) => Data (Pat id)
data HsConDetails arg rec
= PrefixCon [arg]
| RecCon rec
| InfixCon arg arg
deriving (Data, Typeable)
type HsConPatDetails id = HsConDetails (LPat id) (HsRecFields id (LPat id))
hsConPatArgs :: HsConPatDetails id -> [LPat id]
hsConPatArgs (PrefixCon ps) = ps
hsConPatArgs (RecCon fs) = map (hsRecFieldArg . unLoc) (rec_flds fs)
hsConPatArgs (InfixCon p1 p2) = [p1,p2]
data HsRecFields id arg
= HsRecFields { rec_flds :: [LHsRecField id arg],
rec_dotdot :: Maybe Int }
deriving (Data, Typeable)
type LHsRecField id arg = Located (HsRecField id arg)
data HsRecField id arg = HsRecField {
hsRecFieldId :: Located id,
hsRecFieldArg :: arg,
hsRecPun :: Bool
} deriving (Data, Typeable)
hsRecFields :: HsRecFields id arg -> [id]
hsRecFields rbinds = map (unLoc . hsRecFieldId . unLoc) (rec_flds rbinds)
instance (OutputableBndr name) => Outputable (Pat name) where
ppr = pprPat
pprPatBndr :: OutputableBndr name => name -> SDoc
pprPatBndr var
= getPprStyle $ \ sty ->
if debugStyle sty then
parens (pprBndr LambdaBind var)
else
pprPrefixOcc var
pprParendLPat :: (OutputableBndr name) => LPat name -> SDoc
pprParendLPat (L _ p) = pprParendPat p
pprParendPat :: (OutputableBndr name) => Pat name -> SDoc
pprParendPat p | hsPatNeedsParens p = parens (pprPat p)
| otherwise = pprPat p
pprPat :: (OutputableBndr name) => Pat name -> SDoc
pprPat (VarPat var) = pprPatBndr var
pprPat (WildPat _) = char '_'
pprPat (LazyPat pat) = char '~' <> pprParendLPat pat
pprPat (BangPat pat) = char '!' <> pprParendLPat pat
pprPat (AsPat name pat) = hcat [pprPrefixOcc (unLoc 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)
pprPat (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats)
pprPat (ConPatIn con details) = pprUserCon (unLoc con) details
pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
pat_binds = binds, pat_args = details })
= getPprStyle $ \ sty ->
if debugStyle sty then
ppr con
<> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
, ppr binds])
<+> pprConArgs details
else pprUserCon (unLoc con) details
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 (SplicePat splice) = pprUntypedSplice splice
pprPat (QuasiQuotePat qq) = ppr qq
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 :: (OutputableBndr con, OutputableBndr id) => con -> HsConPatDetails id -> SDoc
pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
pprUserCon c details = pprPrefixOcc c <+> pprConArgs details
pprConArgs :: OutputableBndr id => HsConPatDetails id -> SDoc
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 (HsRecFields id arg) where
ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })
= braces (fsep (punctuate comma (map ppr flds)))
ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n })
= braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))
where
dotdot = ptext (sLit "..") <+> ifPprDebug (ppr (drop n flds))
instance (OutputableBndr id, Outputable arg)
=> Outputable (HsRecField id arg) where
ppr (HsRecField { hsRecFieldId = f, hsRecFieldArg = arg,
hsRecPun = pun })
= ppr f <+> (ppUnless pun $ equals <+> ppr arg)
mkPrefixConPat :: DataCon -> [OutPat id] -> [Type] -> OutPat id
mkPrefixConPat dc pats tys
= noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc), pat_tvs = [], pat_dicts = [],
pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats,
pat_arg_tys = tys, pat_wrap = idHsWrapper }
mkNilPat :: Type -> OutPat id
mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
mkCharLitPat :: String -> Char -> OutPat id
mkCharLitPat src c = mkPrefixConPat charDataCon
[noLoc $ LitPat (HsCharPrim src c)] []
isStrictLPat :: LPat id -> Bool
isStrictLPat (L _ (ParPat p)) = isStrictLPat p
isStrictLPat (L _ (BangPat {})) = True
isStrictLPat (L _ (TuplePat _ Unboxed _)) = True
isStrictLPat _ = False
isStrictHsBind :: HsBind id -> Bool
isStrictHsBind (PatBind { pat_lhs = p }) = isStrictLPat p
isStrictHsBind _ = False
looksLazyPatBind :: HsBind id -> Bool
looksLazyPatBind (PatBind { pat_lhs = p }) = looksLazyLPat p
looksLazyPatBind _ = False
looksLazyLPat :: LPat id -> Bool
looksLazyLPat (L _ (ParPat p)) = looksLazyLPat p
looksLazyLPat (L _ (AsPat _ p)) = looksLazyLPat p
looksLazyLPat (L _ (BangPat {})) = False
looksLazyLPat (L _ (TuplePat _ Unboxed _)) = False
looksLazyLPat (L _ (VarPat {})) = False
looksLazyLPat (L _ (WildPat {})) = False
looksLazyLPat _ = True
isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool
isIrrefutableHsPat pat
= go pat
where
go (L _ pat) = go1 pat
go1 (WildPat {}) = True
go1 (VarPat {}) = True
go1 (LazyPat {}) = True
go1 (BangPat pat) = go pat
go1 (CoPat _ pat _) = go1 pat
go1 (ParPat pat) = go pat
go1 (AsPat _ pat) = go pat
go1 (ViewPat _ pat _) = go pat
go1 (SigPatIn pat _) = go pat
go1 (SigPatOut pat _) = go pat
go1 (TuplePat pats _ _) = all go pats
go1 (ListPat {}) = False
go1 (PArrPat {}) = False
go1 (ConPatIn {}) = False
go1 (ConPatOut{ pat_con = L _ (RealDataCon con), pat_args = details })
= isJust (tyConSingleDataCon_maybe (dataConTyCon con))
&& all go (hsConPatArgs details)
go1 (ConPatOut{ pat_con = L _ (PatSynCon _pat) })
= False
go1 (LitPat {}) = False
go1 (NPat {}) = False
go1 (NPlusKPat {}) = False
go1 (SplicePat {}) = urk pat
go1 (QuasiQuotePat {}) = urk pat
urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat)
hsPatNeedsParens :: Pat a -> Bool
hsPatNeedsParens (NPlusKPat {}) = True
hsPatNeedsParens (SplicePat {}) = False
hsPatNeedsParens (QuasiQuotePat {}) = True
hsPatNeedsParens (ConPatIn _ ds) = conPatNeedsParens ds
hsPatNeedsParens p@(ConPatOut {}) = conPatNeedsParens (pat_args p)
hsPatNeedsParens (SigPatIn {}) = True
hsPatNeedsParens (SigPatOut {}) = True
hsPatNeedsParens (ViewPat {}) = True
hsPatNeedsParens (CoPat {}) = True
hsPatNeedsParens (WildPat {}) = False
hsPatNeedsParens (VarPat {}) = False
hsPatNeedsParens (LazyPat {}) = False
hsPatNeedsParens (BangPat {}) = False
hsPatNeedsParens (ParPat {}) = False
hsPatNeedsParens (AsPat {}) = False
hsPatNeedsParens (TuplePat {}) = False
hsPatNeedsParens (ListPat {}) = False
hsPatNeedsParens (PArrPat {}) = False
hsPatNeedsParens (LitPat {}) = False
hsPatNeedsParens (NPat {}) = False
conPatNeedsParens :: HsConDetails a b -> Bool
conPatNeedsParens (PrefixCon args) = not (null args)
conPatNeedsParens (InfixCon {}) = True
conPatNeedsParens (RecCon {}) = True