X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsPat.lhs;h=ec92913b7d05d6ce1d3cc4654fbd0ce826042377;hb=920d0d7e8f4adf97a2adbc08317522e34de10c65;hp=73124ac4f0f4b0cacc0458a35a2dbbe6202b4ad7;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index 73124ac..ec92913 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -1,39 +1,38 @@ % -% (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, + collectSigTysFromPats ) where -import Ubiq +#include "HsVersions.h" + -- friends: -import HsLit ( HsLit ) -import HsLoop ( HsExpr ) +import HsLit ( HsLit, HsOverLit ) +import HsExpr ( HsExpr ) +import HsTypes ( HsType ) +import BasicTypes ( Fixity, Boxity, tupleParens ) -- others: -import Id ( GenId, getDataConSig ) +import Var ( Id, TyVar ) +import DataCon ( DataCon, dataConTyCon ) +import Name ( isDataSymOcc, getOccName, NamedThing ) import Maybes ( maybeToBool ) -import Outputable -import PprStyle ( PprStyle(..) ) -import Pretty +import Outputable import TyCon ( maybeTyConSingleCon ) -import TyVar ( GenTyVar ) -import PprType ( GenType, GenTyVar ) -import Unique ( Unique ) - +import Type ( Type ) \end{code} Patterns come in distinct before- and after-typechecking flavo(u)rs. @@ -45,149 +44,180 @@ 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) - | ListPatIn [InPat name] -- syntactic list - -- must have >= 1 elements - | TuplePatIn [InPat name] -- tuple - | RecPatIn name -- record - [(name, Maybe (InPat name))] + | NPatIn HsOverLit -data OutPat tyvar uvar id - = WildPat (GenType tyvar uvar) -- wild card + | NPlusKPatIn name -- n+k pattern + HsOverLit -- It'll always be an HsIntegral - | VarPat id -- variable (type is in the Id) + -- We preserve prefix negation and parenthesis for the precedence parser. - | LazyPat (OutPat tyvar uvar id) -- lazy pattern + | ParPatIn (InPat name) -- parenthesised pattern - | 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)] - - | 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)] - - | TuplePat [(OutPat tyvar uvar id)] -- tuple - -- UnitPat is TuplePat [] + | ListPatIn [InPat name] -- syntactic list + -- must have >= 1 elements + | TuplePatIn [InPat name] Boxity -- tuple (boxed?) - | RecPat id -- record - [(id, Maybe (OutPat tyvar uvar id))] + | RecPatIn name -- record + [(name, InPat name, Bool)] -- True <=> source used punning + +-- Generics + | TypePatIn (HsType name) -- Type pattern for generic definitions + -- e.g f{| a+b |} = ... + -- These show up only in class + -- declarations, + -- and should be a top-level pattern + +-- /Generics + +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) + + | ListPat -- Syntactic list + Type -- The type of the elements + [OutPat id] + + | TuplePat [OutPat id] -- Tuple + Boxity + -- UnitPat is TuplePat [] + + | ConPat DataCon + Type -- the type of the pattern + [TyVar] -- Existentially bound type variables + [id] -- Ditto dictionaries + [OutPat id] + + -- ConOpPats are only used on the input side + + | 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 + 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)) - -- of type t -> Bool; detects match + -- Always HsInt, HsRat or HsString. + Type -- Type of pattern, t + (HsExpr id (OutPat id)) -- Of type t -> Bool; detects match + + | NPlusKPat id + Integer + 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 + | DictPat -- Used when destructing Dictionaries with an explicit case [id] -- superclass dicts [id] -- methods \end{code} -\begin{code} -instance (Outputable name, NamedThing name) => Outputable (InPat name) where - ppr = pprInPat +Now name in Inpat is not need to be in NAmedThing to be Outputable. +Needed by ../deSugar/Check.lhs -pprInPat :: (Outputable name, NamedThing name) => PprStyle -> InPat name -> Pretty +JJQC-2-12-97 -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] +\begin{code} +instance (Outputable name) => Outputable (InPat name) where + ppr = pprInPat -pprInPat sty (ConPatIn c pats) - = if null pats then - ppr sty c - else - ppBesides [ppLparen, ppr sty c, ppSP, interppSP sty pats, ppRparen] +pprInPat :: (Outputable name) => InPat name -> SDoc +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 (ParPatIn pat) = parens (pprInPat pat) +pprInPat (ListPatIn pats) = brackets (interpp'SP pats) +pprInPat (TuplePatIn pats bx) = tupleParens bx (interpp'SP pats) +pprInPat (NPlusKPatIn n k) = parens (hcat [ppr n, char '+', ppr k]) +pprInPat (NPatIn l) = ppr l -pprInPat sty (ConOpPatIn pat1 op pat2) - = ppBesides [ppLparen, ppr sty pat1, ppSP, ppr sty op, ppSP, ppr sty pat2, ppRparen] +pprInPat (ConPatIn c pats) + | null pats = ppr c + | otherwise = hsep [ppr c, interppSP pats] -- inner ParPats supply the necessary parens. --- ToDo: use pprOp to print op (but this involves fiddling various --- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP) +pprInPat (ConOpPatIn pat1 op fixity pat2) + = hsep [ppr pat1, ppr op, ppr pat2] -- ParPats put in parens -pprInPat sty (ListPatIn pats) - = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack] -pprInPat sty (TuplePatIn pats) - = ppBesides [ppLparen, interpp'SP sty pats, ppRparen] + -- ToDo: use pprSym to print op (but this involves fiddling various + -- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP) -pprInPat sty (RecPatIn con rpats) - = ppBesides [ppr sty con, ppSP, ppChar '{', ppInterleave ppComma (map pp_rpat rpats), ppChar '}'] +pprInPat (RecPatIn con rpats) + = hsep [ppr con, braces (hsep (punctuate comma (map (pp_rpat) rpats)))] where - pp_rpat (v, Nothing) = ppr sty v - pp_rpat (v, Just 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] + +pprInPat (TypePatIn ty) = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}") \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 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, Nothing) = ppr sty v - pp_rpat (v, Just 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 '+', integer 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 - = ppBesides [ppLparen, ppr sty ty, ppRparen] \end{code} %************************************************************************ @@ -217,70 +247,108 @@ 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) = getDataConSig 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 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 (NPatIn _) bndrs = bndrs +collect (ConPatIn c pats) bndrs = foldr collect bndrs pats +collect (ConOpPatIn p1 c f p2) bndrs = collect p1 (collect p2 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 +-- Generics +collect (TypePatIn ty) bndrs = bndrs +-- assume the type variables do not need to be bound +\end{code} -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-} ] +\begin{code} +collectSigTysFromPats :: [InPat name] -> [HsType name] +collectSigTysFromPats pats = foldr collect_pat [] pats + +collect_pat (SigPatIn pat ty) acc = collect_pat pat (ty:acc) +collect_pat WildPatIn acc = acc +collect_pat (VarPatIn var) acc = acc +collect_pat (LitPatIn _) acc = acc +collect_pat (LazyPatIn pat) acc = collect_pat pat acc +collect_pat (AsPatIn a pat) acc = collect_pat pat acc +collect_pat (NPatIn _) acc = acc +collect_pat (NPlusKPatIn n _) acc = acc +collect_pat (ConPatIn c pats) acc = foldr collect_pat acc pats +collect_pat (ConOpPatIn p1 c f p2) acc = collect_pat p1 (collect_pat p2 acc) +collect_pat (ParPatIn pat) acc = collect_pat pat acc +collect_pat (ListPatIn pats) acc = foldr collect_pat acc pats +collect_pat (TuplePatIn pats _) acc = foldr collect_pat acc pats +collect_pat (RecPatIn c fields) acc = foldr (\ (f,pat,_) acc -> collect_pat pat acc) acc fields +-- Generics +collect_pat (TypePatIn ty) acc = ty:acc \end{code} +