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, tcMatchExpected ) where
  10
  11 IMP_Ubiq()
  12
  13 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
  14 IMPORT_DELOOPER(TcLoop)         ( tcGRHSsAndBinds )
  15 #else
  16 import {-# SOURCE #-} TcGRHSs ( tcGRHSsAndBinds )
  17 #endif
  18
  19 import HsSyn            ( Match(..), GRHSsAndBinds(..), GRHS(..), InPat,
  20                           HsExpr(..), HsBinds(..), MonoBinds(..), OutPat, Fake, Stmt,
  21                           Sig, HsLit, DoOrListComp, Fixity, HsType, ArithSeqInfo,
  22                           collectPatBinders, pprMatch )
  23 import RnHsSyn          ( SYN_IE(RenamedMatch) )
  24 import TcHsSyn          ( SYN_IE(TcMatch) )
  25
  26 import TcMonad
  27 import Inst             ( Inst, SYN_IE(LIE), plusLIE )
  28 import TcEnv            ( newMonoIds )
  29 import TcPat            ( tcPat )
  30 import TcType           ( TcIdOcc(..), SYN_IE(TcType), TcMaybe, zonkTcType )
  31 import TcSimplify       ( bindInstsOfLocalFuns )
  32 import Unify            ( unifyTauTy, unifyTauTyList, unifyFunTy )
  33 import Name             ( Name {- instance Outputable -} )
  34
  35 import Kind             ( Kind, mkTypeKind )
  36 import Pretty
  37 import Type             ( isTyVarTy, isTauTy, mkFunTy, getFunTy_maybe )
  38 import Util
  39 import Outputable
  40 #if __GLASGOW_HASKELL__ >= 202
  41 import SrcLoc           (SrcLoc)
  42 #endif
  43
  44 \end{code}
  45
  46 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
  47 @FunMonoBind@.  The second argument is the name of the function, which
  48 is used in error messages.  It checks that all the equations have the
  49 same number of arguments before using @tcMatches@ to do the work.
  50
  51 \begin{code}
  52 tcMatchesFun :: Name
  53              -> TcType s                -- Expected type
  54              -> [RenamedMatch]
  55              -> TcM s ([TcMatch s], LIE s)
  56
  57 tcMatchesFun fun_name expected_ty matches@(first_match:_)
  58   =      -- Set the location to that of the first equation, so that
  59          -- any inter-equation error messages get some vaguely
  60          -- sensible location.  Note: we have to do this odd
  61          -- ann-grabbing, because we don't always have annotations in
  62          -- hand when we call tcMatchesFun...
  63
  64     tcAddSrcLoc (get_Match_loc first_match)      (
  65
  66          -- Check that they all have the same no of arguments
  67     checkTc (all_same (noOfArgs matches))
  68             (varyingArgsErr fun_name matches) `thenTc_`
  69
  70         -- ToDo: Don't use "expected" stuff if there ain't a type signature
  71         -- because inconsistency between branches
  72         -- may show up as something wrong with the (non-existent) type signature
  73
  74         -- We need to substitute so that we can see as much about the type as possible
  75     zonkTcType expected_ty              `thenNF_Tc` \ expected_ty' ->
  76     tcMatchesExpected expected_ty' (MFun fun_name) matches
  77
  78     )
  79   where
  80     all_same :: [Int] -> Bool
  81     all_same []     = True      -- Should never happen (ToDo: panic?)
  82     all_same [x]    = True
  83     all_same (x:xs) = all ((==) x) xs
  84 \end{code}
  85
  86 @tcMatchesCase@ doesn't do the argument-count check because the
  87 parser guarantees that each equation has exactly one argument.
  88
  89 \begin{code}
  90 tcMatchesCase :: TcType s -> [RenamedMatch] -> TcM s ([TcMatch s], LIE s)
  91 tcMatchesCase expected_ty matches = tcMatchesExpected expected_ty MCase matches
  92 \end{code}
  93
  94
  95 \begin{code}
  96 data FunOrCase = MCase | MFun Name      -- Records whether doing  fun or case rhss;
  97                                         -- used to produced better error messages
  98
  99 tcMatchesExpected :: TcType s
 100                   -> FunOrCase
 101                   -> [RenamedMatch]
 102                   -> TcM s ([TcMatch s], LIE s)
 103
 104 tcMatchesExpected expected_ty fun_or_case [match]
 105   = tcAddSrcLoc (get_Match_loc match)           $
 106     tcAddErrCtxt (matchCtxt fun_or_case match)  $
 107     tcMatchExpected expected_ty match   `thenTc` \ (match',  lie) ->
 108     returnTc ([match'], lie)
 109
 110 tcMatchesExpected expected_ty fun_or_case (match1 : matches)
 111   = tcAddSrcLoc (get_Match_loc match1)  (
 112         tcAddErrCtxt (matchCtxt fun_or_case match1)     $
 113         tcMatchExpected expected_ty  match1
 114     )                                                   `thenTc` \ (match1',  lie1) ->
 115     tcMatchesExpected expected_ty fun_or_case matches   `thenTc` \ (matches', lie2) ->
 116     returnTc (match1' : matches', plusLIE lie1 lie2)
 117 \end{code}
 118
 119 \begin{code}
 120 tcMatchExpected
 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 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         tcMatchExpected rest_ty  match  `thenTc` \ (match', lie_match) ->
 137                 -- In case there are any polymorpic, overloaded binders in the pattern
 138                 -- (which can happen in the case of rank-2 type signatures, or data constructors
 139                 -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
 140                 --
 141                 -- 99% of the time there are no bindings.  In the unusual case we
 142                 -- march down the match to dump them in the right place (boring but easy).
 143         bindInstsOfLocalFuns lie_match mono_ids         `thenTc` \ (lie_match', inst_mbinds) ->
 144         let
 145            inst_binds = MonoBind inst_mbinds [] False
 146            match'' = case inst_mbinds of
 147                         EmptyMonoBinds -> match'
 148                         other          -> glue_on match'
 149            glue_on (PatMatch p m) = PatMatch p (glue_on m)
 150            glue_on (GRHSMatch (GRHSsAndBindsOut grhss binds ty))
 151                 = (GRHSMatch (GRHSsAndBindsOut grhss
 152                                                (inst_binds `ThenBinds` binds)
 153                                                ty))
 154            glue_on (SimpleMatch expr) = SimpleMatch (HsLet inst_binds expr)
 155         in
 156         returnTc (PatMatch pat' match'',
 157                   plusLIE lie_pat lie_match')
 158     )
 159
 160 tcMatchExpected expected_ty (GRHSMatch grhss_and_binds)
 161   = tcGRHSsAndBinds expected_ty grhss_and_binds         `thenTc` \ (grhss_and_binds', lie) ->
 162     checkTc (isTauTy expected_ty)
 163             lurkingRank2SigErr          `thenTc_`
 164     returnTc (GRHSMatch grhss_and_binds', lie)
 165 \end{code}
 166
 167
 168 @noOfArgs@ takes a @[RenamedMatch]@ and returns a list telling how
 169 many arguments were used in each of the equations.  This is used to
 170 report a sensible error message when different equations have
 171 different numbers of arguments.
 172
 173 \begin{code}
 174 noOfArgs :: [RenamedMatch] -> [Int]
 175
 176 noOfArgs ms = map args_in_match ms
 177   where
 178     args_in_match :: RenamedMatch -> Int
 179     args_in_match (GRHSMatch _) = 0
 180     args_in_match (PatMatch _ match) = 1 + args_in_match match
 181 \end{code}
 182
 183 @get_Match_loc@ takes a @RenamedMatch@ and returns the
 184 source-location gotten from the GRHS inside.
 185 THis is something of a nuisance, but no more.
 186
 187 \begin{code}
 188 get_Match_loc     :: RenamedMatch   -> SrcLoc
 189
 190 get_Match_loc (PatMatch _ m)    = get_Match_loc m
 191 get_Match_loc (GRHSMatch (GRHSsAndBindsIn (g:_) _))
 192       = get_GRHS_loc g
 193       where
 194         get_GRHS_loc (OtherwiseGRHS _ locn) = locn
 195         get_GRHS_loc (GRHS _ _ locn)        = locn
 196 \end{code}
 197
 198 Errors and contexts
 199 ~~~~~~~~~~~~~~~~~~~
 200 \begin{code}
 201 matchCtxt MCase match sty
 202   = hang (ptext SLIT("In a \"case\" branch:"))
 203          4 (pprMatch sty True{-is_case-} match)
 204
 205 matchCtxt (MFun fun) match sty
 206   = hang (hcat [ptext SLIT("In an equation for function "), ppr sty fun, char ':'])
 207          4 (pprQuote sty $ \sty -> hcat [ppr sty fun, space, pprMatch sty False{-not case-} match])
 208 \end{code}
 209
 210
 211 \begin{code}
 212 varyingArgsErr name matches sty
 213   = sep [ptext SLIT("Varying number of arguments for function"), ppr sty name]
 214
 215 lurkingRank2SigErr sty
 216   = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
 217 \end{code}