%
-% (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.
\begin{code}
-#include "HsVersions.h"
-
module HsMatches where
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
-- Friends
-import HsExpr ( HsExpr, Stmt )
+import HsExpr ( HsExpr, Stmt(..) )
import HsBinds ( HsBinds, nullBinds )
-- Others
-import Outputable ( ifPprShowAll, PprStyle )
-import PprType ( GenType{-instance Outputable-} )
-import Pretty
-import SrcLoc ( SrcLoc{-instances-} )
-import Util ( panic )
-import Outputable ( Outputable(..) )
-#if __GLASGOW_HASKELL__ >= 202
-import Name
-#endif
-
+import Type ( GenType )
+import SrcLoc ( SrcLoc )
+import Outputable
+import Name ( NamedThing )
\end{code}
%************************************************************************
patterns in each equation.
\begin{code}
-data Match tyvar uvar id pat
+data Match flexi id pat
= PatMatch pat
- (Match tyvar uvar id pat)
- | GRHSMatch (GRHSsAndBinds tyvar uvar id pat)
+ (Match flexi id pat)
+ | GRHSMatch (GRHSsAndBinds flexi id pat)
- | SimpleMatch (HsExpr tyvar uvar id pat) -- Used in translations
+ | SimpleMatch (HsExpr flexi id pat) -- Used in translations
\end{code}
Sets of guarded right hand sides (GRHSs). In:
sides, as the definition of @f@ shows.
\begin{code}
-data GRHSsAndBinds tyvar uvar id pat
- = GRHSsAndBindsIn [GRHS tyvar uvar id pat] -- at least one GRHS
- (HsBinds tyvar uvar id pat)
+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
- | GRHSsAndBindsOut [GRHS tyvar uvar id pat] -- at least one GRHS
- (HsBinds tyvar uvar id pat)
- (GenType tyvar uvar)
+unguardedRHS :: (HsExpr flexi id pat) -> SrcLoc -> [GRHS flexi id pat]
+unguardedRHS rhs loc = [GRHS [ExprStmt rhs loc] loc]
+\end{code}
-data GRHS tyvar uvar id pat
- = GRHS [Stmt tyvar uvar id pat] -- guard(ed)...
- (HsExpr tyvar uvar id pat) -- ... right-hand side
- SrcLoc
+@getMatchLoc@ takes a @Match@ and returns the
+source-location gotten from the GRHS inside.
+THis is something of a nuisance, but no more.
- | OtherwiseGRHS (HsExpr tyvar uvar id pat) -- guard-free
- SrcLoc
+\begin{code}
+getMatchLoc :: Match flexi id pat -> SrcLoc
+getMatchLoc (PatMatch _ m) = getMatchLoc m
+getMatchLoc (GRHSMatch (GRHSsAndBindsIn (GRHS _ loc : _) _)) = loc
\end{code}
%************************************************************************
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, Doc) -> [Match tyvar uvar id pat] -> Doc
+pprMatches :: (NamedThing id, Outputable id, Outputable pat)
+ => (Bool, SDoc) -> [Match flexi id pat] -> SDoc
-pprMatches sty print_info@(is_case, name) [match]
+pprMatches print_info@(is_case, name) [match]
= if is_case then
- pprMatch sty is_case match
+ pprMatch is_case match
else
- name <+> (pprMatch sty is_case match)
+ name <+> (pprMatch is_case match)
-pprMatches sty print_info (match1 : rest)
- = ($$) (pprMatches sty print_info [match1])
- (pprMatches sty print_info rest)
+pprMatches print_info (match1 : rest)
+ = ($$) (pprMatches print_info [match1])
+ (pprMatches 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 -> Doc
+pprMatch :: (NamedThing id, Outputable id, Outputable pat)
+ => Bool -> Match flexi id pat -> SDoc
-pprMatch sty is_case first_match
- = sep [(sep (map (ppr sty) row_of_pats)),
+pprMatch is_case first_match
+ = sep [(sep (map (ppr) row_of_pats)),
grhss_etc_stuff]
where
- (row_of_pats, grhss_etc_stuff) = ppr_match sty is_case first_match
+ (row_of_pats, grhss_etc_stuff) = ppr_match is_case first_match
- ppr_match sty is_case (PatMatch pat match)
+ ppr_match is_case (PatMatch pat match)
= (pat:pats, grhss_stuff)
where
- (pats, grhss_stuff) = ppr_match sty is_case match
+ (pats, grhss_stuff) = ppr_match is_case match
- ppr_match sty is_case (GRHSMatch grhss_n_binds)
- = ([], pprGRHSsAndBinds sty is_case grhss_n_binds)
+ ppr_match is_case (GRHSMatch grhss_n_binds)
+ = ([], pprGRHSsAndBinds is_case grhss_n_binds)
- ppr_match sty is_case (SimpleMatch expr)
- = ([], text (if is_case then "->" else "=") <+> ppr sty expr)
+ ppr_match is_case (SimpleMatch expr)
+ = ([], text (if is_case then "->" else "=") <+> ppr expr)
----------------------------------------------------------
-pprGRHSsAndBinds :: (NamedThing id, Outputable id, Outputable pat,
- Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
- PprStyle -> Bool -> GRHSsAndBinds tyvar uvar id pat -> Doc
+pprGRHSsAndBinds :: (NamedThing id, Outputable id, Outputable pat)
+ => Bool -> GRHSsAndBinds flexi id pat -> SDoc
-pprGRHSsAndBinds sty is_case (GRHSsAndBindsIn grhss binds)
- = ($$) (vcat (map (pprGRHS sty is_case) grhss))
+pprGRHSsAndBinds is_case (GRHSsAndBindsIn grhss binds)
+ = ($$) (vcat (map (pprGRHS is_case) grhss))
(if (nullBinds binds)
then empty
- else vcat [ text "where", nest 4 (ppr sty binds) ])
+ else vcat [ text "where", nest 4 (pprDeeper (ppr binds)) ])
-pprGRHSsAndBinds sty is_case (GRHSsAndBindsOut grhss binds ty)
- = ($$) (vcat (map (pprGRHS sty is_case) grhss))
+pprGRHSsAndBinds is_case (GRHSsAndBindsOut grhss binds ty)
+ = ($$) (vcat (map (pprGRHS is_case) grhss))
(if (nullBinds binds)
then empty
- else vcat [ ifPprShowAll sty
- (hsep [text "{- ty:", ppr sty ty, text "-}"]),
- text "where", nest 4 (ppr sty binds) ])
+ else vcat [text "where", nest 4 (pprDeeper (ppr binds)) ])
---------------------------------------------
-pprGRHS :: (NamedThing id, Outputable id, Outputable pat,
- Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
- => PprStyle -> Bool -> GRHS tyvar uvar id pat -> Doc
+pprGRHS :: (NamedThing id, Outputable id, Outputable pat)
+ => Bool -> GRHS flexi id pat -> SDoc
-pprGRHS sty is_case (GRHS [] expr locn)
- = text (if is_case then "->" else "=") <+> ppr sty expr
+pprGRHS is_case (GRHS [ExprStmt expr _] locn)
+ = text (if is_case then "->" else "=") <+> pprDeeper (ppr expr)
-pprGRHS sty is_case (GRHS guard expr locn)
- = sep [char '|' <+> ppr sty guard,
- text (if is_case then "->" else "=") <+> ppr sty expr
+pprGRHS is_case (GRHS guarded locn)
+ = sep [char '|' <+> interpp'SP guards,
+ text (if is_case then "->" else "=") <+> pprDeeper (ppr expr)
]
-
-pprGRHS sty is_case (OtherwiseGRHS expr locn)
- = text (if is_case then "->" else "=") <+> ppr sty expr
+ where
+ ExprStmt expr _ = last guarded -- Last stmt should be a ExprStmt for guards
+ guards = init guarded
\end{code}
projects / ghc-hetmet.git / blobdiff