X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsPat.lhs;h=00df7797b42b788be659fb2e4bdc670f78f4676f;hb=1d874e7c18d8b1bd46cbb27c3e146b092a64fc63;hp=09494a1ad1c047660ebd4b3468bf2b9b44b263a3;hpb=77a8c0dbd5c5ad90fe483cb9ddc2b6ef36d3f4d8;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index 09494a1..00df779 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -9,22 +9,24 @@ module HsPat ( OutPat(..), irrefutablePat, irrefutablePats, - failureFreePat, isWildPat, - patsAreAllCons, isConPat, + failureFreePat, isWildPat, + patsAreAllCons, isConPat, patsAreAllLits, isLitPat, collectPatBinders, collectPatsBinders, - collectSigTysFromPats + collectSigTysFromPat, collectSigTysFromPats ) where #include "HsVersions.h" + -- friends: -import HsBasic ( HsLit ) +import HsLit ( HsLit, HsOverLit ) import HsExpr ( HsExpr ) import HsTypes ( HsType ) import BasicTypes ( Fixity, Boxity, tupleParens ) -- others: +import Name ( Name ) import Var ( Id, TyVar ) import DataCon ( DataCon, dataConTyCon ) import Name ( isDataSymOcc, getOccName, NamedThing ) @@ -52,12 +54,14 @@ 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 @@ -67,6 +71,15 @@ data InPat name | 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) @@ -74,13 +87,19 @@ data OutPat id | AsPat id -- as pattern (OutPat id) - | ListPat -- syntactic list - Type -- the type of the elements + | 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] - | TuplePat [OutPat id] -- tuple + | TuplePat [OutPat id] -- Tuple Boxity - -- UnitPat is TuplePat [] + -- UnitPat is TuplePat [] | ConPat DataCon Type -- the type of the pattern @@ -90,31 +109,28 @@ data 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 + | 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 - Type -- 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 - Type -- type of pattern, t - (HsExpr id (OutPat 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.) - Type -- Type of pattern, t + 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 @@ -134,12 +150,17 @@ 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 (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 (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 (ConPatIn c pats) | null pats = ppr c @@ -151,31 +172,13 @@ 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 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) = 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} @@ -190,6 +193,8 @@ pprOutPat (LazyPat pat) = hcat [char '~', ppr pat] pprOutPat (AsPat name pat) = parens (hcat [ppr name, char '@', ppr pat]) +pprOutPat (SigPat pat ty _) = ppr pat <+> dcolon <+> ppr ty + pprOutPat (ConPat name ty [] [] []) = ppr name @@ -216,7 +221,7 @@ pprOutPat (RecPat con ty tvs dicts 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-}"), @@ -322,33 +327,41 @@ 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 (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 (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 +-- Generics +collect (TypePatIn ty) bndrs = bndrs +-- assume the type variables do not need to be bound \end{code} - \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 (NPlusKPatIn n _) acc = 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 (NegPatIn pat) acc = collect_pat pat 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} +