X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMatches.lhs;h=31a31501a0fb872b99216cbf3c991a621c1f3e6c;hb=6c381e873e222417d9a67aeec77b9555eca7b7a8;hp=b7037aadbe2cb27904e69a0e4e94727748140616;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index b7037aa..31a3150 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -8,23 +8,26 @@ module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatch ) where -import TcMonad -- typechecking monad machinery -import TcMonadFns ( mkIdsWithOpenTyVarTys ) -import AbsSyn -- the stuff being typechecked - -import AbsPrel ( mkFunTy ) -import AbsUniType ( isTyVarTy, maybeUnpackFunTy ) -import E ( E, growE_LVE, LVE(..), GVE(..) ) -#if USE_ATTACK_PRAGMAS -import CE -import TCE -#endif -import Errors ( varyingArgsErr, Error(..), UnifyErrContext(..) ) -import LIE ( LIE, plusLIE ) -import Maybes ( Maybe(..) ) -import TcGRHSs ( tcGRHSsAndBinds ) +import Ubiq + +import HsSyn ( Match(..), GRHSsAndBinds(..), GRHS(..), InPat, + HsExpr, HsBinds, OutPat, Fake, + collectPatBinders, pprMatch ) +import RnHsSyn ( RenamedMatch(..) ) +import TcHsSyn ( TcIdOcc(..), TcMatch(..) ) + +import TcMonad +import Inst ( Inst, LIE(..), plusLIE ) +import TcEnv ( newMonoIds ) +import TcLoop ( tcGRHSsAndBinds ) import TcPat ( tcPat ) +import TcType ( TcType(..), TcMaybe, zonkTcType ) import Unify ( unifyTauTy, unifyTauTyList ) + +import Kind ( Kind, mkTypeKind ) +import Name ( Name ) +import Pretty +import Type ( isTyVarTy, mkFunTy, getFunTy_maybe ) import Util \end{code} @@ -34,22 +37,22 @@ is used in error messages. It checks that all the equations have the same number of arguments before using @tcMatches@ to do the work. \begin{code} -tcMatchesFun :: E -> Name - -> UniType -- Expected type +tcMatchesFun :: Name + -> TcType s -- Expected type -> [RenamedMatch] - -> TcM ([TypecheckedMatch], LIE) + -> TcM s ([TcMatch s], LIE s) -tcMatchesFun e fun_name expected_ty matches@(first_match:_) +tcMatchesFun fun_name expected_ty matches@(first_match:_) = -- Set the location to that of the first equation, so that -- any inter-equation error messages get some vaguely -- sensible location. Note: we have to do this odd -- ann-grabbing, because we don't always have annotations in -- hand when we call tcMatchesFun... - addSrcLocTc (get_Match_loc first_match) ( + tcAddSrcLoc (get_Match_loc first_match) ( -- Check that they all have the same no of arguments - checkTc (not (all_same (noOfArgs matches))) + checkTc (all_same (noOfArgs matches)) (varyingArgsErr fun_name matches) `thenTc_` -- ToDo: Don't use "expected" stuff if there ain't a type signature @@ -57,8 +60,8 @@ tcMatchesFun e fun_name expected_ty matches@(first_match:_) -- may show up as something wrong with the (non-existent) type signature -- We need to substitute so that we can see as much about the type as possible - applyTcSubstToTy expected_ty `thenNF_Tc` \ expected_ty' -> - tcMatchesExpected e expected_ty' (\ m -> FunMonoBindsCtxt fun_name [m]) matches + zonkTcType expected_ty `thenNF_Tc` \ expected_ty' -> + tcMatchesExpected expected_ty' (MFun fun_name) matches ) where @@ -72,120 +75,98 @@ tcMatchesFun e fun_name expected_ty matches@(first_match:_) parser guarantees that each equation has exactly one argument. \begin{code} -tcMatchesCase :: E -> [RenamedMatch] - -> TcM ([TypecheckedMatch], LIE, UniType) - -tcMatchesCase e matches - = - - -- Typecheck them - tcMatches e matches `thenTc` \ (matches', lie, tys@(first_ty:_)) -> - - -- Set the location to that of the first equation, so that - -- any inter-equation error messages get some vaguely sensible location - addSrcLocTc (get_Match_loc (head matches)) ( - unifyTauTyList tys (CaseBranchesCtxt matches) - ) `thenTc_` - - returnTc (matches', lie, first_ty) +tcMatchesCase :: TcType s -> [RenamedMatch] -> TcM s ([TcMatch s], LIE s) +tcMatchesCase expected_ty matches = tcMatchesExpected expected_ty MCase matches \end{code} \begin{code} -tcMatchesExpected :: E - -> UniType - -> (RenamedMatch -> UnifyErrContext) - -> [RenamedMatch] - -> TcM ([TypecheckedMatch], LIE) - -tcMatchesExpected e expected_ty err_ctxt_fn [match] - = addSrcLocTc (get_Match_loc match) ( - tcMatchExpected e expected_ty (err_ctxt_fn match) match - ) `thenTc` \ (match', lie) -> +data FunOrCase = MCase | MFun Name -- Records whether doing fun or case rhss; + -- used to produced better error messages + +tcMatchesExpected :: TcType s + -> FunOrCase + -> [RenamedMatch] + -> TcM s ([TcMatch s], LIE s) + +tcMatchesExpected expected_ty fun_or_case [match] + = tcAddSrcLoc (get_Match_loc match) $ + tcAddErrCtxt (matchCtxt fun_or_case match) $ + tcMatchExpected expected_ty match `thenTc` \ (match', lie) -> returnTc ([match'], lie) -tcMatchesExpected e expected_ty err_ctxt_fn ms@(match1 : matches) - = addSrcLocTc (get_Match_loc match1) ( - tcMatchExpected e expected_ty (err_ctxt_fn match1) match1 +tcMatchesExpected expected_ty fun_or_case (match1 : matches) + = tcAddSrcLoc (get_Match_loc match1) ( + tcAddErrCtxt (matchCtxt fun_or_case match1) $ + tcMatchExpected expected_ty match1 ) `thenTc` \ (match1', lie1) -> - tcMatchesExpected e expected_ty err_ctxt_fn matches `thenTc` \ (matches', lie2) -> + tcMatchesExpected expected_ty fun_or_case matches `thenTc` \ (matches', lie2) -> returnTc (match1' : matches', plusLIE lie1 lie2) -tcMatches :: E -> [RenamedMatch] -> TcM ([TypecheckedMatch], LIE, [UniType]) +tcMatches :: [RenamedMatch] -> TcM s ([TcMatch s], LIE s, [TcType s]) -tcMatches e [match] - = tcMatch e match `thenTc` \ (match', lie, ty) -> +tcMatches [match] + = tcAddSrcLoc (get_Match_loc match) $ + tcMatch match `thenTc` \ (match', lie, ty) -> returnTc ([match'], lie, [ty]) -tcMatches e ms@(match1 : matches) - = addSrcLocTc (get_Match_loc match1) ( - tcMatch e match1 +tcMatches (match1 : matches) + = tcAddSrcLoc (get_Match_loc match1) ( + tcMatch match1 ) `thenTc` \ (match1', lie1, match1_ty) -> - tcMatches e matches `thenTc` \ (matches', lie2, matches_ty) -> + tcMatches matches `thenTc` \ (matches', lie2, matches_ty) -> returnTc (match1' : matches', plusLIE lie1 lie2, match1_ty : matches_ty) \end{code} \begin{code} -tcMatchExpected - :: E - -> UniType -- This gives the expected +tcMatchExpected + :: TcType s -- This gives the expected -- result-type of the Match. Early unification -- with this guy gives better error messages - -> UnifyErrContext - -> RenamedMatch - -> TcM (TypecheckedMatch,LIE) - -- NB No type returned, because it was passed - -- in instead! + -> RenamedMatch + -> TcM s (TcMatch s,LIE s) -- NB No type returned, because it was passed + -- in instead! -tcMatchExpected e expected_ty err_ctxt the_match@(PatMatch pat match) - = case maybeUnpackFunTy expected_ty of +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 e the_match `thenTc` \ (match', lie_match, match_ty) -> - unifyTauTy match_ty expected_ty err_ctxt `thenTc_` + tcMatch the_match `thenTc` \ (match', lie_match, match_ty) -> + unifyTauTy match_ty expected_ty `thenTc_` returnTc (match', lie_match) Just (arg_ty,rest_ty) -> -- It's a function type! let binders = collectPatBinders pat in - mkIdsWithOpenTyVarTys binders `thenNF_Tc` \ lve -> - let e' = growE_LVE e lve - in - tcPat e' pat `thenTc` \ (pat', lie_pat, pat_ty) -> - - unifyTauTy arg_ty pat_ty err_ctxt `thenTc_` - tcMatchExpected e' rest_ty err_ctxt match `thenTc` \ (match', lie_match) -> - returnTc (PatMatch pat' match', + newMonoIds binders mkTypeKind (\ _ -> + tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) -> + unifyTauTy arg_ty pat_ty `thenTc_` + tcMatchExpected rest_ty match `thenTc` \ (match', lie_match) -> + returnTc (PatMatch pat' match', plusLIE lie_pat lie_match) + ) -tcMatchExpected e expected_ty err_ctxt (GRHSMatch grhss_and_binds) - = tcGRHSsAndBinds e grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) -> - unifyTauTy grhss_ty expected_ty err_ctxt `thenTc_` +tcMatchExpected expected_ty (GRHSMatch grhss_and_binds) + = tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) -> + unifyTauTy grhss_ty expected_ty `thenTc_` returnTc (GRHSMatch grhss_and_binds', lie) -tcMatch :: E - -> RenamedMatch - -> TcM (TypecheckedMatch,LIE,UniType) +tcMatch :: RenamedMatch -> TcM s (TcMatch s, LIE s, TcType s) -tcMatch e (PatMatch pat match) +tcMatch (PatMatch pat match) = let binders = collectPatBinders pat in - mkIdsWithOpenTyVarTys binders `thenNF_Tc` \ lve -> - let e' = growE_LVE e lve - in - tcPat e' pat `thenTc` \ (pat', lie_pat, pat_ty) -> - tcMatch e' match `thenTc` \ (match', lie_match, match_ty) -> - --- We don't do this any more, do we? --- applyTcSubstToTy pat_ty `thenNF_Tc`\ pat_ty' -> - - returnTc (PatMatch pat' match', - plusLIE lie_pat lie_match, - mkFunTy pat_ty match_ty) + newMonoIds binders mkTypeKind (\ _ -> + 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) + ) -tcMatch e (GRHSMatch grhss_and_binds) - = tcGRHSsAndBinds e grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) -> +tcMatch (GRHSMatch grhss_and_binds) + = tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) -> returnTc (GRHSMatch grhss_and_binds', lie, grhss_ty) \end{code} @@ -219,3 +200,21 @@ get_Match_loc (GRHSMatch (GRHSsAndBindsIn (g:_) _)) get_GRHS_loc (OtherwiseGRHS _ locn) = locn get_GRHS_loc (GRHS _ _ locn) = locn \end{code} + +Errors and contexts +~~~~~~~~~~~~~~~~~~~ +\begin{code} +matchCtxt MCase match sty + = ppHang (ppStr "In a \"case\" branch:") + 4 (pprMatch sty True{-is_case-} match) + +matchCtxt (MFun fun) match sty + = ppHang (ppBesides [ppStr "In an equation for function ", ppr sty fun, ppChar ':']) + 4 (ppBesides [ppr sty fun, pprMatch sty False{-not case-} match]) +\end{code} + + +\begin{code} +varyingArgsErr name matches sty + = ppSep [ppStr "Varying number of arguments for function", ppr sty name] +\end{code}