%
\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
-- Friends
import HsExpr ( HsExpr, Stmt(..) )
-import HsBinds ( HsBinds, nullBinds )
+import HsBinds ( HsBinds(..), nullBinds )
+import HsTypes ( HsTyVarBndr, HsType )
-- Others
-import Type ( GenType )
+import Type ( Type )
import SrcLoc ( SrcLoc )
import Outputable
-import Name ( NamedThing )
\end{code}
%************************************************************************
%* *
-\subsection{@Match@, @GRHSsAndBinds@, and @GRHS@ datatypes}
+\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}
%* *
%************************************************************************
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
+ [HsTyVarBndr 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}
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}
%************************************************************************
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)
-
-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)) ])
-
-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
+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)
projects / ghc-hetmet.git / blobdiff