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 module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchExpected ) where
   8
   9 #include "HsVersions.h"
  10
  11 import {-# SOURCE #-} TcGRHSs ( tcGRHSsAndBinds )
  12
  13 import HsSyn            ( HsBinds(..), Match(..), GRHSsAndBinds(..), GRHS(..),
  14                           HsExpr(..), MonoBinds(..),
  15                           collectPatBinders, pprMatch, getMatchLoc
  16                         )
  17 import RnHsSyn          ( RenamedMatch )
  18 import TcHsSyn          ( TcIdBndr, TcMatch )
  19
  20 import TcMonad
  21 import Inst             ( Inst, LIE, plusLIE )
  22 import TcEnv            ( TcIdOcc(..), newMonoIds )
  23 import TcPat            ( tcPat )
  24 import TcType           ( TcType, TcMaybe, zonkTcType )
  25 import TcSimplify       ( bindInstsOfLocalFuns )
  26 import Unify            ( unifyTauTy, unifyTauTyList, unifyFunTy )
  27 import Name             ( Name {- instance Outputable -} )
  28
  29 import Kind             ( Kind, mkTypeKind )
  30 import BasicTypes       ( RecFlag(..) )
  31 import Type             ( isTyVarTy, isTauTy, mkFunTy, splitFunTy_maybe )
  32 import Util
  33 import Outputable
  34 import SrcLoc           (SrcLoc)
  35 \end{code}
  36
  37 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
  38 @FunMonoBind@.  The second argument is the name of the function, which
  39 is used in error messages.  It checks that all the equations have the
  40 same number of arguments before using @tcMatches@ to do the work.
  41
  42 \begin{code}
  43 tcMatchesFun :: Name
  44              -> TcType s                -- Expected type
  45              -> [RenamedMatch]
  46              -> TcM s ([TcMatch s], LIE s)
  47
  48 tcMatchesFun fun_name expected_ty matches@(first_match:_)
  49   =      -- Set the location to that of the first equation, so that
  50          -- any inter-equation error messages get some vaguely
  51          -- sensible location.  Note: we have to do this odd
  52          -- ann-grabbing, because we don't always have annotations in
  53          -- hand when we call tcMatchesFun...
  54
  55     tcAddSrcLoc (getMatchLoc first_match)        (
  56
  57          -- Check that they all have the same no of arguments
  58     checkTc (all_same (noOfArgs matches))
  59             (varyingArgsErr fun_name matches) `thenTc_`
  60
  61         -- ToDo: Don't use "expected" stuff if there ain't a type signature
  62         -- because inconsistency between branches
  63         -- may show up as something wrong with the (non-existent) type signature
  64
  65         -- We need to substitute so that we can see as much about the type as possible
  66     zonkTcType expected_ty              `thenNF_Tc` \ expected_ty' ->
  67     tcMatchesExpected expected_ty' (MFun fun_name) matches
  68
  69     )
  70   where
  71     all_same :: [Int] -> Bool
  72     all_same []     = True      -- Should never happen (ToDo: panic?)
  73     all_same [x]    = True
  74     all_same (x:xs) = all ((==) x) xs
  75 \end{code}
  76
  77 @tcMatchesCase@ doesn't do the argument-count check because the
  78 parser guarantees that each equation has exactly one argument.
  79
  80 \begin{code}
  81 tcMatchesCase :: TcType s -> [RenamedMatch] -> TcM s ([TcMatch s], LIE s)
  82 tcMatchesCase expected_ty matches = tcMatchesExpected expected_ty MCase matches
  83 \end{code}
  84
  85
  86 \begin{code}
  87 data FunOrCase = MCase | MFun Name      -- Records whether doing  fun or case rhss;
  88                                         -- used to produced better error messages
  89
  90 tcMatchesExpected :: TcType s
  91                   -> FunOrCase
  92                   -> [RenamedMatch]
  93                   -> TcM s ([TcMatch s], LIE s)
  94
  95 tcMatchesExpected expected_ty fun_or_case [match]
  96   = tcAddSrcLoc (getMatchLoc match)             $
  97     tcAddErrCtxt (matchCtxt fun_or_case match)  $
  98     tcMatchExpected [] expected_ty match        `thenTc` \ (match',  lie) ->
  99     returnTc ([match'], lie)
 100
 101 tcMatchesExpected expected_ty fun_or_case (match1 : matches)
 102   = tcAddSrcLoc (getMatchLoc match1)    (
 103         tcAddErrCtxt (matchCtxt fun_or_case match1)     $
 104         tcMatchExpected [] expected_ty  match1
 105     )                                                   `thenTc` \ (match1',  lie1) ->
 106     tcMatchesExpected expected_ty fun_or_case matches   `thenTc` \ (matches', lie2) ->
 107     returnTc (match1' : matches', plusLIE lie1 lie2)
 108 \end{code}
 109
 110 \begin{code}
 111 tcMatchExpected
 112         :: [TcIdBndr s]         -- Ids bound by enclosing matches
 113         -> TcType s             -- This gives the expected
 114                                 -- result-type of the Match.  Early unification
 115                                 -- with this guy gives better error messages
 116         -> RenamedMatch
 117         -> TcM s (TcMatch s,LIE s)      -- NB No type returned, because it was passed
 118                                         -- in instead!
 119
 120 tcMatchExpected matched_ids expected_ty the_match@(PatMatch pat match)
 121   = unifyFunTy expected_ty              `thenTc` \ (arg_ty, rest_ty) ->
 122
 123     let binders = collectPatBinders pat
 124     in
 125     newMonoIds binders mkTypeKind (\ mono_ids ->
 126         tcPat pat                       `thenTc` \ (pat', lie_pat, pat_ty) ->
 127         unifyTauTy pat_ty arg_ty        `thenTc_`
 128
 129         tcMatchExpected (mono_ids ++ matched_ids)
 130                         rest_ty match   `thenTc` \ (match', lie_match) ->
 131
 132         returnTc (PatMatch pat' match',
 133                   plusLIE lie_pat lie_match)
 134     )
 135
 136 tcMatchExpected matched_ids expected_ty (GRHSMatch grhss_and_binds)
 137   =     -- Check that the remaining "expected type" is not a rank-2 type
 138         -- If it is it'll mess up the unifier when checking the RHS
 139     checkTc (isTauTy expected_ty)
 140             lurkingRank2SigErr          `thenTc_`
 141
 142     tcGRHSsAndBinds expected_ty grhss_and_binds         `thenTc` \ (GRHSsAndBindsOut grhss binds ty, lie) ->
 143
 144         -- In case there are any polymorpic, overloaded binders in the pattern
 145         -- (which can happen in the case of rank-2 type signatures, or data constructors
 146         -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
 147     bindInstsOfLocalFuns lie matched_ids        `thenTc` \ (lie', inst_mbinds) ->
 148     let
 149         binds' = case inst_mbinds of
 150                    EmptyMonoBinds -> binds      -- The common case
 151                    other          -> MonoBind inst_mbinds [] Recursive `ThenBinds` binds
 152     in
 153     returnTc (GRHSMatch (GRHSsAndBindsOut grhss binds' ty), lie')
 154 \end{code}
 155
 156
 157 @noOfArgs@ takes a @[RenamedMatch]@ and returns a list telling how
 158 many arguments were used in each of the equations.  This is used to
 159 report a sensible error message when different equations have
 160 different numbers of arguments.
 161
 162 \begin{code}
 163 noOfArgs :: [RenamedMatch] -> [Int]
 164
 165 noOfArgs ms = map args_in_match ms
 166   where
 167     args_in_match :: RenamedMatch -> Int
 168     args_in_match (GRHSMatch _) = 0
 169     args_in_match (PatMatch _ match) = 1 + args_in_match match
 170 \end{code}
 171
 172 Errors and contexts
 173 ~~~~~~~~~~~~~~~~~~~
 174 \begin{code}
 175 matchCtxt MCase match
 176   = hang (ptext SLIT("In a \"case\" branch:"))
 177          4 (pprMatch True{-is_case-} match)
 178
 179 matchCtxt (MFun fun) match
 180   = hang (hcat [ptext SLIT("In an equation for function "), quotes (ppr fun), char ':'])
 181          4 (hcat [ppr fun, space, pprMatch False{-not case-} match])
 182 \end{code}
 183
 184
 185 \begin{code}
 186 varyingArgsErr name matches
 187   = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
 188
 189 lurkingRank2SigErr
 190   = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
 191 \end{code}