\section[TcMatches]{Typecheck some @Matches@}
\begin{code}
-#include "HsVersions.h"
-
-module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatch ) where
+module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchExpected ) where
-IMP_Ubiq()
+#include "HsVersions.h"
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
-IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds )
-#else
import {-# SOURCE #-} TcGRHSs ( tcGRHSsAndBinds )
-#endif
-import HsSyn ( Match(..), GRHSsAndBinds(..), GRHS(..), InPat,
- HsExpr, HsBinds, OutPat, Fake, Stmt,
- collectPatBinders, pprMatch )
-import RnHsSyn ( SYN_IE(RenamedMatch) )
-import TcHsSyn ( TcIdOcc(..), SYN_IE(TcMatch) )
+import HsSyn ( HsBinds(..), Match(..), GRHSsAndBinds(..), GRHS(..),
+ HsExpr, MonoBinds(..),
+ collectPatBinders, pprMatch, getMatchLoc
+ )
+import RnHsSyn ( RenamedMatch )
+import TcHsSyn ( TcIdBndr, TcMatch )
import TcMonad
-import Inst ( Inst, SYN_IE(LIE), plusLIE )
-import TcEnv ( newMonoIds )
+import Inst ( Inst, LIE, plusLIE )
+import TcEnv ( TcIdOcc(..), newMonoIds )
import TcPat ( tcPat )
-import TcType ( SYN_IE(TcType), TcMaybe, zonkTcType )
-import Unify ( unifyTauTy, unifyTauTyList )
+import TcType ( TcType, TcMaybe, zonkTcType, newTyVarTy )
+import TcSimplify ( bindInstsOfLocalFuns )
+import Unify ( unifyTauTy, unifyFunTy )
import Name ( Name {- instance Outputable -} )
import Kind ( Kind, mkTypeKind )
-import Pretty
-import Type ( isTyVarTy, mkFunTy, getFunTy_maybe )
+import BasicTypes ( RecFlag(..) )
+import Type ( isTauTy, mkFunTy )
import Util
import Outputable
-#if __GLASGOW_HASKELL__ >= 202
import SrcLoc (SrcLoc)
-#endif
-
\end{code}
@tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
-- ann-grabbing, because we don't always have annotations in
-- hand when we call tcMatchesFun...
- tcAddSrcLoc (get_Match_loc first_match) (
+ tcAddSrcLoc (getMatchLoc first_match) (
-- Check that they all have the same no of arguments
checkTc (all_same (noOfArgs matches))
parser guarantees that each equation has exactly one argument.
\begin{code}
-tcMatchesCase :: TcType s -> [RenamedMatch] -> TcM s ([TcMatch s], LIE s)
-tcMatchesCase expected_ty matches = tcMatchesExpected expected_ty MCase matches
+tcMatchesCase :: TcType s -- Type of whole case expressions
+ -> [RenamedMatch] -- The case alternatives
+ -> TcM s (TcType s, -- Inferred type of the scrutinee
+ [TcMatch s], -- Translated alternatives
+ LIE s)
+
+tcMatchesCase expr_ty matches
+ = newTyVarTy mkTypeKind `thenNF_Tc` \ scrut_ty ->
+ tcMatchesExpected (mkFunTy scrut_ty expr_ty) MCase matches `thenTc` \ (matches', lie) ->
+ returnTc (scrut_ty, matches', lie)
\end{code}
-> TcM s ([TcMatch s], LIE s)
tcMatchesExpected expected_ty fun_or_case [match]
- = tcAddSrcLoc (get_Match_loc match) $
+ = tcAddSrcLoc (getMatchLoc match) $
tcAddErrCtxt (matchCtxt fun_or_case match) $
- tcMatchExpected expected_ty match `thenTc` \ (match', lie) ->
+ tcMatchExpected [] expected_ty match `thenTc` \ (match', lie) ->
returnTc ([match'], lie)
tcMatchesExpected expected_ty fun_or_case (match1 : matches)
- = tcAddSrcLoc (get_Match_loc match1) (
+ = tcAddSrcLoc (getMatchLoc match1) (
tcAddErrCtxt (matchCtxt fun_or_case match1) $
- tcMatchExpected expected_ty match1
+ tcMatchExpected [] expected_ty match1
) `thenTc` \ (match1', lie1) ->
tcMatchesExpected expected_ty fun_or_case matches `thenTc` \ (matches', lie2) ->
returnTc (match1' : matches', plusLIE lie1 lie2)
-
-tcMatches :: [RenamedMatch] -> TcM s ([TcMatch s], LIE s, [TcType s])
-
-tcMatches [match]
- = tcAddSrcLoc (get_Match_loc match) $
- tcMatch match `thenTc` \ (match', lie, ty) ->
- returnTc ([match'], lie, [ty])
-
-tcMatches (match1 : matches)
- = tcAddSrcLoc (get_Match_loc match1) (
- tcMatch match1
- ) `thenTc` \ (match1', lie1, match1_ty) ->
- tcMatches matches `thenTc` \ (matches', lie2, matches_ty) ->
- returnTc (match1' : matches', plusLIE lie1 lie2, match1_ty : matches_ty)
\end{code}
\begin{code}
tcMatchExpected
- :: TcType s -- This gives the expected
+ :: [TcIdBndr s] -- Ids bound by enclosing matches
+ -> TcType s -- This gives the expected
-- result-type of the Match. Early unification
-- with this guy gives better error messages
-> RenamedMatch
-> TcM s (TcMatch s,LIE s) -- NB No type returned, because it was passed
-- in instead!
-tcMatchExpected expected_ty the_match@(PatMatch pat match)
- = case getFunTy_maybe expected_ty of
-
- Nothing -> -- Not a function type (eg type variable)
- -- So use tcMatch instead
- tcMatch the_match `thenTc` \ (match', lie_match, match_ty) ->
- unifyTauTy expected_ty match_ty `thenTc_`
- returnTc (match', lie_match)
-
- Just (arg_ty,rest_ty) -> -- It's a function type!
- let binders = collectPatBinders pat
- in
- newMonoIds binders mkTypeKind (\ _ ->
- tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
- unifyTauTy pat_ty arg_ty `thenTc_`
- tcMatchExpected rest_ty match `thenTc` \ (match', lie_match) ->
- returnTc (PatMatch pat' match',
- plusLIE lie_pat lie_match)
- )
-
-tcMatchExpected expected_ty (GRHSMatch grhss_and_binds)
- = tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
- unifyTauTy expected_ty grhss_ty `thenTc_`
- returnTc (GRHSMatch grhss_and_binds', lie)
-
-tcMatch :: RenamedMatch -> TcM s (TcMatch s, LIE s, TcType s)
-
-tcMatch (PatMatch pat match)
- = let binders = collectPatBinders pat
+tcMatchExpected matched_ids expected_ty the_match@(PatMatch pat match)
+ = unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
+
+ let binders = collectPatBinders pat
in
- newMonoIds binders mkTypeKind (\ _ ->
- -- NB TypeKind; lambda-bound variables are allowed
- -- to unify with unboxed types.
+ newMonoIds binders mkTypeKind (\ mono_ids ->
+ tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
+ unifyTauTy pat_ty arg_ty `thenTc_`
+
+ tcMatchExpected (mono_ids ++ matched_ids)
+ rest_ty match `thenTc` \ (match', lie_match) ->
- tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
- tcMatch match `thenTc` \ (match', lie_match, match_ty) ->
returnTc (PatMatch pat' match',
- plusLIE lie_pat lie_match,
- mkFunTy pat_ty match_ty)
+ plusLIE lie_pat lie_match)
)
-tcMatch (GRHSMatch grhss_and_binds)
- = tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
- returnTc (GRHSMatch grhss_and_binds', lie, grhss_ty)
+tcMatchExpected matched_ids expected_ty (GRHSMatch grhss_and_binds)
+ = -- Check that the remaining "expected type" is not a rank-2 type
+ -- If it is it'll mess up the unifier when checking the RHS
+ checkTc (isTauTy expected_ty)
+ lurkingRank2SigErr `thenTc_`
+
+ tcGRHSsAndBinds expected_ty grhss_and_binds `thenTc` \ (GRHSsAndBindsOut grhss binds ty, lie) ->
+
+ -- In case there are any polymorpic, overloaded binders in the pattern
+ -- (which can happen in the case of rank-2 type signatures, or data constructors
+ -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
+ bindInstsOfLocalFuns lie matched_ids `thenTc` \ (lie', inst_mbinds) ->
+ let
+ binds' = case inst_mbinds of
+ EmptyMonoBinds -> binds -- The common case
+ other -> MonoBind inst_mbinds [] Recursive `ThenBinds` binds
+ in
+ returnTc (GRHSMatch (GRHSsAndBindsOut grhss binds' ty), lie')
\end{code}
args_in_match (PatMatch _ match) = 1 + args_in_match match
\end{code}
-@get_Match_loc@ takes a @RenamedMatch@ and returns the
-source-location gotten from the GRHS inside.
-THis is something of a nuisance, but no more.
-
-\begin{code}
-get_Match_loc :: RenamedMatch -> SrcLoc
-
-get_Match_loc (PatMatch _ m) = get_Match_loc m
-get_Match_loc (GRHSMatch (GRHSsAndBindsIn (g:_) _))
- = get_GRHS_loc g
- where
- get_GRHS_loc (OtherwiseGRHS _ locn) = locn
- get_GRHS_loc (GRHS _ _ locn) = locn
-\end{code}
-
Errors and contexts
~~~~~~~~~~~~~~~~~~~
\begin{code}
-matchCtxt MCase match sty
+matchCtxt MCase match
= hang (ptext SLIT("In a \"case\" branch:"))
- 4 (pprMatch sty True{-is_case-} match)
+ 4 (pprMatch True{-is_case-} match)
-matchCtxt (MFun fun) match sty
- = hang (hcat [ptext SLIT("In an equation for function "), ppr sty fun, char ':'])
- 4 (pprQuote sty $ \sty -> hcat [ppr sty fun, space, pprMatch sty False{-not case-} match])
+matchCtxt (MFun fun) match
+ = hang (hcat [ptext SLIT("In an equation for function "), quotes (ppr fun), char ':'])
+ 4 (hcat [ppr fun, space, pprMatch False{-not case-} match])
\end{code}
\begin{code}
-varyingArgsErr name matches sty
- = sep [ptext SLIT("Varying number of arguments for function"), ppr sty name]
+varyingArgsErr name matches
+ = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
+
+lurkingRank2SigErr
+ = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
\end{code}
projects / ghc-hetmet.git / blobdiff