X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsPat.lhs;h=c801a86888a8ddc91a456d0bd8d72918c529e2ee;hb=10fcd78ccde892feccda3f5eacd221c1de75feea;hp=e8c9296759f7aa3c6845ef5cb7d7fc0bfa29405c;hpb=5e6242927839c8ddc73a55eb7828c0b7e4cc3ab2;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index e8c9296..c801a86 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -9,15 +9,16 @@ module HsPat ( OutPat(..), irrefutablePat, irrefutablePats, - failureFreePat, isWildPat, - patsAreAllCons, isConPat, + failureFreePat, isWildPat, + patsAreAllCons, isConPat, patsAreAllLits, isLitPat, - collectPatBinders, collectPatsBinders, - collectSigTysFromPats + collectPatBinders, collectOutPatBinders, collectPatsBinders, + collectSigTysFromPat, collectSigTysFromPats ) where #include "HsVersions.h" + -- friends: import HsLit ( HsLit, HsOverLit ) import HsExpr ( HsExpr ) @@ -25,6 +26,7 @@ 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 ) @@ -56,6 +58,7 @@ data InPat name | 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. @@ -63,6 +66,8 @@ data InPat name | ListPatIn [InPat name] -- syntactic list -- must have >= 1 elements + | PArrPatIn [InPat name] -- syntactic parallel array + -- must have >= 1 elements | TuplePatIn [InPat name] Boxity -- tuple (boxed?) | RecPatIn name -- record @@ -84,9 +89,18 @@ data OutPat id | 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 @@ -111,11 +125,11 @@ data OutPat id HsLit Type -- Type of pattern - | NPat -- Used for *overloaded* literal patterns + | 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 - -- Always HsInt, HsRat or HsString. + -- Always HsInteger, HsRat or HsString. Type -- Type of pattern, t (HsExpr id (OutPat id)) -- Of type t -> Bool; detects match @@ -149,8 +163,9 @@ 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 (NPlusKPatIn n k _) = parens (hcat [ppr n, char '+', ppr k]) pprInPat (NPatIn l) = ppr l pprInPat (ConPatIn c pats) @@ -170,6 +185,11 @@ pprInPat (RecPatIn con rpats) 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} @@ -184,6 +204,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 @@ -199,6 +221,7 @@ pprOutPat (ConPat name ty tyvars dicts pats) _ -> 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) @@ -267,6 +290,7 @@ 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 (PArrPat _ _) = False failureFreePat (TuplePat pats _) = all failureFreePat pats failureFreePat (DictPat _ _) = True failureFreePat other_pat = False -- Literals, NPat @@ -284,6 +308,7 @@ patsAreAllCons pat_list = all isConPat pat_list isConPat (AsPat _ pat) = isConPat pat isConPat (ConPat _ _ _ _ _) = True isConPat (ListPat _ _) = True +isConPat (PArrPat _ _) = True isConPat (TuplePat _ _) = True isConPat (RecPat _ _ _ _ _) = True isConPat (DictPat ds ms) = (length ds + length ms) > 1 @@ -307,6 +332,9 @@ collected is important; see @HsBinds.lhs@. 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 @@ -316,23 +344,46 @@ 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 (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} \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 @@ -340,11 +391,12 @@ 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 (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