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 #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          ( TcIdOcc(..), 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           ( SYN_IE(TcType), TcMaybe, zonkTcType )
  31 import TcSimplify       ( bindInstsOfLocalFuns )
  32 import Unify            ( unifyTauTy, unifyTauTyList )
  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
 118 tcMatches :: [RenamedMatch] -> TcM s ([TcMatch s], LIE s, [TcType s])
 119
 120 tcMatches [match]
 121   = tcAddSrcLoc (get_Match_loc match) $
 122     tcMatch match               `thenTc` \ (match', lie, ty) ->
 123     returnTc ([match'], lie, [ty])
 124
 125 tcMatches (match1 : matches)
 126   = tcAddSrcLoc (get_Match_loc match1) (
 127         tcMatch match1
 128     )                           `thenTc` \ (match1',  lie1, match1_ty) ->
 129     tcMatches matches           `thenTc` \ (matches', lie2, matches_ty) ->
 130     returnTc (match1' : matches', plusLIE lie1 lie2, match1_ty : matches_ty)
 131 \end{code}
 132
 133 \begin{code}
 134 tcMatchExpected
 135         :: TcType s             -- This gives the expected
 136                                 -- result-type of the Match.  Early unification
 137                                 -- with this guy gives better error messages
 138         -> RenamedMatch
 139         -> TcM s (TcMatch s,LIE s)      -- NB No type returned, because it was passed
 140                                         -- in instead!
 141
 142 tcMatchExpected expected_ty the_match@(PatMatch pat match)
 143   = case getFunTy_maybe expected_ty of
 144
 145         Nothing ->                      -- Not a function type (eg type variable)
 146                                         -- So use tcMatch instead
 147             tcMatch the_match                   `thenTc`   \ (match', lie_match, match_ty) ->
 148             unifyTauTy expected_ty match_ty     `thenTc_`
 149             returnTc (match', lie_match)
 150
 151         Just (arg_ty,rest_ty) ->        -- It's a function type!
 152             let binders = collectPatBinders pat
 153             in
 154             newMonoIds binders mkTypeKind (\ mono_ids ->
 155                 tcPat pat                       `thenTc` \ (pat', lie_pat, pat_ty) ->
 156                 unifyTauTy pat_ty arg_ty        `thenTc_`
 157                 tcMatchExpected rest_ty  match  `thenTc` \ (match', lie_match) ->
 158
 159                         -- In case there are any polymorpic, overloaded binders in the pattern
 160                         -- (which can happen in the case of rank-2 type signatures, or data constructors
 161                         -- with polymorphic arguments), we must dd a bindInstsOfLocalFns here
 162                         --
 163                         -- 99% of the time there are no bindings.  In the unusual case we
 164                         -- march down the match to dump them in the right place (boring but easy).
 165                 bindInstsOfLocalFuns lie_match mono_ids         `thenTc` \ (lie_match', inst_mbinds) ->
 166                 let
 167                    inst_binds = MonoBind inst_mbinds [] False
 168                    match'' = case inst_mbinds of
 169                                 EmptyMonoBinds -> match'
 170                                 other          -> glue_on match'
 171                    glue_on (PatMatch p m) = PatMatch p (glue_on m)
 172                    glue_on (GRHSMatch (GRHSsAndBindsOut grhss binds ty))
 173                         = (GRHSMatch (GRHSsAndBindsOut grhss
 174                                                        (inst_binds `ThenBinds` binds)
 175                                                        ty))
 176                    glue_on (SimpleMatch expr) = SimpleMatch (HsLet inst_binds expr)
 177                 in
 178                 returnTc (PatMatch pat' match'',
 179                           plusLIE lie_pat lie_match')
 180             )
 181
 182 tcMatchExpected expected_ty (GRHSMatch grhss_and_binds)
 183   = tcGRHSsAndBinds grhss_and_binds     `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
 184     checkTc (isTauTy expected_ty)
 185             lurkingRank2SigErr          `thenTc_`
 186     unifyTauTy expected_ty grhss_ty     `thenTc_`
 187     returnTc (GRHSMatch grhss_and_binds', lie)
 188
 189 tcMatch :: RenamedMatch -> TcM s (TcMatch s, LIE s, TcType s)
 190
 191 tcMatch (PatMatch pat match)
 192   = let binders = collectPatBinders pat
 193     in
 194     newMonoIds binders mkTypeKind (\ _ ->
 195         -- NB TypeKind; lambda-bound variables are allowed
 196         -- to unify with unboxed types.
 197
 198         tcPat pat               `thenTc`   \ (pat',   lie_pat,   pat_ty) ->
 199         tcMatch match           `thenTc`   \ (match', lie_match, match_ty) ->
 200         returnTc (PatMatch pat' match',
 201                   plusLIE lie_pat lie_match,
 202                   mkFunTy pat_ty match_ty)
 203     )
 204
 205 tcMatch (GRHSMatch grhss_and_binds)
 206   = tcGRHSsAndBinds grhss_and_binds   `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
 207     returnTc (GRHSMatch grhss_and_binds', lie, grhss_ty)
 208 \end{code}
 209
 210
 211 @noOfArgs@ takes a @[RenamedMatch]@ and returns a list telling how
 212 many arguments were used in each of the equations.  This is used to
 213 report a sensible error message when different equations have
 214 different numbers of arguments.
 215
 216 \begin{code}
 217 noOfArgs :: [RenamedMatch] -> [Int]
 218
 219 noOfArgs ms = map args_in_match ms
 220   where
 221     args_in_match :: RenamedMatch -> Int
 222     args_in_match (GRHSMatch _) = 0
 223     args_in_match (PatMatch _ match) = 1 + args_in_match match
 224 \end{code}
 225
 226 @get_Match_loc@ takes a @RenamedMatch@ and returns the
 227 source-location gotten from the GRHS inside.
 228 THis is something of a nuisance, but no more.
 229
 230 \begin{code}
 231 get_Match_loc     :: RenamedMatch   -> SrcLoc
 232
 233 get_Match_loc (PatMatch _ m)    = get_Match_loc m
 234 get_Match_loc (GRHSMatch (GRHSsAndBindsIn (g:_) _))
 235       = get_GRHS_loc g
 236       where
 237         get_GRHS_loc (OtherwiseGRHS _ locn) = locn
 238         get_GRHS_loc (GRHS _ _ locn)        = locn
 239 \end{code}
 240
 241 Errors and contexts
 242 ~~~~~~~~~~~~~~~~~~~
 243 \begin{code}
 244 matchCtxt MCase match sty
 245   = hang (ptext SLIT("In a \"case\" branch:"))
 246          4 (pprMatch sty True{-is_case-} match)
 247
 248 matchCtxt (MFun fun) match sty
 249   = hang (hcat [ptext SLIT("In an equation for function "), ppr sty fun, char ':'])
 250          4 (pprQuote sty $ \sty -> hcat [ppr sty fun, space, pprMatch sty False{-not case-} match])
 251 \end{code}
 252
 253
 254 \begin{code}
 255 varyingArgsErr name matches sty
 256   = sep [ptext SLIT("Varying number of arguments for function"), ppr sty name]
 257
 258 lurkingRank2SigErr sty
 259   = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
 260 \end{code}