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