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 import TcMonad          -- typechecking monad machinery
  12 import TcMonadFns       ( mkIdsWithOpenTyVarTys )
  13 import AbsSyn           -- the stuff being typechecked
  14
  15 import AbsPrel          ( mkFunTy )
  16 import AbsUniType       ( isTyVarTy, maybeUnpackFunTy )
  17 import E                ( E, growE_LVE, LVE(..), GVE(..) )
  18 #if USE_ATTACK_PRAGMAS
  19 import CE
  20 import TCE
  21 #endif
  22 import Errors           ( varyingArgsErr, Error(..), UnifyErrContext(..) )
  23 import LIE              ( LIE, plusLIE )
  24 import Maybes           ( Maybe(..) )
  25 import TcGRHSs          ( tcGRHSsAndBinds )
  26 import TcPat            ( tcPat )
  27 import Unify            ( unifyTauTy, unifyTauTyList )
  28 import Util
  29 \end{code}
  30
  31 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
  32 @FunMonoBind@.  The second argument is the name of the function, which
  33 is used in error messages.  It checks that all the equations have the
  34 same number of arguments before using @tcMatches@ to do the work.
  35
  36 \begin{code}
  37 tcMatchesFun :: E -> Name
  38              -> UniType                 -- Expected type
  39              -> [RenamedMatch]
  40              -> TcM ([TypecheckedMatch], LIE)
  41
  42 tcMatchesFun e fun_name expected_ty matches@(first_match:_)
  43   =      -- Set the location to that of the first equation, so that
  44          -- any inter-equation error messages get some vaguely
  45          -- sensible location.  Note: we have to do this odd
  46          -- ann-grabbing, because we don't always have annotations in
  47          -- hand when we call tcMatchesFun...
  48
  49     addSrcLocTc (get_Match_loc first_match)      (
  50
  51          -- Check that they all have the same no of arguments
  52     checkTc (not (all_same (noOfArgs matches)))
  53             (varyingArgsErr fun_name matches) `thenTc_`
  54
  55         -- ToDo: Don't use "expected" stuff if there ain't a type signature
  56         -- because inconsistency between branches
  57         -- may show up as something wrong with the (non-existent) type signature
  58
  59         -- We need to substitute so that we can see as much about the type as possible
  60     applyTcSubstToTy expected_ty        `thenNF_Tc` \ expected_ty' ->
  61     tcMatchesExpected e expected_ty' (\ m -> FunMonoBindsCtxt fun_name [m]) matches
  62
  63     )
  64   where
  65     all_same :: [Int] -> Bool
  66     all_same []     = True      -- Should never happen (ToDo: panic?)
  67     all_same [x]    = True
  68     all_same (x:xs) = all ((==) x) xs
  69 \end{code}
  70
  71 @tcMatchesCase@ doesn't do the argument-count check because the
  72 parser guarantees that each equation has exactly one argument.
  73
  74 \begin{code}
  75 tcMatchesCase :: E -> [RenamedMatch]
  76               -> TcM ([TypecheckedMatch], LIE, UniType)
  77
  78 tcMatchesCase e matches
  79   =
  80
  81          -- Typecheck them
  82     tcMatches e matches                 `thenTc` \ (matches', lie, tys@(first_ty:_)) ->
  83
  84         -- Set the location to that of the first equation, so that
  85         -- any inter-equation error messages get some vaguely sensible location
  86     addSrcLocTc (get_Match_loc (head matches)) (
  87             unifyTauTyList tys (CaseBranchesCtxt matches)
  88     )                                    `thenTc_`
  89
  90     returnTc (matches', lie, first_ty)
  91 \end{code}
  92
  93
  94 \begin{code}
  95 tcMatchesExpected :: E
  96                   -> UniType
  97                   -> (RenamedMatch -> UnifyErrContext)
  98                   -> [RenamedMatch]
  99                   -> TcM ([TypecheckedMatch], LIE)
 100
 101 tcMatchesExpected e expected_ty err_ctxt_fn [match]
 102   = addSrcLocTc (get_Match_loc match) (
 103         tcMatchExpected e expected_ty (err_ctxt_fn match) match
 104     )                                           `thenTc` \ (match',  lie) ->
 105     returnTc ([match'], lie)
 106
 107 tcMatchesExpected e expected_ty err_ctxt_fn ms@(match1 : matches)
 108   = addSrcLocTc (get_Match_loc match1) (
 109         tcMatchExpected e expected_ty (err_ctxt_fn match1) match1
 110     )                                                   `thenTc` \ (match1',  lie1) ->
 111     tcMatchesExpected e expected_ty err_ctxt_fn matches `thenTc` \ (matches', lie2) ->
 112     returnTc (match1' : matches', plusLIE lie1 lie2)
 113
 114 tcMatches :: E -> [RenamedMatch] -> TcM ([TypecheckedMatch], LIE, [UniType])
 115
 116 tcMatches e [match]
 117   = tcMatch e match             `thenTc` \ (match', lie, ty) ->
 118     returnTc ([match'], lie, [ty])
 119
 120 tcMatches e ms@(match1 : matches)
 121   = addSrcLocTc (get_Match_loc match1) (
 122         tcMatch e match1
 123     )                           `thenTc` \ (match1',  lie1, match1_ty) ->
 124     tcMatches e matches         `thenTc` \ (matches', lie2, matches_ty) ->
 125     returnTc (match1' : matches', plusLIE lie1 lie2, match1_ty : matches_ty)
 126 \end{code}
 127
 128 \begin{code}
 129 tcMatchExpected
 130         :: E
 131         -> UniType              -- This gives the expected
 132                                 -- result-type of the Match.  Early unification
 133                                 -- with this guy gives better error messages
 134         -> UnifyErrContext
 135         -> RenamedMatch
 136         -> TcM (TypecheckedMatch,LIE)
 137                                 -- NB No type returned, because it was passed
 138                                 -- in instead!
 139
 140 tcMatchExpected e expected_ty err_ctxt the_match@(PatMatch pat match)
 141   = case maybeUnpackFunTy expected_ty of
 142
 143         Nothing ->                      -- Not a function type (eg type variable)
 144                                         -- So use tcMatch instead
 145             tcMatch e the_match                         `thenTc`   \ (match', lie_match, match_ty) ->
 146             unifyTauTy match_ty expected_ty err_ctxt    `thenTc_`
 147             returnTc (match', lie_match)
 148
 149         Just (arg_ty,rest_ty) ->        -- It's a function type!
 150             let binders = collectPatBinders pat
 151             in
 152             mkIdsWithOpenTyVarTys binders    `thenNF_Tc` \ lve ->
 153             let e' = growE_LVE e lve
 154             in
 155             tcPat e' pat                `thenTc`   \ (pat',   lie_pat,   pat_ty) ->
 156
 157             unifyTauTy arg_ty pat_ty err_ctxt         `thenTc_`
 158             tcMatchExpected e' rest_ty err_ctxt match `thenTc` \ (match', lie_match) ->
 159             returnTc (PatMatch pat' match',
 160                           plusLIE lie_pat lie_match)
 161
 162 tcMatchExpected e expected_ty err_ctxt (GRHSMatch grhss_and_binds)
 163   = tcGRHSsAndBinds e grhss_and_binds           `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
 164     unifyTauTy grhss_ty expected_ty err_ctxt    `thenTc_`
 165     returnTc (GRHSMatch grhss_and_binds', lie)
 166
 167 tcMatch :: E
 168         -> RenamedMatch
 169         -> TcM (TypecheckedMatch,LIE,UniType)
 170
 171 tcMatch e (PatMatch pat match)
 172   = let binders = collectPatBinders pat
 173     in
 174     mkIdsWithOpenTyVarTys binders    `thenNF_Tc` \ lve ->
 175     let e' = growE_LVE e lve
 176     in
 177     tcPat e' pat                `thenTc`   \ (pat',   lie_pat,   pat_ty) ->
 178     tcMatch e' match            `thenTc`   \ (match', lie_match, match_ty) ->
 179
 180 --    We don't do this any more, do we?
 181 --    applyTcSubstToTy pat_ty   `thenNF_Tc`\ pat_ty' ->
 182
 183     returnTc (PatMatch pat' match',
 184               plusLIE lie_pat lie_match,
 185               mkFunTy pat_ty match_ty)
 186
 187 tcMatch e (GRHSMatch grhss_and_binds)
 188   = tcGRHSsAndBinds e grhss_and_binds   `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
 189     returnTc (GRHSMatch grhss_and_binds', lie, grhss_ty)
 190 \end{code}
 191
 192
 193 @noOfArgs@ takes a @[RenamedMatch]@ and returns a list telling how
 194 many arguments were used in each of the equations.  This is used to
 195 report a sensible error message when different equations have
 196 different numbers of arguments.
 197
 198 \begin{code}
 199 noOfArgs :: [RenamedMatch] -> [Int]
 200
 201 noOfArgs ms = map args_in_match ms
 202   where
 203     args_in_match :: RenamedMatch -> Int
 204     args_in_match (GRHSMatch _) = 0
 205     args_in_match (PatMatch _ match) = 1 + args_in_match match
 206 \end{code}
 207
 208 @get_Match_loc@ takes a @RenamedMatch@ and returns the
 209 source-location gotten from the GRHS inside.
 210 THis is something of a nuisance, but no more.
 211
 212 \begin{code}
 213 get_Match_loc     :: RenamedMatch   -> SrcLoc
 214
 215 get_Match_loc (PatMatch _ m)    = get_Match_loc m
 216 get_Match_loc (GRHSMatch (GRHSsAndBindsIn (g:_) _))
 217       = get_GRHS_loc g
 218       where
 219         get_GRHS_loc (OtherwiseGRHS _ locn) = locn
 220         get_GRHS_loc (GRHS _ _ locn)        = locn
 221 \end{code}