X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsPat.lhs;h=6f0cc212c0039ed7a1077ac2ba4abaada46d88ed;hb=f3d24c87016078e0e50fa80575e04f340f86acb4;hp=62c460068d1a066f65a7092092e04f1c3080857f;hpb=aa44169c3c01243cdbf38f50f58e80477586552c;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index 62c4600..6f0cc21 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 + collectPatBinders, collectOutPatBinders, collectPatsBinders, + collectSigTysFromPat, collectSigTysFromPats ) where #include "HsVersions.h" + -- friends: import HsLit ( HsLit, HsOverLit ) import HsExpr ( HsExpr ) -import HsTypes ( HsType ) +import HsTypes ( HsType, SyntaxName ) import BasicTypes ( Fixity, Boxity, tupleParens ) -- others: +import Name ( Name ) import Var ( Id, TyVar ) import DataCon ( DataCon, dataConTyCon ) import Name ( isDataSymOcc, getOccName, NamedThing ) @@ -52,14 +54,13 @@ data InPat name Fixity -- c.f. OpApp in HsExpr (InPat name) - | NPatIn (HsOverLit name) + | NPatIn HsOverLit -- Always positive + (Maybe SyntaxName) -- Just (Name of 'negate') for negative + -- patterns, Nothing otherwise | NPlusKPatIn name -- n+k pattern - (HsOverLit name) -- It'll always be an HsIntegral, but - -- we need those names to support -fuser-numerics - name -- Name for "-"; this supports -fuser-numerics - -- We don't do the same for >= because that isn't - -- affected by -fuser-numerics + HsOverLit -- It'll always be an HsIntegral + SyntaxName -- Name of '-' (see RnEnv.lookupSyntaxName) -- We preserve prefix negation and parenthesis for the precedence parser. @@ -67,6 +68,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 @@ -88,9 +91,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 @@ -115,11 +127,13 @@ 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. + -- *Unlike* NPatIn, for negative literals, the + -- literal is acutally negative! Type -- Type of pattern, t (HsExpr id (OutPat id)) -- Of type t -> Bool; detects match @@ -153,9 +167,10 @@ 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 (NPatIn l _) = ppr l pprInPat (ConPatIn c pats) | null pats = ppr c @@ -174,6 +189,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} @@ -188,6 +208,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 @@ -203,6 +225,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) @@ -271,6 +294,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 @@ -288,6 +312,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 @@ -311,6 +336,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 @@ -321,34 +349,58 @@ 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 (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 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 (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