X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcSimplify.lhs;h=f1467ba4548f368e4970c45cb8ddf3b8e68d2c6f;hb=8ddfc3c10a9d08e11812b5564da291d7024d5fc8;hp=1bf752ce79f9b29a035060e797d72ecabc4a5336;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 1bf752c..f1467ba 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -116,54 +116,56 @@ and hence the default mechanism would resolve the "a". \begin{code} module TcSimplify ( - tcSimplify, tcSimplifyAndCheck, + tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts, tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas, - bindInstsOfLocalFuns + bindInstsOfLocalFuns, partitionPredsOfLIE ) where #include "HsVersions.h" -import CmdLineOpts ( opt_MaxContextReductionDepth ) +import CmdLineOpts ( opt_MaxContextReductionDepth, opt_GlasgowExts, opt_WarnTypeDefaults ) import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList ) -import TcHsSyn ( TcExpr, TcIdOcc(..), TcIdBndr, +import TcHsSyn ( TcExpr, TcId, TcMonoBinds, TcDictBinds ) import TcMonad import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..), - tyVarsOfInst, - isDict, isStdClassTyVarDict, isMethodFor, + tyVarsOfInst, tyVarsOfInsts, + isDict, isClassDict, isStdClassTyVarDict, + isMethodFor, notFunDep, instToId, instBindingRequired, instCanBeGeneralised, newDictFromOld, - instLoc, getDictClassTys, - pprInst, zonkInst, tidyInst, tidyInsts, - Inst, LIE, pprInsts, pprInstsInFull, mkLIE, emptyLIE, - plusLIE, pprOrigin + getDictClassTys, getIPs, + getDictPred_maybe, getMethodTheta_maybe, + instLoc, pprInst, zonkInst, tidyInst, tidyInsts, + Inst, LIE, pprInsts, pprInstsInFull, + mkLIE, emptyLIE, unitLIE, consLIE, plusLIE, + lieToList, listToLIE ) -import TcEnv ( TcIdOcc(..), tcGetGlobalTyVars ) +import TcEnv ( tcGetGlobalTyVars ) import TcType ( TcType, TcTyVarSet, typeToTcType ) import TcUnify ( unifyTauTy ) import Id ( idType ) -import VarSet ( mkVarSet ) +import Class ( Class, classBigSig, classInstEnv ) +import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass ) -import Bag ( bagToList ) -import Class ( Class, ClassInstEnv, classBigSig, classInstEnv ) -import PrelInfo ( isNumericClass, isCreturnableClass ) - -import Type ( Type, ThetaType, TauType, mkTyVarTy, getTyVar, - isTyVarTy, substFlexiTheta, splitSigmaTy, - tyVarsOfTypes +import Type ( Type, ThetaType, TauType, ClassContext, + mkTyVarTy, getTyVar, + isTyVarTy, splitSigmaTy, tyVarsOfTypes ) +import InstEnv ( InstEnv ) +import Subst ( mkTopTyVarSubst, substClasses ) import PprType ( pprConstraint ) import TysWiredIn ( unitTy ) import VarSet -import VarEnv ( zipVarEnv ) import FiniteMap import BasicTypes ( TopLevelFlag(..) ) import CmdLineOpts ( opt_GlasgowExts ) import Outputable import Util import List ( partition ) +import Maybes ( maybeToBool ) \end{code} @@ -183,19 +185,21 @@ float them out if poss, after inlinings are sorted out. \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 - -tcSimplify str top_lvl local_tvs wanted_lie + -> LIE -- Wanted + -> TcM s (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) | otherwise +-} = reduceContext str try_me [] wanteds `thenTc` \ (binds, frees, irreds) -> -- Check for non-generalisable insts @@ -227,11 +231,22 @@ tcSimplify str top_lvl local_tvs wanted_lie -- Finished returnTc (mkLIE frees, binds, mkLIE irreds') where - wanteds = bagToList wanted_lie + -- the idea behind filtering out the dependencies here is that + -- they've already served their purpose, and can be reconstructed + -- at a later point from the retained class predicates. + -- however, there *is* the possibility that a dependency + -- out-lives the predicate from which it arose. + -- I don't have any examples of this, but if they show up, + -- we'd want to consider the possibility of saving the + -- dependencies as hidden constraints (i.e. they'd only + -- show up in interface files) -- or maybe they'd be useful + -- as first class predicates... + wanteds = filter notFunDep (lieToList wanted_lie) try_me inst -- Does not constrain a local tyvar | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs) + && null (getIPs inst) = -- if is_top_level then -- FreeIfTautological -- Special case for inference on -- -- top-level defns @@ -240,7 +255,7 @@ tcSimplify str top_lvl local_tvs wanted_lie -- We're infering (not checking) the type, and -- the inst constrains a local type variable - | isDict inst = DontReduce -- Dicts + | isDict inst = DontReduceUnlessConstant -- Dicts | otherwise = ReduceMe AddToIrreds -- Lits and Methods \end{code} @@ -251,20 +266,22 @@ some of constant insts, which have to be resolved finally at the end. \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 s (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 @@ -273,12 +290,15 @@ tcSimplifyAndCheck str local_tvs given_lie wanted_lie -- Done returnTc (mkLIE frees, binds) where - givens = bagToList given_lie - wanteds = bagToList wanted_lie + givens = lieToList given_lie + -- see comment on wanteds in tcSimplify + wanteds = filter notFunDep (lieToList wanted_lie) + given_dicts = filter isClassDict givens try_me inst -- Does not constrain a local tyvar | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs) + && (isDict inst || null (getIPs inst)) = Free -- When checking against a given signature we always reduce @@ -287,7 +307,88 @@ tcSimplifyAndCheck str local_tvs given_lie wanted_lie = 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 s (LIE, TcDictBinds) +tcSimplifyToDicts wanted_lie + = reduceContext (text "tcSimplifyToDicts") try_me [] wanteds `thenTc` \ (binds, frees, irreds) -> + ASSERT( null frees ) + returnTc (mkLIE irreds, binds) + where + -- see comment on wanteds in tcSimplify + -- ZZ waitaminute - doesn't appear that any funDeps should even be here... + -- wanteds = filter notFunDep (lieToList wanted_lie) + 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} @@ -304,12 +405,22 @@ data WhatToDo = 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 @@ -325,26 +436,26 @@ data NoInstanceAction \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. @@ -353,7 +464,7 @@ data RHS s -- 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. @@ -365,8 +476,8 @@ data RHS s -- 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. @@ -374,10 +485,13 @@ data RHS s -- 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 "" pprRhs (Rhs rhs b) = ppr rhs @@ -394,12 +508,12 @@ pprRhs (PassiveScSel rhs is) = text "passive" <+> 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 s (TcDictBinds, + [Inst], -- Free + [Inst]) -- Irreducible reduceContext str try_me givens wanteds = -- Zonking first @@ -446,6 +560,7 @@ reduceContext str try_me givens wanteds text "wanted" <+> ppr wanteds, text "----", text "avails" <+> pprAvails avails, + text "frees" <+> ppr frees, text "irreds" <+> ppr irreds, text "----------------------" ]) $ @@ -456,9 +571,10 @@ reduceContext str try_me givens wanteds The main context-reduction function is @reduce@. Here's its game plan. \begin{code} -reduceList :: (Int,[Inst s]) - -> (Inst s -> WhatToDo) - -> [Inst s] +reduceList :: (Int,[Inst]) -- Stack (for err msgs) + -- along with its depth + -> (Inst -> WhatToDo) + -> [Inst] -> RedState s -> TcM s (RedState s) \end{code} @@ -475,6 +591,10 @@ reduceList :: (Int,[Inst s]) 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} reduceList (n,stack) try_me wanteds state @@ -484,7 +604,7 @@ reduceList (n,stack) try_me wanteds state | otherwise = #ifdef DEBUG - (if n > 4 then + (if n > 8 then pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack) else (\x->x)) #endif @@ -496,56 +616,56 @@ reduceList (n,stack) try_me wanteds 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 = returnTc (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)) + | 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 stack try_me_taut wanted (avails, [], []) `thenTc_` + (reduce stack try_me_taut wanted (avails, [], []) `thenTc_` returnTc (avails, wanted:frees, irreds)) - -- 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 = let @@ -561,8 +681,6 @@ reduce stack try_me wanted state@(avails, frees, irreds) use_instance wanteds' rhs = addWanted avails wanted rhs `thenNF_Tc` \ avails' -> 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 @@ -571,7 +689,7 @@ reduce stack try_me wanted state@(avails, frees, irreds) \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). @@ -613,33 +731,59 @@ addWanted avails wanted rhs_expr rhs | instBindingRequired wanted = Rhs rhs_expr False -- Not superclass selection | otherwise = NoRhs -addFree :: Avails s -> Inst 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. + -- 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 s -> NF_TcM s (Avails s) +addGiven :: Avails s -> Inst -> NF_TcM s (Avails s) addGiven avails given = -- ASSERT( not (given `elemFM` avails) ) -- 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 s (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 @@ -647,14 +791,13 @@ addSuperClasses avails dict where (clas, tys) = getDictClassTys dict - (tyvars, sc_theta, sc_sels, _, _) = classBigSig clas - sc_theta' = substFlexiTheta (zipVarEnv tyvars tys) sc_theta + (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 @@ -699,20 +842,22 @@ a,b,c are type variables. This is required for the context of 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 :: (Class -> InstEnv) -- How to find the InstEnv + -> ClassContext -- Wanted + -> TcM s ClassContext -- Needed tcSimplifyThetas inst_mapper wanteds = reduceSimple inst_mapper [] wanteds `thenNF_Tc` \ irreds -> let - -- Check that the returned dictionaries are of the form (C a b c) + -- 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 | opt_GlasgowExts = [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 @@ -726,8 +871,8 @@ used with \tr{default} declarations. We are only interested in whether it worked or not. \begin{code} -tcSimplifyCheckThetas :: ThetaType -- Given - -> ThetaType -- Wanted +tcSimplifyCheckThetas :: ClassContext -- Given + -> ClassContext -- Wanted -> TcM s () tcSimplifyCheckThetas givens wanteds @@ -741,14 +886,14 @@ tcSimplifyCheckThetas givens wanteds \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 :: (Class -> InstEnv) + -> ClassContext -- Given + -> ClassContext -- Wanted + -> NF_TcM s ClassContext -- Irreducible reduceSimple inst_mapper givens wanteds = reduce_simple (0,[]) inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' -> @@ -756,10 +901,10 @@ reduceSimple inst_mapper givens wanteds where givens_fm = foldl addNonIrred emptyFM givens -reduce_simple :: (Int,ThetaType) -- Stack - -> (Class -> ClassInstEnv) +reduce_simple :: (Int,ClassContext) -- Stack + -> (Class -> InstEnv) -> AvailsSimple - -> ThetaType + -> ClassContext -> NF_TcM s AvailsSimple reduce_simple (n,stack) inst_mapper avails wanteds @@ -780,29 +925,30 @@ reduce_simple_help stack inst_mapper givens wanted@(clas,tys) Nothing -> returnNF_Tc (addIrred givens wanted) Just theta -> reduce_simple stack inst_mapper (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 = substFlexiTheta (zipVarEnv 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} @@ -832,7 +978,7 @@ For each method @Inst@ in the @init_lie@ that mentions one of the @LIE@), as well as the @HsBinds@ generated. \begin{code} -bindInstsOfLocalFuns :: LIE s -> [TcIdBndr s] -> TcM s (LIE s, TcMonoBinds s) +bindInstsOfLocalFuns :: LIE -> [TcId] -> TcM s (LIE, TcMonoBinds) bindInstsOfLocalFuns init_lie local_ids | null overloaded_ids || null lie_for_here @@ -856,7 +1002,7 @@ bindInstsOfLocalFuns init_lie local_ids -- 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) - (bagToList init_lie) + (lieToList init_lie) try_me inst | isMethodFor overloaded_set inst = ReduceMe AddToIrreds | otherwise = Free \end{code} @@ -903,7 +1049,7 @@ variable, and using @disambigOne@ to do the real business. all the constant and ambiguous Insts. \begin{code} -tcSimplifyTop :: LIE s -> TcM s (TcDictBinds s) +tcSimplifyTop :: LIE -> TcM s TcDictBinds tcSimplifyTop wanted_lie = reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) -> ASSERT( null frees ) @@ -936,13 +1082,15 @@ tcSimplifyTop wanted_lie returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig) where - wanteds = bagToList wanted_lie + -- see comment on wanteds in tcSimplify + wanteds = filter notFunDep (lieToList wanted_lie) try_me inst = ReduceMe AddToIrreds d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2 - complain d | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d - | otherwise = addAmbigErr tyVarsOfInst 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 @@ -963,11 +1111,15 @@ Since we're not using the result of @foo@, the result if (presumably) @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 s 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 @@ -981,7 +1133,7 @@ disambigGroup dicts = 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 @@ -1000,8 +1152,9 @@ disambigGroup dicts in unifyTauTy chosen_default_tc_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 @@ -1021,7 +1174,37 @@ disambigGroup dicts 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 ~~~~~~~~~~~~~~~~~~~ @@ -1038,35 +1221,63 @@ genCantGenErr insts -- Can't generalise these Insts addAmbigErrs ambig_tv_fn dicts = mapNF_Tc (addAmbigErr ambig_tv_fn) dicts addAmbigErr ambig_tv_fn dict - = tcAddSrcLoc (instLoc dict) $ - addErrTcM (tidy_env, - sep [text "Ambiguous type variable(s)" <+> - hsep (punctuate comma (map (quotes . ppr) ambig_tvs)), - nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict)), - nest 4 (pprOrigin 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 + | not opt_WarnTypeDefaults + = returnNF_Tc () + + | otherwise + = warnTc True msg + where + msg | length dicts > 1 + = (ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty)) + $$ pprInstsInFull tidy_dicts + | otherwise + = ptext SLIT("Defaulting") <+> quotes (pprInst (head tidy_dicts)) <+> + ptext SLIT("to type") <+> quotes (ppr default_ty) + + (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts + +addRuleLhsErr dict + = addInstErrTcM (instLoc dict) + (tidy_env, + vcat [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict), + nest 4 (ptext SLIT("LHS of a rule must have no overloading"))]) + where + (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict + +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) $ - addErrTcM (tidy_env, - sep [ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict), - nest 4 $ pprOrigin dict]) + = addInstErrTcM (instLoc dict) + (tidy_env, + ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict)) where (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict addNoInstanceErr str givens dict - = tcAddSrcLoc (instLoc dict) $ - addErrTcM (tidy_env, - sep [sep [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict), - nest 4 $ parens $ pprOrigin dict], - nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens] - $$ - ptext SLIT("Probable cause:") <+> - vcat [ptext SLIT("missing") <+> quotes (pprInst tidy_dict) <+> ptext SLIT("in") <+> str, - if all_tyvars then empty else + = addInstErrTcM (instLoc dict) + (tidy_env, + sep [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict), + nest 4 $ ptext SLIT("from the context:") <+> pprInsts tidy_givens] + $$ + ptext SLIT("Probable cause:") <+> + vcat [sep [ptext SLIT("missing") <+> quotes (pprInst tidy_dict), + ptext SLIT("in") <+> str], + if isClassDict dict && all_tyvars then empty else ptext SLIT("or missing instance declaration for") <+> quotes (pprInst tidy_dict)] ) where