\begin{code}
#include "HsVersions.h"
-module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatch ) where
+module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchExpected ) where
IMP_Ubiq()
-import HsSyn ( Match(..), GRHSsAndBinds(..), GRHS(..), InPat,
- HsExpr, HsBinds, OutPat, Fake,
+#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(..), MonoBinds(..), OutPat, Fake, Stmt,
+ Sig, HsLit, DoOrListComp, Fixity, HsType, ArithSeqInfo,
collectPatBinders, pprMatch )
-import RnHsSyn ( SYN_IE(RenamedMatch), RnName{-instance Outputable-} )
-import TcHsSyn ( TcIdOcc(..), SYN_IE(TcMatch) )
+import RnHsSyn ( SYN_IE(RenamedMatch) )
+import TcHsSyn ( SYN_IE(TcMatch) )
-import TcMonad hiding ( rnMtoTcM )
+import TcMonad
import Inst ( Inst, SYN_IE(LIE), plusLIE )
import TcEnv ( newMonoIds )
-IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds )
import TcPat ( tcPat )
-import TcType ( SYN_IE(TcType), TcMaybe, zonkTcType )
-import Unify ( unifyTauTy, unifyTauTyList )
+import TcType ( TcIdOcc(..), SYN_IE(TcType), TcMaybe, zonkTcType )
+import TcSimplify ( bindInstsOfLocalFuns )
+import Unify ( unifyTauTy, unifyTauTyList, unifyFunTy )
+import Name ( Name {- instance Outputable -} )
import Kind ( Kind, mkTypeKind )
import Pretty
-import Type ( isTyVarTy, mkFunTy, getFunTy_maybe )
+import Type ( isTyVarTy, isTauTy, mkFunTy, getFunTy_maybe )
import Util
+import Outputable
+#if __GLASGOW_HASKELL__ >= 202
+import SrcLoc (SrcLoc)
+#endif
+
\end{code}
@tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
same number of arguments before using @tcMatches@ to do the work.
\begin{code}
-tcMatchesFun :: RnName
+tcMatchesFun :: Name
-> TcType s -- Expected type
-> [RenamedMatch]
-> TcM s ([TcMatch s], LIE s)
\begin{code}
-data FunOrCase = MCase | MFun RnName -- Records whether doing fun or case rhss;
+data FunOrCase = MCase | MFun Name -- Records whether doing fun or case rhss;
-- used to produced better error messages
tcMatchesExpected :: TcType s
) `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}
-- 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 match_ty expected_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 arg_ty pat_ty `thenTc_`
- tcMatchExpected rest_ty match `thenTc` \ (match', lie_match) ->
- returnTc (PatMatch pat' match',
- plusLIE lie_pat lie_match)
- )
+ = unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
-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 :: RenamedMatch -> TcM s (TcMatch s, LIE s, TcType s)
-
-tcMatch (PatMatch pat match)
- = let binders = collectPatBinders pat
+ let binders = collectPatBinders pat
in
- newMonoIds binders mkTypeKind (\ _ ->
- -- NB TypeKind; lambda-bound variables are allowed
- -- to unify with unboxed types.
-
- 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)
+ newMonoIds binders mkTypeKind (\ mono_ids ->
+ tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
+ unifyTauTy pat_ty arg_ty `thenTc_`
+ tcMatchExpected rest_ty match `thenTc` \ (match', lie_match) ->
+ -- 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
+ --
+ -- 99% of the time there are no bindings. In the unusual case we
+ -- march down the match to dump them in the right place (boring but easy).
+ bindInstsOfLocalFuns lie_match mono_ids `thenTc` \ (lie_match', inst_mbinds) ->
+ let
+ inst_binds = MonoBind inst_mbinds [] False
+ match'' = case inst_mbinds of
+ EmptyMonoBinds -> match'
+ other -> glue_on match'
+ glue_on (PatMatch p m) = PatMatch p (glue_on m)
+ glue_on (GRHSMatch (GRHSsAndBindsOut grhss binds ty))
+ = (GRHSMatch (GRHSsAndBindsOut grhss
+ (inst_binds `ThenBinds` binds)
+ ty))
+ glue_on (SimpleMatch expr) = SimpleMatch (HsLet inst_binds expr)
+ in
+ returnTc (PatMatch pat' match'',
+ 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 expected_ty (GRHSMatch grhss_and_binds)
+ = tcGRHSsAndBinds expected_ty grhss_and_binds `thenTc` \ (grhss_and_binds', lie) ->
+ checkTc (isTauTy expected_ty)
+ lurkingRank2SigErr `thenTc_`
+ returnTc (GRHSMatch grhss_and_binds', lie)
\end{code}
~~~~~~~~~~~~~~~~~~~
\begin{code}
matchCtxt MCase match sty
- = ppHang (ppStr "In a \"case\" branch:")
+ = hang (ptext SLIT("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, ppSP, pprMatch sty False{-not case-} match])
+ = 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])
\end{code}
\begin{code}
varyingArgsErr name matches sty
- = ppSep [ppStr "Varying number of arguments for function", ppr sty name]
+ = sep [ptext SLIT("Varying number of arguments for function"), ppr sty name]
+
+lurkingRank2SigErr sty
+ = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
\end{code}
projects / ghc-hetmet.git / blobdiff