#include "HsVersions.h"
-import CmdLineOpts ( opt_MaxContextReductionDepth, opt_GlasgowExts, opt_WarnTypeDefaults )
+import CmdLineOpts ( opt_MaxContextReductionDepth, dopt_GlasgowExts, opt_WarnTypeDefaults )
import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
import TcHsSyn ( TcExpr, TcId,
TcMonoBinds, TcDictBinds
import TcMonad
import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
- tyVarsOfInst, tyVarsOfInsts,
+ tyVarsOfInst,
isDict, isClassDict, isMethod, notFunDep,
isStdClassTyVarDict, isMethodFor,
instToId, instBindingRequired, instCanBeGeneralised,
instLoc, pprInst, zonkInst, tidyInst, tidyInsts,
Inst, LIE, pprInsts, pprInstsInFull,
mkLIE, emptyLIE, unitLIE, consLIE, plusLIE,
- lieToList, listToLIE
+ lieToList
)
-import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv,
- InstEnv, lookupInstEnv, InstLookupResult(..)
- )
-import TcType ( TcType, TcTyVarSet, typeToTcType )
+import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv )
+import TcInstUtil ( lookupInstEnv, InstLookupResult(..) )
+
+import TcType ( TcTyVarSet )
import TcUnify ( unifyTauTy )
import Id ( idType )
import Class ( Class, classBigSig )
import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass )
-import Type ( Type, ThetaType, TauType, ClassContext,
+import Type ( Type, ClassContext,
mkTyVarTy, getTyVar,
isTyVarTy, splitSigmaTy, tyVarsOfTypes
)
import TysWiredIn ( unitTy )
import VarSet
import FiniteMap
-import CmdLineOpts ( opt_GlasgowExts )
import Outputable
-import Util
+import ListSetOps ( equivClasses )
+import Util ( zipEqual, mapAccumL )
import List ( partition )
import Maybe ( fromJust )
import Maybes ( maybeToBool )
-> TcTyVarSet -- ``Local'' type variables
-- ASSERT: this tyvar set is already zonked
-> LIE -- Wanted
- -> TcM s (LIE, -- Free
+ -> TcM (LIE, -- Free
TcDictBinds, -- Bindings
LIE) -- Remaining wanteds; no dups
-- ASSERT: this tyvar set is already zonked
-> LIE -- Given; constrain only local tyvars
-> LIE -- Wanted
- -> TcM s (LIE, -- Free
+ -> TcM (LIE, -- Free
TcDictBinds) -- Bindings
tcSimplifyAndCheck str local_tvs given_lie wanted_lie
So tcSimplifyToDicts squeezes out all Methods.
\begin{code}
-tcSimplifyToDicts :: LIE -> TcM s (LIE, TcDictBinds)
+tcSimplifyToDicts :: LIE -> TcM (LIE, TcDictBinds)
tcSimplifyToDicts wanted_lie
= reduceContext (text "tcSimplifyToDicts") try_me [] wanteds `thenTc` \ (binds, frees, irreds) ->
ASSERT( null frees )
reduceContext :: SDoc -> (Inst -> WhatToDo)
-> [Inst] -- Given
-> [Inst] -- Wanted
- -> TcM s (TcDictBinds,
+ -> TcM (TcDictBinds,
[Inst], -- Free
[Inst]) -- Irreducible
-> (Inst -> WhatToDo)
-> [Inst]
-> RedState s
- -> TcM s (RedState s)
+ -> TcM (RedState s)
\end{code}
@reduce@ is passed
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.
| isDict free = addToFM avails free (Avail (instToId free) NoRhs [])
| otherwise = avails
-addGiven :: Avails s -> Inst -> NF_TcM s (Avails s)
+addGiven :: Avails s -> Inst -> NF_TcM (Avails s)
addGiven avails given
= -- ASSERT( not (given `elemFM` avails) )
-- This assertion isn't necessarily true. It's permitted
addAvail avails wanted avail
= addSuperClasses (addToFM avails wanted avail) wanted
-addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s)
+addSuperClasses :: Avails s -> Inst -> NF_TcM (Avails s)
-- Add all the superclasses of the Inst to Avails
- -- JRL - also add in the functional dependencies
-- Invariant: the Inst is already in Avails.
addSuperClasses avails dict
| otherwise -- It is a dictionary
= foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels) `thenNF_Tc` \ avails' ->
- newFunDepFromDict dict `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
+ addFunDeps avails' dict
where
(clas, tys) = getDictClassTys dict
(tyvars, sc_theta, sc_sels, _) = classBigSig clas
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}
%************************************************************************
\begin{code}
tcSimplifyThetas :: ClassContext -- Wanted
- -> TcM s ClassContext -- Needed
+ -> TcM ClassContext -- Needed
tcSimplifyThetas wanteds
- = reduceSimple [] wanteds `thenNF_Tc` \ irreds ->
+ = doptsTc dopt_GlasgowExts `thenNF_Tc` \ glaExts ->
+ reduceSimple [] wanteds `thenNF_Tc` \ irreds ->
let
-- 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)]
+ 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
\begin{code}
tcSimplifyCheckThetas :: ClassContext -- Given
-> ClassContext -- Wanted
- -> TcM s ()
+ -> TcM ()
tcSimplifyCheckThetas givens wanteds
= reduceSimple givens wanteds `thenNF_Tc` \ irreds ->
reduceSimple :: ClassContext -- Given
-> ClassContext -- Wanted
- -> NF_TcM s ClassContext -- Irreducible
+ -> NF_TcM ClassContext -- Irreducible
reduceSimple givens wanteds
= reduce_simple (0,[]) givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
reduce_simple :: (Int,ClassContext) -- Stack
-> AvailsSimple
-> ClassContext
- -> NF_TcM s AvailsSimple
+ -> NF_TcM AvailsSimple
reduce_simple (n,stack) avails wanteds
= go avails wanteds
@LIE@), as well as the @HsBinds@ generated.
\begin{code}
-bindInstsOfLocalFuns :: LIE -> [TcId] -> TcM s (LIE, TcMonoBinds)
+bindInstsOfLocalFuns :: LIE -> [TcId] -> TcM (LIE, TcMonoBinds)
bindInstsOfLocalFuns init_lie local_ids
| null overloaded_ids || null lie_for_here
all the constant and ambiguous Insts.
\begin{code}
-tcSimplifyTop :: LIE -> TcM s TcDictBinds
+tcSimplifyTop :: LIE -> TcM TcDictBinds
tcSimplifyTop wanted_lie
= reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) ->
ASSERT( null frees )
\begin{code}
disambigGroup :: [Inst] -- All standard classes of form (C a)
- -> TcM s TcDictBinds
+ -> TcM TcDictBinds
disambigGroup dicts
| any isNumericClass classes -- Guaranteed all standard classes
try_default default_tys `thenTc` \ chosen_default_ty ->
-- Bind the type variable and reduce the context, for real this time
- let
- chosen_default_tc_ty = typeToTcType chosen_default_ty -- Tiresome!
- in
- 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) ->
ASSERT( null frees && null ambigs )
(_, 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,