+data MatchGroup id
+ = MatchGroup
+ [LMatch id] -- The alternatives
+ PostTcType -- The type is the type of the entire group
+ -- t1 -> ... -> tn -> tr
+ -- where there are n patterns
+
+type LMatch id = Located (Match id)
+
+data Match id
+ = Match
+ [LPat id] -- The patterns
+ (Maybe (LHsType id)) -- A type signature for the result of the match
+ -- Nothing after typechecking
+ (GRHSs id)
+
+matchGroupArity :: MatchGroup id -> Arity
+matchGroupArity (MatchGroup (match:matches) _)
+ = ASSERT( all ((== n_pats) . length . hsLMatchPats) matches )
+ -- Assertion just checks that all the matches have the same number of pats
+ n_pats
+ where
+ n_pats = length (hsLMatchPats match)
+
+hsLMatchPats :: LMatch id -> [LPat id]
+hsLMatchPats (L _ (Match pats _ _)) = pats
+
+-- GRHSs are used both for pattern bindings and for Matches
+data GRHSs id
+ = GRHSs [LGRHS id] -- Guarded RHSs
+ (HsLocalBinds id) -- The where clause
+
+type LGRHS id = Located (GRHS id)
+
+data GRHS id = GRHS [LStmt id] -- Guards
+ (LHsExpr id) -- Right hand side
+\end{code}
+
+We know the list must have at least one @Match@ in it.
+
+\begin{code}
+pprMatches :: (OutputableBndr id) => HsMatchContext id -> MatchGroup id -> SDoc
+pprMatches ctxt (MatchGroup matches _) = vcat (map (pprMatch ctxt) (map unLoc matches))
+
+-- Exported to HsBinds, which can't see the defn of HsMatchContext
+pprFunBind :: (OutputableBndr id) => id -> MatchGroup id -> SDoc
+pprFunBind fun matches = pprMatches (FunRhs fun) matches
+
+-- Exported to HsBinds, which can't see the defn of HsMatchContext
+pprPatBind :: (OutputableBndr bndr, OutputableBndr id)
+ => LPat bndr -> GRHSs id -> SDoc
+pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)]
+
+
+pprMatch :: OutputableBndr id => HsMatchContext id -> Match id -> SDoc
+pprMatch ctxt (Match pats maybe_ty grhss)
+ = pp_name ctxt <+> sep [sep (map ppr pats),
+ ppr_maybe_ty,
+ nest 2 (pprGRHSs ctxt grhss)]
+ where
+ pp_name (FunRhs fun) = ppr fun -- Not pprBndr; the AbsBinds will
+ -- have printed the signature
+ pp_name LambdaExpr = char '\\'
+ pp_name other = empty
+
+ ppr_maybe_ty = case maybe_ty of
+ Just ty -> dcolon <+> ppr ty
+ Nothing -> empty
+
+
+pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc
+pprGRHSs ctxt (GRHSs grhss binds)
+ = vcat (map (pprGRHS ctxt . unLoc) grhss)
+ $$
+ (if isEmptyLocalBinds binds then empty
+ else text "where" $$ nest 4 (pprBinds binds))
+
+pprGRHS :: OutputableBndr id => HsMatchContext id -> GRHS id -> SDoc
+
+pprGRHS ctxt (GRHS [] expr)
+ = pp_rhs ctxt expr
+
+pprGRHS ctxt (GRHS guards expr)
+ = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr]
+
+pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Do stmts and list comprehensions}
+%* *
+%************************************************************************
+
+\begin{code}
+type LStmt id = Located (Stmt id)
+
+-- The SyntaxExprs in here are used *only* for do-notation, which
+-- has rebindable syntax. Otherwise they are unused.
+data Stmt id
+ = BindStmt (LPat id)
+ (LHsExpr id)
+ (SyntaxExpr id) -- The (>>=) operator
+ (SyntaxExpr id) -- The fail operator
+ -- The fail operator is noSyntaxExpr
+ -- if the pattern match can't fail
+
+ | ExprStmt (LHsExpr id)
+ (SyntaxExpr id) -- The (>>) operator
+ PostTcType -- Element type of the RHS (used for arrows)
+
+ | LetStmt (HsLocalBinds id)
+
+ -- ParStmts only occur in a list comprehension
+ | ParStmt [([LStmt id], [id])] -- After renaming, the ids are the binders
+ -- bound by the stmts and used subsequently
+
+ -- Recursive statement (see Note [RecStmt] below)
+ | RecStmt [LStmt id]
+ --- The next two fields are only valid after renaming
+ [id] -- The ids are a subset of the variables bound by the stmts
+ -- that are used in stmts that follow the RecStmt
+
+ [id] -- Ditto, but these variables are the "recursive" ones, that
+ -- are used before they are bound in the stmts of the RecStmt
+ -- From a type-checking point of view, these ones have to be monomorphic
+
+ --- These fields are only valid after typechecking
+ [PostTcExpr] -- These expressions correspond
+ -- 1-to-1 with the "recursive" [id], and are the expresions that
+ -- should be returned by the recursion. They may not quite be the
+ -- Ids themselves, because the Id may be *polymorphic*, but
+ -- the returned thing has to be *monomorphic*.
+ (DictBinds id) -- Method bindings of Ids bound by the RecStmt,
+ -- and used afterwards
+\end{code}
+
+ExprStmts are a bit tricky, because what they mean
+depends on the context. Consider the following contexts:
+
+ A do expression of type (m res_ty)
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ * ExprStmt E any_ty: do { ....; E; ... }
+ E :: m any_ty
+ Translation: E >> ...
+
+ A list comprehensions of type [elt_ty]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ * ExprStmt E Bool: [ .. | .... E ]
+ [ .. | ..., E, ... ]
+ [ .. | .... | ..., E | ... ]
+ E :: Bool
+ Translation: if E then fail else ...
+
+ A guard list, guarding a RHS of type rhs_ty
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ * ExprStmt E Bool: f x | ..., E, ... = ...rhs...
+ E :: Bool
+ Translation: if E then fail else ...
+
+Array comprehensions are handled like list comprehensions -=chak
+
+Note [RecStmt]
+~~~~~~~~~~~~~~
+Example:
+ HsDo [ BindStmt x ex
+
+ , RecStmt [a::forall a. a -> a, b]
+ [a::Int -> Int, c]
+ [ BindStmt b (return x)
+ , LetStmt a = ea
+ , BindStmt c ec ]
+
+ , return (a b) ]
+
+Here, the RecStmt binds a,b,c; but
+ - Only a,b are used in the stmts *following* the RecStmt,
+ This 'a' is *polymorphic'
+ - Only a,c are used in the stmts *inside* the RecStmt
+ *before* their bindings
+ This 'a' is monomorphic
+
+Nota Bene: the two a's have different types, even though they
+have the same Name.
+
+
+\begin{code}
+instance OutputableBndr id => Outputable (Stmt id) where
+ ppr stmt = pprStmt stmt
+
+pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, ptext SLIT("<-"), ppr expr]
+pprStmt (LetStmt binds) = hsep [ptext SLIT("let"), pprBinds binds]
+pprStmt (ExprStmt expr _ _) = ppr expr
+pprStmt (ParStmt stmtss) = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
+pprStmt (RecStmt segment _ _ _ _) = ptext SLIT("rec") <+> braces (vcat (map ppr segment))
+
+pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc
+pprDo DoExpr stmts body = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts) $$ ppr body)
+pprDo (MDoExpr _) stmts body = hang (ptext SLIT("mdo")) 3 (vcat (map ppr stmts) $$ ppr body)
+pprDo ListComp stmts body = pprComp brackets stmts body
+pprDo PArrComp stmts body = pprComp pa_brackets stmts body
+
+pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [LStmt id] -> LHsExpr id -> SDoc
+pprComp brack quals body
+ = brack $
+ hang (ppr body <+> char '|')
+ 4 (interpp'SP quals)