X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcUnify.lhs;h=1a05fd509a522adcbc52c65509e1e9890a23f762;hb=c86e9006fbdc9cb229080dd6a64ce462e9e460af;hp=fd2255758e58c82c0b42f96fd8561803b4431951;hpb=9f24a6953e29dbee1b299099553fc4dd34029a39;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index fd22557..1a05fd5 100644 --- 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} %* * %************************************************************************