[project @ 2000-10-03 08:43:00 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 4827932..ea737a1 100644 (file)
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -12,14 +12,14 @@ module TcBinds ( tcBindsAndThen, tcTopBindsAndThen,
 import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun )
 import {-# SOURCE #-} TcExpr  ( tcExpr )
 
-import HsSyn           ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..), StmtCtxt(..),
-                         Match(..), collectMonoBinders, andMonoBindList, andMonoBinds
+import HsSyn           ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), StmtCtxt(..),
+                         Match(..), collectMonoBinders, andMonoBinds
                        )
 import RnHsSyn         ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
-import TcHsSyn         ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet )
+import TcHsSyn         ( TcMonoBinds, TcId, zonkId, mkHsLet )
 
 import TcMonad
-import Inst            ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..),
+import Inst            ( LIE, emptyLIE, mkLIE, plusLIE, InstOrigin(..),
                          newDicts, tyVarsOfInst, instToId,
                          getAllFunDepsOfLIE, getIPsOfLIE, zonkFunDeps
                        )
@@ -35,33 +35,30 @@ import TcMonoType   ( tcHsSigType, checkSigTyVars,
                        )
 import TcPat           ( tcPat )
 import TcSimplify      ( bindInstsOfLocalFuns )
-import TcType          ( TcType, TcThetaType,
-                         TcTyVar,
-                         newTyVarTy, newTyVar, newTyVarTy_OpenKind, tcInstTcType,
-                         zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcTyVarToTyVar
+import TcType          ( TcThetaType, newTyVarTy, newTyVar, 
+                         zonkTcTypes, zonkTcThetaType, zonkTcTyVarToTyVar
                        )
 import TcUnify         ( unifyTauTy, unifyTauTyLists )
 
-import Id              ( Id, mkVanillaId, setInlinePragma, idFreeTyVars )
+import Id              ( mkVanillaId, setInlinePragma, idFreeTyVars )
 import Var             ( idType, idName )
-import IdInfo          ( setInlinePragInfo, InlinePragInfo(..) )
-import Name            ( Name, getName, getOccName, getSrcLoc )
+import IdInfo          ( InlinePragInfo(..) )
+import Name            ( Name, getOccName, getSrcLoc )
 import NameSet
 import Type            ( mkTyVarTy, tyVarsOfTypes, mkTyConApp,
-                         splitSigmaTy, mkForAllTys, mkFunTys, getTyVar, 
-                         mkPredTy, splitRhoTy, mkForAllTy, isUnLiftedType, 
-                         isUnboxedType, unboxedTypeKind, boxedTypeKind
+                         mkForAllTys, mkFunTys, 
+                         mkPredTy, mkForAllTy, isUnLiftedType, 
+                         isUnboxedType, unboxedTypeKind, boxedTypeKind, openTypeKind
                        )
 import FunDeps         ( tyVarFunDep, oclose )
-import Var             ( TyVar, tyVarKind )
+import Var             ( tyVarKind )
 import VarSet
 import Bag
 import Util            ( isIn )
 import Maybes          ( maybeToBool )
 import BasicTypes      ( TopLevelFlag(..), RecFlag(..), isNotTopLevel )
 import FiniteMap       ( listToFM, lookupFM )
-import Unique          ( ioTyConKey, mainKey, hasKey, Uniquable(..) )
-import SrcLoc           ( SrcLoc )
+import PrelNames       ( ioTyConKey, mainKey, hasKey )
 import Outputable
 \end{code}
 
@@ -236,7 +233,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
        newTyVar boxedTypeKind          `thenNF_Tc` \ alpha_tv ->
        let
          forall_a_a    = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
-          binder_names  = map fst (bagToList (collectMonoBinders mbind))
+          binder_names  = collectMonoBinders mbind
          poly_ids      = map mk_dummy binder_names
          mk_dummy name = case maybeSig tc_ty_sigs name of
                            Just (TySigInfo _ poly_id _ _ _ _ _ _) -> poly_id   -- Signature
@@ -401,8 +398,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
                -- at all.
        
        pat_binders :: [Name]
-       pat_binders = map fst $ bagToList $ collectMonoBinders $ 
-                     (justPatBindings mbind EmptyMonoBinds)
+       pat_binders = collectMonoBinders (justPatBindings mbind EmptyMonoBinds)
     in
        -- CHECK FOR UNBOXED BINDERS IN PATTERN BINDINGS
     mapTc (\id -> checkTc (not (idName id `elem` pat_binders
@@ -613,7 +609,6 @@ tcMonoBinds :: RenamedMonoBinds
 tcMonoBinds mbinds tc_ty_sigs is_rec
   = tc_mb_pats mbinds          `thenTc` \ (complete_it, lie_req_pat, tvs, ids, lie_avail) ->
     let
-       tv_list           = bagToList tvs
        id_list           = bagToList ids
        (names, mono_ids) = unzip id_list
 
@@ -681,7 +676,7 @@ tcMonoBinds mbinds tc_ty_sigs is_rec
                  lie_avail1 `plusLIE` lie_avail2)
 
     tc_mb_pats (FunMonoBind name inf matches locn)
-      = new_lhs_ty                     `thenNF_Tc` \ bndr_ty ->
+      = newTyVarTy kind                `thenNF_Tc` \ bndr_ty -> 
        tc_pat_bndr name bndr_ty        `thenTc` \ bndr_id ->
        let
           complete_it xve = tcAddSrcLoc locn                           $
@@ -692,7 +687,7 @@ tcMonoBinds mbinds tc_ty_sigs is_rec
 
     tc_mb_pats bind@(PatMonoBind pat grhss locn)
       = tcAddSrcLoc locn               $
-       new_lhs_ty                      `thenNF_Tc` \ pat_ty -> 
+       newTyVarTy kind                 `thenNF_Tc` \ pat_ty -> 
 
                --      Now typecheck the pattern
                -- We don't support binding fresh type variables in the
@@ -716,9 +711,9 @@ tcMonoBinds mbinds tc_ty_sigs is_rec
 
        -- Figure out the appropriate kind for the pattern,
        -- and generate a suitable type variable 
-    new_lhs_ty = case is_rec of
-                    Recursive    -> newTyVarTy boxedTypeKind   -- Recursive, so no unboxed types
-                    NonRecursive -> newTyVarTy_OpenKind        -- Non-recursive, so we permit unboxed types
+    kind = case is_rec of
+               Recursive    -> boxedTypeKind   -- Recursive, so no unboxed types
+               NonRecursive -> openTypeKind    -- Non-recursive, so we permit unboxed types
 \end{code}
 
 %************************************************************************
@@ -910,21 +905,6 @@ valSpecSigCtxt v ty
         nest 4 (ppr v <+> dcolon <+> ppr ty)]
 
 -----------------------------------------------
-notAsPolyAsSigErr sig_tau mono_tyvars
-  = hang (ptext SLIT("A type signature is more polymorphic than the inferred type"))
-       4  (vcat [text "Can't for-all the type variable(s)" <+> 
-                 pprQuotedList mono_tyvars,
-                 text "in the type" <+> quotes (ppr sig_tau)
-          ])
-
------------------------------------------------
-badMatchErr sig_ty inferred_ty
-  = hang (ptext SLIT("Type signature doesn't match inferred type"))
-        4 (vcat [hang (ptext SLIT("Signature:")) 4 (ppr sig_ty),
-                     hang (ptext SLIT("Inferred :")) 4 (ppr inferred_ty)
-          ])
-
------------------------------------------------
 unboxedPatBindErr id
   = ptext SLIT("variable in a lazy pattern binding has unboxed type: ")
         <+> quotes (ppr id)