X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcSimplify.lhs;h=a1e987a1417697893ffb68ae8db9e27cd815c793;hb=26741ec416bae2c502ef00a2ba0e79050a32cb67;hp=bcb90dd97cf1443b565638b3cdf5cc78732dd34c;hpb=ca5a4a480d10d61e5b7a52eb4d556e8b8c33e69d;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index bcb90dd..a1e987a 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,43 +7,49 @@ #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, + Match, HsBinds, Qualifier, PolyType, ArithSeqInfo, GRHSsAndBinds, Stmt, Fake ) import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcExpr(..), TcMonoBinds(..) ) import TcMonad hiding ( rnMtoTcM ) -import Inst ( lookupInst, tyVarsOfInst, isTyVarDict, isDict, matchesInst, - instToId, instBindingRequired, instCanBeGeneralised, newDictsAtLoc, - Inst(..), LIE(..), zonkLIE, emptyLIE, plusLIE, unitLIE, consLIE, - InstOrigin(..), OverloadedLit ) +import Inst ( lookupInst, lookupSimpleInst, + tyVarsOfInst, isTyVarDict, isDict, + matchesInst, instToId, instBindingRequired, + instCanBeGeneralised, newDictsAtLoc, + pprInst, + Inst(..), LIE(..), zonkLIE, emptyLIE, + plusLIE, unitLIE, consLIE, InstOrigin(..), + OverloadedLit ) import TcEnv ( tcGetGlobalTyVars ) import TcType ( TcType(..), TcTyVar(..), TcTyVarSet(..), TcMaybe, tcInstType ) import Unify ( unifyTauTy ) import Bag ( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList, snocBag, consBag, unionBags, isEmptyBag ) -import Class ( isNumericClass, isStandardClass, isCcallishClass, - isSuperClassOf, classSuperDictSelId +import Class ( GenClass, SYN_IE(Class), SYN_IE(ClassInstEnv), + isNumericClass, isStandardClass, isCcallishClass, + isSuperClassOf, classSuperDictSelId, classInstEnv ) import Id ( GenId ) -import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool, Maybe(..) ) +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 Pretty import SrcLoc ( mkUnknownSrcLoc ) import Util -import Type ( GenType, Type(..), TauType(..), mkTyVarTy, getTyVar, eqSimpleTy ) +import Type ( GenType, SYN_IE(Type), SYN_IE(TauType), mkTyVarTy, getTyVar, eqSimpleTy, + getTyVar_maybe ) import TysWiredIn ( intTy ) -import TyVar ( GenTyVar, GenTyVarSet(..), +import TyVar ( GenTyVar, SYN_IE(GenTyVarSet), elementOfTyVarSet, emptyTyVarSet, unionTyVarSets, isEmptyTyVarSet, tyVarSetToList ) import Unique ( Unique ) @@ -156,26 +162,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. @@ -228,72 +214,10 @@ mechansim with the extra flag to say ``beat out constant insts''. \begin{code} tcSimplifyTop :: LIE s -> TcM s [(TcIdOcc s, TcExpr s)] tcSimplifyTop dicts - = tcGetGlobalTyVars `thenNF_Tc` \ global_tvs -> - tcSimpl True emptyTyVarSet emptyTyVarSet emptyBag dicts `thenTc` \ (_, binds, _) -> + = tcSimpl True emptyTyVarSet emptyTyVarSet emptyBag dicts `thenTc` \ (_, binds, _) -> returnTc binds \end{code} -@tcSimplifyThetas@ simplifies class-type constraints formed by -@deriving@ declarations and when specialising instances. We are -only interested in the simplified bunch of class/type constraints. - -\begin{code} -tcSimplifyThetas :: (Class -> TauType -> InstOrigin s) -- Creates an origin for the dummy dicts - -> [(Class, TauType)] -- Simplify this - -> TcM s [(Class, TauType)] -- Result - -tcSimplifyThetas = panic "tcSimplifyThetas" - -{- LATER -tcSimplifyThetas mk_inst_origin theta - = let - dicts = listToBag (map mk_dummy_dict theta) - in - -- Do the business (this is just the heart of "tcSimpl") - elimTyCons True (\tv -> False) emptyLIE dicts `thenTc` \ (_, _, dicts2) -> - - -- Deal with superclass relationships - elimSCs [] dicts2 `thenNF_Tc` \ (_, dicts3) -> - - returnTc (map unmk_dummy_dict (bagToList dicts3)) - where - mk_dummy_dict (clas, ty) = Dict uniq clas ty (mk_inst_origin clas ty) mkUnknownSrcLoc - uniq = panic "tcSimplifyThetas:uniq" - - unmk_dummy_dict (Dict _ clas ty _ _) = (clas, ty) --} -\end{code} - -@tcSimplifyCheckThetas@ just checks class-type constraints, essentially; -used with \tr{default} declarations. We are only interested in -whether it worked or not. - -\begin{code} -tcSimplifyCheckThetas :: InstOrigin s -- context; for error msg - -> [(Class, TauType)] -- Simplify this - -> TcM s () - -tcSimplifyCheckThetas x y = _trace "tcSimplifyCheckThetas: does nothing" $ - returnTc () - -{- LATER -tcSimplifyCheckThetas origin theta - = let - dicts = map mk_dummy_dict theta - in - -- Do the business (this is just the heart of "tcSimpl") - elimTyCons True (\tv -> False) emptyLIE dicts `thenTc` \ _ -> - - returnTc () - where - mk_dummy_dict (clas, ty) - = Dict uniq clas ty origin mkUnknownSrcLoc - - uniq = panic "tcSimplifyCheckThetas:uniq" --} -\end{code} - - %************************************************************************ %* * \subsection[elimTyCons]{@elimTyCons@} @@ -534,13 +458,93 @@ sortSC dicts = sortLt lt (bagToList dicts) = if ty1 `eqSimpleTy` ty2 then maybeToBool (c2 `isSuperClassOf` c1) else - -- order is immaterial, I think... + -- Order is immaterial, I think... False \end{code} %************************************************************************ %* * +\subsection[simple]{@Simple@ versions} +%* * +%************************************************************************ + +Much simpler versions when there are no bindings to make! + +@tcSimplifyThetas@ simplifies class-type constraints formed by +@deriving@ declarations and when specialising instances. We are +only interested in the simplified bunch of class/type constraints. + +\begin{code} +tcSimplifyThetas :: (Class -> ClassInstEnv) -- How to find the ClassInstEnv + -> [(Class, TauType)] -- Given + -> [(Class, TauType)] -- Wanted + -> TcM s [(Class, TauType)] + + +tcSimplifyThetas inst_mapper given wanted + = elimTyConsSimple inst_mapper wanted `thenTc` \ wanted1 -> + returnTc (elimSCsSimple given wanted1) +\end{code} + +@tcSimplifyCheckThetas@ just checks class-type constraints, essentially; +used with \tr{default} declarations. We are only interested in +whether it worked or not. + +\begin{code} +tcSimplifyCheckThetas :: [(Class, TauType)] -- Simplify this to nothing at all + -> TcM s () + +tcSimplifyCheckThetas theta + = elimTyConsSimple classInstEnv theta `thenTc` \ theta1 -> + ASSERT( null theta1 ) + returnTc () +\end{code} + + +\begin{code} +elimTyConsSimple :: (Class -> ClassInstEnv) + -> [(Class,Type)] + -> TcM s [(Class,Type)] +elimTyConsSimple inst_mapper theta + = elim theta + where + elim [] = returnTc [] + elim ((clas,ty):rest) = elim_one clas ty `thenTc` \ r1 -> + elim rest `thenTc` \ r2 -> + returnTc (r1++r2) + + elim_one clas ty + = case getTyVar_maybe ty of + + Just tv -> returnTc [(clas,ty)] + + otherwise -> recoverTc (returnTc []) $ + lookupSimpleInst (inst_mapper clas) clas ty `thenTc` \ theta -> + elim theta + +elimSCsSimple :: [(Class,Type)] -- Given + -> [(Class,Type)] -- Wanted + -> [(Class,Type)] -- Subset of wanted; no dups, no subclass relnships + +elimSCsSimple givens [] = [] +elimSCsSimple givens (c_t@(clas,ty) : rest) + | any (`subsumes` c_t) givens || + any (`subsumes` c_t) rest -- (clas,ty) is old hat + = elimSCsSimple givens rest + | otherwise -- (clas,ty) is new + = c_t : elimSCsSimple (c_t : givens) rest + where + rest' = elimSCsSimple rest + (c1,t1) `subsumes` (c2,t2) = t1 `eqSimpleTy` t2 && + (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} + +%************************************************************************ +%* * \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@} %* * %************************************************************************ @@ -650,8 +654,6 @@ 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 () @@ -676,7 +678,7 @@ disambigOne dict_infos try_default (default_ty : default_tys) = tryTc (try_default default_tys) $ -- If default_ty fails, we try -- default_tys instead - tcSimplifyCheckThetas DefaultDeclOrigin thetas `thenTc` \ _ -> + tcSimplifyCheckThetas thetas `thenTc` \ _ -> returnTc default_ty where thetas = classes `zip` repeat default_ty @@ -722,8 +724,7 @@ genCantGenErr insts sty -- Can't generalise these Insts \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 @@ -731,10 +732,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} @@ -742,7 +741,7 @@ 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)), + 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.)" ])