X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsPat.lhs;h=953d228942a0c85da06b8035a72c430609819740;hb=5d3051c66796dcf884b052f9e4afc3ed19b9f514;hp=82ab6e30dd308c1dc6c956a181cb766986df83fa;hpb=23f40f0e9be6d4aa5cf9ea31d73f4013f8e7b4bd;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index 82ab6e3..953d228 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -11,26 +11,27 @@ module HsPat ( mkPrefixConPat, mkCharLitPat, mkNilPat, - isWildPat, - patsAreAllCons, isConPat, isSigPat, - patsAreAllLits, isLitPat + isBangHsBind, + patsAreAllCons, isConPat, isSigPat, isWildPat, + patsAreAllLits, isLitPat, isIrrefutableHsPat ) where #include "HsVersions.h" -import {-# SOURCE #-} HsExpr ( HsExpr ) +import {-# SOURCE #-} HsExpr ( SyntaxExpr ) -- friends: -import HsBinds ( DictBinds, emptyLHsBinds, pprLHsBinds ) +import HsBinds ( DictBinds, HsBind(..), emptyLHsBinds, pprLHsBinds ) import HsLit ( HsLit(HsCharPrim), HsOverLit ) -import HsTypes ( LHsType, SyntaxName, PostTcType ) +import HsTypes ( LHsType, PostTcType ) import BasicTypes ( Boxity, tupleParens ) -- others: import PprCore ( {- instance OutputableBndr TyVar -} ) import TysWiredIn ( nilDataCon, charDataCon, charTy ) import Var ( TyVar ) -import DataCon ( DataCon ) +import DataCon ( DataCon, dataConTyCon ) +import TyCon ( isProductTyCon ) import Outputable import Type ( Type ) import SrcLoc ( Located(..), unLoc, noLoc ) @@ -52,6 +53,7 @@ data Pat id | LazyPat (LPat id) -- Lazy pattern | AsPat (Located id) (LPat id) -- As pattern | ParPat (LPat id) -- Parenthesised pattern + | BangPat (LPat id) -- Bang patterng ------------ Lists, tuples, arrays --------------- | ListPat [LPat id] -- Syntactic list @@ -59,6 +61,18 @@ data Pat id | TuplePat [LPat id] -- Tuple Boxity -- UnitPat is TuplePat [] + PostTcType + -- You might think that the PostTcType was redundant, but it's essential + -- data T a where + -- T1 :: Int -> T Int + -- f :: (T a, a) -> Int + -- f (T1 x, z) = z + -- When desugaring, we must generate + -- f = /\a. \v::a. case v of (t::T a, w::a) -> + -- case t of (T1 (x::Int)) -> + -- Note the (w::a), NOT (w::Int), because we have not yet + -- refined 'a' to Int. So we must know that the second component + -- of the tuple is of type 'a' not Int. See selectMatchVar | PArrPat [LPat id] -- Syntactic parallel array PostTcType -- The type of the elements @@ -67,7 +81,7 @@ data Pat id | ConPatIn (Located id) (HsConDetails id (LPat id)) - | ConPatOut DataCon + | ConPatOut (Located DataCon) [TyVar] -- Existentially bound type variables [id] -- Ditto dictionaries (DictBinds id) -- Bindings involving those dictionaries @@ -78,28 +92,16 @@ data Pat id | LitPat HsLit -- Used for *non-overloaded* literal patterns: -- Int#, Char#, Int, Char, String, etc. - | NPatIn HsOverLit -- Always positive - (Maybe SyntaxName) -- Just (Name of 'negate') for negative - -- patterns, Nothing otherwise - - | NPatOut HsLit -- Used for literal patterns where there's an equality function to call - -- The literal is retained so that the desugarer can readily identify - -- equations with identical literal-patterns - -- Always HsInteger, HsRat or HsString. - -- *Unlike* NPatIn, for negative literals, the - -- literal is acutally negative! - Type -- Type of pattern, t - (HsExpr id) -- Of type t -> Bool; detects match - - | NPlusKPatIn (Located id) -- n+k pattern - HsOverLit -- It'll always be an HsIntegral - SyntaxName -- Name of '-' (see RnEnv.lookupSyntaxName) - - | NPlusKPatOut (Located id) - Integer - (HsExpr id) -- Of type t -> Bool; detects match - (HsExpr id) -- Of type t -> t; subtracts k + | NPat (HsOverLit id) -- ALWAYS positive + (Maybe (SyntaxExpr id)) -- Just (Name of 'negate') for negative + -- patterns, Nothing otherwise + (SyntaxExpr id) -- Equality checker, of type t->t->Bool + PostTcType -- Type of the pattern + | NPlusKPat (Located id) -- n+k pattern + (HsOverLit id) -- It'll always be an HsIntegral + (SyntaxExpr id) -- (>=) function, of type t->t->Bool + (SyntaxExpr id) -- Name of '-' (see RnEnv.lookupSyntaxName) ------------ Generics --------------- | TypePat (LHsType id) -- Type pattern for generic definitions @@ -155,17 +157,16 @@ pprPatBndr var -- Print with type info if -dppr-debug is on ppr var pprPat :: (OutputableBndr name) => Pat name -> SDoc - pprPat (VarPat var) = pprPatBndr var pprPat (VarPatOut var bs) = parens (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 (ParPat pat) = parens (ppr pat) - -pprPat (ListPat pats _) = brackets (interpp'SP pats) -pprPat (PArrPat pats _) = pabrackets (interpp'SP pats) -pprPat (TuplePat pats bx) = tupleParens bx (interpp'SP pats) +pprPat (ListPat pats _) = brackets (interpp'SP pats) +pprPat (PArrPat pats _) = pabrackets (interpp'SP pats) +pprPat (TuplePat pats bx _) = tupleParens bx (interpp'SP pats) pprPat (ConPatIn con details) = pprUserCon con details pprPat (ConPatOut con tvs dicts binds details _) @@ -177,10 +178,9 @@ pprPat (ConPatOut con tvs dicts binds details _) else pprUserCon con details pprPat (LitPat s) = ppr s -pprPat (NPatIn l _) = ppr l -pprPat (NPatOut l _ _) = ppr l -pprPat (NPlusKPatIn n k _) = hcat [ppr n, char '+', ppr k] -pprPat (NPlusKPatOut n k _ _) = hcat [ppr n, char '+', integer k] +pprPat (NPat l Nothing _ _) = ppr l +pprPat (NPat l (Just _) _ _) = char '-' <> ppr l +pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k] pprPat (TypePat ty) = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}") pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty @@ -214,7 +214,7 @@ pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") \begin{code} mkPrefixConPat :: DataCon -> [OutPat id] -> Type -> OutPat id -- Make a vanilla Prefix constructor pattern -mkPrefixConPat dc pats ty = noLoc $ ConPatOut dc [] [] emptyLHsBinds (PrefixCon pats) ty +mkPrefixConPat dc pats ty = noLoc $ ConPatOut (noLoc dc) [] [] emptyLHsBinds (PrefixCon pats) ty mkNilPat :: Type -> OutPat id mkNilPat ty = mkPrefixConPat nilDataCon [] ty @@ -265,7 +265,7 @@ isConPat (ConPatIn _ _) = True isConPat (ConPatOut _ _ _ _ _ _) = True isConPat (ListPat _ _) = True isConPat (PArrPat _ _) = True -isConPat (TuplePat _ _) = True +isConPat (TuplePat _ _ _) = True isConPat (DictPat ds ms) = (length ds + length ms) > 1 isConPat other = False @@ -278,10 +278,47 @@ patsAreAllLits pat_list = all isLitPat pat_list isLitPat (AsPat _ pat) = isLitPat (unLoc pat) isLitPat (LitPat _) = True -isLitPat (NPatIn _ _) = True -isLitPat (NPatOut _ _ _) = True -isLitPat (NPlusKPatIn _ _ _) = True -isLitPat (NPlusKPatOut _ _ _ _) = True +isLitPat (NPat _ _ _ _) = True +isLitPat (NPlusKPat _ _ _ _) = True isLitPat other = False + +isBangHsBind :: HsBind id -> Bool +-- In this module because HsPat is above HsBinds in the import graph +isBangHsBind (PatBind { pat_lhs = L _ (BangPat p) }) = True +isBangHsBind bind = False + +isIrrefutableHsPat :: LPat id -> Bool +-- This function returns False if it's in doubt; specifically +-- on a ConPatIn it doesn't know the size of the constructor family +-- But if it returns True, the pattern is definitely irrefutable +isIrrefutableHsPat pat + = go pat + where + go (L _ pat) = go1 pat + + go1 (WildPat _) = True + go1 (VarPat _) = True + go1 (VarPatOut _ _) = True + go1 (LazyPat pat) = True + go1 (BangPat pat) = go pat + go1 (ParPat pat) = go pat + go1 (AsPat _ pat) = go pat + go1 (SigPatIn pat _) = go pat + go1 (SigPatOut pat _) = go pat + go1 (TuplePat pats _ _) = all go pats + go1 (ListPat pats _) = False + go1 (PArrPat pats _) = False -- ? + + go1 (ConPatIn _ _) = False -- Conservative + go1 (ConPatOut (L _ con) _ _ _ details _) + = isProductTyCon (dataConTyCon con) + && all go (hsConArgs details) + + go1 (LitPat _) = False + go1 (NPat _ _ _ _) = False + go1 (NPlusKPat _ _ _ _) = False + + go1 (TypePat _) = panic "isIrrefutableHsPat: type pattern" + go1 (DictPat _ _) = panic "isIrrefutableHsPat: type pattern" \end{code}