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