X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsPat.lhs;h=ec92913b7d05d6ce1d3cc4654fbd0ce826042377;hb=f4c599d2460672cdeec7e6b3c4c99bb308a54b67;hp=d115306a3ac8b6abaca844da66f57bbf902d23cf;hpb=7e602b0a11e567fcb035d1afd34015aebcf9a577;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index d115306..ec92913 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -12,20 +12,23 @@ module HsPat ( failureFreePat, isWildPat, patsAreAllCons, isConPat, patsAreAllLits, isLitPat, - collectPatBinders, collectPatsBinders + collectPatBinders, collectPatsBinders, + collectSigTysFromPats ) where #include "HsVersions.h" + -- friends: -import HsBasic ( HsLit ) +import HsLit ( HsLit, HsOverLit ) import HsExpr ( HsExpr ) import HsTypes ( HsType ) -import BasicTypes ( Fixity ) +import BasicTypes ( Fixity, Boxity, tupleParens ) -- others: import Var ( Id, TyVar ) import DataCon ( DataCon, dataConTyCon ) +import Name ( isDataSymOcc, getOccName, NamedThing ) import Maybes ( maybeToBool ) import Outputable import TyCon ( maybeTyConSingleCon ) @@ -50,72 +53,76 @@ 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 -- 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] Bool -- tuple (boxed?) + | TuplePatIn [InPat name] Boxity -- tuple (boxed?) | RecPatIn name -- record [(name, InPat name, Bool)] -- True <=> source used punning -data OutPat id - = WildPat Type -- wild card +-- 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 - | VarPat id -- variable (type is in the Id) +-- /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 + | AsPat id -- as pattern (OutPat id) - | ListPat -- syntactic list - Type -- the type of the elements + | ListPat -- Syntactic list + Type -- The type of the elements [OutPat id] - | TuplePat [OutPat id] -- tuple - Bool -- boxed? - -- UnitPat is TuplePat [] + | TuplePat [OutPat id] -- Tuple + Boxity + -- UnitPat is TuplePat [] | ConPat DataCon Type -- the type of the pattern [TyVar] -- Existentially bound type variables - [id] -- Ditto dictionaries + [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 + | 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 + 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 HsInt, 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 @@ -135,16 +142,21 @@ 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 - | 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 @@ -152,37 +164,17 @@ 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 False) - = text "(#" <> (interpp'SP pats) <> text "#)" -pprInPat (TuplePatIn pats True) - = 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("|}") \end{code} \begin{code} -instance (Outputable id) => Outputable (OutPat id) where +instance (NamedThing id, Outputable id) => Outputable (OutPat id) where ppr = pprOutPat \end{code} @@ -196,15 +188,19 @@ pprOutPat (AsPat name 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) - = parens (hsep [ppr name, interppSP tyvars, interppSP dicts, interppSP 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 boxed@True) - = parens (interpp'SP pats) -pprOutPat (TuplePat pats unboxed@False) - = text "(#" <> (interpp'SP pats) <> text "#)" +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)))] @@ -215,7 +211,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,11 +318,37 @@ 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 (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 + +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} +