%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[PatSyntax]{Abstract Haskell syntax---patterns}
\begin{code}
module HsPat (
Pat(..), InPat, OutPat, LPat,
HsConDetails(..),
HsConPatDetails, hsConPatArgs,
HsRecFields(..), HsRecField(..), hsRecFields,
mkPrefixConPat, mkCharLitPat, mkNilPat,
isBangHsBind, isLiftedPatBind,
isBangLPat, hsPatNeedsParens,
isIrrefutableHsPat,
pprParendLPat
) where
import HsExpr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprUntypedSplice)
import HsBinds
import HsLit
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)
import Data.Maybe
\end{code}
\begin{code}
type InPat id = LPat id
type OutPat id = LPat id
type LPat id = Located (Pat id)
data Pat id
=
WildPat PostTcType
| VarPat id
| LazyPat (LPat id)
| AsPat (Located id) (LPat id)
| ParPat (LPat id)
| BangPat (LPat id)
| ListPat [LPat id]
PostTcType
(Maybe (PostTcType, SyntaxExpr id))
| TuplePat [LPat id]
Boxity
PostTcType
| PArrPat [LPat id]
PostTcType
| ConPatIn (Located id)
(HsConPatDetails id)
| ConPatOut {
pat_con :: Located ConLike,
pat_tvs :: [TyVar],
pat_dicts :: [EvVar],
pat_binds :: TcEvBinds,
pat_args :: HsConPatDetails id,
pat_ty :: Type,
pat_wrap :: HsWrapper
}
| ViewPat (LHsExpr id)
(LPat id)
PostTcType
| 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 (LHsType id))
| SigPatOut (LPat id)
Type
| CoPat HsWrapper
(Pat id)
Type
deriving (Data, Typeable)
\end{code}
HsConDetails is use for patterns/expressions *and* for data type declarations
\begin{code}
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 (rec_flds fs)
hsConPatArgs (InfixCon p1 p2) = [p1,p2]
\end{code}
However HsRecFields is used only for patterns and expressions
(not data type declarations)
\begin{code}
data HsRecFields id arg
= HsRecFields { rec_flds :: [HsRecField id arg],
rec_dotdot :: Maybe Int }
deriving (Data, Typeable)
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) (rec_flds rbinds)
\end{code}
%************************************************************************
%* *
%* Printing patterns
%* *
%************************************************************************
\begin{code}
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)
\end{code}
%************************************************************************
%* *
%* Building patterns
%* *
%************************************************************************
\begin{code}
mkPrefixConPat :: DataCon -> [OutPat id] -> Type -> OutPat id
mkPrefixConPat dc pats ty
= noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc), pat_tvs = [], pat_dicts = [],
pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats,
pat_ty = ty, pat_wrap = idHsWrapper }
mkNilPat :: Type -> OutPat id
mkNilPat ty = mkPrefixConPat nilDataCon [] ty
mkCharLitPat :: Char -> OutPat id
mkCharLitPat c = mkPrefixConPat charDataCon [noLoc $ LitPat (HsCharPrim c)] charTy
\end{code}
%************************************************************************
%* *
%* Predicates for checking things about pattern-lists in EquationInfo *
%* *
%************************************************************************
\subsection[Pat-list-predicates]{Look for interesting things in patterns}
Unlike in the Wadler chapter, where patterns are either ``variables''
or ``constructors,'' here we distinguish between:
\begin{description}
\item[unfailable:]
Patterns that cannot fail to match: variables, wildcards, and lazy
patterns.
These are the irrefutable patterns; the two other categories
are refutable patterns.
\item[constructor:]
A non-literal constructor pattern (see next category).
\item[literal patterns:]
At least the numeric ones may be overloaded.
\end{description}
A pattern is in {\em exactly one} of the above three categories; `as'
patterns are treated specially, of course.
The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
\begin{code}
isBangLPat :: LPat id -> Bool
isBangLPat (L _ (BangPat {})) = True
isBangLPat (L _ (ParPat p)) = isBangLPat p
isBangLPat _ = False
isBangHsBind :: HsBind id -> Bool
isBangHsBind (PatBind { pat_lhs = p }) = isBangLPat p
isBangHsBind _ = False
isLiftedPatBind :: HsBind id -> Bool
isLiftedPatBind (PatBind { pat_lhs = p }) = isLiftedLPat p
isLiftedPatBind _ = False
isLiftedLPat :: LPat id -> Bool
isLiftedLPat (L _ (ParPat p)) = isLiftedLPat p
isLiftedLPat (L _ (BangPat p)) = isLiftedLPat p
isLiftedLPat (L _ (AsPat _ p)) = isLiftedLPat p
isLiftedLPat (L _ (TuplePat _ Unboxed _)) = False
isLiftedLPat (L _ (VarPat {})) = False
isLiftedLPat (L _ (WildPat {})) = False
isLiftedLPat _ = 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
\end{code}