X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsPat.lhs;h=96d308229dc4a2a5838c90d1ee72778190a90dca;hb=5cf27e8f1731c52fe63a5b9615f927484164c61b;hp=73124ac4f0f4b0cacc0458a35a2dbbe6202b4ad7;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index 73124ac..96d3082 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -24,16 +24,14 @@ import HsLit ( HsLit ) import HsLoop ( HsExpr ) -- others: -import Id ( GenId, getDataConSig ) +import Id ( GenId, dataConSig ) import Maybes ( maybeToBool ) -import Outputable +import Name ( pprSym, pprNonSym ) +import Outputable ( interppSP, interpp'SP, ifPprShowAll ) import PprStyle ( PprStyle(..) ) import Pretty import TyCon ( maybeTyConSingleCon ) -import TyVar ( GenTyVar ) -import PprType ( GenType, GenTyVar ) -import Unique ( Unique ) - +import PprType ( GenType ) \end{code} Patterns come in distinct before- and after-typechecking flavo(u)rs. @@ -50,15 +48,21 @@ data InPat name | ConOpPatIn (InPat name) name (InPat name) + + -- 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 | RecPatIn name -- record - [(name, Maybe (InPat name))] + [(name, InPat name, Bool)] -- True <=> source used punning data OutPat tyvar uvar id - = WildPat (GenType tyvar uvar) -- wild card + = WildPat (GenType tyvar uvar) -- wild card | VarPat id -- variable (type is in the Id) @@ -69,7 +73,7 @@ data OutPat tyvar uvar id | ConPat Id -- Constructor is always an Id (GenType tyvar uvar) -- the type of the pattern - [(OutPat tyvar uvar id)] + [OutPat tyvar uvar id] | ConOpPat (OutPat tyvar uvar id) -- just a special case... Id @@ -77,13 +81,14 @@ data OutPat tyvar uvar id (GenType tyvar uvar) | ListPat -- syntactic list (GenType tyvar uvar) -- the type of the elements - [(OutPat tyvar uvar id)] + [OutPat tyvar uvar id] - | TuplePat [(OutPat tyvar uvar id)] -- tuple + | TuplePat [OutPat tyvar uvar id] -- tuple -- UnitPat is TuplePat [] - | RecPat id -- record - [(id, Maybe (OutPat tyvar uvar id))] + | RecPat Id -- record constructor + (GenType tyvar uvar) -- the type of the pattern + [(Id, OutPat tyvar uvar id, Bool)] -- True <=> source used punning | LitPat -- Used for *non-overloaded* literal patterns: -- Int#, Char#, Int, Char, String, etc. @@ -98,7 +103,7 @@ data OutPat tyvar uvar id (HsExpr tyvar uvar id (OutPat tyvar uvar id)) -- of type t -> Bool; detects match - | DictPat -- Used when destructing Dictionaries with an explicit case + | DictPat -- Used when destructing Dictionaries with an explicit case [id] -- superclass dicts [id] -- methods \end{code} @@ -110,7 +115,7 @@ instance (Outputable name, NamedThing name) => Outputable (InPat name) where pprInPat :: (Outputable name, NamedThing name) => PprStyle -> InPat name -> Pretty pprInPat sty (WildPatIn) = ppStr "_" -pprInPat sty (VarPatIn var) = pprNonOp sty var +pprInPat sty (VarPatIn var) = pprNonSym sty var pprInPat sty (LitPatIn s) = ppr sty s pprInPat sty (LazyPatIn pat) = ppBeside (ppChar '~') (ppr sty pat) pprInPat sty (AsPatIn name pat) @@ -120,25 +125,37 @@ pprInPat sty (ConPatIn c pats) = if null pats then ppr sty c else - ppBesides [ppLparen, ppr sty c, ppSP, interppSP sty pats, ppRparen] - + ppCat [ppr sty c, interppSP sty pats] -- ParPats put in the parens pprInPat sty (ConOpPatIn pat1 op pat2) - = ppBesides [ppLparen, ppr sty pat1, ppSP, ppr sty op, ppSP, ppr sty pat2, ppRparen] + = ppCat [ppr sty pat1, ppr sty op, ppr sty pat2] -- ParPats put in parens + + -- ToDo: use pprSym to print op (but this involves fiddling various + -- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP) + +pprInPat sty (NegPatIn pat) + = let + pp_pat = pprInPat sty pat + in + ppBeside (ppChar '-') ( + case pat of + LitPatIn _ -> pp_pat + _ -> ppParens pp_pat + ) --- ToDo: use pprOp to print op (but this involves fiddling various --- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP) +pprInPat sty (ParPatIn pat) + = ppParens (pprInPat sty pat) pprInPat sty (ListPatIn pats) = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack] pprInPat sty (TuplePatIn pats) - = ppBesides [ppLparen, interpp'SP sty pats, ppRparen] + = ppParens (interpp'SP sty pats) pprInPat sty (RecPatIn con rpats) - = ppBesides [ppr sty con, ppSP, ppChar '{', ppInterleave ppComma (map pp_rpat rpats), ppChar '}'] + = ppBesides [ppr sty con, ppSP, ppChar '{', ppInterleave ppComma (map (pp_rpat sty) rpats), ppChar '}'] where - pp_rpat (v, Nothing) = ppr sty v - pp_rpat (v, Just p) = ppCat [ppr sty v, ppStr "<-", ppr sty p] + pp_rpat PprForUser (v, _, True) = ppr PprForUser v + pp_rpat sty (v, p, _) = ppCat [ppr sty v, ppStr "=", ppr sty p] \end{code} \begin{code} @@ -150,7 +167,7 @@ instance (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar, \begin{code} pprOutPat sty (WildPat ty) = ppChar '_' -pprOutPat sty (VarPat var) = pprNonOp sty var +pprOutPat sty (VarPat var) = pprNonSym sty var pprOutPat sty (LazyPat pat) = ppBesides [ppChar '~', ppr sty pat] pprOutPat sty (AsPat name pat) = ppBesides [ppLparen, ppr sty name, ppChar '@', ppr sty pat, ppRparen] @@ -165,18 +182,18 @@ pprOutPat sty (ConPat name ty pats) ifPprShowAll sty (pprConPatTy sty ty) ] pprOutPat sty (ConOpPat pat1 op pat2 ty) - = ppBesides [ppLparen, ppr sty pat1, ppSP, pprOp sty op, ppSP, ppr sty pat2, ppRparen] + = ppBesides [ppLparen, ppr sty pat1, ppSP, pprSym sty op, ppSP, ppr sty pat2, ppRparen] pprOutPat sty (ListPat ty pats) = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack] pprOutPat sty (TuplePat pats) - = ppBesides [ppLparen, interpp'SP sty pats, ppRparen] + = ppParens (interpp'SP sty pats) -pprOutPat sty (RecPat con rpats) - = ppBesides [ppr sty con, ppChar '{', ppInterleave ppComma (map pp_rpat rpats), ppChar '}'] +pprOutPat sty (RecPat con ty rpats) + = ppBesides [ppr sty con, ppChar '{', ppInterleave ppComma (map (pp_rpat sty) rpats), ppChar '}'] where - pp_rpat (v, Nothing) = ppr sty v - pp_rpat (v, Just p) = ppBesides [ppr sty v, ppStr "<-", ppr sty p] + pp_rpat PprForUser (v, _, True) = ppr PprForUser v + pp_rpat sty (v, p, _) = ppCat [ppr sty v, ppStr "=", ppr sty p] pprOutPat sty (LitPat l ty) = ppr sty l -- ToDo: print more pprOutPat sty (NPat l ty e) = ppr sty l -- ToDo: print more @@ -187,7 +204,7 @@ pprOutPat sty (DictPat dicts methods) ppBesides [ppBracket (interpp'SP sty methods), ppRparen]] pprConPatTy sty ty - = ppBesides [ppLparen, ppr sty ty, ppRparen] + = ppParens (ppr sty ty) \end{code} %************************************************************************ @@ -236,6 +253,7 @@ isConPat (ConPat _ _ _) = True isConPat (ConOpPat _ _ _ _) = True isConPat (ListPat _ _) = True isConPat (TuplePat _) = True +isConPat (RecPat _ _ _) = True isConPat (DictPat ds ms) = (length ds + length ms) > 1 isConPat other = False @@ -257,8 +275,9 @@ irrefutablePat (WildPat _) = True irrefutablePat (VarPat _) = True irrefutablePat (LazyPat _) = True irrefutablePat (AsPat _ pat) = irrefutablePat pat -irrefutablePat (ConPat con tys pats) = all irrefutablePat pats && only_con con -irrefutablePat (ConOpPat pat1 con pat2 _) = irrefutablePat pat1 && irrefutablePat pat1 && only_con con +irrefutablePat (ConPat con tys pats) = only_con con && all irrefutablePat pats +irrefutablePat (ConOpPat pat1 con pat2 _) = only_con con && irrefutablePat pat1 && irrefutablePat pat1 +irrefutablePat (RecPat con _ fields) = only_con con && and [ irrefutablePat pat | (_,pat,_) <- fields ] irrefutablePat (ListPat _ _) = False irrefutablePat (TuplePat pats) = all irrefutablePat pats irrefutablePat (DictPat _ _) = True @@ -266,7 +285,7 @@ irrefutablePat other_pat = False -- Literals, NPat only_con con = maybeToBool (maybeTyConSingleCon tycon) where - (_,_,_,tycon) = getDataConSig con + (_,_,_,tycon) = dataConSig con \end{code} This function @collectPatBinders@ works with the ``collectBinders'' @@ -275,12 +294,16 @@ collected is important; see @HsBinds.lhs@. \begin{code} collectPatBinders :: InPat a -> [a] -collectPatBinders (VarPatIn var) = [var] -collectPatBinders (LazyPatIn pat) = collectPatBinders pat -collectPatBinders (AsPatIn a pat) = a : collectPatBinders pat -collectPatBinders (ConPatIn c pats) = concat (map collectPatBinders pats) +collectPatBinders WildPatIn = [] +collectPatBinders (VarPatIn var) = [var] +collectPatBinders (LitPatIn _) = [] +collectPatBinders (LazyPatIn pat) = collectPatBinders pat +collectPatBinders (AsPatIn a pat) = a : collectPatBinders pat +collectPatBinders (ConPatIn c pats) = concat (map collectPatBinders pats) collectPatBinders (ConOpPatIn p1 c p2)= collectPatBinders p1 ++ collectPatBinders p2 -collectPatBinders (ListPatIn pats) = concat (map collectPatBinders pats) -collectPatBinders (TuplePatIn pats) = concat (map collectPatBinders pats) -collectPatBinders any_other_pat = [ {-no binders-} ] +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) \end{code}