X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMatches.lhs;h=6ea887e75c8558d67900f1d5e6cf525256b69329;hb=f36fb2ce821caf594c1db5669dd10ca082f66361;hp=a5ca1ddc4abd32e8069d68f7871c33806079eff7;hpb=d51ed372b15487c3c3d0406ba018cd2fd3c0d906;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index a5ca1dd..6ea887e 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -4,41 +4,34 @@ \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 @@ -59,7 +52,7 @@ tcMatchesFun fun_name expected_ty matches@(first_match:_) -- 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)) @@ -85,8 +78,16 @@ tcMatchesFun fun_name expected_ty matches@(first_match:_) 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} @@ -100,87 +101,64 @@ tcMatchesExpected :: TcType s -> 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} @@ -199,35 +177,23 @@ noOfArgs ms = map args_in_match ms 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}