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}
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
-- 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
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}
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}
projects / ghc-hetmet.git / blobdiff