X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcSimplify.lhs;h=2aa4ef5afa4ca095404bb696d3e4b60d855d977c;hb=57b42110b792d50ae1452a31c4d74aa20736ec41;hp=21f45479df6e36db588cbc8f16074ab3f8c13ee3;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 21f4547..2aa4ef5 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -7,7 +7,7 @@ #include "HsVersions.h" module TcSimplify ( - tcSimplify, tcSimplifyAndCheck, tcSimplifyWithExtraGlobals, + tcSimplify, tcSimplifyAndCheck, tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas, tcSimplifyRank2, bindInstsOfLocalFuns ) where @@ -15,44 +15,46 @@ module TcSimplify ( IMP_Ubiq() import HsSyn ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit, - Match, HsBinds, Qual, PolyType, ArithSeqInfo, - GRHSsAndBinds, Stmt, Fake ) -import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcExpr(..), TcMonoBinds(..) ) + Match, HsBinds, HsType, ArithSeqInfo, Fixity, + GRHSsAndBinds, Stmt, DoOrListComp, Fake ) +import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr), SYN_IE(TcMonoBinds) ) -import TcMonad hiding ( rnMtoTcM ) +import TcMonad import Inst ( lookupInst, lookupSimpleInst, tyVarsOfInst, isTyVarDict, isDict, matchesInst, instToId, instBindingRequired, instCanBeGeneralised, newDictsAtLoc, pprInst, - Inst(..), LIE(..), zonkLIE, emptyLIE, + Inst(..), SYN_IE(LIE), zonkLIE, emptyLIE, plusLIE, unitLIE, consLIE, InstOrigin(..), OverloadedLit ) import TcEnv ( tcGetGlobalTyVars ) -import TcType ( TcType(..), TcTyVar(..), TcTyVarSet(..), TcMaybe, tcInstType ) +import SpecEnv ( SpecEnv ) +import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), TcMaybe, tcInstType ) import Unify ( unifyTauTy ) import Bag ( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList, snocBag, consBag, unionBags, isEmptyBag ) -import Class ( GenClass, Class(..), ClassInstEnv(..), - isNumericClass, isStandardClass, isCcallishClass, +import Class ( GenClass, SYN_IE(Class), SYN_IE(ClassInstEnv), isSuperClassOf, classSuperDictSelId, classInstEnv ) import Id ( GenId ) -import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool, Maybe(..) ) +import PrelInfo ( isNumericClass, isStandardClass, isCcallishClass ) + +import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool ) import Outputable ( Outputable(..){-instance * []-} ) -import PprStyle--ToDo:rm -import PprType ( GenType, GenTyVar, GenClass{-instance Outputable;ToDo:rm-} ) +--import PprStyle--ToDo:rm +import PprType ( GenType, GenTyVar ) import Pretty -import SrcLoc ( mkUnknownSrcLoc ) -import Util -import Type ( GenType, Type(..), TauType(..), mkTyVarTy, getTyVar, eqSimpleTy, +import SrcLoc ( noSrcLoc ) +import Type ( GenType, SYN_IE(Type), SYN_IE(TauType), mkTyVarTy, getTyVar, eqSimpleTy, getTyVar_maybe ) -import TysWiredIn ( intTy ) -import TyVar ( GenTyVar, GenTyVarSet(..), +import TysWiredIn ( intTy, unitTy ) +import TyVar ( GenTyVar, SYN_IE(GenTyVarSet), elementOfTyVarSet, emptyTyVarSet, unionTyVarSets, isEmptyTyVarSet, tyVarSetToList ) import Unique ( Unique ) +import Util \end{code} @@ -162,26 +164,6 @@ tcSimplify local_tvs wanteds tcSimpl False global_tvs local_tvs emptyBag wanteds \end{code} -@tcSimplifyWithExtraGlobals@ is just like @tcSimplify@ except that you get -to specify some extra global type variables that the simplifer will treat -as free in the environment. - -\begin{code} -tcSimplifyWithExtraGlobals - :: TcTyVarSet s -- Extra ``Global'' type variables - -> TcTyVarSet s -- ``Local'' type variables - -> LIE s -- Wanted - -> TcM s (LIE s, -- Free - [(TcIdOcc s,TcExpr s)], -- Bindings - LIE s) -- Remaining wanteds; no dups - -tcSimplifyWithExtraGlobals extra_global_tvs local_tvs wanteds - = tcGetGlobalTyVars `thenNF_Tc` \ global_tvs -> - tcSimpl False - (global_tvs `unionTyVarSets` extra_global_tvs) - local_tvs emptyBag wanteds -\end{code} - @tcSimplifyAndCheck@ is similar to the above, except that it checks that there is an empty wanted-set at the end. It may still return some of constant insts, which have to be resolved finally at the end. @@ -419,7 +401,7 @@ trySC :: LIE s -- Givens trySC givens wanted@(Dict _ wanted_class wanted_ty wanted_orig loc) | not (maybeToBool maybe_best_subclass_chain) = -- No superclass relationship - returnNF_Tc (givens, emptyBag, unitLIE wanted) + returnNF_Tc ((wanted `consLIE` givens), emptyBag, unitLIE wanted) | otherwise = -- There's a subclass relationship with a "given" @@ -475,11 +457,9 @@ sortSC :: LIE s -- Expected to be all dicts (no MethodIds), all of sortSC dicts = sortLt lt (bagToList dicts) where (Dict _ c1 ty1 _ _) `lt` (Dict _ c2 ty2 _ _) - = if ty1 `eqSimpleTy` ty2 then - maybeToBool (c2 `isSuperClassOf` c1) - else - -- Order is immaterial, I think... - False + = maybeToBool (c2 `isSuperClassOf` c1) + -- The ice is a bit thin here because this "lt" isn't a total order + -- But it *is* transitive, so it works ok \end{code} @@ -679,10 +659,7 @@ Since we're not using the result of @foo@, the result if (presumably) disambigOne :: [SimpleDictInfo s] -> TcM s () disambigOne dict_infos - | not (isStandardNumericDefaultable classes) - = failTc (ambigErr dicts) -- no default - - | otherwise -- isStandardNumericDefaultable dict_infos + | any isNumericClass classes && all isStandardClass classes = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT -- SO, TRY DEFAULT TYPES IN ORDER @@ -693,7 +670,7 @@ disambigOne dict_infos tcGetDefaultTys `thenNF_Tc` \ default_tys -> let try_default [] -- No defaults work, so fail - = failTc (defaultErr dicts default_tys) + = failTc (ambigErr dicts) try_default (default_ty : default_tys) = tryTc (try_default default_tys) $ -- If default_ty fails, we try @@ -706,7 +683,15 @@ disambigOne dict_infos -- See if any default works, and if so bind the type variable to it try_default default_tys `thenTc` \ chosen_default_ty -> tcInstType [] chosen_default_ty `thenNF_Tc` \ chosen_default_tc_ty -> -- Tiresome! - unifyTauTy (mkTyVarTy tyvar) chosen_default_tc_ty + unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar) + + | all isCcallishClass classes + = -- Default CCall stuff to (); we don't even both to check that () is an + -- instance of CCallable/CReturnable, because we know it is. + unifyTauTy (mkTyVarTy tyvar) unitTy + + | otherwise -- No defaults + = failTc (ambigErr dicts) where (_,_,tyvar) = head dict_infos -- Should be non-empty @@ -715,19 +700,6 @@ disambigOne dict_infos \end{code} -@isStandardNumericDefaultable@ sees whether the dicts have the -property required for defaulting; namely at least one is numeric, and -all are standard; or all are CcallIsh. - -\begin{code} -isStandardNumericDefaultable :: [Class] -> Bool - -isStandardNumericDefaultable classes - = --pprTrace "isStdNumeric:\n" (ppAboves [ppCat (map (ppr PprDebug) classes), ppCat (map (ppr PprDebug . isNumericClass) classes), ppCat (map (ppr PprDebug . isStandardClass) classes), ppCat (map (ppr PprDebug . isCcallishClass) classes)]) $ - (any isNumericClass classes && all isStandardClass classes) - || (all isCcallishClass classes) -\end{code} - Errors and contexts @@ -738,7 +710,7 @@ now? \begin{code} genCantGenErr insts sty -- Can't generalise these Insts - = ppHang (ppStr "Cannot generalise these overloadings (in a _ccall_):") + = ppHang (ppPStr SLIT("Cannot generalise these overloadings (in a _ccall_):")) 4 (ppAboves (map (ppr sty) (bagToList insts))) \end{code} @@ -756,14 +728,4 @@ reduceErr insts sty (bagToList insts)) \end{code} -\begin{code} -defaultErr dicts defaulting_tys sty - = ppHang (ppStr "Ambiguously-overloaded types could not be resolved:") - 4 (ppAboves [ - ppHang (ppStr "Conflicting:") - 4 (ppInterleave ppSemi (map (pprInst sty ""{-???-}) dicts)), - ppHang (ppStr "Defaulting types :") - 4 (ppr sty defaulting_tys), - ppStr "([Int, Double] is the default list of defaulting types.)" ]) -\end{code}