X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsPat.lhs;h=6e4051ec83286affb70c2ed0450a050454fd5401;hb=f6d1d276e759f97c80bec8974343322b28ea0545;hp=d96e8ecc8ccc140ed2f2af29e1a74f994f1068fe;hpb=7b0181919416d8f04324575b7e17031ca692f5b0;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index d96e8ec..6e4051e 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -1,37 +1,36 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[PatSyntax]{Abstract Haskell syntax---patterns} \begin{code} -#include "HsVersions.h" - module HsPat ( InPat(..), OutPat(..), - unfailablePats, unfailablePat, + irrefutablePat, irrefutablePats, + failureFreePat, isWildPat, patsAreAllCons, isConPat, patsAreAllLits, isLitPat, - irrefutablePat, - collectPatBinders + collectPatBinders, collectPatsBinders ) where -import Ubiq +#include "HsVersions.h" -- friends: -import HsLit ( HsLit ) -import HsLoop ( HsExpr ) +import HsBasic ( HsLit ) +import HsExpr ( HsExpr ) +import HsTypes ( HsType ) +import BasicTypes ( Fixity, Boxity, tupleParens ) -- others: -import Id ( GenId, dataConSig ) +import Var ( Id, TyVar ) +import DataCon ( DataCon, dataConTyCon ) +import Name ( isDataSymOcc, getOccName, NamedThing ) import Maybes ( maybeToBool ) -import Name ( pprOp, pprNonOp ) -import Outputable ( interppSP, interpp'SP, ifPprShowAll ) -import PprStyle ( PprStyle(..) ) -import Pretty +import Outputable import TyCon ( maybeTyConSingleCon ) -import PprType ( GenType ) +import Type ( Type ) \end{code} Patterns come in distinct before- and after-typechecking flavo(u)rs. @@ -43,12 +42,18 @@ data InPat name | LazyPatIn (InPat name) -- lazy pattern | AsPatIn name -- as pattern (InPat name) + | SigPatIn (InPat name) + (HsType name) | ConPatIn name -- constructed type [InPat name] | ConOpPatIn (InPat name) name + Fixity -- c.f. OpApp in HsExpr (InPat name) + | NPlusKPatIn name -- n+k pattern + HsLit + -- We preserve prefix negation and parenthesis for the precedence parser. | NegPatIn (InPat name) -- negated pattern @@ -56,150 +61,167 @@ data InPat name | ListPatIn [InPat name] -- syntactic list -- must have >= 1 elements - | TuplePatIn [InPat name] -- tuple + | TuplePatIn [InPat name] Boxity -- tuple (boxed?) | RecPatIn name -- record [(name, InPat name, Bool)] -- True <=> source used punning -data OutPat tyvar uvar id - = WildPat (GenType tyvar uvar) -- wild card - - | VarPat id -- variable (type is in the Id) +data OutPat id + = WildPat Type -- wild card + | VarPat id -- variable (type is in the Id) + | LazyPat (OutPat id) -- lazy pattern + | AsPat id -- as pattern + (OutPat id) - | LazyPat (OutPat tyvar uvar id) -- lazy pattern + | ListPat -- syntactic list + Type -- the type of the elements + [OutPat id] - | AsPat id -- as pattern - (OutPat tyvar uvar id) - - | ConPat Id -- Constructor is always an Id - (GenType tyvar uvar) -- the type of the pattern - [(OutPat tyvar uvar id)] + | TuplePat [OutPat id] -- tuple + Boxity + -- UnitPat is TuplePat [] - | ConOpPat (OutPat tyvar uvar id) -- just a special case... - Id - (OutPat tyvar uvar id) - (GenType tyvar uvar) - | ListPat -- syntactic list - (GenType tyvar uvar) -- the type of the elements - [(OutPat tyvar uvar id)] + | ConPat DataCon + Type -- the type of the pattern + [TyVar] -- Existentially bound type variables + [id] -- Ditto dictionaries + [OutPat id] - | TuplePat [(OutPat tyvar uvar id)] -- tuple - -- UnitPat is TuplePat [] + -- ConOpPats are only used on the input side - | RecPat Id -- record constructor - (GenType tyvar uvar) -- the type of the pattern - [(id, OutPat tyvar uvar id, Bool)] -- True <=> source used punning + | RecPat DataCon -- record constructor + Type -- the type of the pattern + [TyVar] -- Existentially bound type variables + [id] -- Ditto dictionaries + [(Id, OutPat id, Bool)] -- True <=> source used punning | LitPat -- Used for *non-overloaded* literal patterns: -- Int#, Char#, Int, Char, String, etc. HsLit - (GenType tyvar uvar) -- type of pattern + Type -- type of pattern | NPat -- Used for *overloaded* literal patterns HsLit -- the literal is retained so that -- the desugarer can readily identify -- equations with identical literal-patterns - (GenType tyvar uvar) -- type of pattern, t - (HsExpr tyvar uvar id (OutPat tyvar uvar id)) + Type -- type of pattern, t + (HsExpr id (OutPat id)) -- of type t -> Bool; detects match - | DictPat -- Used when destructing Dictionaries with an explicit case + | NPlusKPat id + HsLit -- Same reason as for LitPat + -- (This could be an Integer, but then + -- it's harder to partitionEqnsByLit + -- in the desugarer.) + Type -- Type of pattern, t + (HsExpr id (OutPat id)) -- Of type t -> Bool; detects match + (HsExpr id (OutPat id)) -- Of type t -> t; subtracts k + + | DictPat -- Used when destructing Dictionaries with an explicit case [id] -- superclass dicts [id] -- methods \end{code} +Now name in Inpat is not need to be in NAmedThing to be Outputable. +Needed by ../deSugar/Check.lhs + +JJQC-2-12-97 + \begin{code} -instance (Outputable name, NamedThing name) => Outputable (InPat name) where +instance (Outputable name) => Outputable (InPat name) where ppr = pprInPat -pprInPat :: (Outputable name, NamedThing name) => PprStyle -> InPat name -> Pretty +pprInPat :: (Outputable name) => InPat name -> SDoc -pprInPat sty (WildPatIn) = ppStr "_" -pprInPat sty (VarPatIn var) = pprNonOp sty var -pprInPat sty (LitPatIn s) = ppr sty s -pprInPat sty (LazyPatIn pat) = ppBeside (ppChar '~') (ppr sty pat) -pprInPat sty (AsPatIn name pat) - = ppBesides [ppLparen, ppr sty name, ppChar '@', ppr sty pat, ppRparen] +pprInPat (WildPatIn) = char '_' +pprInPat (VarPatIn var) = ppr var +pprInPat (LitPatIn s) = ppr s +pprInPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty +pprInPat (LazyPatIn pat) = char '~' <> ppr pat +pprInPat (AsPatIn name pat) = parens (hcat [ppr name, char '@', ppr pat]) -pprInPat sty (ConPatIn c pats) - = if null pats then - ppr sty c - else - ppBesides [ppLparen, ppr sty c, ppSP, interppSP sty pats, ppRparen] +pprInPat (ConPatIn c pats) + | null pats = ppr c + | otherwise = hsep [ppr c, interppSP pats] -- inner ParPats supply the necessary parens. +pprInPat (ConOpPatIn pat1 op fixity pat2) + = hsep [ppr pat1, ppr op, ppr pat2] -- ParPats put in parens -pprInPat sty (ConOpPatIn pat1 op pat2) - = ppBesides [ppLparen, ppr sty pat1, ppSP, ppr sty op, ppSP, ppr sty pat2, ppRparen] - - -- ToDo: use pprOp to print op (but this involves fiddling various + -- ToDo: use pprSym to print op (but this involves fiddling various -- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP) -pprInPat sty (NegPatIn pat) - = ppBeside (ppChar '-') (ppParens (pprInPat sty pat)) - -pprInPat sty (ParPatIn pat) - = ppParens (pprInPat sty pat) - - -pprInPat sty (ListPatIn pats) - = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack] -pprInPat sty (TuplePatIn pats) - = ppBesides [ppLparen, interpp'SP sty pats, ppRparen] - -pprInPat sty (RecPatIn con rpats) - = ppBesides [ppr sty con, ppSP, ppChar '{', ppInterleave ppComma (map pp_rpat rpats), ppChar '}'] +pprInPat (NegPatIn pat) + = let + pp_pat = pprInPat pat + in + char '-' <> ( + case pat of + LitPatIn _ -> pp_pat + _ -> parens pp_pat + ) + +pprInPat (ParPatIn pat) + = parens (pprInPat pat) + +pprInPat (ListPatIn pats) + = brackets (interpp'SP pats) +pprInPat (TuplePatIn pats boxity) + = tupleParens boxity (interpp'SP pats) +pprInPat (NPlusKPatIn n k) + = parens (hcat [ppr n, char '+', ppr k]) + +pprInPat (RecPatIn con rpats) + = hsep [ppr con, braces (hsep (punctuate comma (map (pp_rpat) rpats)))] where - pp_rpat (v, _, True{-pun-}) = ppr sty v - pp_rpat (v, p, _) = ppCat [ppr sty v, ppStr "<-", ppr sty p] + pp_rpat (v, _, True) = ppr v + pp_rpat (v, p, _) = hsep [ppr v, char '=', ppr p] \end{code} \begin{code} -instance (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar, - NamedThing id, Outputable id) - => Outputable (OutPat tyvar uvar id) where +instance (NamedThing id, Outputable id) => Outputable (OutPat id) where ppr = pprOutPat \end{code} \begin{code} -pprOutPat sty (WildPat ty) = ppChar '_' -pprOutPat sty (VarPat var) = pprNonOp sty var -pprOutPat sty (LazyPat pat) = ppBesides [ppChar '~', ppr sty pat] -pprOutPat sty (AsPat name pat) - = ppBesides [ppLparen, ppr sty name, ppChar '@', ppr sty pat, ppRparen] - -pprOutPat sty (ConPat name ty []) - = ppBeside (ppr sty name) - (ifPprShowAll sty (pprConPatTy sty ty)) - -pprOutPat sty (ConPat name ty pats) - = ppBesides [ppLparen, ppr sty name, ppSP, - interppSP sty pats, ppRparen, - ifPprShowAll sty (pprConPatTy sty ty) ] - -pprOutPat sty (ConOpPat pat1 op pat2 ty) - = ppBesides [ppLparen, ppr sty pat1, ppSP, pprOp sty op, ppSP, ppr sty pat2, ppRparen] - -pprOutPat sty (ListPat ty pats) - = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack] -pprOutPat sty (TuplePat pats) - = ppBesides [ppLparen, interpp'SP sty pats, ppRparen] - -pprOutPat sty (RecPat con ty rpats) - = ppBesides [ppr sty con, ppChar '{', ppInterleave ppComma (map pp_rpat rpats), ppChar '}'] +pprOutPat (WildPat ty) = char '_' +pprOutPat (VarPat var) = ppr var +pprOutPat (LazyPat pat) = hcat [char '~', ppr pat] +pprOutPat (AsPat name pat) + = parens (hcat [ppr name, char '@', ppr pat]) + +pprOutPat (ConPat name ty [] [] []) + = ppr name + +-- Kludge to get infix constructors to come out right +-- when ppr'ing desugar warnings. +pprOutPat (ConPat name ty tyvars dicts pats) + = getPprStyle $ \ sty -> + parens $ + case pats of + [p1,p2] + | userStyle sty && isDataSymOcc (getOccName name) -> + hsep [ppr p1, ppr name, ppr p2] + _ -> hsep [ppr name, interppSP tyvars, interppSP dicts, interppSP pats] + +pprOutPat (ListPat ty pats) = brackets (interpp'SP pats) +pprOutPat (TuplePat pats boxity) = tupleParens boxity (interpp'SP pats) + +pprOutPat (RecPat con ty tvs dicts rpats) + = hsep [ppr con, interppSP tvs, interppSP dicts, braces (hsep (punctuate comma (map (pp_rpat) rpats)))] where --- pp_rpat (v, _, True{-pun-}) = ppr sty v - pp_rpat (v, p, _) = ppBesides [ppr sty v, ppStr "<-", ppr sty p] + pp_rpat (v, _, True) = ppr v + pp_rpat (v, p, _) = hsep [ppr v, char '=', ppr p] -pprOutPat sty (LitPat l ty) = ppr sty l -- ToDo: print more -pprOutPat sty (NPat l ty e) = ppr sty l -- ToDo: print more +pprOutPat (LitPat l ty) = ppr l -- ToDo: print more +pprOutPat (NPat l ty e) = ppr l -- ToDo: print more +pprOutPat (NPlusKPat n k ty e1 e2) -- ToDo: print more + = parens (hcat [ppr n, char '+', ppr k]) -pprOutPat sty (DictPat dicts methods) - = ppSep [ppBesides [ppLparen, ppPStr SLIT("{-dict-}")], - ppBracket (interpp'SP sty dicts), - ppBesides [ppBracket (interpp'SP sty methods), ppRparen]] +pprOutPat (DictPat dicts methods) + = parens (sep [ptext SLIT("{-dict-}"), + brackets (interpp'SP dicts), + brackets (interpp'SP methods)]) -pprConPatTy sty ty - = ppParens (ppr sty ty) \end{code} %************************************************************************ @@ -229,70 +251,82 @@ At least the numeric ones may be overloaded. 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} -unfailablePats :: [OutPat a b c] -> Bool -unfailablePats pat_list = all unfailablePat pat_list +irrefutablePats :: [OutPat id] -> Bool +irrefutablePats pat_list = all irrefutablePat pat_list + +irrefutablePat (AsPat _ pat) = irrefutablePat pat +irrefutablePat (WildPat _) = True +irrefutablePat (VarPat _) = True +irrefutablePat (LazyPat _) = True +irrefutablePat (DictPat ds ms) = (length ds + length ms) <= 1 +irrefutablePat other = False + +failureFreePat :: OutPat id -> Bool + +failureFreePat (WildPat _) = True +failureFreePat (VarPat _) = True +failureFreePat (LazyPat _) = True +failureFreePat (AsPat _ pat) = failureFreePat pat +failureFreePat (ConPat con tys _ _ pats) = only_con con && all failureFreePat pats +failureFreePat (RecPat con _ _ _ fields) = only_con con && and [ failureFreePat pat | (_,pat,_) <- fields ] +failureFreePat (ListPat _ _) = False +failureFreePat (TuplePat pats _) = all failureFreePat pats +failureFreePat (DictPat _ _) = True +failureFreePat other_pat = False -- Literals, NPat + +only_con con = maybeToBool (maybeTyConSingleCon (dataConTyCon con)) +\end{code} -unfailablePat (AsPat _ pat) = unfailablePat pat -unfailablePat (WildPat _) = True -unfailablePat (VarPat _) = True -unfailablePat (LazyPat _) = True -unfailablePat (DictPat ds ms) = (length ds + length ms) <= 1 -unfailablePat other = False +\begin{code} +isWildPat (WildPat _) = True +isWildPat other = False -patsAreAllCons :: [OutPat a b c] -> Bool +patsAreAllCons :: [OutPat id] -> Bool patsAreAllCons pat_list = all isConPat pat_list isConPat (AsPat _ pat) = isConPat pat -isConPat (ConPat _ _ _) = True -isConPat (ConOpPat _ _ _ _) = True +isConPat (ConPat _ _ _ _ _) = True isConPat (ListPat _ _) = True -isConPat (TuplePat _) = True +isConPat (TuplePat _ _) = True +isConPat (RecPat _ _ _ _ _) = True isConPat (DictPat ds ms) = (length ds + length ms) > 1 isConPat other = False -patsAreAllLits :: [OutPat a b c] -> Bool +patsAreAllLits :: [OutPat id] -> Bool patsAreAllLits pat_list = all isLitPat pat_list -isLitPat (AsPat _ pat) = isLitPat pat -isLitPat (LitPat _ _) = True -isLitPat (NPat _ _ _) = True -isLitPat other = False -\end{code} - -A pattern is irrefutable if a match on it cannot fail -(at any depth). -\begin{code} -irrefutablePat :: OutPat a b c -> Bool - -irrefutablePat (WildPat _) = True -irrefutablePat (VarPat _) = True -irrefutablePat (LazyPat _) = True -irrefutablePat (AsPat _ pat) = irrefutablePat pat -irrefutablePat (ConPat con tys pats) = all irrefutablePat pats && only_con con -irrefutablePat (ConOpPat pat1 con pat2 _) = irrefutablePat pat1 && irrefutablePat pat1 && only_con con -irrefutablePat (ListPat _ _) = False -irrefutablePat (TuplePat pats) = all irrefutablePat pats -irrefutablePat (DictPat _ _) = True -irrefutablePat other_pat = False -- Literals, NPat - -only_con con = maybeToBool (maybeTyConSingleCon tycon) - where - (_,_,_,tycon) = dataConSig con +isLitPat (AsPat _ pat) = isLitPat pat +isLitPat (LitPat _ _) = True +isLitPat (NPat _ _ _) = True +isLitPat (NPlusKPat _ _ _ _ _) = True +isLitPat other = False \end{code} This function @collectPatBinders@ works with the ``collectBinders'' functions for @HsBinds@, etc. The order in which the binders are collected is important; see @HsBinds.lhs@. + \begin{code} collectPatBinders :: InPat a -> [a] - -collectPatBinders (VarPatIn var) = [var] -collectPatBinders (LazyPatIn pat) = collectPatBinders pat -collectPatBinders (AsPatIn a pat) = a : collectPatBinders pat -collectPatBinders (ConPatIn c pats) = concat (map collectPatBinders pats) -collectPatBinders (ConOpPatIn p1 c p2)= collectPatBinders p1 ++ collectPatBinders p2 -collectPatBinders (ListPatIn pats) = concat (map collectPatBinders pats) -collectPatBinders (TuplePatIn pats) = concat (map collectPatBinders pats) -collectPatBinders any_other_pat = [ {-no binders-} ] +collectPatBinders pat = collect pat [] + +collectPatsBinders :: [InPat a] -> [a] +collectPatsBinders pats = foldr collect [] pats + +collect WildPatIn bndrs = bndrs +collect (VarPatIn var) bndrs = var : bndrs +collect (LitPatIn _) bndrs = bndrs +collect (SigPatIn pat _) bndrs = collect pat bndrs +collect (LazyPatIn pat) bndrs = collect pat bndrs +collect (AsPatIn a pat) bndrs = a : collect pat bndrs +collect (NPlusKPatIn n _) bndrs = n : bndrs +collect (ConPatIn c pats) bndrs = foldr collect bndrs pats +collect (ConOpPatIn p1 c f p2) bndrs = collect p1 (collect p2 bndrs) +collect (NegPatIn pat) bndrs = collect pat bndrs +collect (ParPatIn pat) bndrs = collect pat bndrs +collect (ListPatIn pats) bndrs = foldr collect bndrs pats +collect (TuplePatIn pats _) bndrs = foldr collect bndrs pats +collect (RecPatIn c fields) bndrs = foldr (\ (f,pat,_) bndrs -> collect pat bndrs) bndrs fields \end{code}