[project @ 1996-06-05 06:44:31 by partain]

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

diff --git a/ghc/compiler/typecheck/Unify.lhs b/ghc/compiler/typecheck/Unify.lhs
index c8edce0..77742f4 100644 (file)
--- a/ghc/compiler/typecheck/Unify.lhs
+++ b/ghc/compiler/typecheck/Unify.lhs
@@ -11,18 +11,18 @@ updatable substitution).
 
 module Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy ) where
 
-import Ubiq
+IMP_Ubiq()
 
 -- friends: 
-import TcMonad
-import Type    ( GenType(..), getTypeKind, mkFunTy, getFunTy_maybe )
+import TcMonad hiding ( rnMtoTcM )
+import Type    ( GenType(..), typeKind, mkFunTy, getFunTy_maybe )
 import TyCon   ( TyCon, mkFunTyCon )
-import TyVar   ( GenTyVar(..), TyVar(..), getTyVarKind )
+import TyVar   ( GenTyVar(..), TyVar(..), tyVarKind )
 import TcType  ( TcType(..), TcMaybe(..), TcTauType(..), TcTyVar(..),
                  newTyVarTy, tcReadTyVar, tcWriteTyVar, zonkTcType
                )
 -- others:
-import Kind    ( Kind, isSubKindOf, mkTypeKind )
+import Kind    ( Kind, hasMoreBoxityInfo, mkTypeKind )
 import Usage   ( duffUsage )
 import PprType ( GenTyVar, GenType )   -- instances
 import Pretty
@@ -229,15 +229,24 @@ uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1)
     case (maybe_ty1, maybe_ty2) of
        (_, BoundTo ty2') -> uUnboundVar tv1 maybe_ty1 ty2' ty2'
 
-       (DontBind,DontBind) 
-                    -> failTc (unifyDontBindErr tv1 ps_ty2)
-
-       (UnBound, _) |  kind2 `isSubKindOf` kind1
+       (UnBound, _) |  kind2 `hasMoreBoxityInfo` kind1
                     -> tcWriteTyVar tv1 ty2            `thenNF_Tc_` returnTc ()
        
-       (_, UnBound) |  kind1 `isSubKindOf` kind2
+       (_, UnBound) |  kind1 `hasMoreBoxityInfo` kind2
                     -> tcWriteTyVar tv2 (TyVarTy tv1)  `thenNF_Tc_` returnTc ()
 
+-- TEMPORARY FIX
+--     (DontBind,DontBind) 
+--                  -> failTc (unifyDontBindErr tv1 ps_ty2)
+
+-- TEMPORARILY allow two type-sig variables to be bound together.
+-- See notes in tcCheckSigVars
+       (DontBind,DontBind) |  kind2 `hasMoreBoxityInfo` kind1
+                           -> tcWriteTyVar tv1 ty2             `thenNF_Tc_` returnTc ()
+       
+                           |  kind1 `hasMoreBoxityInfo` kind2
+                           -> tcWriteTyVar tv2 (TyVarTy tv1)   `thenNF_Tc_` returnTc ()
+
        other        -> failTc (unifyKindErr tv1 ps_ty2)
 
        -- Second one isn't a type variable
@@ -245,7 +254,7 @@ uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1) maybe_ty1 ps_ty2 non_var_ty2
   = case maybe_ty1 of
        DontBind -> failTc (unifyDontBindErr tv1 ps_ty2)
 
-       UnBound  |  getTypeKind non_var_ty2 `isSubKindOf` kind1
+       UnBound  |  typeKind non_var_ty2 `hasMoreBoxityInfo` kind1
                 -> occur_check non_var_ty2                     `thenTc_`
                    tcWriteTyVar tv1 ps_ty2                     `thenNF_Tc_`
                    returnTc ()
@@ -330,9 +339,9 @@ expectedFunErr ty sty
 
 unifyKindErr tyvar ty sty
   = ppHang (ppStr "Compiler bug: kind mis-match between")
-        4 (ppSep [ppr sty tyvar, ppLparen, ppr sty (getTyVarKind tyvar), ppRparen,
+        4 (ppSep [ppCat [ppr sty tyvar, ppStr "::", ppr sty (tyVarKind tyvar)],
                   ppStr "and", 
-                  ppr sty ty, ppLparen, ppr sty (getTypeKind ty), ppRparen])
+                  ppCat [ppr sty ty, ppStr "::", ppr sty (typeKind ty)]])
 
 unifyDontBindErr tyvar ty sty
   = ppHang (ppStr "Couldn't match the *signature/existential* type variable")