%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[TcSimplify]{TcSimplify}
#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 )
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.
\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@}
= 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@}
%* *
%************************************************************************
\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 ()
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
\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
\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}
= 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.)" ])
projects / ghc-hetmet.git / blobdiff