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