diff options
Diffstat (limited to 'ghc/compiler/hsSyn/HsMatches.lhs')
| -rw-r--r-- | ghc/compiler/hsSyn/HsMatches.lhs | 148 |
1 files changed, 58 insertions, 90 deletions
diff --git a/ghc/compiler/hsSyn/HsMatches.lhs b/ghc/compiler/hsSyn/HsMatches.lhs index c09fff192e..7fe648d25e 100644 --- a/ghc/compiler/hsSyn/HsMatches.lhs +++ b/ghc/compiler/hsSyn/HsMatches.lhs @@ -3,7 +3,7 @@ % \section[HsMatches]{Abstract syntax: matches and guarded right-hand-sides} -The @Match@, @GRHSsAndBinds@ and @GRHS@ datatypes. +The @Match@, @GRHSs@ and @GRHS@ datatypes. \begin{code} module HsMatches where @@ -12,10 +12,11 @@ module HsMatches where -- Friends import HsExpr ( HsExpr, Stmt(..) ) -import HsBinds ( HsBinds, nullBinds ) +import HsBinds ( HsBinds(..), nullBinds ) +import HsTypes ( HsTyVar, HsType ) -- Others -import Type ( GenType ) +import Type ( Type ) import SrcLoc ( SrcLoc ) import Outputable import Name ( NamedThing ) @@ -23,7 +24,7 @@ import Name ( NamedThing ) %************************************************************************ %* * -\subsection{@Match@, @GRHSsAndBinds@, and @GRHS@ datatypes} +\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes} %* * %************************************************************************ @@ -37,46 +38,38 @@ g ((x:ys),y) = y+1, then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@. It is always the case that each element of an @[Match]@ list has the -same number of @PatMatch@s inside it. This corresponds to saying that +same number of @pats@s inside it. This corresponds to saying that a function defined by pattern matching must have the same number of patterns in each equation. \begin{code} -data Match flexi id pat - = PatMatch pat - (Match flexi id pat) - | GRHSMatch (GRHSsAndBinds flexi id pat) - - | SimpleMatch (HsExpr flexi id pat) -- Used in translations -\end{code} - -Sets of guarded right hand sides (GRHSs). In: -\begin{verbatim} -f (x,y) | x==True = y - | otherwise = y*2 -\end{verbatim} -a guarded right hand side is either -@(x==True = y)@, or @(otherwise = y*2)@. - -For each match, there may be several guarded right hand -sides, as the definition of @f@ shows. - -\begin{code} -data GRHSsAndBinds flexi id pat - = GRHSsAndBindsIn [GRHS flexi id pat] -- at least one GRHS - (HsBinds flexi id pat) - - | GRHSsAndBindsOut [GRHS flexi id pat] -- at least one GRHS - (HsBinds flexi id pat) - (GenType flexi) - -data GRHS flexi id pat - = GRHS [Stmt flexi id pat] -- The RHS is the final ExprStmt - -- I considered using a RetunStmt, but - -- it printed 'wrong' in error messages - SrcLoc - -unguardedRHS :: (HsExpr flexi id pat) -> SrcLoc -> [GRHS flexi id pat] +data Match id pat + = Match + [HsTyVar id] -- Tyvars wrt which this match is universally quantified + -- emtpy after typechecking + [pat] -- The patterns + (Maybe (HsType id)) -- A type signature for the result of the match + -- Nothing after typechecking + + (GRHSs id pat) + +-- GRHSs are used both for pattern bindings and for Matches +data GRHSs id pat + = GRHSs [GRHS id pat] -- Guarded RHSs + (HsBinds id pat) -- The where clause + (Maybe Type) -- Just rhs_ty after type checking + +data GRHS id pat + = GRHS [Stmt id pat] -- The RHS is the final ExprStmt + -- I considered using a RetunStmt, but + -- it printed 'wrong' in error messages + SrcLoc + +mkSimpleMatch :: [pat] -> HsExpr id pat -> Maybe Type -> SrcLoc -> Match id pat +mkSimpleMatch pats rhs maybe_rhs_ty locn + = Match [] pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds maybe_rhs_ty) + +unguardedRHS :: HsExpr id pat -> SrcLoc -> [GRHS id pat] unguardedRHS rhs loc = [GRHS [ExprStmt rhs loc] loc] \end{code} @@ -85,9 +78,8 @@ source-location gotten from the GRHS inside. THis is something of a nuisance, but no more. \begin{code} -getMatchLoc :: Match flexi id pat -> SrcLoc -getMatchLoc (PatMatch _ m) = getMatchLoc m -getMatchLoc (GRHSMatch (GRHSsAndBindsIn (GRHS _ loc : _) _)) = loc +getMatchLoc :: Match id pat -> SrcLoc +getMatchLoc (Match _ _ _ (GRHSs (GRHS _ loc : _) _ _)) = loc \end{code} %************************************************************************ @@ -99,59 +91,35 @@ getMatchLoc (GRHSMatch (GRHSsAndBindsIn (GRHS _ loc : _) _)) = loc We know the list must have at least one @Match@ in it. \begin{code} pprMatches :: (NamedThing id, Outputable id, Outputable pat) - => (Bool, SDoc) -> [Match flexi id pat] -> SDoc - -pprMatches print_info@(is_case, name) [match] - = if is_case then - pprMatch is_case match - else - name <+> (pprMatch is_case match) + => (Bool, SDoc) -> [Match id pat] -> SDoc +pprMatches print_info matches = vcat (map (pprMatch print_info) matches) -pprMatches print_info (match1 : rest) - = ($$) (pprMatches print_info [match1]) - (pprMatches print_info rest) ---------------------------------------------- pprMatch :: (NamedThing id, Outputable id, Outputable pat) - => Bool -> Match flexi id pat -> SDoc - -pprMatch is_case first_match - = sep [(sep (map (ppr) row_of_pats)), - grhss_etc_stuff] - where - (row_of_pats, grhss_etc_stuff) = ppr_match is_case first_match - - ppr_match is_case (PatMatch pat match) - = (pat:pats, grhss_stuff) - where - (pats, grhss_stuff) = ppr_match is_case match - - ppr_match is_case (GRHSMatch grhss_n_binds) - = ([], pprGRHSsAndBinds is_case grhss_n_binds) - - ppr_match is_case (SimpleMatch expr) - = ([], text (if is_case then "->" else "=") <+> ppr expr) - ----------------------------------------------------------- - -pprGRHSsAndBinds :: (NamedThing id, Outputable id, Outputable pat) - => Bool -> GRHSsAndBinds flexi id pat -> SDoc - -pprGRHSsAndBinds is_case (GRHSsAndBindsIn grhss binds) - = ($$) (vcat (map (pprGRHS is_case) grhss)) - (if (nullBinds binds) - then empty - else vcat [ text "where", nest 4 (pprDeeper (ppr binds)) ]) + => (Bool, SDoc) -> Match id pat -> SDoc +pprMatch print_info@(is_case, name) (Match _ pats maybe_ty grhss) + = maybe_name <+> sep [sep (map ppr pats), + ppr_maybe_ty, + nest 2 (pprGRHSs is_case grhss)] + where + maybe_name | is_case = empty + | otherwise = name + ppr_maybe_ty = case maybe_ty of + Just ty -> dcolon <+> ppr ty + Nothing -> empty + + +pprGRHSs :: (NamedThing id, Outputable id, Outputable pat) + => Bool -> GRHSs id pat -> SDoc +pprGRHSs is_case (GRHSs grhss binds maybe_ty) + = vcat (map (pprGRHS is_case) grhss) + $$ + (if nullBinds binds then empty + else text "where" $$ nest 4 (pprDeeper (ppr binds))) -pprGRHSsAndBinds is_case (GRHSsAndBindsOut grhss binds ty) - = ($$) (vcat (map (pprGRHS is_case) grhss)) - (if (nullBinds binds) - then empty - else vcat [text "where", nest 4 (pprDeeper (ppr binds)) ]) ---------------------------------------------- pprGRHS :: (NamedThing id, Outputable id, Outputable pat) - => Bool -> GRHS flexi id pat -> SDoc + => Bool -> GRHS id pat -> SDoc pprGRHS is_case (GRHS [ExprStmt expr _] locn) = text (if is_case then "->" else "=") <+> pprDeeper (ppr expr) |