X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsPat.lhs;h=c801a86888a8ddc91a456d0bd8d72918c529e2ee;hb=cabac059f16560ffed23a504a1d793d108dc6653;hp=ffbd373b16ebf920eadcea80a9285a2e274230e1;hpb=be33dbc967b4915cfdb0307ae1b7ae3cee651b8c;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index ffbd373..c801a86 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[PatSyntax]{Abstract Haskell syntax---patterns} @@ -9,26 +9,31 @@ module HsPat ( OutPat(..), irrefutablePat, irrefutablePats, - failureFreePat, - patsAreAllCons, isConPat, + failureFreePat, isWildPat, + patsAreAllCons, isConPat, patsAreAllLits, isLitPat, - collectPatBinders + collectPatBinders, collectOutPatBinders, collectPatsBinders, + collectSigTysFromPat, collectSigTysFromPats ) where #include "HsVersions.h" + -- friends: -import HsBasic ( HsLit ) +import HsLit ( HsLit, HsOverLit ) import HsExpr ( HsExpr ) -import BasicTypes ( Fixity ) +import HsTypes ( HsType ) +import BasicTypes ( Fixity, Boxity, tupleParens ) -- others: -import Id ( Id, dataConTyCon, GenId ) +import Name ( Name ) +import Var ( Id, TyVar ) +import DataCon ( DataCon, dataConTyCon ) +import Name ( isDataSymOcc, getOccName, NamedThing ) import Maybes ( maybeToBool ) import Outputable import TyCon ( maybeTyConSingleCon ) -import PprType ( GenType ) -import Name ( NamedThing ) +import Type ( Type ) \end{code} Patterns come in distinct before- and after-typechecking flavo(u)rs. @@ -40,6 +45,8 @@ 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) @@ -47,71 +54,90 @@ data InPat name Fixity -- c.f. OpApp in HsExpr (InPat name) - | NPlusKPatIn name -- n+k pattern - HsLit + | NPatIn HsOverLit + + | NPlusKPatIn name -- n+k pattern + HsOverLit -- It'll always be an HsIntegral + Name -- Name of '-' (see RnEnv.lookupSyntaxName) -- We preserve prefix negation and parenthesis for the precedence parser. - | NegPatIn (InPat name) -- negated pattern | ParPatIn (InPat name) -- parenthesised pattern | ListPatIn [InPat name] -- syntactic list -- must have >= 1 elements - | TuplePatIn [InPat name] -- tuple + | PArrPatIn [InPat name] -- syntactic parallel array + -- must have >= 1 elements + | TuplePatIn [InPat name] Boxity -- tuple (boxed?) | RecPatIn name -- record [(name, InPat name, Bool)] -- True <=> source used punning -data OutPat flexi id - = WildPat (GenType flexi) -- wild card - - | VarPat id -- variable (type is in the Id) - - | LazyPat (OutPat flexi id) -- lazy pattern - - | AsPat id -- as pattern - (OutPat flexi id) - - | ConPat Id -- Constructor is always an Id - (GenType flexi) -- the type of the pattern - [OutPat flexi id] - - | ConOpPat (OutPat flexi id) -- just a special case... - Id - (OutPat flexi id) - (GenType flexi) - | ListPat -- syntactic list - (GenType flexi) -- the type of the elements - [OutPat flexi id] - - | TuplePat [OutPat flexi id] -- tuple - -- UnitPat is TuplePat [] - - | RecPat Id -- record constructor - (GenType flexi) -- the type of the pattern - [(Id, OutPat flexi id, 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) + + | SigPat (OutPat id) -- Pattern p + Type -- Type, t, of the whole pattern + (HsExpr id (OutPat id)) + -- Coercion function, + -- of type t -> typeof(p) + + | ListPat -- Syntactic list + Type -- The type of the elements + [OutPat id] + | PArrPat -- Syntactic parallel array + 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 flexi) -- type of pattern + Type -- Type of pattern - | NPat -- Used for *overloaded* literal patterns - HsLit -- the literal is retained so that + | NPat -- Used for literal patterns where there's an equality function to call + HsLit -- The literal is retained so that -- the desugarer can readily identify -- equations with identical literal-patterns - (GenType flexi) -- type of pattern, t - (HsExpr flexi id (OutPat flexi id)) - -- of type t -> Bool; detects match + -- Always HsInteger, HsRat or HsString. + Type -- Type of pattern, t + (HsExpr id (OutPat id)) -- Of type t -> Bool; detects match | NPlusKPat id - HsLit -- Same reason as for LitPat - -- (This could be an Integer, but then - -- it's harder to partitionEqnsByLit - -- in the desugarer.) - (GenType flexi) -- Type of pattern, t - (HsExpr flexi id (OutPat flexi id)) -- Of type t -> Bool; detects match - (HsExpr flexi id (OutPat flexi id)) -- Of type t -> t; subtracts k + 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 [id] -- superclass dicts @@ -129,15 +155,22 @@ instance (Outputable name) => Outputable (InPat name) where pprInPat :: (Outputable name) => InPat name -> SDoc -pprInPat (WildPatIn) = char '_' -pprInPat (VarPatIn var) = ppr var -pprInPat (LitPatIn s) = ppr s -pprInPat (LazyPatIn pat) = char '~' <> ppr pat -pprInPat (AsPatIn name pat) = parens (hcat [ppr name, char '@', ppr pat]) +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 (PArrPatIn pats) = pabrackets (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 (ConPatIn c pats) | null pats = ppr c - | otherwise = hsep [ppr c, interppSP pats] -- ParPats put in the parens + | 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 @@ -145,35 +178,22 @@ pprInPat (ConOpPatIn pat1 op fixity pat2) -- ToDo: use pprSym to print op (but this involves fiddling various -- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP) -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) - = parens (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) = ppr v pp_rpat (v, p, _) = hsep [ppr v, char '=', ppr p] + +pprInPat (TypePatIn ty) = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}") + +-- add parallel array brackets around a document +-- +pabrackets :: SDoc -> SDoc +pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") \end{code} \begin{code} -instance (Outputable id) => Outputable (OutPat flexi id) where +instance (NamedThing id, Outputable id) => Outputable (OutPat id) where ppr = pprOutPat \end{code} @@ -184,22 +204,28 @@ pprOutPat (LazyPat pat) = hcat [char '~', ppr pat] pprOutPat (AsPat name pat) = parens (hcat [ppr name, char '@', ppr pat]) -pprOutPat (ConPat name ty []) - = ppr name - -pprOutPat (ConPat name ty pats) - = hcat [parens (hcat [ppr name, space, interppSP pats])] - -pprOutPat (ConOpPat pat1 op pat2 ty) - = parens (hcat [ppr pat1, space, ppr op, space, ppr pat2]) +pprOutPat (SigPat pat ty _) = ppr pat <+> dcolon <+> ppr ty -pprOutPat (ListPat ty pats) - = brackets (interpp'SP pats) -pprOutPat (TuplePat pats) - = parens (interpp'SP pats) +pprOutPat (ConPat name ty [] [] []) + = ppr name -pprOutPat (RecPat con ty rpats) - = hcat [ppr con, braces (hsep (punctuate comma (map (pp_rpat) rpats)))] +-- 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 (PArrPat ty pats) = pabrackets (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) = ppr v pp_rpat (v, p, _) = hsep [ppr v, char '=', ppr p] @@ -207,7 +233,7 @@ pprOutPat (RecPat con ty rpats) 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]) + = parens (hcat [ppr n, char '+', integer k]) pprOutPat (DictPat dicts methods) = parens (sep [ptext SLIT("{-dict-}"), @@ -245,7 +271,7 @@ patterns are treated specially, of course. The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are. \begin{code} -irrefutablePats :: [OutPat a b] -> Bool +irrefutablePats :: [OutPat id] -> Bool irrefutablePats pat_list = all irrefutablePat pat_list irrefutablePat (AsPat _ pat) = irrefutablePat pat @@ -255,17 +281,17 @@ irrefutablePat (LazyPat _) = True irrefutablePat (DictPat ds ms) = (length ds + length ms) <= 1 irrefutablePat other = False -failureFreePat :: OutPat a b -> Bool +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 (ConOpPat pat1 con pat2 _) = only_con con && failureFreePat pat1 && failureFreePat pat1 -failureFreePat (RecPat con _ fields) = only_con con && and [ failureFreePat pat | (_,pat,_) <- fields ] +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 (PArrPat _ _) = False +failureFreePat (TuplePat pats _) = all failureFreePat pats failureFreePat (DictPat _ _) = True failureFreePat other_pat = False -- Literals, NPat @@ -273,19 +299,22 @@ only_con con = maybeToBool (maybeTyConSingleCon (dataConTyCon con)) \end{code} \begin{code} -patsAreAllCons :: [OutPat a b] -> Bool +isWildPat (WildPat _) = True +isWildPat other = False + +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 (RecPat _ _ _) = True +isConPat (PArrPat _ _) = True +isConPat (TuplePat _ _) = True +isConPat (RecPat _ _ _ _ _) = True isConPat (DictPat ds ms) = (length ds + length ms) > 1 isConPat other = False -patsAreAllLits :: [OutPat a b] -> Bool +patsAreAllLits :: [OutPat id] -> Bool patsAreAllLits pat_list = all isLitPat pat_list isLitPat (AsPat _ pat) = isLitPat pat @@ -298,20 +327,79 @@ isLitPat other = False 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 [] + +collectOutPatBinders :: OutPat a -> [a] +collectOutPatBinders pat = collectOut 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 (PArrPatIn 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 + +-- collect the bounds *value* variables in renamed patterns; type variables +-- are *not* collected +-- +collectOut (WildPat _) bndrs = bndrs +collectOut (VarPat var) bndrs = var : bndrs +collectOut (LazyPat pat) bndrs = collectOut pat bndrs +collectOut (AsPat a pat) bndrs = a : collectOut pat bndrs +collectOut (ListPat _ pats) bndrs = foldr collectOut bndrs pats +collectOut (PArrPat _ pats) bndrs = foldr collectOut bndrs pats +collectOut (TuplePat pats _) bndrs = foldr collectOut bndrs pats +collectOut (ConPat _ _ _ ds pats) bndrs = ds ++ foldr collectOut bndrs pats +collectOut (RecPat _ _ _ ds fields) bndrs = ds ++ foldr comb bndrs fields + where + comb (_, pat, _) bndrs = collectOut pat bndrs +collectOut (LitPat _ _) bndrs = bndrs +collectOut (NPat _ _ _) bndrs = bndrs +collectOut (NPlusKPat n _ _ _ _) bndrs = n : bndrs +collectOut (DictPat ids1 ids2) bndrs = ids1 ++ ids2 ++ bndrs +\end{code} -collectPatBinders WildPatIn = [] -collectPatBinders (VarPatIn var) = [var] -collectPatBinders (LitPatIn _) = [] -collectPatBinders (LazyPatIn pat) = collectPatBinders pat -collectPatBinders (AsPatIn a pat) = a : collectPatBinders pat -collectPatBinders (NPlusKPatIn n _) = [n] -collectPatBinders (ConPatIn c pats) = concat (map collectPatBinders pats) -collectPatBinders (ConOpPatIn p1 c f p2) = collectPatBinders p1 ++ collectPatBinders p2 -collectPatBinders (NegPatIn pat) = collectPatBinders pat -collectPatBinders (ParPatIn pat) = collectPatBinders pat -collectPatBinders (ListPatIn pats) = concat (map collectPatBinders pats) -collectPatBinders (TuplePatIn pats) = concat (map collectPatBinders pats) -collectPatBinders (RecPatIn c fields) = concat (map (\ (f,pat,_) -> collectPatBinders pat) fields) +\begin{code} +collectSigTysFromPats :: [InPat name] -> [HsType name] +collectSigTysFromPats pats = foldr collect_pat [] pats + +collectSigTysFromPat :: InPat name -> [HsType name] +collectSigTysFromPat pat = collect_pat pat [] + +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 (PArrPatIn 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} +