[project @ 2000-05-23 11:35:36 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index d9dc3a2..342529c 100644 (file)
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -13,7 +13,7 @@ import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun )
 import {-# SOURCE #-} TcExpr  ( tcExpr )
 
 import HsSyn           ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..), StmtCtxt(..),
-                         collectMonoBinders, andMonoBindList, andMonoBinds
+                         Match(..), collectMonoBinders, andMonoBindList, andMonoBinds
                        )
 import RnHsSyn         ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
 import TcHsSyn         ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet )
@@ -30,7 +30,7 @@ import TcEnv          ( tcExtendLocalValEnv,
                        )
 import TcSimplify      ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts )
 import TcImprove       ( tcImprove )
-import TcMonoType      ( tcHsType, checkSigTyVars,
+import TcMonoType      ( tcHsSigType, checkSigTyVars,
                          TcSigInfo(..), tcTySig, maybeSig, sigCtxt
                        )
 import TcPat           ( tcPat )
@@ -44,7 +44,7 @@ import TcUnify                ( unifyTauTy, unifyTauTyLists )
 
 import PrelInfo                ( main_NAME, ioTyCon_NAME )
 
-import Id              ( Id, mkVanillaId, setInlinePragma )
+import Id              ( Id, mkVanillaId, setInlinePragma, idFreeTyVars )
 import Var             ( idType, idName )
 import IdInfo          ( setInlinePragInfo, InlinePragInfo(..) )
 import Name            ( Name, getName, getOccName, getSrcLoc )
@@ -259,7 +259,10 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
        -- come before:
        --   - computing vars over which to quantify
        --   - zonking the generalized type vars
-    tcImprove lie_req `thenTc_`
+    let lie_avail = case maybe_sig_theta of
+                     Nothing      -> emptyLIE
+                     Just (_, la) -> la in
+    tcImprove (lie_avail `plusLIE` lie_req)                    `thenTc_`
 
        -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
        -- The tyvars_not_to_gen are free in the environment, and hence
@@ -570,13 +573,16 @@ isUnRestrictedGroup :: [Name]             -- Signatures given for these
 
 is_elem v vs = isIn "isUnResMono" v vs
 
-isUnRestrictedGroup sigs (PatMonoBind (VarPatIn v) _ _) = v `is_elem` sigs
 isUnRestrictedGroup sigs (PatMonoBind other        _ _) = False
 isUnRestrictedGroup sigs (VarMonoBind v _)             = v `is_elem` sigs
-isUnRestrictedGroup sigs (FunMonoBind _ _ _ _)         = True
+isUnRestrictedGroup sigs (FunMonoBind v _ matches _)   = any isUnRestrictedMatch matches || 
+                                                         v `is_elem` sigs
 isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2)                = isUnRestrictedGroup sigs mb1 &&
                                                          isUnRestrictedGroup sigs mb2
 isUnRestrictedGroup sigs EmptyMonoBinds                        = True
+
+isUnRestrictedMatch (Match _ [] Nothing _) = False     -- No args, no signature
+isUnRestrictedMatch other                 = True       -- Some args or a signature
 \end{code}
 
 
@@ -766,10 +772,10 @@ checkSigMatch top_lvl binder_names mono_ids sigs
                      
        -- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK
        -- Doesn't affect substitution
-    check_one_sig (TySigInfo _ id sig_tyvars _ sig_tau _ _ src_loc)
+    check_one_sig (TySigInfo _ id sig_tyvars sig_theta sig_tau _ _ src_loc)
       = tcAddSrcLoc src_loc                                    $
-       tcAddErrCtxtM (sigCtxt (sig_msg id) (idType id))        $
-       checkSigTyVars sig_tyvars
+       tcAddErrCtxtM (sigCtxt (sig_msg id) sig_tyvars sig_theta sig_tau)       $
+       checkSigTyVars sig_tyvars (idFreeTyVars id)
 
 
        -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
@@ -796,8 +802,7 @@ checkSigMatch top_lvl binder_names mono_ids sigs
 
     mk_dict_tys theta = map mkPredTy theta
 
-    sig_msg id tidy_ty = sep [ptext SLIT("When checking the type signature"),
-                             nest 4 (ppr id <+> dcolon <+> ppr tidy_ty)]
+    sig_msg id = ptext SLIT("When checking the type signature for") <+> quotes (ppr id)
 
        -- Search for Main.main in the binder_names, return corresponding mono_id
     find_main NotTopLevel binder_names mono_ids = Nothing
@@ -857,7 +862,7 @@ tcSpecSigs (SpecSig name poly_ty src_loc : sigs)
     tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
 
        -- Get and instantiate its alleged specialised type
-    tcHsType poly_ty                           `thenTc` \ sig_ty ->
+    tcHsSigType poly_ty                                `thenTc` \ sig_ty ->
 
        -- Check that f has a more general type, and build a RHS for
        -- the spec-pragma-id at the same time