ghc/compiler/typecheck/TcMatches.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
   3 %
   4 \section[TcMatches]{Typecheck some @Matches@}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatch ) where
  10
  11 IMP_Ubiq()
  12
  13 import HsSyn            ( Match(..), GRHSsAndBinds(..), GRHS(..), InPat,
  14                           HsExpr, HsBinds, OutPat, Fake,
  15                           collectPatBinders, pprMatch )
  16 import RnHsSyn          ( RenamedMatch(..) )
  17 import TcHsSyn          ( TcIdOcc(..), TcMatch(..) )
  18
  19 import TcMonad          hiding ( rnMtoTcM )
  20 import Inst             ( Inst, LIE(..), plusLIE )
  21 import TcEnv            ( newMonoIds )
  22 IMPORT_DELOOPER(TcLoop)         ( tcGRHSsAndBinds )
  23 import TcPat            ( tcPat )
  24 import TcType           ( TcType(..), TcMaybe, zonkTcType )
  25 import Unify            ( unifyTauTy, unifyTauTyList )
  26
  27 import Kind             ( Kind, mkTypeKind )
  28 import Pretty
  29 import RnHsSyn          ( RnName{-instance Outputable-} )
  30 import Type             ( isTyVarTy, mkFunTy, getFunTy_maybe )
  31 import Util
  32 \end{code}
  33
  34 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
  35 @FunMonoBind@.  The second argument is the name of the function, which
  36 is used in error messages.  It checks that all the equations have the
  37 same number of arguments before using @tcMatches@ to do the work.
  38
  39 \begin{code}
  40 tcMatchesFun :: RnName
  41              -> TcType s                -- Expected type
  42              -> [RenamedMatch]
  43              -> TcM s ([TcMatch s], LIE s)
  44
  45 tcMatchesFun fun_name expected_ty matches@(first_match:_)
  46   =      -- Set the location to that of the first equation, so that
  47          -- any inter-equation error messages get some vaguely
  48          -- sensible location.  Note: we have to do this odd
  49          -- ann-grabbing, because we don't always have annotations in
  50          -- hand when we call tcMatchesFun...
  51
  52     tcAddSrcLoc (get_Match_loc first_match)      (
  53
  54          -- Check that they all have the same no of arguments
  55     checkTc (all_same (noOfArgs matches))
  56             (varyingArgsErr fun_name matches) `thenTc_`
  57
  58         -- ToDo: Don't use "expected" stuff if there ain't a type signature
  59         -- because inconsistency between branches
  60         -- may show up as something wrong with the (non-existent) type signature
  61
  62         -- We need to substitute so that we can see as much about the type as possible
  63     zonkTcType expected_ty              `thenNF_Tc` \ expected_ty' ->
  64     tcMatchesExpected expected_ty' (MFun fun_name) matches
  65
  66     )
  67   where
  68     all_same :: [Int] -> Bool
  69     all_same []     = True      -- Should never happen (ToDo: panic?)
  70     all_same [x]    = True
  71     all_same (x:xs) = all ((==) x) xs
  72 \end{code}
  73
  74 @tcMatchesCase@ doesn't do the argument-count check because the
  75 parser guarantees that each equation has exactly one argument.
  76
  77 \begin{code}
  78 tcMatchesCase :: TcType s -> [RenamedMatch] -> TcM s ([TcMatch s], LIE s)
  79 tcMatchesCase expected_ty matches = tcMatchesExpected expected_ty MCase matches
  80 \end{code}
  81
  82
  83 \begin{code}
  84 data FunOrCase = MCase | MFun RnName    -- Records whether doing  fun or case rhss;
  85                                         -- used to produced better error messages
  86
  87 tcMatchesExpected :: TcType s
  88                   -> FunOrCase
  89                   -> [RenamedMatch]
  90                   -> TcM s ([TcMatch s], LIE s)
  91
  92 tcMatchesExpected expected_ty fun_or_case [match]
  93   = tcAddSrcLoc (get_Match_loc match)           $
  94     tcAddErrCtxt (matchCtxt fun_or_case match)  $
  95     tcMatchExpected expected_ty match   `thenTc` \ (match',  lie) ->
  96     returnTc ([match'], lie)
  97
  98 tcMatchesExpected expected_ty fun_or_case (match1 : matches)
  99   = tcAddSrcLoc (get_Match_loc match1)  (
 100         tcAddErrCtxt (matchCtxt fun_or_case match1)     $
 101         tcMatchExpected expected_ty  match1
 102     )                                                   `thenTc` \ (match1',  lie1) ->
 103     tcMatchesExpected expected_ty fun_or_case matches   `thenTc` \ (matches', lie2) ->
 104     returnTc (match1' : matches', plusLIE lie1 lie2)
 105
 106 tcMatches :: [RenamedMatch] -> TcM s ([TcMatch s], LIE s, [TcType s])
 107
 108 tcMatches [match]
 109   = tcAddSrcLoc (get_Match_loc match) $
 110     tcMatch match               `thenTc` \ (match', lie, ty) ->
 111     returnTc ([match'], lie, [ty])
 112
 113 tcMatches (match1 : matches)
 114   = tcAddSrcLoc (get_Match_loc match1) (
 115         tcMatch match1
 116     )                           `thenTc` \ (match1',  lie1, match1_ty) ->
 117     tcMatches matches           `thenTc` \ (matches', lie2, matches_ty) ->
 118     returnTc (match1' : matches', plusLIE lie1 lie2, match1_ty : matches_ty)
 119 \end{code}
 120
 121 \begin{code}
 122 tcMatchExpected
 123         :: TcType s             -- This gives the expected
 124                                 -- result-type of the Match.  Early unification
 125                                 -- with this guy gives better error messages
 126         -> RenamedMatch
 127         -> TcM s (TcMatch s,LIE s)      -- NB No type returned, because it was passed
 128                                         -- in instead!
 129
 130 tcMatchExpected expected_ty the_match@(PatMatch pat match)
 131   = case getFunTy_maybe expected_ty of
 132
 133         Nothing ->                      -- Not a function type (eg type variable)
 134                                         -- So use tcMatch instead
 135             tcMatch the_match                   `thenTc`   \ (match', lie_match, match_ty) ->
 136             unifyTauTy match_ty expected_ty     `thenTc_`
 137             returnTc (match', lie_match)
 138
 139         Just (arg_ty,rest_ty) ->        -- It's a function type!
 140             let binders = collectPatBinders pat
 141             in
 142             newMonoIds binders mkTypeKind (\ _ ->
 143                 tcPat pat                       `thenTc` \ (pat', lie_pat, pat_ty) ->
 144                 unifyTauTy arg_ty pat_ty        `thenTc_`
 145                 tcMatchExpected rest_ty  match  `thenTc` \ (match', lie_match) ->
 146                 returnTc (PatMatch pat' match',
 147                           plusLIE lie_pat lie_match)
 148             )
 149
 150 tcMatchExpected expected_ty (GRHSMatch grhss_and_binds)
 151   = tcGRHSsAndBinds grhss_and_binds     `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
 152     unifyTauTy grhss_ty expected_ty     `thenTc_`
 153     returnTc (GRHSMatch grhss_and_binds', lie)
 154
 155 tcMatch :: RenamedMatch -> TcM s (TcMatch s, LIE s, TcType s)
 156
 157 tcMatch (PatMatch pat match)
 158   = let binders = collectPatBinders pat
 159     in
 160     newMonoIds binders mkTypeKind (\ _ ->
 161         tcPat pat               `thenTc`   \ (pat',   lie_pat,   pat_ty) ->
 162         tcMatch match           `thenTc`   \ (match', lie_match, match_ty) ->
 163         returnTc (PatMatch pat' match',
 164                   plusLIE lie_pat lie_match,
 165                   mkFunTy pat_ty match_ty)
 166     )
 167
 168 tcMatch (GRHSMatch grhss_and_binds)
 169   = tcGRHSsAndBinds grhss_and_binds   `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
 170     returnTc (GRHSMatch grhss_and_binds', lie, grhss_ty)
 171 \end{code}
 172
 173
 174 @noOfArgs@ takes a @[RenamedMatch]@ and returns a list telling how
 175 many arguments were used in each of the equations.  This is used to
 176 report a sensible error message when different equations have
 177 different numbers of arguments.
 178
 179 \begin{code}
 180 noOfArgs :: [RenamedMatch] -> [Int]
 181
 182 noOfArgs ms = map args_in_match ms
 183   where
 184     args_in_match :: RenamedMatch -> Int
 185     args_in_match (GRHSMatch _) = 0
 186     args_in_match (PatMatch _ match) = 1 + args_in_match match
 187 \end{code}
 188
 189 @get_Match_loc@ takes a @RenamedMatch@ and returns the
 190 source-location gotten from the GRHS inside.
 191 THis is something of a nuisance, but no more.
 192
 193 \begin{code}
 194 get_Match_loc     :: RenamedMatch   -> SrcLoc
 195
 196 get_Match_loc (PatMatch _ m)    = get_Match_loc m
 197 get_Match_loc (GRHSMatch (GRHSsAndBindsIn (g:_) _))
 198       = get_GRHS_loc g
 199       where
 200         get_GRHS_loc (OtherwiseGRHS _ locn) = locn
 201         get_GRHS_loc (GRHS _ _ locn)        = locn
 202 \end{code}
 203
 204 Errors and contexts
 205 ~~~~~~~~~~~~~~~~~~~
 206 \begin{code}
 207 matchCtxt MCase match sty
 208   = ppHang (ppStr "In a \"case\" branch:")
 209          4 (pprMatch sty True{-is_case-} match)
 210
 211 matchCtxt (MFun fun) match sty
 212   = ppHang (ppBesides [ppStr "In an equation for function ", ppr sty fun, ppChar ':'])
 213          4 (ppBesides [ppr sty fun, ppSP, pprMatch sty False{-not case-} match])
 214 \end{code}
 215
 216
 217 \begin{code}
 218 varyingArgsErr name matches sty
 219   = ppSep [ppStr "Varying number of arguments for function", ppr sty name]
 220 \end{code}