[project @ 2003-03-27 08:18:21 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs
index ad4994d..9947d82 100644 (file)
--- a/ghc/compiler/typecheck/TcMType.lhs
+++ b/ghc/compiler/typecheck/TcMType.lhs
@@ -14,7 +14,7 @@ module TcMType (
   newTyVar, 
   newTyVarTy,          -- Kind -> TcM TcType
   newTyVarTys,         -- Int -> Kind -> TcM [TcType]
-  newKindVar, newKindVars, newBoxityVar,
+  newKindVar, newKindVars, newOpenTypeKind,
   putTcTyVar, getTcTyVar,
   newMutTyVar, readMutTyVar, writeMutTyVar, 
 
@@ -46,14 +46,14 @@ module TcMType (
 
 -- friends:
 import TypeRep         ( Type(..), SourceType(..), TyNote(..),  -- Friend; can see representation
-                         Kind, ThetaType
+                         Kind, ThetaType, typeCon
                        ) 
 import TcType          ( TcType, TcThetaType, TcTauType, TcPredType,
                          TcTyVarSet, TcKind, TcTyVar, TyVarDetails(..),
-                         tcEqType, tcCmpPred,
+                         tcEqType, tcCmpPred, isClassPred,
                          tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe, 
                          tcSplitTyConApp_maybe, tcSplitForAllTys,
-                         tcIsTyVarTy, tcSplitSigmaTy, 
+                         tcIsTyVarTy, tcSplitSigmaTy, mkTyConApp,
                          isUnLiftedType, isIPPred, isHoleTyVar, isTyVarTy,
 
                          mkAppTy, mkTyVarTy, mkTyVarTys, 
@@ -65,11 +65,10 @@ import TcType               ( TcType, TcThetaType, TcTauType, TcPredType,
                          eqKind, isTypeKind, 
                          isFFIArgumentTy, isFFIImportResultTy
                        )
-import qualified Type  ( splitFunTys )
 import Subst           ( Subst, mkTopTyVarSubst, substTy )
 import Class           ( Class, DefMeth(..), classArity, className, classBigSig )
 import TyCon           ( TyCon, isSynTyCon, isUnboxedTupleTyCon, 
-                         tyConArity, tyConName, tyConKind, tyConTheta, 
+                         tyConArity, tyConName, tyConTheta, 
                          getSynTyConDefn, tyConDataCons )
 import DataCon         ( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels )
 import FieldLabel      ( fieldLabelName, fieldLabelType )
@@ -83,13 +82,9 @@ import PrelNames     ( cCallableClassKey, cReturnableClassKey, hasKey )
 import ForeignCall     ( Safety(..) )
 import FunDeps         ( grow )
 import PprType         ( pprPred, pprSourceType, pprTheta, pprClassPred )
-import Name            ( Name, NamedThing(..), setNameUnique, 
-                         mkSystemTvNameEncoded,
-                       )
+import Name            ( Name, setNameUnique, mkSystemTvNameEncoded )
 import VarSet
-import BasicTypes      ( Boxity(Boxed) )
 import CmdLineOpts     ( dopt, DynFlag(..) )
-import SrcLoc          ( noSrcLoc )
 import Util            ( nOfThem, isSingleton, equalLength, notNull )
 import ListSetOps      ( equivClasses, removeDups )
 import Outputable
@@ -136,11 +131,11 @@ newKindVar
 newKindVars :: Int -> TcM [TcKind]
 newKindVars n = mappM (\ _ -> newKindVar) (nOfThem n ())
 
-newBoxityVar :: TcM TcKind
-newBoxityVar
+newOpenTypeKind :: TcM TcKind  -- Returns the kind (Type bx), where bx is fresh
+newOpenTypeKind
   = newUnique                                                    `thenM` \ uniq ->
     newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("bx")) superBoxity VanillaTv  `thenM` \ kv ->
-    returnM (TyVarTy kv)
+    returnM (mkTyConApp typeCon [TyVarTy kv])
 \end{code}
 
 
@@ -913,13 +908,18 @@ checkAmbiguity forall_tyvars theta tau_tyvars
   where
     complain pred     = addErrTc (ambigErr pred)
     extended_tau_vars = grow theta tau_tyvars
-    is_ambig pred     = any ambig_var (varSetElems (tyVarsOfPred pred))
+
+       -- Only a *class* predicate can give rise to ambiguity
+       -- An *implicit parameter* cannot.  For example:
+       --      foo :: (?x :: [a]) => Int
+       --      foo = length ?x
+       -- is fine.  The call site will suppply a particular 'x'
+    is_ambig pred     = isClassPred  pred &&
+                       any ambig_var (varSetElems (tyVarsOfPred pred))
 
     ambig_var ct_var  = (ct_var `elem` forall_tyvars) &&
                        not (ct_var `elemVarSet` extended_tau_vars)
 
-    is_free ct_var    = not (ct_var `elem` forall_tyvars)
-
 ambigErr pred
   = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprPred pred),
         nest 4 (ptext SLIT("At least one of the forall'd type variables mentioned by the constraint") $$
@@ -1016,7 +1016,7 @@ checkValidDataCon con
                -- This checks the argument types and
                -- ambiguity of the existential context (if any)
     addErrCtxt (existentialCtxt con)
-                (checkFreeness ex_tvs ex_theta)
+              (checkFreeness ex_tvs ex_theta)
   where
     ctxt = ConArgCtxt (dataConName con) 
     (_, _, ex_tvs, ex_theta, _, _) = dataConSig con