[project @ 2003-02-26 17:04:11 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs
index fd22557..1a05fd5 100644 (file)
--- a/ghc/compiler/typecheck/TcUnify.lhs
+++ b/ghc/compiler/typecheck/TcUnify.lhs
@@ -12,12 +12,7 @@ module TcUnify (
        -- Various unifications
   unifyTauTy, unifyTauTyList, unifyTauTyLists, 
   unifyFunTy, unifyListTy, unifyPArrTy, unifyTupleTy,
-  unifyKind, unifyKinds, unifyOpenTypeKind, unifyFunKind,
-
-       -- Coercions
-  Coercion, ExprCoFn, PatCoFn, 
-  (<$>), (<.>), mkCoercion, 
-  idCoercion, isIdCoercion
+  unifyKind, unifyKinds, unifyOpenTypeKind, unifyFunKind
 
   ) where
 
@@ -25,7 +20,8 @@ module TcUnify (
 
 
 import HsSyn           ( HsExpr(..) )
-import TcHsSyn         ( TypecheckedHsExpr, TcPat, mkHsLet )
+import TcHsSyn         ( TypecheckedHsExpr, TcPat, mkHsLet,
+                         ExprCoFn, idCoercion, isIdCoercion, mkCoercion, (<.>), (<$>) )
 import TypeRep         ( Type(..), SourceType(..), TyNote(..), openKindCon )
 
 import TcRnMonad         -- TcType, amongst others
@@ -34,7 +30,7 @@ import TcType         ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType,
                          isTauTy, isSigmaTy, 
                          tcSplitAppTy_maybe, tcSplitTyConApp_maybe, 
                          tcGetTyVar_maybe, tcGetTyVar, 
-                         mkTyConApp, mkFunTy, tyVarsOfType, mkPhiTy,
+                         mkFunTy, tyVarsOfType, mkPhiTy,
                          typeKind, tcSplitFunTy_maybe, mkForAllTys,
                          isHoleTyVar, isSkolemTyVar, isUserTyVar, 
                          tidyOpenType, tidyOpenTypes, tidyOpenTyVar, tidyOpenTyVars,
@@ -45,17 +41,17 @@ import qualified Type       ( getTyVar_maybe )
 import Inst            ( newDicts, instToId, tcInstCall )
 import TcMType         ( getTcTyVar, putTcTyVar, tcInstType, readHoleResult, newKindVar,
                          newTyVarTy, newTyVarTys, newOpenTypeKind, newHoleTyVarTy, 
-                         zonkTcType, zonkTcTyVars, zonkTcTyVarsAndFV, zonkTcTyVar )
+                         zonkTcType, zonkTcTyVars, zonkTcTyVarsAndFV )
 import TcSimplify      ( tcSimplifyCheck )
 import TysWiredIn      ( listTyCon, parrTyCon, mkListTy, mkPArrTy, mkTupleTy )
-import TcEnv           ( TcTyThing(..), tcGetGlobalTyVars, findGlobals )
+import TcEnv           ( tcGetGlobalTyVars, findGlobals )
 import TyCon           ( tyConArity, isTupleTyCon, tupleTyConBoxity )
 import PprType         ( pprType )
-import Id              ( Id, mkSysLocal, idType )
+import Id              ( Id, mkSysLocal )
 import Var             ( Var, varName, tyVarKind )
 import VarSet          ( emptyVarSet, unitVarSet, unionVarSet, elemVarSet, varSetElems )
 import VarEnv
-import Name            ( isSystemName, getSrcLoc )
+import Name            ( isSystemName )
 import ErrUtils                ( Message )
 import BasicTypes      ( Boxity, Arity, isBoxed )
 import Util            ( equalLength, notNull )
@@ -100,7 +96,8 @@ These two check for holes
 
 \begin{code}
 tcSubExp expected_ty offered_ty
-  = checkHole expected_ty offered_ty tcSub
+  = traceTc (text "tcSubExp" <+> (ppr expected_ty $$ ppr offered_ty))  `thenM_`
+    checkHole expected_ty offered_ty tcSub
 
 tcSubOff expected_ty offered_ty
   = checkHole offered_ty expected_ty (\ off exp -> tcSub exp off)
@@ -116,7 +113,8 @@ checkHole (TyVarTy tv) other_ty thing_inside
   = getTcTyVar tv      `thenM` \ maybe_ty ->
     case maybe_ty of
        Just ty -> thing_inside ty other_ty
-       Nothing -> putTcTyVar tv other_ty       `thenM_`
+       Nothing -> traceTc (text "checkHole" <+> ppr tv)        `thenM_`
+                  putTcTyVar tv other_ty       `thenM_`
                   returnM idCoercion
 
 checkHole ty other_ty thing_inside 
@@ -129,7 +127,7 @@ No holes expected now.  Add some error-check context info.
 tcSub expected_ty actual_ty
   = traceTc (text "tcSub" <+> details)         `thenM_`
     addErrCtxtM (unifyCtxt "type" expected_ty actual_ty)
-                 (tc_sub expected_ty expected_ty actual_ty actual_ty)
+               (tc_sub expected_ty expected_ty actual_ty actual_ty)
   where
     details = vcat [text "Expected:" <+> ppr expected_ty,
                    text "Actual:  " <+> ppr actual_ty]
@@ -179,7 +177,7 @@ tc_sub exp_sty expected_ty act_sty actual_ty
   | isSigmaTy actual_ty
   = tcInstCall Rank2Origin actual_ty           `thenM` \ (inst_fn, body_ty) ->
     tc_sub exp_sty expected_ty body_ty body_ty `thenM` \ co_fn ->
-    returnM (co_fn <.> mkCoercion inst_fn)
+    returnM (co_fn <.> inst_fn)
 
 -----------------------------------
 -- Function case
@@ -199,7 +197,19 @@ tc_sub _ (FunTy exp_arg exp_res) _ (FunTy act_arg act_res)
 --      when the arg/res is not a tau-type?
 -- NO!  e.g.   f :: ((forall a. a->a) -> Int) -> Int
 --     then   x = (f,f)
---     is perfectly fine!
+--     is perfectly fine, because we can instantiat f's type to a monotype
+--
+-- However, we get can get jolly unhelpful error messages.  
+--     e.g.    foo = id runST
+--
+--    Inferred type is less polymorphic than expected
+--     Quantified type variable `s' escapes
+--     Expected type: ST s a -> t
+--     Inferred type: (forall s1. ST s1 a) -> a
+--    In the first argument of `id', namely `runST'
+--    In a right-hand side of function `foo': id runST
+--
+-- I'm not quite sure what to do about this!
 
 tc_sub exp_sty exp_ty@(FunTy exp_arg exp_res) _ (TyVarTy tv)
   = ASSERT( not (isHoleTyVar tv) )
@@ -339,39 +349,6 @@ tcGen expected_ty extra_tvs thing_inside   -- We expect expected_ty to be a forall
 
 %************************************************************************
 %*                                                                     *
-\subsection{Coercion functions}
-%*                                                                     *
-%************************************************************************
-
-\begin{code}
-type Coercion a = Maybe (a -> a)
-       -- Nothing => identity fn
-
-type ExprCoFn = Coercion TypecheckedHsExpr
-type PatCoFn  = Coercion TcPat
-
-(<.>) :: Coercion a -> Coercion a -> Coercion a        -- Composition
-Nothing <.> Nothing = Nothing
-Nothing <.> Just f  = Just f
-Just f  <.> Nothing = Just f
-Just f1 <.> Just f2 = Just (f1 . f2)
-
-(<$>) :: Coercion a -> a -> a
-Just f  <$> e = f e
-Nothing <$> e = e
-
-mkCoercion :: (a -> a) -> Coercion a
-mkCoercion f = Just f
-
-idCoercion :: Coercion a
-idCoercion = Nothing
-
-isIdCoercion :: Coercion a -> Bool
-isIdCoercion = isNothing
-\end{code}
-
-%************************************************************************
-%*                                                                     *
 \subsection[Unify-exported]{Exported unification functions}
 %*                                                                     *
 %************************************************************************