[project @ 2001-09-26 15:12:33 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 70ee5bd..e5a83ab 100644 (file)
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -28,32 +28,31 @@ import TcEnv                ( tcExtendLocalValEnv,
                          newSpecPragmaId, newLocalId
                        )
 import TcSimplify      ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, tcSimplifyToDicts )
-import TcMonoType      ( tcHsSigType, checkSigTyVars,
+import TcMonoType      ( tcHsSigType, UserTypeCtxt(..), checkSigTyVars,
                          TcSigInfo(..), tcTySig, maybeSig, sigCtxt
                        )
 import TcPat           ( tcPat )
 import TcSimplify      ( bindInstsOfLocalFuns )
-import TcType          ( newTyVarTy, newTyVar, 
-                         zonkTcTyVarToTyVar
+import TcMType         ( newTyVarTy, newTyVar, 
+                         zonkTcTyVarToTyVar, 
+                         unifyTauTy, unifyTauTyLists
+                       )
+import TcType          ( mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType, 
+                         mkPredTy, mkForAllTy, isUnLiftedType, 
+                         unliftedTypeKind, liftedTypeKind, openTypeKind, eqKind
                        )
-import TcUnify         ( unifyTauTy, unifyTauTyLists )
 
 import CoreFVs         ( idFreeTyVars )
 import Id              ( mkLocalId, setInlinePragma )
 import Var             ( idType, idName )
-import IdInfo          ( InlinePragInfo(..) )
 import Name            ( Name, getOccName, getSrcLoc )
 import NameSet
-import Type            ( mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType, 
-                         mkPredTy, mkForAllTy, isUnLiftedType, 
-                         unliftedTypeKind, liftedTypeKind, openTypeKind
-                       )
 import Var             ( tyVarKind )
 import VarSet
 import Bag
 import Util            ( isIn )
-import Maybes          ( maybeToBool )
-import BasicTypes      ( TopLevelFlag(..), RecFlag(..), isNonRec, isNotTopLevel )
+import BasicTypes      ( TopLevelFlag(..), RecFlag(..), isNonRec, isNotTopLevel,
+                         isAlwaysActive )
 import FiniteMap       ( listToFM, lookupFM )
 import Outputable
 \end{code}
@@ -223,7 +222,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
        -- TYPECHECK THE BINDINGS
     tcMonoBinds mbind tc_ty_sigs is_rec                `thenTc` \ (mbind', lie_req, binder_names, mono_ids) ->
     let
-       tau_tvs = varSetElems (foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet mono_ids)
+       tau_tvs = foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet mono_ids
     in
 
        -- GENERALISE
@@ -258,14 +257,10 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
        exports  = zipWith mk_export binder_names zonked_mono_ids
        dict_tys = map idType zonked_dict_ids
 
-       inlines    = mkNameSet [name | InlineSig name _ loc <- inline_sigs]
-        no_inlines = listToFM ([(name, IMustNotBeINLINEd False phase) | NoInlineSig name phase loc <- inline_sigs] ++
-                              [(name, IMustNotBeINLINEd True  phase) | InlineSig   name phase loc <- inline_sigs, maybeToBool phase])
-               -- "INLINE n foo" means inline foo, but not until at least phase n
-               -- "NOINLINE n foo" means don't inline foo until at least phase n, and even 
-               --                  then only if it is small enough etc.
-               -- "NOINLINE foo" means don't inline foo ever, which we signal with a (IMustNotBeINLINEd Nothing)
-               -- See comments in CoreUnfold.blackListed for the Authorised Version
+       inlines    = mkNameSet [name | InlineSig True name _ loc <- inline_sigs]
+        no_inlines = listToFM [(name, phase) | InlineSig _ name phase _ <- inline_sigs, 
+                                              not (isAlwaysActive phase)]
+                       -- AlwaysActive is the default, so don't bother with them
 
        mk_export binder_name zonked_mono_id
          = (tyvars, 
@@ -309,7 +304,7 @@ attachNoInlinePrag no_inlines bndr
        Nothing   -> bndr
 
 checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind zonked_mono_ids
-  = ASSERT( not (any ((== unliftedTypeKind) . tyVarKind) real_tyvars_to_gen) )
+  = ASSERT( not (any ((eqKind unliftedTypeKind) . tyVarKind) real_tyvars_to_gen) )
                -- The instCantBeGeneralised stuff in tcSimplify should have
                -- already raised an error if we're trying to generalise an 
                -- unboxed tyvar (NB: unboxed tyvars are always introduced 
@@ -433,7 +428,7 @@ generalise binder_names mbind tau_tvs lie_req sigs
   =    -- CHECKING CASE: Unrestricted group, there are type signatures
        -- Check signature contexts are empty 
     checkSigsCtxts sigs                                `thenTc` \ (sig_avails, sig_dicts) ->
-
+    
        -- Check that the needed dicts can be
        -- expressed in terms of the signature ones
     tcSimplifyInferCheck doc tau_tvs sig_avails lie_req        `thenTc` \ (forall_tvs, lie_free, dict_binds) ->
@@ -660,8 +655,9 @@ tcMonoBinds mbinds tc_ty_sigs is_rec
        newTyVarTy kind                 `thenNF_Tc` \ pat_ty -> 
 
                --      Now typecheck the pattern
-               -- We don't support binding fresh type variables in the
-               -- pattern of a pattern binding.  For example, this is illegal:
+               -- We don't support binding fresh (not-already-in-scope) scoped 
+               -- type variables in the pattern of a pattern binding.  
+               -- For example, this is illegal:
                --      (x::a, y::b) = e
                -- whereas this is ok
                --      (x::Int, y::Bool) = e
@@ -736,7 +732,7 @@ tcSpecSigs (SpecSig name poly_ty src_loc : sigs)
     tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
 
        -- Get and instantiate its alleged specialised type
-    tcHsSigType poly_ty                                `thenTc` \ sig_ty ->
+    tcHsSigType (FunSigCtxt name) 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
@@ -780,9 +776,10 @@ valSpecSigCtxt v ty
 sigContextsErr = ptext SLIT("Mismatched contexts")
 
 sigContextsCtxt s1 s2
-  = hang (hsep [ptext SLIT("When matching the contexts of the signatures for"), 
-               quotes (ppr s1), ptext SLIT("and"), quotes (ppr s2)])
-        4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)"))
+  = vcat [ptext SLIT("When matching the contexts of the signatures for"), 
+         nest 2 (vcat [ppr s1 <+> dcolon <+> ppr (idType s1),
+                       ppr s2 <+> dcolon <+> ppr (idType s2)]),
+         ptext SLIT("The signature contexts in a mutually recursive group should all be identical")]
 
 -----------------------------------------------
 unliftedBindErr flavour mbind