[project @ 1997-06-18 23:52:36 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcMatches.lhs

diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs
index 1eba821..be45c99 100644 (file)
--- a/ghc/compiler/typecheck/TcMatches.lhs
+++ b/ghc/compiler/typecheck/TcMatches.lhs
@@ -10,24 +10,37 @@ module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatch ) 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 RnHsSyn         ( SYN_IE(RenamedMatch) )
 import TcHsSyn         ( TcIdOcc(..), 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 TcSimplify      ( bindInstsOfLocalFuns )
 import Unify           ( unifyTauTy, unifyTauTyList )
+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
@@ -36,7 +49,7 @@ 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 :: RnName
+tcMatchesFun :: Name
             -> TcType s                -- Expected type
             -> [RenamedMatch]
             -> TcM s ([TcMatch s], LIE s)
@@ -80,7 +93,7 @@ tcMatchesCase expected_ty matches = tcMatchesExpected expected_ty MCase matches
 
 
 \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
@@ -138,16 +151,38 @@ tcMatchExpected expected_ty the_match@(PatMatch pat match)
        Just (arg_ty,rest_ty) ->        -- It's a function type!
            let binders = collectPatBinders pat
            in
-           newMonoIds binders mkTypeKind (\ _ ->
+           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) ->
-               returnTc (PatMatch pat' match',
-                         plusLIE lie_pat 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 dd 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')
            )
 
 tcMatchExpected expected_ty (GRHSMatch grhss_and_binds)
   = tcGRHSsAndBinds grhss_and_binds    `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
+    checkTc (isTauTy expected_ty)
+           lurkingRank2SigErr          `thenTc_`
     unifyTauTy expected_ty grhss_ty    `thenTc_`
     returnTc (GRHSMatch grhss_and_binds', lie)
 
@@ -207,16 +242,19 @@ Errors and contexts
 ~~~~~~~~~~~~~~~~~~~
 \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}