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