[project @ 2005-01-27 10:44:00 by simonpj]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcType.lhs
index 5dcac23..39035dd 100644 (file)
@@ -22,14 +22,14 @@ module TcType (
 
   --------------------------------
   -- MetaDetails
-  TcTyVarDetails(..),
+  Expected(..), TcRef, TcTyVarDetails(..),
   MetaDetails(Flexi, Indirect), SkolemInfo(..), pprSkolemTyVar,
   isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isExistentialTyVar, skolemTvInfo, metaTvRef,
   isFlexi, isIndirect,
 
   --------------------------------
   -- Builders
-  mkPhiTy, mkSigmaTy, 
+  mkPhiTy, mkSigmaTy, hoistForAllTys,
 
   --------------------------------
   -- Splitters  
@@ -43,7 +43,7 @@ module TcType (
   ---------------------------------
   -- Predicates. 
   -- Again, newtypes are opaque
-  tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred,
+  tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, tcEqTypeX,
   isSigmaTy, isOverloadedTy, 
   isDoubleTy, isFloatTy, isIntTy,
   isIntegerTy, isAddrTy, isBoolTy, isUnitTy,
@@ -60,7 +60,7 @@ module TcType (
   getClassPredTys_maybe, getClassPredTys, 
   isClassPred, isTyVarClassPred, 
   mkDictTy, tcSplitPredTy_maybe, 
-  isPredTy, isDictTy, tcSplitDFunTy, predTyUnique, 
+  isPredTy, isDictTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique, 
   mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName, 
 
   ---------------------------------
@@ -97,7 +97,7 @@ module TcType (
   mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst,
   getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
   extendTvSubst, extendTvSubstList, isInScope,
-  substTy, substTys, substTyWith, substTheta, substTyVar, 
+  substTy, substTys, substTyWith, substTheta, substTyVar, substTyVarBndr,
 
   isUnLiftedType,      -- Source types are always lifted
   isUnboxedTupleType,  -- Ditto
@@ -139,13 +139,17 @@ import Type               (       -- Re-exports
                          tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
                          tidyTyVarBndr, tidyOpenTyVar,
                          tidyOpenTyVars, 
-                         isSubKind, 
+                         isSubKind, deShadowTy,
+
+                         tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, 
+                         tcEqPred, tcCmpPred, tcEqTypeX, 
+
                          TvSubst(..),
                          TvSubstEnv, emptyTvSubst,
                          mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst,
                          getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
                          extendTvSubst, extendTvSubstList, isInScope,
-                         substTy, substTys, substTyWith, substTheta, substTyVar, 
+                         substTy, substTys, substTyWith, substTheta, substTyVar, substTyVarBndr,
 
                          typeKind, repType,
                          pprKind, pprParendKind,
@@ -157,7 +161,6 @@ import DataCon              ( DataCon )
 import Class           ( Class )
 import Var             ( TyVar, Id, isTcTyVar, tcTyVarDetails )
 import ForeignCall     ( Safety, playSafe, DNType(..) )
-import VarEnv
 import VarSet
 
 -- others:
@@ -169,7 +172,7 @@ import PrelNames    -- Lots (e.g. in isFFIArgumentTy)
 import TysWiredIn      ( unitTyCon, charTyCon, listTyCon )
 import BasicTypes      ( IPName(..), ipNameName )
 import SrcLoc          ( SrcLoc, SrcSpan )
-import Util            ( cmpList, thenCmp, snocView )
+import Util            ( snocView )
 import Maybes          ( maybeToBool, expectJust )
 import Outputable
 import DATA_IOREF
@@ -225,6 +228,10 @@ type TcRhoType      = TcType
 type TcTauType      = TcType
 type TcKind         = Kind
 type TcTyVarSet     = TyVarSet
+
+type TcRef a    = IORef a
+data Expected ty = Infer (TcRef ty)    -- The hole to fill in for type inference
+                | Check ty             -- The type to check during type checking
 \end{code}
 
 
@@ -482,9 +489,14 @@ tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty)
 tcSplitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
 -- Split the type of a dictionary function
 tcSplitDFunTy ty 
-  = case tcSplitSigmaTy ty       of { (tvs, theta, tau) ->
-    case tcSplitPredTy_maybe tau of { Just (ClassP clas tys) -> 
+  = case tcSplitSigmaTy ty   of { (tvs, theta, tau) ->
+    case tcSplitDFunHead tau of { (clas, tys) -> 
     (tvs, theta, clas, tys) }}
+
+tcSplitDFunHead :: Type -> (Class, [Type])
+tcSplitDFunHead tau  
+  = case tcSplitPredTy_maybe tau of 
+       Just (ClassP clas tys) -> (clas, tys)
 \end{code}
 
 
@@ -567,95 +579,6 @@ isLinearPred other            = False
 
 %************************************************************************
 %*                                                                     *
-\subsection{Comparison}
-%*                                                                     *
-%************************************************************************
-
-Comparison, taking note of newtypes, predicates, etc,
-
-\begin{code}
-tcEqType :: Type -> Type -> Bool
-tcEqType ty1 ty2 = case ty1 `tcCmpType` ty2 of { EQ -> True; other -> False }
-
-tcEqTypes :: [Type] -> [Type] -> Bool
-tcEqTypes ty1 ty2 = case ty1 `tcCmpTypes` ty2 of { EQ -> True; other -> False }
-
-tcEqPred :: PredType -> PredType -> Bool
-tcEqPred p1 p2 = case p1 `tcCmpPred` p2 of { EQ -> True; other -> False }
-
--------------
-tcCmpType :: Type -> Type -> Ordering
-tcCmpType ty1 ty2 = cmpTy emptyVarEnv ty1 ty2
-
-tcCmpTypes tys1 tys2 = cmpTys emptyVarEnv tys1 tys2
-
-tcCmpPred p1 p2 = cmpPredTy emptyVarEnv p1 p2
--------------
-cmpTys env tys1 tys2 = cmpList (cmpTy env) tys1 tys2
-
--------------
-cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering
-  -- The "env" maps type variables in ty1 to type variables in ty2
-  -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
-  -- we in effect substitute tv2 for tv1 in t1 before continuing
-
-    -- Look through NoteTy
-cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2
-cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2
-
-    -- Deal with equal constructors
-cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
-                                         Just tv1a -> tv1a `compare` tv2
-                                         Nothing   -> tv1  `compare` tv2
-
-cmpTy env (PredTy p1) (PredTy p2) = cmpPredTy env p1 p2
-cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
-cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
-cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
-cmpTy env (ForAllTy tv1 t1)   (ForAllTy tv2 t2)   = cmpTy (extendVarEnv env tv1 tv2) t1 t2
-    
-    -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < PredTy
-cmpTy env (AppTy _ _) (TyVarTy _) = GT
-    
-cmpTy env (FunTy _ _) (TyVarTy _) = GT
-cmpTy env (FunTy _ _) (AppTy _ _) = GT
-    
-cmpTy env (TyConApp _ _) (TyVarTy _) = GT
-cmpTy env (TyConApp _ _) (AppTy _ _) = GT
-cmpTy env (TyConApp _ _) (FunTy _ _) = GT
-    
-cmpTy env (ForAllTy _ _) (TyVarTy _)    = GT
-cmpTy env (ForAllTy _ _) (AppTy _ _)    = GT
-cmpTy env (ForAllTy _ _) (FunTy _ _)    = GT
-cmpTy env (ForAllTy _ _) (TyConApp _ _) = GT
-
-cmpTy env (PredTy _)   t2              = GT
-
-cmpTy env _ _ = LT
-\end{code}
-
-\begin{code}
-cmpPredTy :: TyVarEnv TyVar -> PredType -> PredType -> Ordering
-cmpPredTy env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` (cmpTy env ty1 ty2)
-       -- Compare types as well as names for implicit parameters
-       -- This comparison is used exclusively (I think) for the
-       -- finite map built in TcSimplify
-cmpPredTy env (IParam _ _)     (ClassP _ _)      = LT
-cmpPredTy env (ClassP _ _)     (IParam _ _)     = GT
-cmpPredTy env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2)
-\end{code}
-
-PredTypes are used as a FM key in TcSimplify, 
-so we take the easy path and make them an instance of Ord
-
-\begin{code}
-instance Eq  PredType where { (==)    = tcEqPred }
-instance Ord PredType where { compare = tcCmpPred }
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
 \subsection{Predicates}
 %*                                                                     *
 %************************************************************************
@@ -701,6 +624,79 @@ is_tc uniq ty = case tcSplitTyConApp_maybe ty of
 \end{code}
 
 
+
+
+%************************************************************************
+%*                                                                     *
+               Hoisting for-alls
+%*                                                                     *
+%************************************************************************
+
+hoistForAllTys is used for user-written type signatures only
+We want to 'look through' type synonyms when doing this
+so it's better done on the Type than the HsType
+
+It moves all the foralls and constraints to the top
+e.g.   T -> forall a. a        ==>   forall a. T -> a
+       T -> (?x::Int) -> Int   ==>   (?x::Int) -> T -> Int
+
+Also: it eliminates duplicate constraints.  These can show up
+when hoisting constraints, notably implicit parameters.
+
+It tries hard to retain type synonyms if hoisting does not break one
+up.  Not only does this improve error messages, but there's a tricky
+interaction with Haskell 98.  H98 requires no unsaturated type
+synonyms, which is checked by checkValidType.  This runs after
+hoisting, so we don't want hoisting to remove the SynNotes!  (We can't
+run validity checking before hoisting because in mutually-recursive
+type definitions we postpone validity checking until after the knot is
+tied.)
+
+\begin{code}
+hoistForAllTys :: Type -> Type
+hoistForAllTys ty
+  = go (deShadowTy ty)
+       -- Running over ty with an empty substitution gives it the
+       -- no-shadowing property.  This is important.  For example:
+       --      type Foo r = forall a. a -> r
+       --      foo :: Foo (Foo ())
+       -- Here the hoisting should give
+       --      foo :: forall a a1. a -> a1 -> ()
+       --
+       -- What about type vars that are lexically in scope in the envt?
+       -- We simply rely on them having a different unique to any
+       -- binder in 'ty'.  Otherwise we'd have to slurp the in-scope-tyvars
+       -- out of the envt, which is boring and (I think) not necessary.
+
+  where
+    go (TyVarTy tv)               = TyVarTy tv
+    go (TyConApp tc tys)          = TyConApp tc (map go tys)
+    go (PredTy pred)              = PredTy pred    -- No nested foralls 
+    go (NoteTy (SynNote ty1) ty2)  = NoteTy (SynNote (go ty1)) (go ty2)
+    go (NoteTy (FTVNote _) ty2)    = go ty2        -- Discard the free tyvar note
+    go (FunTy arg res)            = mk_fun_ty (go arg) (go res)
+    go (AppTy fun arg)            = AppTy (go fun) (go arg)
+    go (ForAllTy tv ty)                   = ForAllTy tv (go ty)
+
+       -- mk_fun_ty does all the work.  
+       -- It's building t1 -> t2: 
+       --      if t2 is a for-all type, push t1 inside it
+       --      if t2 is (pred -> t3), check for duplicates
+    mk_fun_ty ty1 ty2
+       | not (isOverloadedTy ty2)      -- No forall's, or context => 
+       = FunTy ty1 ty2         
+       | PredTy p1 <- ty1              -- ty1 is a predicate
+       = if p1 `elem` theta then       -- so check for duplicates
+               ty2
+         else
+               mkSigmaTy tvs (p1:theta) tau
+       | otherwise     
+       = mkSigmaTy tvs theta (FunTy ty1 tau)
+       where
+         (tvs, theta, tau) = tcSplitSigmaTy ty2
+\end{code}
+
+
 %************************************************************************
 %*                                                                     *
 \subsection{Misc}