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, newTyVarTy )
  25 import TcSimplify       ( bindInstsOfLocalFuns )
  26 import Unify            ( unifyTauTy, unifyFunTy )
  27 import Name             ( Name {- instance Outputable -} )
  28
  29 import Kind             ( Kind, mkTypeKind )
  30 import BasicTypes       ( RecFlag(..) )
  31 import Type             ( isTauTy, mkFunTy )
  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               -- Type of whole case expressions
  82               -> [RenamedMatch]         -- The case alternatives
  83               -> TcM s (TcType s,       -- Inferred type of the scrutinee
  84                         [TcMatch s],    -- Translated alternatives
  85                         LIE s)
  86
  87 tcMatchesCase expr_ty matches
  88   = newTyVarTy mkTypeKind                                       `thenNF_Tc` \ scrut_ty ->
  89     tcMatchesExpected (mkFunTy scrut_ty expr_ty) MCase matches  `thenTc` \ (matches', lie) ->
  90     returnTc (scrut_ty, matches', lie)
  91 \end{code}
  92
  93
  94 \begin{code}
  95 data FunOrCase = MCase | MFun Name      -- Records whether doing  fun or case rhss;
  96                                         -- used to produced better error messages
  97
  98 tcMatchesExpected :: TcType s
  99                   -> FunOrCase
 100                   -> [RenamedMatch]
 101                   -> TcM s ([TcMatch s], LIE s)
 102
 103 tcMatchesExpected expected_ty fun_or_case [match]
 104   = tcAddSrcLoc (getMatchLoc match)             $
 105     tcAddErrCtxt (matchCtxt fun_or_case match)  $
 106     tcMatchExpected [] expected_ty match        `thenTc` \ (match',  lie) ->
 107     returnTc ([match'], lie)
 108
 109 tcMatchesExpected expected_ty fun_or_case (match1 : matches)
 110   = tcAddSrcLoc (getMatchLoc match1)    (
 111         tcAddErrCtxt (matchCtxt fun_or_case match1)     $
 112         tcMatchExpected [] expected_ty  match1
 113     )                                                   `thenTc` \ (match1',  lie1) ->
 114     tcMatchesExpected expected_ty fun_or_case matches   `thenTc` \ (matches', lie2) ->
 115     returnTc (match1' : matches', plusLIE lie1 lie2)
 116 \end{code}
 117
 118 \begin{code}
 119 tcMatchExpected
 120         :: [TcIdBndr s]         -- Ids bound by enclosing matches
 121         -> TcType s             -- This gives the expected
 122                                 -- result-type of the Match.  Early unification
 123                                 -- with this guy gives better error messages
 124         -> RenamedMatch
 125         -> TcM s (TcMatch s,LIE s)      -- NB No type returned, because it was passed
 126                                         -- in instead!
 127
 128 tcMatchExpected matched_ids expected_ty the_match@(PatMatch pat match)
 129   = unifyFunTy expected_ty              `thenTc` \ (arg_ty, rest_ty) ->
 130
 131     let binders = collectPatBinders pat
 132     in
 133     newMonoIds binders mkTypeKind (\ mono_ids ->
 134         tcPat pat                       `thenTc` \ (pat', lie_pat, pat_ty) ->
 135         unifyTauTy pat_ty arg_ty        `thenTc_`
 136
 137         tcMatchExpected (mono_ids ++ matched_ids)
 138                         rest_ty match   `thenTc` \ (match', lie_match) ->
 139
 140         returnTc (PatMatch pat' match',
 141                   plusLIE lie_pat lie_match)
 142     )
 143
 144 tcMatchExpected matched_ids expected_ty (GRHSMatch grhss_and_binds)
 145   =     -- Check that the remaining "expected type" is not a rank-2 type
 146         -- If it is it'll mess up the unifier when checking the RHS
 147     checkTc (isTauTy expected_ty)
 148             lurkingRank2SigErr          `thenTc_`
 149
 150     tcGRHSsAndBinds expected_ty grhss_and_binds         `thenTc` \ (GRHSsAndBindsOut grhss binds ty, lie) ->
 151
 152         -- In case there are any polymorpic, overloaded binders in the pattern
 153         -- (which can happen in the case of rank-2 type signatures, or data constructors
 154         -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
 155     bindInstsOfLocalFuns lie matched_ids        `thenTc` \ (lie', inst_mbinds) ->
 156     let
 157         binds' = case inst_mbinds of
 158                    EmptyMonoBinds -> binds      -- The common case
 159                    other          -> MonoBind inst_mbinds [] Recursive `ThenBinds` binds
 160     in
 161     returnTc (GRHSMatch (GRHSsAndBindsOut grhss binds' ty), lie')
 162 \end{code}
 163
 164
 165 @noOfArgs@ takes a @[RenamedMatch]@ and returns a list telling how
 166 many arguments were used in each of the equations.  This is used to
 167 report a sensible error message when different equations have
 168 different numbers of arguments.
 169
 170 \begin{code}
 171 noOfArgs :: [RenamedMatch] -> [Int]
 172
 173 noOfArgs ms = map args_in_match ms
 174   where
 175     args_in_match :: RenamedMatch -> Int
 176     args_in_match (GRHSMatch _) = 0
 177     args_in_match (PatMatch _ match) = 1 + args_in_match match
 178 \end{code}
 179
 180 Errors and contexts
 181 ~~~~~~~~~~~~~~~~~~~
 182 \begin{code}
 183 matchCtxt MCase match
 184   = hang (ptext SLIT("In a \"case\" branch:"))
 185          4 (pprMatch True{-is_case-} match)
 186
 187 matchCtxt (MFun fun) match
 188   = hang (hcat [ptext SLIT("In an equation for function "), quotes (ppr fun), char ':'])
 189          4 (hcat [ppr fun, space, pprMatch False{-not case-} match])
 190 \end{code}
 191
 192
 193 \begin{code}
 194 varyingArgsErr name matches
 195   = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
 196
 197 lurkingRank2SigErr
 198   = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
 199 \end{code}