X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsMatches.lhs;h=cb81b7c2e60c1770ab5a047fab3c775312fea225;hb=aa44169c3c01243cdbf38f50f58e80477586552c;hp=7c7db36de98642cbfa89d9b1a481e7473e493afd;hpb=ca5a4a480d10d61e5b7a52eb4d556e8b8c33e69d;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsMatches.lhs b/ghc/compiler/hsSyn/HsMatches.lhs index 7c7db36..cb81b7c 100644 --- a/ghc/compiler/hsSyn/HsMatches.lhs +++ b/ghc/compiler/hsSyn/HsMatches.lhs @@ -1,28 +1,29 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[HsMatches]{Abstract syntax: matches and guarded right-hand-sides} -The @Match@, @GRHSsAndBinds@ and @GRHS@ datatypes. +The @Match@, @GRHSs@ and @GRHS@ datatypes. \begin{code} -#include "HsVersions.h" - module HsMatches where -import Ubiq{-uitous-} +#include "HsVersions.h" -import HsLoop ( HsExpr, nullBinds, HsBinds ) -import Outputable ( ifPprShowAll ) -import PprType ( GenType{-instance Outputable-} ) -import Pretty -import SrcLoc ( SrcLoc{-instances-} ) -import Util ( panic ) +-- Friends +import HsExpr ( HsExpr, Stmt(..) ) +import HsBinds ( HsBinds(..), nullBinds ) +import HsTypes ( HsType ) +-- Others +import Type ( Type ) +import SrcLoc ( SrcLoc ) +import Outputable +import List \end{code} %************************************************************************ %* * -\subsection{@Match@, @GRHSsAndBinds@, and @GRHS@ datatypes} +\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes} %* * %************************************************************************ @@ -36,46 +37,48 @@ 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 tyvar uvar id pat - = PatMatch pat - (Match tyvar uvar id pat) - | GRHSMatch (GRHSsAndBinds tyvar uvar id pat) - - | SimpleMatch (HsExpr tyvar uvar id pat) -- Used in translations +data Match id pat + = Match + [id] -- Tyvars wrt which this match is universally quantified + -- empty 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} -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. +@getMatchLoc@ takes a @Match@ and returns the +source-location gotten from the GRHS inside. +THis is something of a nuisance, but no more. \begin{code} -data GRHSsAndBinds tyvar uvar id pat - = GRHSsAndBindsIn [GRHS tyvar uvar id pat] -- at least one GRHS - (HsBinds tyvar uvar id pat) - - | GRHSsAndBindsOut [GRHS tyvar uvar id pat] -- at least one GRHS - (HsBinds tyvar uvar id pat) - (GenType tyvar uvar) - -data GRHS tyvar uvar id pat - = GRHS (HsExpr tyvar uvar id pat) -- guard(ed)... - (HsExpr tyvar uvar id pat) -- ... right-hand side - SrcLoc - - | OtherwiseGRHS (HsExpr tyvar uvar id pat) -- guard-free - SrcLoc +getMatchLoc :: Match id pat -> SrcLoc +getMatchLoc (Match _ _ _ (GRHSs (GRHS _ loc : _) _ _)) = loc \end{code} %************************************************************************ @@ -86,68 +89,46 @@ data GRHS tyvar uvar id pat We know the list must have at least one @Match@ in it. \begin{code} -pprMatches :: (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - PprStyle -> (Bool, Pretty) -> [Match tyvar uvar id pat] -> Pretty - -pprMatches sty print_info@(is_case, name) [match] - = if is_case then - pprMatch sty is_case match - else - ppHang name 4 (pprMatch sty is_case match) - -pprMatches sty print_info (match1 : rest) - = ppAbove (pprMatches sty print_info [match1]) - (pprMatches sty print_info rest) - ---------------------------------------------- -pprMatch :: (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - PprStyle -> Bool -> Match tyvar uvar id pat -> Pretty - -pprMatch sty is_case first_match - = ppHang (ppSep (map (ppr sty) row_of_pats)) - 8 grhss_etc_stuff +pprMatches :: (Outputable id, Outputable pat) + => (Bool, SDoc) -> [Match id pat] -> SDoc +pprMatches print_info matches = vcat (map (pprMatch print_info) matches) + + +pprMatch :: (Outputable id, Outputable pat) + => (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 :: (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))) + + +pprGRHS :: (Outputable id, Outputable pat) + => Bool -> GRHS id pat -> SDoc + +pprGRHS is_case (GRHS [ExprStmt expr _] locn) + = text (if is_case then "->" else "=") <+> pprDeeper (ppr expr) + +pprGRHS is_case (GRHS guarded locn) + = sep [char '|' <+> interpp'SP guards, + text (if is_case then "->" else "=") <+> pprDeeper (ppr expr) + ] where - (row_of_pats, grhss_etc_stuff) = ppr_match sty is_case first_match - - ppr_match sty is_case (PatMatch pat match) - = (pat:pats, grhss_stuff) - where - (pats, grhss_stuff) = ppr_match sty is_case match - - ppr_match sty is_case (GRHSMatch grhss_n_binds) - = ([], pprGRHSsAndBinds sty is_case grhss_n_binds) - - ppr_match sty is_case (SimpleMatch expr) - = ([], ppr sty expr) - ----------------------------------------------------------- - -pprGRHSsAndBinds sty is_case (GRHSsAndBindsIn grhss binds) - = ppAbove (ppAboves (map (pprGRHS sty is_case) grhss)) - (if (nullBinds binds) - then ppNil - else ppAboves [ ppStr "where", ppNest 4 (ppr sty binds) ]) - -pprGRHSsAndBinds sty is_case (GRHSsAndBindsOut grhss binds ty) - = ppAbove (ppAboves (map (pprGRHS sty is_case) grhss)) - (if (nullBinds binds) - then ppNil - else ppAboves [ ifPprShowAll sty - (ppCat [ppStr "{- ty:", ppr sty ty, ppStr "-}"]), - ppStr "where", ppNest 4 (ppr sty binds) ]) - ---------------------------------------------- -pprGRHS :: (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => PprStyle -> Bool -> GRHS tyvar uvar id pat -> Pretty - -pprGRHS sty is_case (GRHS guard expr locn) - = ppHang (ppCat [ppChar '|', ppr sty guard, ppStr (if is_case then "->" else "=")]) - 4 (ppr sty expr) - -pprGRHS sty is_case (OtherwiseGRHS expr locn) - = ppHang (ppStr (if is_case then "->" else "=")) - 4 (ppr sty expr) + ExprStmt expr _ = last guarded -- Last stmt should be a ExprStmt for guards + guards = init guarded \end{code} +