[project @ 2000-10-25 12:56:20 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index 531baeb..ff2b84f 100644 (file)
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -5,7 +5,7 @@
 
 \begin{code}
 module TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType, 
-                   tcContext, tcClassContext,
+                   tcContext, tcClassContext, checkAmbiguity,
 
                        -- Kind checking
                    kcHsTyVar, kcHsTyVars, mkTyClTyVars,
@@ -18,7 +18,7 @@ module TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType,
 
 #include "HsVersions.h"
 
-import HsSyn           ( HsType(..), HsTyVarBndr(..), HsUsageAnn(..),
+import HsSyn           ( HsType(..), HsTyVarBndr(..),
                           Sig(..), HsPred(..), pprParendHsType, HsTupCon(..), hsTyVarNames )
 import RnHsSyn         ( RenamedHsType, RenamedHsPred, RenamedContext, RenamedSig )
 import TcHsSyn         ( TcId )
@@ -38,16 +38,16 @@ import Inst         ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr,
                          instFunDeps, instFunDepsOfTheta )
 import FunDeps         ( tyVarFunDep, oclose )
 import TcUnify         ( unifyKind, unifyOpenTypeKind )
-import Type            ( Type, Kind, PredType(..), ThetaType, UsageAnn(..),
-                         mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, mkUsgTy,
-                          mkUsForAllTy, zipFunTys, hoistForAllTys,
+import Type            ( Type, Kind, PredType(..), ThetaType,
+                         mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy,
+                          zipFunTys, hoistForAllTys,
                          mkSigmaTy, mkPredTy, mkTyConApp,
                          mkAppTys, splitForAllTys, splitRhoTy, mkRhoTy,
                          boxedTypeKind, unboxedTypeKind, mkArrowKind,
                          mkArrowKinds, getTyVar_maybe, getTyVar, splitFunTy_maybe,
                          tidyOpenType, tidyOpenTypes, tidyTyVar, tidyTyVars,
                          tyVarsOfType, tyVarsOfPred, mkForAllTys,
-                         classesOfPreds, isUnboxedTupleType
+                         classesOfPreds,
                        )
 import PprType         ( pprType, pprPred )
 import Subst           ( mkTopTyVarSubst, substTy )
@@ -56,9 +56,9 @@ import Var            ( Var, TyVar, mkTyVar, tyVarKind )
 import VarEnv
 import VarSet
 import ErrUtils                ( Message )
-import TyCon           ( TyCon, isSynTyCon, tyConArity, tyConKind, tyConName )
+import TyCon           ( TyCon, isSynTyCon, tyConArity, tyConKind )
 import Class           ( ClassContext, classArity, classTyCon )
-import Name            ( Name, isLocallyDefined )
+import Name            ( Name )
 import TysWiredIn      ( mkListTy, mkTupleTy, genUnitTyCon )
 import UniqFM          ( elemUFM )
 import BasicTypes      ( Boxity(..) )
@@ -371,9 +371,13 @@ tcHsType full_ty@(HsForAllTy (Just tv_names) ctxt ty)
     tcHsTyVars tv_names kind_check             $ \ tyvars ->
     tcContext ctxt                             `thenTc` \ theta ->
     tcHsType ty                                        `thenTc` \ tau ->
-    checkAmbiguity full_ty tyvars theta tau    `thenTc_`
-    returnTc (mkSigmaTy tyvars theta tau)
+    checkAmbiguity is_source tyvars theta tau
+  where
+    is_source = case tv_names of
+                  (UserTyVar _ : _) -> True
+                  other             -> False
 
+checkAmbiguity :: Bool -> [TyVar] -> ThetaType -> Type -> TcM Type
   -- Check for ambiguity
   --   forall V. P => tau
   -- is ambiguous if P contains generic variables
@@ -392,25 +396,6 @@ tcHsType full_ty@(HsForAllTy (Just tv_names) ctxt ty)
   -- even in a scope where b is in scope.
   -- This is the is_free test below.
 
-checkAmbiguity full_ty forall_tyvars theta tau
-  = mapTc check_pred theta
-  where
-    tau_vars         = tyVarsOfType tau
-    fds                      = instFunDepsOfTheta theta
-    tvFundep         = tyVarFunDep fds
-    extended_tau_vars = oclose tvFundep tau_vars
-
-    is_ambig ct_var   = (ct_var `elem` forall_tyvars) &&
-                       not (ct_var `elemUFM` extended_tau_vars)
-    is_free ct_var    = not (ct_var `elem` forall_tyvars)
-    
-    check_pred pred = checkTc (not any_ambig) (ambigErr pred full_ty) `thenTc_`
-                     checkTc (not all_free)  (freeErr  pred full_ty)
-             where 
-               ct_vars   = varSetElems (tyVarsOfPred pred)
-               all_free  = all is_free ct_vars
-               any_ambig = is_source_polytype && any is_ambig ct_vars
-    
     -- Notes on the 'is_source_polytype' test above
     -- Check ambiguity only for source-program types, not
     -- for types coming from inteface files.  The latter can
@@ -426,10 +411,27 @@ checkAmbiguity full_ty forall_tyvars theta tau
     -- If the list of tv_names is empty, we have a monotype,
     -- and then we don't need to check for ambiguity either,
     -- because the test can't fail (see is_ambig).
-    is_source_polytype 
-       = case full_ty of
-           HsForAllTy (Just (UserTyVar _ : _)) _ _ -> True
-           other                                   -> False
+
+checkAmbiguity is_source_polytype forall_tyvars theta tau
+  = mapTc_ check_pred theta    `thenTc_`
+    returnTc sigma_ty
+  where
+    sigma_ty         = mkSigmaTy forall_tyvars theta tau
+    tau_vars         = tyVarsOfType tau
+    fds                      = instFunDepsOfTheta theta
+    tvFundep         = tyVarFunDep fds
+    extended_tau_vars = oclose tvFundep tau_vars
+
+    is_ambig ct_var   = (ct_var `elem` forall_tyvars) &&
+                       not (ct_var `elemUFM` extended_tau_vars)
+    is_free ct_var    = not (ct_var `elem` forall_tyvars)
+    
+    check_pred pred = checkTc (not any_ambig) (ambigErr pred sigma_ty) `thenTc_`
+                     checkTc (not all_free)  (freeErr  pred sigma_ty)
+             where 
+               ct_vars   = varSetElems (tyVarsOfPred pred)
+               all_free  = all is_free ct_vars
+               any_ambig = is_source_polytype && any is_ambig ct_vars
 \end{code}
 
 Help functions for type applications