ghc/compiler/typecheck/TcMatches.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   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(..),
  14                           MonoBinds(..), StmtCtxt(..),
  15                           pprMatch, getMatchLoc
  16                         )
  17 import RnHsSyn          ( RenamedMatch )
  18 import TcHsSyn          ( TcMatch )
  19
  20 import TcMonad
  21 import TcMonoType       ( checkSigTyVars, noSigs, existentialPatCtxt )
  22 import Inst             ( Inst, LIE, plusLIE, emptyLIE )
  23 import TcEnv            ( tcExtendEnvWithPat, tcExtendGlobalTyVars )
  24 import TcPat            ( tcPat )
  25 import TcType           ( TcType, newTyVarTy )
  26 import TcSimplify       ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
  27 import TcUnify          ( unifyFunTy )
  28 import Name             ( Name )
  29
  30 import BasicTypes       ( RecFlag(..) )
  31 import Type             ( Kind, tyVarsOfType, isTauTy, mkFunTy, openTypeKind )
  32 import VarSet
  33 import Util
  34 import Bag
  35 import Outputable
  36 import SrcLoc           (SrcLoc)
  37 \end{code}
  38
  39 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
  40 @FunMonoBind@.  The second argument is the name of the function, which
  41 is used in error messages.  It checks that all the equations have the
  42 same number of arguments before using @tcMatches@ to do the work.
  43
  44 \begin{code}
  45 tcMatchesFun :: Name
  46              -> TcType s                -- Expected type
  47              -> [RenamedMatch]
  48              -> TcM s ([TcMatch s], LIE s)
  49
  50 tcMatchesFun fun_name expected_ty matches@(first_match:_)
  51   =      -- Set the location to that of the first equation, so that
  52          -- any inter-equation error messages get some vaguely
  53          -- sensible location.  Note: we have to do this odd
  54          -- ann-grabbing, because we don't always have annotations in
  55          -- hand when we call tcMatchesFun...
  56
  57     tcAddSrcLoc (getMatchLoc first_match)        (
  58
  59          -- Check that they all have the same no of arguments
  60     checkTc (all_same (noOfArgs matches))
  61             (varyingArgsErr fun_name matches) `thenTc_`
  62
  63         -- ToDo: Don't use "expected" stuff if there ain't a type signature
  64         -- because inconsistency between branches
  65         -- may show up as something wrong with the (non-existent) type signature
  66
  67         -- No need to zonk expected_ty, because unifyFunTy does that on the fly
  68     tcMatchesExpected matches expected_ty (FunRhs fun_name)
  69
  70     )
  71   where
  72     all_same :: [Int] -> Bool
  73     all_same []     = True      -- Should never happen (ToDo: panic?)
  74     all_same [x]    = True
  75     all_same (x:xs) = all ((==) x) xs
  76 \end{code}
  77
  78 @tcMatchesCase@ doesn't do the argument-count check because the
  79 parser guarantees that each equation has exactly one argument.
  80
  81 \begin{code}
  82 tcMatchesCase :: TcType s               -- Type of whole case expressions
  83               -> [RenamedMatch]         -- The case alternatives
  84               -> TcM s (TcType s,       -- Inferred type of the scrutinee
  85                         [TcMatch s],    -- Translated alternatives
  86                         LIE s)
  87
  88 tcMatchesCase expr_ty matches
  89   = newTyVarTy openTypeKind                                     `thenNF_Tc` \ scrut_ty ->
  90     tcMatchesExpected matches (mkFunTy scrut_ty expr_ty) CaseAlt `thenTc` \ (matches', lie) ->
  91     returnTc (scrut_ty, matches', lie)
  92 \end{code}
  93
  94
  95 \begin{code}
  96 tcMatchesExpected :: [RenamedMatch]
  97                   -> TcType s
  98                   -> StmtCtxt
  99                   -> TcM s ([TcMatch s], LIE s)
 100
 101 tcMatchesExpected [match] expected_ty fun_or_case
 102   = tcAddSrcLoc (getMatchLoc match)             $
 103     tcAddErrCtxt (matchCtxt fun_or_case match)  $
 104     tcMatchExpected match expected_ty fun_or_case       `thenTc` \ (match',  lie) ->
 105     returnTc ([match'], lie)
 106
 107 tcMatchesExpected (match1 : matches) expected_ty fun_or_case
 108   = tcAddSrcLoc (getMatchLoc match1)    (
 109         tcAddErrCtxt (matchCtxt fun_or_case match1)     $
 110         tcMatchExpected match1 expected_ty fun_or_case
 111     )                                                   `thenTc` \ (match1',  lie1) ->
 112     tcMatchesExpected matches expected_ty fun_or_case   `thenTc` \ (matches', lie2) ->
 113     returnTc (match1' : matches', plusLIE lie1 lie2)
 114 \end{code}
 115
 116 \begin{code}
 117 tcMatchExpected
 118         :: RenamedMatch
 119         -> TcType s             -- Expected result-type of the Match.
 120                                 -- Early unification with this guy gives better error messages
 121         -> StmtCtxt
 122         -> TcM s (TcMatch s,LIE s)
 123
 124 tcMatchExpected match expected_ty ctxt
 125   = tcMatchExpected_help emptyBag emptyBag emptyLIE match expected_ty ctxt
 126
 127
 128 tcMatchExpected_help bound_tvs bound_ids bound_lie
 129                      the_match@(PatMatch pat match) expected_ty ctxt
 130   = unifyFunTy expected_ty      `thenTc` \ (arg_ty, rest_ty) ->
 131
 132     tcPat noSigs pat arg_ty     `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail_lie) ->
 133
 134     tcMatchExpected_help
 135         (bound_tvs `unionBags` pat_tvs)
 136         (bound_ids `unionBags` pat_ids)
 137         (bound_lie `plusLIE`   avail_lie)
 138         match rest_ty ctxt                      `thenTc` \ (match', lie_match) ->
 139
 140     returnTc (PatMatch pat' match', pat_lie `plusLIE` lie_match)
 141
 142
 143 tcMatchExpected_help bound_tvs bound_ids bound_lie
 144                      (GRHSMatch grhss_and_binds) expected_ty ctxt
 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     tcExtendEnvWithPat bound_ids (
 151         tcGRHSsAndBinds grhss_and_binds expected_ty ctxt
 152     )                                                   `thenTc` \ (GRHSsAndBindsOut grhss binds ty, lie) ->
 153
 154
 155         -- Check for existentially bound type variables
 156     tcExtendGlobalTyVars (tyVarsOfType expected_ty) (
 157       tcAddErrCtxtM (existentialPatCtxt bound_tvs bound_ids)    $
 158       checkSigTyVars (bagToList bound_tvs)                      `thenTc` \ zonked_pat_tvs ->
 159       tcSimplifyAndCheck
 160         (text ("the existential context of a data constructor"))
 161         (mkVarSet zonked_pat_tvs)
 162         bound_lie lie
 163     )                                                   `thenTc` \ (ex_lie, ex_binds) ->
 164
 165         -- In case there are any polymorpic, overloaded binders in the pattern
 166         -- (which can happen in the case of rank-2 type signatures, or data constructors
 167         -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
 168     bindInstsOfLocalFuns ex_lie bound_id_list           `thenTc` \ (inst_lie, inst_binds) ->
 169
 170     let
 171         binds' = ex_binds `glue_on` (inst_binds `glue_on` binds)
 172     in
 173     returnTc (GRHSMatch (GRHSsAndBindsOut grhss binds' ty), inst_lie)
 174   where
 175     bound_id_list = map snd (bagToList bound_ids)
 176
 177         -- glue_on just avoids stupid dross
 178     glue_on EmptyMonoBinds binds = binds        -- The common case
 179     glue_on mbinds         binds = MonoBind mbinds [] Recursive `ThenBinds` binds
 180 \end{code}
 181
 182
 183 @noOfArgs@ takes a @[RenamedMatch]@ and returns a list telling how
 184 many arguments were used in each of the equations.  This is used to
 185 report a sensible error message when different equations have
 186 different numbers of arguments.
 187
 188 \begin{code}
 189 noOfArgs :: [RenamedMatch] -> [Int]
 190
 191 noOfArgs ms = map args_in_match ms
 192   where
 193     args_in_match :: RenamedMatch -> Int
 194     args_in_match (GRHSMatch _) = 0
 195     args_in_match (PatMatch _ match) = 1 + args_in_match match
 196 \end{code}
 197
 198 Errors and contexts
 199 ~~~~~~~~~~~~~~~~~~~
 200 \begin{code}
 201 matchCtxt CaseAlt match
 202   = hang (ptext SLIT("In a \"case\" branch:"))
 203          4 (pprMatch True{-is_case-} match)
 204
 205 matchCtxt (FunRhs fun) match
 206   = hang (hcat [ptext SLIT("In an equation for function "), quotes (ppr fun), char ':'])
 207          4 (hcat [ppr fun, space, pprMatch False{-not case-} match])
 208 \end{code}
 209
 210
 211 \begin{code}
 212 varyingArgsErr name matches
 213   = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
 214
 215 lurkingRank2SigErr
 216   = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
 217 \end{code}