tidyInsts, tidyMoreInsts,
- newDictsFromOld, newDicts, newDictsAtLoc, cloneDict,
+ newDicts, newDictAtLoc, newDictsAtLoc, cloneDict,
newOverloadedLit, newIPDict,
newMethod, newMethodFromName, newMethodWithGivenTy,
tcInstClassOp, tcInstCall, tcInstStupidTheta,
ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
instLoc, getDictClassTys, dictPred,
- lookupInst, LookupInstResult(..),
+ lookupInst, LookupInstResult(..), lookupPred,
tcExtendLocalInstEnv, tcGetInstEnvs,
isDict, isClassDict, isMethod,
import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
import InstEnv ( DFunId, InstEnv, lookupInstEnv, checkFunDeps, extendInstEnv )
import TcIface ( loadImportedInsts )
-import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType,
- zonkTcThetaType, tcInstTyVar, tcInstType
+import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType,
+ tcInstTyVar, tcInstType, tcSkolType
)
import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcTyVar, TcPredType,
- PredType(..), typeKind, mkSigmaTy,
+ PredType(..), SkolemInfo(..), typeKind, mkSigmaTy,
tcSplitForAllTys, tcSplitForAllTys,
tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy, tcSplitDFunHead,
isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
import Unify ( tcMatchTys )
import Kind ( isSubKind )
import Packages ( isHomeModule )
-import HscTypes ( HscEnv( hsc_HPT ), ExternalPackageState(..),
- ModDetails( md_insts ), HomeModInfo( hm_details ) )
+import HscTypes ( ExternalPackageState(..) )
import CoreFVs ( idFreeTyVars )
import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName )
import Id ( Id, idName, idType, mkUserLocal, mkLocalId )
import PrelInfo ( isStandardClass, isNoDictClass )
import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
- isInternalName, setNameUnique, mkSystemNameEncoded )
+ isInternalName, setNameUnique, mkSystemVarNameEncoded )
import NameSet ( addOneToNameSet )
import Literal ( inIntRange )
import Var ( TyVar, tyVarKind, setIdType )
import VarEnv ( TidyEnv, emptyTidyEnv )
import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
-import Module ( moduleEnvElts, elemModuleEnv, lookupModuleEnv )
import TysWiredIn ( floatDataCon, doubleDataCon )
import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
import BasicTypes( IPName(..), mapIPName, ipNameName )
import UniqSupply( uniqsFromSupply )
import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) )
-import CmdLineOpts( DynFlags )
-import Maybes ( isJust, fromJust )
+import DynFlags( DynFlags )
+import Maybes ( isJust )
import Outputable
\end{code}
cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq ->
returnM (Dict (setNameUnique nm uniq) ty loc)
-newDictsFromOld :: Inst -> TcThetaType -> TcM [Inst]
-newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
+newDictAtLoc :: InstLoc -> TcPredType -> TcM Inst
+newDictAtLoc inst_loc pred
+ = do { uniq <- newUnique
+ ; return (mkDict inst_loc uniq pred) }
--- Local function, similar to newDicts,
--- but with slightly different interface
-newDictsAtLoc :: InstLoc
- -> TcThetaType
- -> TcM [Inst]
+newDictsAtLoc :: InstLoc -> TcThetaType -> TcM [Inst]
newDictsAtLoc inst_loc theta
= newUniqueSupply `thenM` \ us ->
- returnM (zipWith mk_dict (uniqsFromSupply us) theta)
+ returnM (zipWith (mkDict inst_loc) (uniqsFromSupply us) theta)
+
+mkDict inst_loc uniq pred
+ = Dict name pred inst_loc
where
- mk_dict uniq pred = Dict (mkPredName uniq loc pred)
- pred inst_loc
- loc = instLocSrcLoc inst_loc
+ name = mkPredName uniq (instLocSrcLoc inst_loc) pred
-- For vanilla implicit parameters, there is only one in scope
-- at any time, so we used to use the name of the implicit parameter itself
= getInstLoc orig `thenM` \ loc ->
newUnique `thenM` \ new_uniq ->
let
- lit_nm = mkSystemNameEncoded new_uniq FSLIT("lit")
+ lit_nm = mkSystemVarNameEncoded new_uniq FSLIT("lit")
-- The "encoded" bit means that we don't need to z-encode
-- the string every time we call this!
lit_inst = LitInst lit_nm lit expected_ty loc
addInst dflags home_ie dfun
= do { -- Instantiate the dfun type so that we extend the instance
-- envt with completely fresh template variables
- (tvs', theta', tau') <- tcInstType (idType dfun)
+ -- This is important because the template variables must
+ -- not overlap with anything in the things being looked up
+ -- (since we do unification).
+ -- We use tcSkolType because we don't want to allocate fresh
+ -- *meta* type variables.
+ (tvs', theta', tau') <- tcSkolType (InstSkol dfun) (idType dfun)
; let (cls, tys') = tcSplitDFunHead tau'
dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
(HsVar (instToId method_inst))) rat_lit))
-- Dictionaries
-lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
- = do { pkg_ie <- loadImportedInsts clas tys
- -- Suck in any instance decls that may be relevant
- ; tcg_env <- getGblEnv
- ; dflags <- getDOpts
- ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
- ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ;
- (matches, unifs) -> do
- { traceTc (text "lookupInst fail" <+> vcat [text "dict" <+> ppr pred,
- text "matches" <+> ppr matches,
- text "unifs" <+> ppr unifs])
- ; return NoInstance } } }
- -- In the case of overlap (multiple matches) we report
- -- NoInstance here. That has the effect of making the
- -- context-simplifier return the dict as an irreducible one.
- -- Then it'll be given to addNoInstanceErrs, which will do another
- -- lookupInstEnv to get the detailed info about what went wrong.
-
-lookupInst (Dict _ _ _) = returnM NoInstance
-
------------------
-instantiate_dfun :: TvSubst -> DFunId -> TcPredType -> InstLoc -> TcM LookupInstResult
-instantiate_dfun tenv dfun_id pred loc
- = -- tenv is a substitution that instantiates the dfun_id
- -- to match the requested result type. However, the dfun
- -- might have some tyvars that only appear in arguments
+lookupInst (Dict _ pred loc)
+ = do { mb_result <- lookupPred pred
+ ; case mb_result of {
+ Nothing -> return NoInstance ;
+ Just (tenv, dfun_id) -> do
+
+ -- tenv is a substitution that instantiates the dfun_id
+ -- to match the requested result type.
+ --
+ -- We ASSUME that the dfun is quantified over the very same tyvars
+ -- that are bound by the tenv.
+ --
+ -- However, the dfun
+ -- might have some tyvars that *only* appear in arguments
-- dfun :: forall a b. C a b, Ord b => D [a]
-- We instantiate b to a flexi type variable -- it'll presumably
-- become fixed later via functional dependencies
- traceTc (text "lookupInst success" <+>
- vcat [text "dict" <+> ppr pred,
- text "witness" <+> ppr dfun_id <+> ppr (idType dfun_id) ]) `thenM_`
- -- Record that this dfun is needed
- record_dfun_usage dfun_id `thenM_`
-
- getStage `thenM` \ use_stage ->
- checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
- (topIdLvl dfun_id) use_stage `thenM_`
+ { use_stage <- getStage
+ ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
+ (topIdLvl dfun_id) use_stage
-- It's possible that not all the tyvars are in
-- the substitution, tenv. For example:
-- instance C X a => D X where ...
-- (presumably there's a functional dependency in class C)
-- Hence the open_tvs to instantiate any un-substituted tyvars.
- let
- (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
- open_tvs = filter (`notElemTvSubst` tenv) tyvars
- in
- mappM tcInstTyVar open_tvs `thenM` \ open_tvs' ->
- let
+ ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
+ open_tvs = filter (`notElemTvSubst` tenv) tyvars
+ ; open_tvs' <- mappM tcInstTyVar open_tvs
+ ; let
tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
- -- Since the tyvars are freshly made, they cannot possibly be captured by
+ -- Since the open_tvs' are freshly made, they cannot possibly be captured by
-- any nested for-alls in rho. So the in-scope set is unchanged
dfun_rho = substTy tenv' rho
(theta, _) = tcSplitPhiTy dfun_rho
ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id))
(map (substTyVar tenv') tyvars)
- in
- if null theta then
+ ; if null theta then
returnM (SimpleInst ty_app)
- else
- newDictsAtLoc loc theta `thenM` \ dicts ->
- let
- rhs = mkHsDictApp ty_app (map instToId dicts)
- in
- returnM (GenInst dicts rhs)
-
-record_dfun_usage dfun_id = do
- dflags <- getDOpts
- let dfun_name = idName dfun_id
- dfun_mod = nameModule dfun_name
- if isInternalName dfun_name || not (isHomeModule dflags dfun_mod)
- then return () -- internal, or in another package
- else do tcg_env <- getGblEnv
- updMutVar (tcg_inst_uses tcg_env)
- (`addOneToNameSet` idName dfun_id)
+ else do
+ { dicts <- newDictsAtLoc loc theta
+ ; let rhs = mkHsDictApp ty_app (map instToId dicts)
+ ; returnM (GenInst dicts rhs)
+ }}}}
+
+---------------
+lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
+-- Look up a class constraint in the instance environment
+lookupPred pred@(ClassP clas tys)
+ = do { pkg_ie <- loadImportedInsts clas tys
+ -- Suck in any instance decls that may be relevant
+ ; tcg_env <- getGblEnv
+ ; dflags <- getDOpts
+ ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
+ ([(tenv, (_,_,dfun_id))], [])
+ -> do { traceTc (text "lookupInst success" <+>
+ vcat [text "dict" <+> ppr pred,
+ text "witness" <+> ppr dfun_id
+ <+> ppr (idType dfun_id) ])
+ -- Record that this dfun is needed
+ ; record_dfun_usage dfun_id
+ ; return (Just (tenv, dfun_id)) } ;
+
+ (matches, unifs)
+ -> do { traceTc (text "lookupInst fail" <+>
+ vcat [text "dict" <+> ppr pred,
+ text "matches" <+> ppr matches,
+ text "unifs" <+> ppr unifs])
+ -- In the case of overlap (multiple matches) we report
+ -- NoInstance here. That has the effect of making the
+ -- context-simplifier return the dict as an irreducible one.
+ -- Then it'll be given to addNoInstanceErrs, which will do another
+ -- lookupInstEnv to get the detailed info about what went wrong.
+ ; return Nothing }
+ }}
+
+lookupPred ip_pred = return Nothing
+
+record_dfun_usage dfun_id
+ = do { dflags <- getDOpts
+ ; let dfun_name = idName dfun_id
+ dfun_mod = nameModule dfun_name
+ ; if isInternalName dfun_name || not (isHomeModule dflags dfun_mod)
+ then return () -- internal, or in another package
+ else do { tcg_env <- getGblEnv
+ ; updMutVar (tcg_inst_uses tcg_env)
+ (`addOneToNameSet` idName dfun_id) }}
+
tcGetInstEnvs :: TcM (InstEnv, InstEnv)
-- Gets both the external-package inst-env
projects / ghc-hetmet.git / blobdiff