ghc/compiler/hsSyn/HsMatches.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[HsMatches]{Abstract syntax: matches and guarded right-hand-sides}
   5
   6 The @Match@, @GRHSsAndBinds@ and @GRHS@ datatypes.
   7
   8 \begin{code}
   9 #include "HsVersions.h"
  10
  11 module HsMatches where
  12
  13 IMP_Ubiq(){-uitous-}
  14
  15 -- Friends
  16 import HsExpr           ( HsExpr, Stmt )
  17 import HsBinds          ( HsBinds, nullBinds )
  18
  19 -- Others
  20 import Outputable       ( ifPprShowAll, PprStyle )
  21 import PprType          ( GenType{-instance Outputable-} )
  22 import Pretty
  23 import SrcLoc           ( SrcLoc{-instances-} )
  24 import Util             ( panic )
  25 import Outputable       ( Outputable(..) )
  26 #if __GLASGOW_HASKELL__ >= 202
  27 import Name
  28 #endif
  29
  30 \end{code}
  31
  32 %************************************************************************
  33 %*                                                                      *
  34 \subsection{@Match@, @GRHSsAndBinds@, and @GRHS@ datatypes}
  35 %*                                                                      *
  36 %************************************************************************
  37
  38 @Match@es are sets of pattern bindings and right hand sides for
  39 functions, patterns or case branches. For example, if a function @g@
  40 is defined as:
  41 \begin{verbatim}
  42 g (x,y) = y
  43 g ((x:ys),y) = y+1,
  44 \end{verbatim}
  45 then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@.
  46
  47 It is always the case that each element of an @[Match]@ list has the
  48 same number of @PatMatch@s inside it.  This corresponds to saying that
  49 a function defined by pattern matching must have the same number of
  50 patterns in each equation.
  51
  52 \begin{code}
  53 data Match tyvar uvar id pat
  54   = PatMatch        pat
  55                     (Match tyvar uvar id pat)
  56   | GRHSMatch       (GRHSsAndBinds tyvar uvar id pat)
  57
  58   | SimpleMatch     (HsExpr tyvar uvar id pat)          -- Used in translations
  59 \end{code}
  60
  61 Sets of guarded right hand sides (GRHSs). In:
  62 \begin{verbatim}
  63 f (x,y) | x==True = y
  64         | otherwise = y*2
  65 \end{verbatim}
  66 a guarded right hand side is either
  67 @(x==True = y)@, or @(otherwise = y*2)@.
  68
  69 For each match, there may be several guarded right hand
  70 sides, as the definition of @f@ shows.
  71
  72 \begin{code}
  73 data GRHSsAndBinds tyvar uvar id pat
  74   = GRHSsAndBindsIn     [GRHS tyvar uvar id pat]            -- at least one GRHS
  75                         (HsBinds tyvar uvar id pat)
  76
  77   | GRHSsAndBindsOut    [GRHS tyvar uvar id pat]            -- at least one GRHS
  78                         (HsBinds tyvar uvar id pat)
  79                         (GenType tyvar uvar)
  80
  81 data GRHS tyvar uvar id pat
  82   = GRHS            [Stmt tyvar uvar id pat]    -- guard(ed)...
  83                     (HsExpr tyvar uvar id pat)  -- ... right-hand side
  84                     SrcLoc
  85
  86   | OtherwiseGRHS   (HsExpr tyvar uvar id pat)  -- guard-free
  87                     SrcLoc
  88 \end{code}
  89
  90 %************************************************************************
  91 %*                                                                      *
  92 \subsection{Printing}
  93 %*                                                                      *
  94 %************************************************************************
  95
  96 We know the list must have at least one @Match@ in it.
  97 \begin{code}
  98 pprMatches :: (NamedThing id, Outputable id, Outputable pat,
  99                Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
 100                 PprStyle -> (Bool, Doc) -> [Match tyvar uvar id pat] -> Doc
 101
 102 pprMatches sty print_info@(is_case, name) [match]
 103   = if is_case then
 104         pprMatch sty is_case match
 105     else
 106         hang name 4 (pprMatch sty is_case match)
 107
 108 pprMatches sty print_info (match1 : rest)
 109  = ($$) (pprMatches sty print_info [match1])
 110            (pprMatches sty print_info rest)
 111
 112 ---------------------------------------------
 113 pprMatch :: (NamedThing id, Outputable id, Outputable pat,
 114                Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
 115         PprStyle -> Bool -> Match tyvar uvar id pat -> Doc
 116
 117 pprMatch sty is_case first_match
 118  = hang (sep (map (ppr sty) row_of_pats))
 119         8 grhss_etc_stuff
 120  where
 121     (row_of_pats, grhss_etc_stuff) = ppr_match sty is_case first_match
 122
 123     ppr_match sty is_case (PatMatch pat match)
 124       = (pat:pats, grhss_stuff)
 125       where
 126         (pats, grhss_stuff) = ppr_match sty is_case match
 127
 128     ppr_match sty is_case (GRHSMatch grhss_n_binds)
 129       = ([], pprGRHSsAndBinds sty is_case grhss_n_binds)
 130
 131     ppr_match sty is_case (SimpleMatch expr)
 132       = ([], hang (text (if is_case then "->" else "="))
 133                  4 (ppr sty expr))
 134
 135 ----------------------------------------------------------
 136
 137 pprGRHSsAndBinds :: (NamedThing id, Outputable id, Outputable pat,
 138                     Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
 139                 PprStyle -> Bool -> GRHSsAndBinds tyvar uvar id pat -> Doc
 140
 141 pprGRHSsAndBinds sty is_case (GRHSsAndBindsIn grhss binds)
 142  = ($$) (vcat (map (pprGRHS sty is_case) grhss))
 143            (if (nullBinds binds)
 144             then empty
 145             else vcat [ text "where", nest 4 (ppr sty binds) ])
 146
 147 pprGRHSsAndBinds sty is_case (GRHSsAndBindsOut grhss binds ty)
 148  = ($$) (vcat (map (pprGRHS sty is_case) grhss))
 149            (if (nullBinds binds)
 150             then empty
 151             else vcat [ ifPprShowAll sty
 152                                 (hsep [text "{- ty:", ppr sty ty, text "-}"]),
 153                             text "where", nest 4 (ppr sty binds) ])
 154
 155 ---------------------------------------------
 156 pprGRHS :: (NamedThing id, Outputable id, Outputable pat,
 157             Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
 158         => PprStyle -> Bool -> GRHS tyvar uvar id pat -> Doc
 159
 160 pprGRHS sty is_case (GRHS [] expr locn)
 161  =  hang (text (if is_case then "->" else "="))
 162          4 (ppr sty expr)
 163
 164 pprGRHS sty is_case (GRHS guard expr locn)
 165  = hang (hsep [char '|', ppr sty guard, text (if is_case then "->" else "=")])
 166         4 (ppr sty expr)
 167
 168 pprGRHS sty is_case (OtherwiseGRHS  expr locn)
 169   = hang (text (if is_case then "->" else "="))
 170          4 (ppr sty expr)
 171 \end{code}