%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcSimplify]{TcSimplify}
\begin{code}
module TcSimplify (
- tcSimplify, tcSimplifyAndCheck,
+ tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts,
tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas,
- bindInstsOfLocalFuns
+ bindInstsOfLocalFuns, partitionPredsOfLIE
) where
#include "HsVersions.h"
-import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds )
-import TcHsSyn ( TcExpr, TcIdOcc(..), TcIdBndr,
+import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
+import TcHsSyn ( TcExpr, TcId,
TcMonoBinds, TcDictBinds
)
import TcMonad
import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
tyVarsOfInst,
- isDict, isStdClassTyVarDict, isMethodFor,
+ isDict, isClassDict, isMethod, notFunDep,
+ isStdClassTyVarDict, isMethodFor,
instToId, instBindingRequired, instCanBeGeneralised,
- newDictFromOld,
- instLoc, getDictClassTys,
- pprInst, zonkInst,
- Inst(..), LIE, pprInsts, pprInstsInFull, mkLIE,
- InstOrigin, pprOrigin
+ newDictFromOld, newFunDepFromDict,
+ getDictClassTys, getIPs, isTyVarDict,
+ getDictPred_maybe, getMethodTheta_maybe,
+ instLoc, pprInst, zonkInst, tidyInst, tidyInsts,
+ Inst, LIE, pprInsts, pprInstsInFull,
+ mkLIE, emptyLIE, unitLIE, consLIE, plusLIE,
+ lieToList
)
-import TcEnv ( TcIdOcc(..) )
-import TcType ( TcType, TcTyVarSet, TcMaybe, tcInstType, tcInstTheta )
-import Unify ( unifyTauTy )
-import Id ( mkIdSet )
-
-import Bag ( Bag, bagToList, snocBag )
-import Class ( Class, ClassInstEnv, classBigSig, classInstEnv )
-import PrelInfo ( isNumericClass, isCreturnableClass )
-
-import Maybes ( maybeToBool )
-import Type ( Type, ThetaType, TauType, mkTyVarTy, getTyVar,
- isTyVarTy, instantiateThetaTy
+import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv )
+import InstEnv ( lookupInstEnv, InstLookupResult(..) )
+
+import TcType ( TcTyVarSet )
+import TcUnify ( unifyTauTy )
+import Id ( idType )
+import Class ( Class, classBigSig )
+import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass )
+
+import Type ( Type, ClassContext,
+ mkTyVarTy, getTyVar,
+ isTyVarTy, splitSigmaTy, tyVarsOfTypes
)
+import Subst ( mkTopTyVarSubst, substClasses )
import PprType ( pprConstraint )
import TysWiredIn ( unitTy )
-import TyVar ( intersectTyVarSets, unionManyTyVarSets,
- isEmptyTyVarSet, zipTyVarEnv, emptyTyVarEnv
- )
+import VarSet
import FiniteMap
-import BasicTypes ( TopLevelFlag(..) )
-import Unique ( Unique )
import Outputable
-import Util
+import ListSetOps ( equivClasses )
+import Util ( zipEqual, mapAccumL )
import List ( partition )
+import Maybe ( fromJust )
+import Maybes ( maybeToBool )
+import CmdLineOpts
\end{code}
\begin{code}
tcSimplify
:: SDoc
- -> TopLevelFlag
- -> TcTyVarSet s -- ``Local'' type variables
+ -> TcTyVarSet -- ``Local'' type variables
-- ASSERT: this tyvar set is already zonked
- -> LIE s -- Wanted
- -> TcM s (LIE s, -- Free
- TcDictBinds s, -- Bindings
- LIE s) -- Remaining wanteds; no dups
+ -> LIE -- Wanted
+ -> TcM (LIE, -- Free
+ TcDictBinds, -- Bindings
+ LIE) -- Remaining wanteds; no dups
+
+tcSimplify str local_tvs wanted_lie
+{- this is just an optimization, and interferes with implicit params,
+ disable it for now. same goes for tcSimplifyAndCheck
+ | isEmptyVarSet local_tvs
+ = returnTc (wanted_lie, EmptyMonoBinds, emptyLIE)
-tcSimplify str top_lvl local_tvs wanted_lie
+ | otherwise
+-}
= reduceContext str try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
-- Check for non-generalisable insts
checkTc (null cant_generalise)
(genCantGenErr cant_generalise) `thenTc_`
- -- Finished
- returnTc (mkLIE frees, binds, mkLIE irreds)
+ -- Check for ambiguous insts.
+ -- You might think these can't happen (I did) because an ambiguous
+ -- inst like (Eq a) will get tossed out with "frees", and eventually
+ -- dealt with by tcSimplifyTop.
+ -- But we can get stuck with
+ -- C a b
+ -- where "a" is one of the local_tvs, but "b" is unconstrained.
+ -- Then we must yell about the ambiguous b
+ -- But we must only do so if "b" really is unconstrained; so
+ -- we must grab the global tyvars to answer that question
+ tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
+ let
+ avail_tvs = local_tvs `unionVarSet` global_tvs
+ (irreds', bad_guys) = partition (isEmptyVarSet . ambig_tv_fn) irreds
+ ambig_tv_fn dict = tyVarsOfInst dict `minusVarSet` avail_tvs
+ in
+ addAmbigErrs ambig_tv_fn bad_guys `thenNF_Tc_`
+
+
+ -- Finished
+ returnTc (mkLIE frees, binds, mkLIE irreds')
where
- wanteds = bagToList wanted_lie
+ wanteds = lieToList wanted_lie
try_me inst
-- Does not constrain a local tyvar
- | isEmptyTyVarSet (tyVarsOfInst inst `intersectTyVarSets` local_tvs)
+ | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
+ && null (getIPs inst)
= -- if is_top_level then
-- FreeIfTautological -- Special case for inference on
-- -- top-level defns
-- We're infering (not checking) the type, and
-- the inst constrains a local type variable
- | isDict inst = DontReduce -- Dicts
- | otherwise = ReduceMe AddToIrreds -- Lits and Methods
+ | isClassDict inst = DontReduceUnlessConstant -- Dicts
+ | otherwise = ReduceMe AddToIrreds -- Lits and Methods
\end{code}
@tcSimplifyAndCheck@ is similar to the above, except that it checks
\begin{code}
tcSimplifyAndCheck
:: SDoc
- -> TcTyVarSet s -- ``Local'' type variables
- -- ASSERT: this tyvar set is already zonked
- -> LIE s -- Given; constrain only local tyvars
- -> LIE s -- Wanted
- -> TcM s (LIE s, -- Free
- TcDictBinds s) -- Bindings
+ -> TcTyVarSet -- ``Local'' type variables
+ -- ASSERT: this tyvar set is already zonked
+ -> LIE -- Given; constrain only local tyvars
+ -> LIE -- Wanted
+ -> TcM (LIE, -- Free
+ TcDictBinds) -- Bindings
tcSimplifyAndCheck str local_tvs given_lie wanted_lie
+{-
+ | isEmptyVarSet local_tvs
+ -- This can happen quite legitimately; for example in
+ -- instance Num Int where ...
+ = returnTc (wanted_lie, EmptyMonoBinds)
+
+ | otherwise
+-}
= reduceContext str try_me givens wanteds `thenTc` \ (binds, frees, irreds) ->
-- Complain about any irreducible ones
-- Done
returnTc (mkLIE frees, binds)
where
- givens = bagToList given_lie
- wanteds = bagToList wanted_lie
+ givens = lieToList given_lie
+ wanteds = lieToList wanted_lie
+ given_dicts = filter isClassDict givens
try_me inst
-- Does not constrain a local tyvar
- | isEmptyTyVarSet (tyVarsOfInst inst `intersectTyVarSets` local_tvs)
+ | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
+ && (not (isMethod inst) || null (getIPs inst))
= Free
-- When checking against a given signature we always reduce
= ReduceMe AddToIrreds
complain dict = mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
- addNoInstanceErr str givens dict
+ addNoInstanceErr str given_dicts dict
+\end{code}
+
+On the LHS of transformation rules we only simplify methods and constants,
+getting dictionaries. We want to keep all of them unsimplified, to serve
+as the available stuff for the RHS of the rule.
+
+The same thing is used for specialise pragmas. Consider
+
+ f :: Num a => a -> a
+ {-# SPECIALISE f :: Int -> Int #-}
+ f = ...
+
+The type checker generates a binding like:
+
+ f_spec = (f :: Int -> Int)
+
+and we want to end up with
+
+ f_spec = _inline_me_ (f Int dNumInt)
+
+But that means that we must simplify the Method for f to (f Int dNumInt)!
+So tcSimplifyToDicts squeezes out all Methods.
+
+\begin{code}
+tcSimplifyToDicts :: LIE -> TcM (LIE, TcDictBinds)
+tcSimplifyToDicts wanted_lie
+ = reduceContext (text "tcSimplifyToDicts") try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
+ ASSERT( null frees )
+ returnTc (mkLIE irreds, binds)
+ where
+ wanteds = lieToList wanted_lie
+
+ -- Reduce methods and lits only; stop as soon as we get a dictionary
+ try_me inst | isDict inst = DontReduce
+ | otherwise = ReduceMe AddToIrreds
+\end{code}
+
+The following function partitions a LIE by a predicate defined
+over `Pred'icates (an unfortunate overloading of terminology!).
+This means it sometimes has to split up `Methods', in which case
+a binding is generated.
+
+It is used in `with' bindings to extract from the LIE the implicit
+parameters being bound.
+
+\begin{code}
+partitionPredsOfLIE pred lie
+ = foldlTc (partPreds pred) (emptyLIE, emptyLIE, EmptyMonoBinds) insts
+ where insts = lieToList lie
+
+-- warning: the term `pred' is overloaded here!
+partPreds pred (lie1, lie2, binds) inst
+ | maybeToBool maybe_pred
+ = if pred p then
+ returnTc (consLIE inst lie1, lie2, binds)
+ else
+ returnTc (lie1, consLIE inst lie2, binds)
+ where maybe_pred = getDictPred_maybe inst
+ Just p = maybe_pred
+
+-- the assumption is that those satisfying `pred' are being extracted,
+-- so we leave the method untouched when nothing satisfies `pred'
+partPreds pred (lie1, lie2, binds1) inst
+ | maybeToBool maybe_theta
+ = if any pred theta then
+ zonkInst inst `thenTc` \ inst' ->
+ tcSimplifyToDicts (unitLIE inst') `thenTc` \ (lie3, binds2) ->
+ partitionPredsOfLIE pred lie3 `thenTc` \ (lie1', lie2', EmptyMonoBinds) ->
+ returnTc (lie1 `plusLIE` lie1',
+ lie2 `plusLIE` lie2',
+ binds1 `AndMonoBinds` binds2)
+ else
+ returnTc (lie1, consLIE inst lie2, binds1)
+ where maybe_theta = getMethodTheta_maybe inst
+ Just theta = maybe_theta
+
+partPreds pred (lie1, lie2, binds) inst
+ = returnTc (lie1, consLIE inst lie2, binds)
\end{code}
= ReduceMe -- Try to reduce this
NoInstanceAction -- What to do if there's no such instance
- | DontReduce -- Return as irreducible
+ | DontReduce -- Return as irreducible
+
+ | DontReduceUnlessConstant -- Return as irreducible unless it can
+ -- be reduced to a constant in one step
| Free -- Return as free
| FreeIfTautological -- Return as free iff it's tautological;
-- if not, return as irreducible
+ -- The FreeIfTautological case is to allow the possibility
+ -- of generating functions with types like
+ -- f :: C Int => Int -> Int
+ -- Here, the C Int isn't a tautology presumably because Int
+ -- isn't an instance of C in this module; but perhaps it will
+ -- be at f's call site(s). Haskell doesn't allow this at
+ -- present.
data NoInstanceAction
= Stop -- Fail; no error message
\begin{code}
type RedState s
= (Avails s, -- What's available
- [Inst s], -- Insts for which try_me returned Free
- [Inst s] -- Insts for which try_me returned DontReduce
+ [Inst], -- Insts for which try_me returned Free
+ [Inst] -- Insts for which try_me returned DontReduce
)
-type Avails s = FiniteMap (Inst s) (Avail s)
+type Avails s = FiniteMap Inst Avail
-data Avail s
+data Avail
= Avail
- (TcIdOcc s) -- The "main Id"; that is, the Id for the Inst that
+ TcId -- The "main Id"; that is, the Id for the Inst that
-- caused this avail to be put into the finite map in the first place
-- It is this Id that is bound to the RHS.
- (RHS s) -- The RHS: an expression whose value is that Inst.
+ RHS -- The RHS: an expression whose value is that Inst.
-- The main Id should be bound to this RHS
- [TcIdOcc s] -- Extra Ids that must all be bound to the main Id.
+ [TcId] -- Extra Ids that must all be bound to the main Id.
-- At the end we generate a list of bindings
-- { i1 = main_id; i2 = main_id; i3 = main_id; ... }
-data RHS s
+data RHS
= NoRhs -- Used for irreducible dictionaries,
-- which are going to be lambda bound, or for those that are
-- suppplied as "given" when checking againgst a signature.
-- where no witness is required.
| Rhs -- Used when there is a RHS
- (TcExpr s)
+ TcExpr
Bool -- True => the RHS simply selects a superclass dictionary
-- from a subclass dictionary.
-- False => not so.
-- an (Ord t) dictionary; then we put an (Eq t) entry in
-- the finite map, with an PassiveScSel. Then if the
-- the (Eq t) binding is ever *needed* we make it an Rhs
- (TcExpr s)
- [Inst s] -- List of Insts that are free in the RHS.
+ TcExpr
+ [Inst] -- List of Insts that are free in the RHS.
-- If the main Id is subsequently needed, we toss this list into
-- the needed-inst pool so that we make sure their bindings
-- will actually be produced.
-- Invariant: these Insts are already in the finite mapping
-pprAvails avails = vcat (map pp (eltsFM avails))
- where
- pp (Avail main_id rhs ids)
- = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs
+pprAvails avails = vcat (map pprAvail (eltsFM avails))
+
+pprAvail (Avail main_id rhs ids)
+ = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs
+
+instance Outputable Avail where
+ ppr = pprAvail
pprRhs NoRhs = text "<no rhs>"
pprRhs (Rhs rhs b) = ppr rhs
The main entry point for context reduction is @reduceContext@:
\begin{code}
-reduceContext :: SDoc -> (Inst s -> WhatToDo)
- -> [Inst s] -- Given
- -> [Inst s] -- Wanted
- -> TcM s (TcDictBinds s,
- [Inst s], -- Free
- [Inst s]) -- Irreducible
+reduceContext :: SDoc -> (Inst -> WhatToDo)
+ -> [Inst] -- Given
+ -> [Inst] -- Wanted
+ -> TcM (TcDictBinds,
+ [Inst], -- Free
+ [Inst]) -- Irreducible
reduceContext str try_me givens wanteds
= -- Zonking first
mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds ->
+ -- JRL - process fundeps last. We eliminate fundeps by seeing
+ -- what available classes generate them, so we need to process the
+ -- classes first. (would it be useful to make LIEs ordered in the first place?)
+ let (wantedOther, wantedFds) = partition notFunDep wanteds
+ wanteds' = wantedOther ++ wantedFds in
{-
pprTrace "reduceContext" (vcat [
text "----------------------"
]) $
-}
-
-- Build the Avail mapping from "givens"
- foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails ->
+ foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails ->
-- Do the real work
- reduce try_me wanteds (avails, [], []) `thenTc` \ (avails, frees, irreds) ->
+ reduceList (0,[]) try_me wanteds' (avails, [], []) `thenNF_Tc` \ (avails, frees, irreds) ->
-- Extract the bindings from avails
let
| otherwise = binds
in
{-
- pprTrace ("reduceContext1") (vcat [
+ pprTrace ("reduceContext end") (vcat [
text "----------------------",
str,
text "given" <+> ppr givens,
text "wanted" <+> ppr wanteds,
text "----",
- pprAvails avails,
+ text "avails" <+> pprAvails avails,
+ text "frees" <+> ppr frees,
+ text "irreds" <+> ppr irreds,
text "----------------------"
]) $
-}
- returnTc (binds, frees, irreds)
+ returnNF_Tc (binds, frees, irreds)
\end{code}
The main context-reduction function is @reduce@. Here's its game plan.
\begin{code}
-reduce :: (Inst s -> WhatToDo)
- -> [Inst s]
- -> RedState s
- -> TcM s (RedState s)
+reduceList :: (Int,[Inst]) -- Stack (for err msgs)
+ -- along with its depth
+ -> (Inst -> WhatToDo)
+ -> [Inst]
+ -> RedState s
+ -> TcM (RedState s)
\end{code}
@reduce@ is passed
wanteds: The list of insts to reduce
state: An accumulating parameter of type RedState
that contains the state of the algorithm
-
+
It returns a RedState.
+The (n,stack) pair is just used for error reporting.
+n is always the depth of the stack.
+The stack is the stack of Insts being reduced: to produce X
+I had to produce Y, to produce Y I had to produce Z, and so on.
\begin{code}
- -- Base case: we're done!
-reduce try_me [] state = returnTc state
+reduceList (n,stack) try_me wanteds state
+ | n > opt_MaxContextReductionDepth
+ = failWithTc (reduceDepthErr n stack)
-reduce try_me (wanted:wanteds) state@(avails, frees, irreds)
+ | otherwise
+ =
+#ifdef DEBUG
+ (if n > 8 then
+ pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack)
+ else (\x->x))
+#endif
+ go wanteds state
+ where
+ go [] state = returnTc state
+ go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenTc` \ state' ->
+ go ws state'
+ -- Base case: we're done!
+reduce stack try_me wanted state@(avails, frees, irreds)
-- It's the same as an existing inst, or a superclass thereof
| wanted `elemFM` avails
- = reduce try_me wanteds (activate avails wanted, frees, irreds)
-
- -- It should be reduced
- | case try_me_result of { ReduceMe _ -> True; _ -> False }
- = lookupInst wanted `thenNF_Tc` \ lookup_result ->
-
- case lookup_result of
- GenInst wanteds' rhs -> use_instance wanteds' rhs
- SimpleInst rhs -> use_instance [] rhs
-
- NoInstance -> -- No such instance!
- -- Decide what to do based on the no_instance_action requested
- case no_instance_action of
- Stop -> failTc -- Fail
- AddToIrreds -> add_to_irreds -- Add the offending insts to the irreds
-
- -- It's free and this isn't a top-level binding, so just chuck it upstairs
- | case try_me_result of { Free -> True; _ -> False }
- = -- First, see if the inst can be reduced to a constant in one step
- lookupInst wanted `thenNF_Tc` \ lookup_result ->
- case lookup_result of
- SimpleInst rhs -> use_instance [] rhs
- other -> add_to_frees
-
- -- It's free and this is a top level binding, so
- -- check whether it's a tautology or not
- | case try_me_result of { FreeIfTautological -> True; _ -> False }
- = -- Try for tautology
- tryTc
- -- If tautology trial fails, add to irreds
- (addGiven avails wanted `thenNF_Tc` \ avails' ->
- returnTc (avails', frees, wanted:irreds))
+ = returnTc (activate avails wanted, frees, irreds)
+
+ | otherwise
+ = case try_me wanted of {
+
+ ReduceMe no_instance_action -> -- It should be reduced
+ lookupInst wanted `thenNF_Tc` \ lookup_result ->
+ case lookup_result of
+ GenInst wanteds' rhs -> use_instance wanteds' rhs
+ SimpleInst rhs -> use_instance [] rhs
+
+ NoInstance -> -- No such instance!
+ case no_instance_action of
+ Stop -> failTc
+ AddToIrreds -> add_to_irreds
+ ;
+ Free -> -- It's free and this isn't a top-level binding, so just chuck it upstairs
+ -- First, see if the inst can be reduced to a constant in one step
+ lookupInst wanted `thenNF_Tc` \ lookup_result ->
+ case lookup_result of
+ SimpleInst rhs -> use_instance [] rhs
+ other -> add_to_frees
+
+
+
+ ;
+ FreeIfTautological -> -- It's free and this is a top level binding, so
+ -- check whether it's a tautology or not
+ tryTc_
+ add_to_irreds -- If tautology trial fails, add to irreds
-- If tautology succeeds, just add to frees
- (reduce try_me_taut [wanted] (avails, [], []) `thenTc_`
+ (reduce stack try_me_taut wanted (avails, [], []) `thenTc_`
returnTc (avails, wanted:frees, irreds))
- `thenTc` \ state' ->
- reduce try_me wanteds state'
- -- It's irreducible (or at least should not be reduced)
- | otherwise
- = ASSERT( case try_me_result of { DontReduce -> True; other -> False } )
- -- See if the inst can be reduced to a constant in one step
- lookupInst wanted `thenNF_Tc` \ lookup_result ->
- case lookup_result of
- SimpleInst rhs -> use_instance [] rhs
- other -> add_to_irreds
+ ;
+
+ DontReduce -> add_to_irreds
+ ;
+ DontReduceUnlessConstant -> -- It's irreducible (or at least should not be reduced)
+ -- See if the inst can be reduced to a constant in one step
+ lookupInst wanted `thenNF_Tc` \ lookup_result ->
+ case lookup_result of
+ SimpleInst rhs -> use_instance [] rhs
+ other -> add_to_irreds
+ }
where
-- The three main actions
- add_to_frees = reduce try_me wanteds (avails, wanted:frees, irreds)
+ add_to_frees = let
+ avails' = addFree avails wanted
+ -- Add the thing to the avails set so any identical Insts
+ -- will be commoned up with it right here
+ in
+ returnTc (avails', wanted:frees, irreds)
add_to_irreds = addGiven avails wanted `thenNF_Tc` \ avails' ->
- reduce try_me wanteds (avails', frees, wanted:irreds)
+ returnTc (avails', frees, wanted:irreds)
use_instance wanteds' rhs = addWanted avails wanted rhs `thenNF_Tc` \ avails' ->
- reduce try_me (wanteds' ++ wanteds) (avails', frees, irreds)
-
+ reduceList stack try_me wanteds' (avails', frees, irreds)
- try_me_result = try_me wanted
- ReduceMe no_instance_action = try_me_result
-- The try-me to use when trying to identify tautologies
-- It blunders on reducing as much as possible
\begin{code}
-activate :: Avails s -> Inst s -> Avails s
+activate :: Avails s -> Inst -> Avails s
-- Activate the binding for Inst, ensuring that a binding for the
-- wanted Inst will be generated.
-- (Activate its parent if necessary, recursively).
addWanted avails wanted rhs_expr
= ASSERT( not (wanted `elemFM` avails) )
- returnNF_Tc (addToFM avails wanted avail)
+ addFunDeps (addToFM avails wanted avail) wanted
-- NB: we don't add the thing's superclasses too!
-- Why not? Because addWanted is used when we've successfully used an
-- instance decl to reduce something; e.g.
rhs | instBindingRequired wanted = Rhs rhs_expr False -- Not superclass selection
| otherwise = NoRhs
-addGiven :: Avails s -> Inst s -> NF_TcM s (Avails s)
+addFree :: Avails s -> Inst -> (Avails s)
+ -- When an Inst is tossed upstairs as 'free' we nevertheless add it
+ -- to avails, so that any other equal Insts will be commoned up right
+ -- here rather than also being tossed upstairs. This is really just
+ -- an optimisation, and perhaps it is more trouble that it is worth,
+ -- as the following comments show!
+ --
+ -- NB1: do *not* add superclasses. If we have
+ -- df::Floating a
+ -- dn::Num a
+ -- but a is not bound here, then we *don't* want to derive
+ -- dn from df here lest we lose sharing.
+ --
+ -- NB2: do *not* add the Inst to avails at all if it's a method.
+ -- The following situation shows why this is bad:
+ -- truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
+ -- From an application (truncate f i) we get
+ -- t1 = truncate at f
+ -- t2 = t1 at i
+ -- If we have also have a secon occurrence of truncate, we get
+ -- t3 = truncate at f
+ -- t4 = t3 at i
+ -- When simplifying with i,f free, we might still notice that
+ -- t1=t3; but alas, the binding for t2 (which mentions t1)
+ -- will continue to float out!
+ -- Solution: never put methods in avail till they are captured
+ -- in which case addFree isn't used
+addFree avails free
+ | isDict free = addToFM avails free (Avail (instToId free) NoRhs [])
+ | otherwise = avails
+
+addGiven :: Avails s -> Inst -> NF_TcM (Avails s)
addGiven avails given
= -- ASSERT( not (given `elemFM` avails) )
- -- This assertion isn' necessarily true. It's permitted
+ -- This assertion isn't necessarily true. It's permitted
-- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...)
-- and when typechecking instance decls we generate redundant "givens" too.
- addAvail avails given avail
+ -- addAvail avails given avail
+ addAvail avails given avail `thenNF_Tc` \av ->
+ zonkInst given `thenNF_Tc` \given' ->
+ returnNF_Tc av
where
avail = Avail (instToId given) NoRhs []
addAvail avails wanted avail
= addSuperClasses (addToFM avails wanted avail) wanted
-addSuperClasses :: Avails s -> Inst s -> NF_TcM s (Avails s)
+addSuperClasses :: Avails s -> Inst -> NF_TcM (Avails s)
-- Add all the superclasses of the Inst to Avails
-- Invariant: the Inst is already in Avails.
addSuperClasses avails dict
- | not (isDict dict)
+ | not (isClassDict dict)
= returnNF_Tc avails
| otherwise -- It is a dictionary
- = tcInstTheta env sc_theta `thenNF_Tc` \ sc_theta' ->
- foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels)
+ = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels) `thenNF_Tc` \ avails' ->
+ addFunDeps avails' dict
where
(clas, tys) = getDictClassTys dict
-
- (tyvars, sc_theta, sc_sels, _, _) = classBigSig clas
- env = zipTyVarEnv tyvars tys
+ (tyvars, sc_theta, sc_sels, _) = classBigSig clas
+ sc_theta' = substClasses (mkTopTyVarSubst tyvars tys) sc_theta
add_sc avails ((super_clas, super_tys), sc_sel)
= newDictFromOld dict super_clas super_tys `thenNF_Tc` \ super_dict ->
let
- sc_sel_rhs = DictApp (TyApp (HsVar (RealId sc_sel))
- tys)
+ sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys)
[instToId dict]
in
case lookupFM avails super_dict of
avail = Avail (instToId super_dict)
(PassiveScSel sc_sel_rhs [dict])
[]
+
+addFunDeps :: Avails s -> Inst -> NF_TcM (Avails s)
+ -- Add in the functional dependencies generated by the inst
+addFunDeps avails inst
+ = newFunDepFromDict inst `thenNF_Tc` \ fdInst_maybe ->
+ case fdInst_maybe of
+ Nothing -> returnNF_Tc avails
+ Just fdInst ->
+ let fdAvail = Avail (instToId (fromJust fdInst_maybe)) NoRhs [] in
+ addAvail avails fdInst fdAvail
\end{code}
%************************************************************************
instance declarations.
\begin{code}
-tcSimplifyThetas :: (Class -> ClassInstEnv) -- How to find the ClassInstEnv
- -> ThetaType -- Wanted
- -> TcM s ThetaType -- Needed; of the form C a b c
- -- where a,b,c are type variables
+tcSimplifyThetas :: ClassContext -- Wanted
+ -> TcM ClassContext -- Needed
-tcSimplifyThetas inst_mapper wanteds
- = reduceSimple inst_mapper [] wanteds `thenNF_Tc` \ irreds ->
+tcSimplifyThetas wanteds
+ = doptsTc Opt_GlasgowExts `thenNF_Tc` \ glaExts ->
+ reduceSimple [] wanteds `thenNF_Tc` \ irreds ->
let
- -- Check that the returned dictionaries are of the form (C a b c)
- bad_guys = [ct | ct@(clas,tys) <- irreds, not (all isTyVarTy tys)]
+ -- For multi-param Haskell, check that the returned dictionaries
+ -- don't have any of the form (C Int Bool) for which
+ -- we expect an instance here
+ -- For Haskell 98, check that all the constraints are of the form C a,
+ -- where a is a type variable
+ bad_guys | glaExts = [ct | ct@(clas,tys) <- irreds,
+ isEmptyVarSet (tyVarsOfTypes tys)]
+ | otherwise = [ct | ct@(clas,tys) <- irreds,
+ not (all isTyVarTy tys)]
in
if null bad_guys then
returnTc irreds
whether it worked or not.
\begin{code}
-tcSimplifyCheckThetas :: ThetaType -- Given
- -> ThetaType -- Wanted
- -> TcM s ()
+tcSimplifyCheckThetas :: ClassContext -- Given
+ -> ClassContext -- Wanted
+ -> TcM ()
tcSimplifyCheckThetas givens wanteds
- = reduceSimple classInstEnv givens wanteds `thenNF_Tc` \ irreds ->
+ = reduceSimple givens wanteds `thenNF_Tc` \ irreds ->
if null irreds then
returnTc ()
else
\begin{code}
-type AvailsSimple = FiniteMap (Class, [TauType]) Bool
+type AvailsSimple = FiniteMap (Class,[Type]) Bool
-- True => irreducible
-- False => given, or can be derived from a given or from an irreducible
-reduceSimple :: (Class -> ClassInstEnv)
- -> ThetaType -- Given
- -> ThetaType -- Wanted
- -> NF_TcM s ThetaType -- Irreducible
+reduceSimple :: ClassContext -- Given
+ -> ClassContext -- Wanted
+ -> NF_TcM ClassContext -- Irreducible
-reduceSimple inst_mapper givens wanteds
- = reduce_simple inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
+reduceSimple givens wanteds
+ = reduce_simple (0,[]) givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
where
givens_fm = foldl addNonIrred emptyFM givens
-reduce_simple :: (Class -> ClassInstEnv)
+reduce_simple :: (Int,ClassContext) -- Stack
-> AvailsSimple
- -> ThetaType
- -> NF_TcM s AvailsSimple
+ -> ClassContext
+ -> NF_TcM AvailsSimple
-reduce_simple inst_mapper givens []
- = -- Finished, so pull out the needed ones
- returnNF_Tc givens
+reduce_simple (n,stack) avails wanteds
+ = go avails wanteds
+ where
+ go avails [] = returnNF_Tc avails
+ go avails (w:ws) = reduce_simple_help (n+1,w:stack) avails w `thenNF_Tc` \ avails' ->
+ go avails' ws
-reduce_simple inst_mapper givens (wanted@(clas,tys) : wanteds)
+reduce_simple_help stack givens wanted@(clas,tys)
| wanted `elemFM` givens
- = reduce_simple inst_mapper givens wanteds
+ = returnNF_Tc givens
| otherwise
- = lookupSimpleInst (inst_mapper clas) clas tys `thenNF_Tc` \ maybe_theta ->
+ = lookupSimpleInst clas tys `thenNF_Tc` \ maybe_theta ->
case maybe_theta of
- Nothing -> reduce_simple inst_mapper (addIrred givens wanted) wanteds
- Just theta -> reduce_simple inst_mapper (addNonIrred givens wanted) (theta ++ wanteds)
+ Nothing -> returnNF_Tc (addIrred givens wanted)
+ Just theta -> reduce_simple stack (addNonIrred givens wanted) theta
-addIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
-addIrred givens ct
+addIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple
+addIrred givens ct@(clas,tys)
= addSCs (addToFM givens ct True) ct
-addNonIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
-addNonIrred givens ct
+addNonIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple
+addNonIrred givens ct@(clas,tys)
= addSCs (addToFM givens ct False) ct
addSCs givens ct@(clas,tys)
= foldl add givens sc_theta
where
- (tyvars, sc_theta_tmpl, _, _, _) = classBigSig clas
- sc_theta = instantiateThetaTy (zipTyVarEnv tyvars tys) sc_theta_tmpl
+ (tyvars, sc_theta_tmpl, _, _) = classBigSig clas
+ sc_theta = substClasses (mkTopTyVarSubst tyvars tys) sc_theta_tmpl
- add givens ct = case lookupFM givens ct of
- Nothing -> -- Add it and its superclasses
- addSCs (addToFM givens ct False) ct
+ add givens ct@(clas, tys)
+ = case lookupFM givens ct of
+ Nothing -> -- Add it and its superclasses
+ addSCs (addToFM givens ct False) ct
- Just True -> -- Set its flag to False; superclasses already done
- addToFM givens ct False
+ Just True -> -- Set its flag to False; superclasses already done
+ addToFM givens ct False
- Just False -> -- Already done
- givens
+ Just False -> -- Already done
+ givens
\end{code}
@LIE@), as well as the @HsBinds@ generated.
\begin{code}
-bindInstsOfLocalFuns :: LIE s -> [TcIdBndr s] -> TcM s (LIE s, TcMonoBinds s)
+bindInstsOfLocalFuns :: LIE -> [TcId] -> TcM (LIE, TcMonoBinds)
bindInstsOfLocalFuns init_lie local_ids
+ | null overloaded_ids || null lie_for_here
+ -- Common case
+ = returnTc (init_lie, EmptyMonoBinds)
+
+ | otherwise
= reduceContext (text "bindInsts" <+> ppr local_ids)
- try_me [] (bagToList init_lie) `thenTc` \ (binds, frees, irreds) ->
+ try_me [] lie_for_here `thenTc` \ (binds, frees, irreds) ->
ASSERT( null irreds )
- returnTc (mkLIE frees, binds)
+ returnTc (mkLIE frees `plusLIE` mkLIE lie_not_for_here, binds)
where
- local_id_set = mkIdSet local_ids -- There can occasionally be a lot of them
- -- so it's worth building a set, so that
- -- lookup (in isMethodFor) is faster
- try_me inst | isMethodFor local_id_set inst = ReduceMe AddToIrreds
- | otherwise = Free
+ overloaded_ids = filter is_overloaded local_ids
+ is_overloaded id = case splitSigmaTy (idType id) of
+ (_, theta, _) -> not (null theta)
+
+ overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them
+ -- so it's worth building a set, so that
+ -- lookup (in isMethodFor) is faster
+
+ -- No sense in repeatedly zonking lots of
+ -- constant constraints so filter them out here
+ (lie_for_here, lie_not_for_here) = partition (isMethodFor overloaded_set)
+ (lieToList init_lie)
+ try_me inst | isMethodFor overloaded_set inst = ReduceMe AddToIrreds
+ | otherwise = Free
\end{code}
all the constant and ambiguous Insts.
\begin{code}
-tcSimplifyTop :: LIE s -> TcM s (TcDictBinds s)
+tcSimplifyTop :: LIE -> TcM TcDictBinds
tcSimplifyTop wanted_lie
= reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) ->
ASSERT( null frees )
-- Have a try at disambiguation
-- if the type variable isn't bound
-- up with one of the non-standard classes
- worth_a_try group@(d:_) = isEmptyTyVarSet (tyVarsOfInst d `intersectTyVarSets` non_std_tyvars)
- non_std_tyvars = unionManyTyVarSets (map tyVarsOfInst non_stds)
+ worth_a_try group@(d:_) = isEmptyVarSet (tyVarsOfInst d `intersectVarSet` non_std_tyvars)
+ non_std_tyvars = unionVarSets (map tyVarsOfInst non_stds)
-- Collect together all the bad guys
bad_guys = non_stds ++ concat std_bads
in
-
-- Disambiguate the ones that look feasible
mapTc disambigGroup std_oks `thenTc` \ binds_ambig ->
-- And complain about the ones that don't
mapNF_Tc complain bad_guys `thenNF_Tc_`
- returnTc (binds1 `AndMonoBinds` andMonoBinds binds_ambig)
+ returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig)
where
- wanteds = bagToList wanted_lie
+ wanteds = lieToList wanted_lie
try_me inst = ReduceMe AddToIrreds
d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
- complain d | isEmptyTyVarSet (tyVarsOfInst d) = addTopInstanceErr d
- | otherwise = addAmbigErr [d]
+ complain d | not (null (getIPs d)) = addTopIPErr d
+ | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d
+ | otherwise = addAmbigErr tyVarsOfInst d
get_tv d = case getDictClassTys d of
(clas, [ty]) -> getTyVar "tcSimplifyTop" ty
@void@.
\begin{code}
-disambigGroup :: [Inst s] -- All standard classes of form (C a)
- -> TcM s (TcDictBinds s)
+disambigGroup :: [Inst] -- All standard classes of form (C a)
+ -> TcM TcDictBinds
disambigGroup dicts
- | any isNumericClass classes -- Guaranteed all standard classes
+ | any isNumericClass classes -- Guaranteed all standard classes
+ -- see comment at the end of function for reasons as to
+ -- why the defaulting mechanism doesn't apply to groups that
+ -- include CCallable or CReturnable dicts.
+ && not (any isCcallishClass classes)
= -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
-- SO, TRY DEFAULT TYPES IN ORDER
= failTc
try_default (default_ty : default_tys)
- = tryTc (try_default default_tys) $ -- If default_ty fails, we try
+ = tryTc_ (try_default default_tys) $ -- If default_ty fails, we try
-- default_tys instead
tcSimplifyCheckThetas [] thetas `thenTc` \ _ ->
returnTc default_ty
in
-- See if any default works, and if so bind the type variable to it
-- If not, add an AmbigErr
- recoverTc (addAmbigErr dicts `thenNF_Tc_` returnTc EmptyMonoBinds) $
+ recoverTc (complain dicts `thenNF_Tc_` returnTc EmptyMonoBinds) $
try_default default_tys `thenTc` \ chosen_default_ty ->
-- Bind the type variable and reduce the context, for real this time
- tcInstType emptyTyVarEnv chosen_default_ty `thenNF_Tc` \ chosen_default_tc_ty -> -- Tiresome!
- unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar) `thenTc_`
+ unifyTauTy chosen_default_ty (mkTyVarTy tyvar) `thenTc_`
reduceContext (text "disambig" <+> ppr dicts)
- try_me [] dicts `thenTc` \ (binds, frees, ambigs) ->
+ try_me [] dicts `thenTc` \ (binds, frees, ambigs) ->
ASSERT( null frees && null ambigs )
+ warnDefault dicts chosen_default_ty `thenTc_`
returnTc binds
| all isCreturnableClass classes
returnTc EmptyMonoBinds
| otherwise -- No defaults
- = addAmbigErr dicts `thenNF_Tc_`
+ = complain dicts `thenNF_Tc_`
returnTc EmptyMonoBinds
where
+ complain = addAmbigErrs tyVarsOfInst
try_me inst = ReduceMe AddToIrreds -- This reduce should not fail
tyvar = get_tv (head dicts) -- Should be non-empty
classes = map get_clas dicts
\end{code}
-
+[Aside - why the defaulting mechanism is turned off when
+ dealing with arguments and results to ccalls.
+
+When typechecking _ccall_s, TcExpr ensures that the external
+function is only passed arguments (and in the other direction,
+results) of a restricted set of 'native' types. This is
+implemented via the help of the pseudo-type classes,
+@CReturnable@ (CR) and @CCallable@ (CC.)
+
+The interaction between the defaulting mechanism for numeric
+values and CC & CR can be a bit puzzling to the user at times.
+For example,
+
+ x <- _ccall_ f
+ if (x /= 0) then
+ _ccall_ g x
+ else
+ return ()
+
+What type has 'x' got here? That depends on the default list
+in operation, if it is equal to Haskell 98's default-default
+of (Integer, Double), 'x' has type Double, since Integer
+is not an instance of CR. If the default list is equal to
+Haskell 1.4's default-default of (Int, Double), 'x' has type
+Int.
+
+To try to minimise the potential for surprises here, the
+defaulting mechanism is turned off in the presence of
+CCallable and CReturnable.
+
+]
Errors and contexts
~~~~~~~~~~~~~~~~~~~
nest 4 (pprInstsInFull insts)
]
-addAmbigErr dicts
- = tcAddSrcLoc (instLoc (head dicts)) $
- addErrTc (sep [text "Cannot resolve the ambiguous context" <+> pprInsts dicts,
- nest 4 (pprInstsInFull dicts)])
+addAmbigErrs ambig_tv_fn dicts = mapNF_Tc (addAmbigErr ambig_tv_fn) dicts
+
+addAmbigErr ambig_tv_fn dict
+ = addInstErrTcM (instLoc dict)
+ (tidy_env,
+ sep [text "Ambiguous type variable(s)" <+> pprQuotedList ambig_tvs,
+ nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict))])
+ where
+ ambig_tvs = varSetElems (ambig_tv_fn tidy_dict)
+ (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
+
+warnDefault dicts default_ty
+ = doptsTc Opt_WarnTypeDefaults `thenTc` \ warn_flag ->
+ if warn_flag
+ then mapNF_Tc warn groups `thenNF_Tc_` returnNF_Tc ()
+ else returnNF_Tc ()
+
+ where
+ -- Tidy them first
+ (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts
+
+ -- Group the dictionaries by source location
+ groups = equivClasses cmp tidy_dicts
+ i1 `cmp` i2 = get_loc i1 `compare` get_loc i2
+ get_loc i = case instLoc i of { (_,loc,_) -> loc }
+
+ warn [dict] = tcAddSrcLoc (get_loc dict) $
+ warnTc True (ptext SLIT("Defaulting") <+> quotes (pprInst dict) <+>
+ ptext SLIT("to type") <+> quotes (ppr default_ty))
+
+ warn dicts = tcAddSrcLoc (get_loc (head dicts)) $
+ warnTc True (vcat [ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty),
+ pprInstsInFull dicts])
+
+addTopIPErr dict
+ = addInstErrTcM (instLoc dict)
+ (tidy_env,
+ ptext SLIT("Unbound implicit parameter") <+> quotes (pprInst tidy_dict))
+ where
+ (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
-- Used for top-level irreducibles
addTopInstanceErr dict
- = tcAddSrcLoc (instLoc dict) $
- addErrTc (sep [ptext SLIT("No instance for") <+> quotes (pprInst dict),
- nest 4 $ parens $ pprOrigin dict])
+ = addInstErrTcM (instLoc dict)
+ (tidy_env,
+ ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict))
+ where
+ (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
+-- The error message when we don't find a suitable instance
+-- is complicated by the fact that sometimes this is because
+-- there is no instance, and sometimes it's because there are
+-- too many instances (overlap). See the comments in TcEnv.lhs
+-- with the InstEnv stuff.
addNoInstanceErr str givens dict
- = tcAddSrcLoc (instLoc dict) $
- addErrTc (sep [sep [ptext SLIT("Could not deduce") <+> quotes (pprInst dict),
- nest 4 $ parens $ pprOrigin dict],
- nest 4 $ ptext SLIT("from the context") <+> pprInsts givens]
- $$
- ptext SLIT("Probable cause:") <+>
- vcat [ptext SLIT("missing") <+> quotes (pprInst dict) <+> ptext SLIT("in") <+> str,
- if all_tyvars then empty else
- ptext SLIT("or missing instance declaration for") <+> quotes (pprInst dict)]
- )
- where
- all_tyvars = all isTyVarTy tys
- (_, tys) = getDictClassTys dict
+ = tcGetInstEnv `thenNF_Tc` \ inst_env ->
+ let
+ doc = vcat [sep [herald <+> quotes (pprInst tidy_dict),
+ nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens],
+ ambig_doc,
+ ptext SLIT("Probable fix:"),
+ nest 4 fix1,
+ nest 4 fix2]
+
+ herald = ptext SLIT("Could not") <+> unambig_doc <+> ptext SLIT("deduce")
+ unambig_doc | ambig_overlap = ptext SLIT("unambiguously")
+ | otherwise = empty
+
+ ambig_doc
+ | not ambig_overlap = empty
+ | otherwise
+ = vcat [ptext SLIT("The choice of (overlapping) instance declaration"),
+ nest 4 (ptext SLIT("depends on the instantiation of") <+>
+ quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst tidy_dict))))]
+
+ fix1 = sep [ptext SLIT("Add") <+> quotes (pprInst tidy_dict),
+ ptext SLIT("to the") <+> str]
+
+ fix2 | isTyVarDict dict || ambig_overlap
+ = empty
+ | otherwise
+ = ptext SLIT("Or add an instance declaration for") <+> quotes (pprInst tidy_dict)
+
+ (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
+
+ -- Checks for the ambiguous case when we have overlapping instances
+ ambig_overlap | isClassDict dict
+ = case lookupInstEnv inst_env clas tys of
+ NoMatch ambig -> ambig
+ other -> False
+ | otherwise = False
+ where
+ (clas,tys) = getDictClassTys dict
+ in
+ addInstErrTcM (instLoc dict) (tidy_env, doc)
-- Used for the ...Thetas variants; all top level
addNoInstErr (c,ts)
= addErrTc (ptext SLIT("No instance for") <+> quotes (pprConstraint c ts))
+
+reduceDepthErr n stack
+ = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
+ ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
+ nest 4 (pprInstsInFull stack)]
+
+reduceDepthMsg n stack = nest 4 (pprInstsInFull stack)
\end{code}
projects / ghc-hetmet.git / blobdiff