X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcSimplify.lhs;h=2aa4ef5afa4ca095404bb696d3e4b60d855d977c;hb=1fb1ab5d53a09607e7f6d2450806760688396387;hp=fcde43dc7fbb00f679d0938f74c80c25162fdfc4;hpb=5cf27e8f1731c52fe63a5b9615f927484164c61b;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index fcde43d..2aa4ef5 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[TcSimplify]{TcSimplify} @@ -7,49 +7,54 @@ #include "HsVersions.h" module TcSimplify ( - tcSimplify, tcSimplifyAndCheck, tcSimplifyWithExtraGlobals, + tcSimplify, tcSimplifyAndCheck, tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas, tcSimplifyRank2, bindInstsOfLocalFuns ) where -import Ubiq +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, - Inst(..), LIE(..), zonkLIE, emptyLIE, plusLIE, unitLIE, consLIE, - InstOrigin(..), OverloadedLit ) + tyVarsOfInst, isTyVarDict, isDict, + matchesInst, instToId, instBindingRequired, + instCanBeGeneralised, newDictsAtLoc, + pprInst, + 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} @@ -159,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. @@ -378,7 +363,7 @@ elimTyCons squash_consts is_free_tv givens wanteds %************************************************************************ %* * \subsection[elimSCs]{@elimSCs@} -%* 2 * +%* * %************************************************************************ \begin{code} @@ -416,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" @@ -472,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} @@ -554,7 +537,10 @@ elimSCsSimple givens (c_t@(clas,ty) : rest) where rest' = elimSCsSimple rest (c1,t1) `subsumes` (c2,t2) = t1 `eqSimpleTy` t2 && - maybeToBool (c2 `isSuperClassOf` c1) + (c1 == c2 || maybeToBool (c2 `isSuperClassOf` c1)) +-- We deal with duplicates here ^^^^^^^^ +-- It's a simple place to do it, although it's done in elimTyCons in the +-- full-blown version of the simpifier. \end{code} %************************************************************************ @@ -668,17 +654,12 @@ the most common use of defaulting is code like: \end{verbatim} Since we're not using the result of @foo@, the result if (presumably) @void@. -WDP Comment: no such thing as voidTy; so not quite in yet (94/07). -SLPJ comment: since \begin{code} 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 @@ -689,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 @@ -702,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 @@ -711,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 @@ -734,14 +710,13 @@ 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} \begin{code} ambigErr insts sty - = ppHang (ppStr "Ambiguous overloading") - 4 (ppAboves (map (ppr sty) insts)) + = ppAboves (map (pprInst sty "Ambiguous overloading") insts) \end{code} @reduceErr@ complains if we can't express required dictionaries in @@ -749,20 +724,8 @@ terms of the signature. \begin{code} reduceErr insts sty - = ppHang (ppStr "Type signature lacks context required by inferred type") - 4 (ppHang (ppStr "Context reqd: ") - 4 (ppAboves (map (ppr sty) (bagToList insts))) - ) + = ppAboves (map (pprInst sty "Context required by inferred type, but missing on a type signature") + (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 (ppr sty) dicts)), - ppHang (ppStr "Defaulting types :") - 4 (ppr sty defaulting_tys), - ppStr "([Int, Double] is the default list of defaulting types.)" ]) -\end{code}