module Inst (
Inst,
- pprDFuns, pprDictsTheta, pprDictsInFull, -- User error messages
+ pprInstances, pprDictsTheta, pprDictsInFull, -- User error messages
showLIE, pprInst, pprInsts, pprInstInFull, -- Debugging messages
tidyInsts, tidyMoreInsts,
- newDictsFromOld, newDicts, newDictsAtLoc, cloneDict,
- newOverloadedLit, newIPDict,
+ newDicts, newDictAtLoc, newDictsAtLoc, cloneDict,
+ shortCutFracLit, shortCutIntLit, newIPDict,
newMethod, newMethodFromName, newMethodWithGivenTy,
- tcInstClassOp, tcInstCall, tcInstStupidTheta,
- tcSyntaxName, tcStdSyntaxName,
+ tcInstClassOp, tcInstStupidTheta,
+ tcSyntaxName, isHsVar,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
instLoc, getDictClassTys, dictPred,
- lookupInst, LookupInstResult(..),
- tcExtendLocalInstEnv, tcGetInstEnvs,
+ lookupInst, LookupInstResult(..), lookupPred,
+ tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
isDict, isClassDict, isMethod,
isLinearInst, linearInstType, isIPDict, isInheritableInst,
- isTyVarDict, isStdClassTyVarDict, isMethodFor,
- instBindingRequired,
+ isTyVarDict, isMethodFor,
zonkInst, zonkInsts,
instToId, instName,
#include "HsVersions.h"
-import {-# SOURCE #-} TcExpr( tcCheckSigma )
-import {-# SOURCE #-} TcUnify ( unifyTauTy ) -- Used in checkKind (sigh)
+import {-# SOURCE #-} TcExpr( tcPolyExpr )
-import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp )
-import TcHsSyn ( TcId, TcIdSet,
- mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId,
- mkCoercion, ExprCoFn
- )
+import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp,
+ nlHsLit, nlHsVar )
+import TcHsSyn ( mkHsTyApp, mkHsDictApp, zonkId )
import TcRnMonad
import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
-import InstEnv ( DFunId, InstEnv, lookupInstEnv, checkFunDeps, extendInstEnv )
-import TcIface ( loadImportedInsts )
-import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType,
- zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
+import InstEnv ( DFunId, InstEnv, Instance(..), OverlapFlag(..),
+ lookupInstEnv, extendInstEnv, pprInstances,
+ instanceHead, instanceDFunId, setInstanceDFunId )
+import FunDeps ( checkFunDeps )
+import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType,
+ tcInstTyVar, tcInstSkolType
)
-import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcTyVar,
- PredType(..), typeKind,
- tcSplitForAllTys, tcSplitForAllTys,
- tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy,
+import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcPredType,
+ BoxyRhoType,
+ PredType(..), SkolemInfo(..), typeKind, mkSigmaTy,
+ tcSplitForAllTys, applyTys,
+ tcSplitPhiTy, tcSplitDFunHead,
isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
- tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
+ mkPredTy, mkTyVarTys,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
isClassPred, isTyVarClassPred, isLinearPred,
- getClassPredTys, getClassPredTys_maybe, mkPredName,
+ getClassPredTys, mkPredName,
isInheritablePred, isIPPred,
tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
- pprPred, pprParendType, pprThetaArrow, pprTheta, pprClassPred
+ pprPred, pprParendType, pprTheta
)
-import Type ( substTy, substTys, substTyWith, substTheta, zipTopTvSubst )
-import Unify ( matchTys )
+import Type ( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSubst,
+ notElemTvSubst, extendTvSubstList )
+import Unify ( tcMatchTys )
import Kind ( isSubKind )
+import Packages ( isHomeModule )
import HscTypes ( ExternalPackageState(..) )
import CoreFVs ( idFreeTyVars )
-import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName )
-import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
-import PrelInfo ( isStandardClass, isNoDictClass )
-import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName, isInternalName )
+import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName, dataConWrapId )
+import Id ( Id, idName, idType, mkUserLocal, mkLocalId )
+import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
+ isInternalName, setNameUnique )
import NameSet ( addOneToNameSet )
import Literal ( inIntRange )
-import Var ( TyVar, tyVarKind )
-import VarEnv ( TidyEnv, emptyTidyEnv, lookupVarEnv )
+import Var ( TyVar, tyVarKind, setIdType )
+import VarEnv ( TidyEnv, emptyTidyEnv )
import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
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 DynFlags ( DynFlag(..), dopt )
import Maybes ( isJust )
import Outputable
\end{code}
instName inst = idName (instToId inst)
instToId :: Inst -> TcId
-instToId (Dict id _ _) = id
-instToId (Method id _ _ _ _ _) = id
-instToId (LitInst id _ _ _) = id
+instToId (LitInst nm _ ty _) = mkLocalId nm ty
+instToId (Dict nm pred _) = mkLocalId nm (mkPredTy pred)
+instToId (Method id _ _ _ _) = id
-instLoc (Dict _ _ loc) = loc
-instLoc (Method _ _ _ _ _ loc) = loc
-instLoc (LitInst _ _ _ loc) = loc
+instLoc (Dict _ _ loc) = loc
+instLoc (Method _ _ _ _ loc) = loc
+instLoc (LitInst _ _ _ loc) = loc
dictPred (Dict _ pred _ ) = pred
dictPred inst = pprPanic "dictPred" (ppr inst)
-- Leaving these in is really important for the call to fdPredsOfInsts
-- in TcSimplify.inferLoop, because the result is fed to 'grow',
-- which is supposed to be conservative
-fdPredsOfInst (Dict _ pred _) = [pred]
-fdPredsOfInst (Method _ _ _ theta _ _) = theta
-fdPredsOfInst other = [] -- LitInsts etc
+fdPredsOfInst (Dict _ pred _) = [pred]
+fdPredsOfInst (Method _ _ _ theta _) = theta
+fdPredsOfInst other = [] -- LitInsts etc
fdPredsOfInsts :: [Inst] -> [PredType]
fdPredsOfInsts insts = concatMap fdPredsOfInst insts
-isInheritableInst (Dict _ pred _) = isInheritablePred pred
-isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
-isInheritableInst other = True
+isInheritableInst (Dict _ pred _) = isInheritablePred pred
+isInheritableInst (Method _ _ _ theta _) = all isInheritablePred theta
+isInheritableInst other = True
ipNamesOfInsts :: [Inst] -> [Name]
-- NB: ?x and %x get different Names
ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
-ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
-ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
-ipNamesOfInst other = []
+ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
+ipNamesOfInst (Method _ _ _ theta _) = [ipNameName n | IParam n _ <- theta]
+ipNamesOfInst other = []
tyVarsOfInst :: Inst -> TcTyVarSet
-tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
-tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
-tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
+tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
+tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
+tyVarsOfInst (Method _ id tys _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
-- The id might have free type variables; in the case of
-- locally-overloaded class methods, for example
isIPDict other = False
isMethod :: Inst -> Bool
-isMethod (Method _ _ _ _ _ _) = True
-isMethod other = False
+isMethod (Method {}) = True
+isMethod other = False
isMethodFor :: TcIdSet -> Inst -> Bool
-isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
-isMethodFor ids inst = False
+isMethodFor ids (Method uniq id tys _ loc) = id `elemVarSet` ids
+isMethodFor ids inst = False
isLinearInst :: Inst -> Bool
isLinearInst (Dict _ pred _) = isLinearPred pred
linearInstType :: Inst -> TcType -- %x::t --> t
linearInstType (Dict _ (IParam _ ty) _) = ty
-
-
-isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
- Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
- other -> False
\end{code}
-Two predicates which deal with the case where class constraints don't
-necessarily result in bindings. The first tells whether an @Inst@
-must be witnessed by an actual binding; the second tells whether an
-@Inst@ can be generalised over.
-
-\begin{code}
-instBindingRequired :: Inst -> Bool
-instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
-instBindingRequired other = True
-\end{code}
%************************************************************************
newDictsAtLoc loc theta
cloneDict :: Inst -> TcM Inst
-cloneDict (Dict id ty loc) = newUnique `thenM` \ uniq ->
- returnM (Dict (setIdUnique id uniq) ty loc)
+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 (mkLocalId (mkPredName uniq loc pred) (mkPredTy 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
let
pred = IParam ip_name ty
name = mkPredName uniq (instLocSrcLoc inst_loc) pred
- id = mkLocalId name (mkPredTy pred)
+ dict = Dict name pred inst_loc
in
- returnM (mapIPName (\n -> id) ip_name, Dict id pred inst_loc)
+ returnM (mapIPName (\n -> instToId dict) ip_name, dict)
\end{code}
\begin{code}
-tcInstCall :: InstOrigin -> TcType -> TcM (ExprCoFn, [TcTyVar], TcType)
-tcInstCall orig fun_ty -- fun_ty is usually a sigma-type
- = do { (tyvars, theta, tau) <- tcInstType fun_ty
- ; dicts <- newDicts orig theta
- ; extendLIEs dicts
- ; let inst_fn e = unLoc (mkHsDictApp (mkHsTyApp (noLoc e) (mkTyVarTys tyvars))
- (map instToId dicts))
- ; return (mkCoercion inst_fn, tyvars, tau) }
-
tcInstStupidTheta :: DataCon -> [TcType] -> TcM ()
-- Instantiate the "stupid theta" of the data con, and throw
-- the constraints into the constraint set
stupid_theta = dataConStupidTheta data_con
tenv = zipTopTvSubst (dataConTyVars data_con) inst_tys
-newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
+newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
newMethodFromName origin ty name
= tcLookupId name `thenM` \ id ->
-- Use tcLookupId not tcLookupGlobalId; the method is almost
extendLIE inst `thenM_`
returnM (instToId inst)
-newMethodWithGivenTy orig id tys theta tau
- = getInstLoc orig `thenM` \ loc ->
- newMethod loc id tys theta tau `thenM` \ inst ->
- extendLIE inst `thenM_`
+newMethodWithGivenTy orig id tys
+ = getInstLoc orig `thenM` \ loc ->
+ newMethod loc id tys `thenM` \ inst ->
+ extendLIE inst `thenM_`
returnM (instToId inst)
--------------------------------------------
tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
tcInstClassOp inst_loc sel_id tys
= let
- (tyvars,rho) = tcSplitForAllTys (idType sel_id)
- rho_ty = ASSERT( length tyvars == length tys )
- substTyWith tyvars tys rho
- (preds,tau) = tcSplitPhiTy rho_ty
+ (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
in
zipWithM_ checkKind tyvars tys `thenM_`
- newMethod inst_loc sel_id tys preds tau
+ newMethod inst_loc sel_id tys
checkKind :: TyVar -> TcType -> TcM ()
-- Ensure that the type has a sub-kind of the tyvar
checkKind tv ty
- = do { ty1 <- zonkTcType ty
+ = do { let ty1 = ty
+ -- ty1 <- zonkTcType ty
; if typeKind ty1 `isSubKind` tyVarKind tv
then return ()
- else do
- { traceTc (text "checkKind: adding kind constraint" <+> ppr tv <+> ppr ty)
- ; tv1 <- tcInstTyVar tv
- ; unifyTauTy (mkTyVarTy tv1) ty1 }}
+ else
+
+ pprPanic "checkKind: adding kind constraint"
+ (vcat [ppr tv <+> ppr (tyVarKind tv),
+ ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
+ }
+-- do { tv1 <- tcInstTyVar tv
+-- ; unifyType ty1 (mkTyVarTy tv1) } }
---------------------------
-newMethod inst_loc id tys theta tau
+newMethod inst_loc id tys
= newUnique `thenM` \ new_uniq ->
let
- meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
- inst = Method meth_id id tys theta tau inst_loc
- loc = instLocSrcLoc inst_loc
+ (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
+ meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
+ inst = Method meth_id id tys theta inst_loc
+ loc = instLocSrcLoc inst_loc
in
returnM inst
\end{code}
-In newOverloadedLit we convert directly to an Int or Integer if we
-know that's what we want. This may save some time, by not
-temporarily generating overloaded literals, but it won't catch all
-cases (the rest are caught in lookupInst).
-
\begin{code}
-newOverloadedLit :: InstOrigin
- -> HsOverLit
- -> TcType
- -> TcM (LHsExpr TcId)
-newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
- | fi /= fromIntegerName -- Do not generate a LitInst for rebindable syntax.
- -- Reason: tcSyntaxName does unification
- -- which is very inconvenient in tcSimplify
- -- ToDo: noLoc sadness
- = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi) `thenM` \ (_,expr) ->
- mkIntegerLit i `thenM` \ integer_lit ->
- returnM (mkHsApp (noLoc expr) integer_lit)
- -- The mkHsApp will get the loc from the literal
- | Just expr <- shortCutIntLit i expected_ty
- = returnM expr
-
- | otherwise
- = newLitInst orig lit expected_ty
-
-newOverloadedLit orig lit@(HsFractional r fr) expected_ty
- | fr /= fromRationalName -- c.f. HsIntegral case
- = tcSyntaxName orig expected_ty (fromRationalName, HsVar fr) `thenM` \ (_,expr) ->
- mkRatLit r `thenM` \ rat_lit ->
- returnM (mkHsApp (noLoc expr) rat_lit)
- -- The mkHsApp will get the loc from the literal
-
- | Just expr <- shortCutFracLit r expected_ty
- = returnM expr
-
- | otherwise
- = newLitInst orig lit expected_ty
-
-newLitInst :: InstOrigin -> HsOverLit -> TcType -> TcM (LHsExpr TcId)
-newLitInst orig lit expected_ty
- = getInstLoc orig `thenM` \ loc ->
- newUnique `thenM` \ new_uniq ->
- let
- lit_inst = LitInst lit_id lit expected_ty loc
- lit_id = mkSysLocal FSLIT("lit") new_uniq expected_ty
- in
- extendLIE lit_inst `thenM_`
- returnM (L (instLocSrcSpan loc) (HsVar (instToId lit_inst)))
-
-shortCutIntLit :: Integer -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
+shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
shortCutIntLit i ty
| isIntTy ty && inIntRange i -- Short cut for Int
- = Just (noLoc (HsLit (HsInt i)))
+ = Just (HsLit (HsInt i))
| isIntegerTy ty -- Short cut for Integer
- = Just (noLoc (HsLit (HsInteger i ty)))
+ = Just (HsLit (HsInteger i ty))
| otherwise = Nothing
-shortCutFracLit :: Rational -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
+shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
shortCutFracLit f ty
| isFloatTy ty
- = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
+ = Just (mk_lit floatDataCon (HsFloatPrim f))
| isDoubleTy ty
- = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
+ = Just (mk_lit doubleDataCon (HsDoublePrim f))
| otherwise = Nothing
+ where
+ mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
mkIntegerLit i
= tcMetaTy rationalTyConName `thenM` \ rat_ty ->
getSrcSpanM `thenM` \ span ->
returnM (L span $ HsLit (HsRat r rat_ty))
+
+isHsVar :: HsExpr Name -> Name -> Bool
+isHsVar (HsVar f) g = f==g
+isHsVar other g = False
\end{code}
%* *
%************************************************************************
-Zonking makes sure that the instance types are fully zonked,
-but doesn't do the same for any of the Ids in an Inst. There's no
-need, and it's a lot of extra work.
+Zonking makes sure that the instance types are fully zonked.
\begin{code}
zonkInst :: Inst -> TcM Inst
-zonkInst (Dict id pred loc)
+zonkInst (Dict name pred loc)
= zonkTcPredType pred `thenM` \ new_pred ->
- returnM (Dict id new_pred loc)
+ returnM (Dict name new_pred loc)
-zonkInst (Method m id tys theta tau loc)
+zonkInst (Method m id tys theta loc)
= zonkId id `thenM` \ new_id ->
-- Essential to zonk the id in case it's a local variable
-- Can't use zonkIdOcc because the id might itself be
zonkTcTypes tys `thenM` \ new_tys ->
zonkTcThetaType theta `thenM` \ new_theta ->
- zonkTcType tau `thenM` \ new_tau ->
- returnM (Method m new_id new_tys new_theta new_tau loc)
+ returnM (Method m new_id new_tys new_theta loc)
-zonkInst (LitInst id lit ty loc)
+zonkInst (LitInst nm lit ty loc)
= zonkTcType ty `thenM` \ new_ty ->
- returnM (LitInst id lit new_ty loc)
+ returnM (LitInst nm lit new_ty loc)
zonkInsts insts = mappM zonkInst insts
\end{code}
pprInst, pprInstInFull :: Inst -> SDoc
-- Debugging: print the evidence :: type
-pprInst (LitInst id lit ty loc) = ppr id <+> dcolon <+> ppr ty
-pprInst (Dict id pred loc) = ppr id <+> dcolon <+> pprPred pred
+pprInst (LitInst nm lit ty loc) = ppr nm <+> dcolon <+> ppr ty
+pprInst (Dict nm pred loc) = ppr nm <+> dcolon <+> pprPred pred
-pprInst m@(Method inst_id id tys theta tau loc)
+pprInst m@(Method inst_id id tys theta loc)
= ppr inst_id <+> dcolon <+>
braces (sep [ppr id <+> ptext SLIT("at"),
brackets (sep (map pprParendType tys))])
pprInstInFull inst
= sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
-pprDFuns :: [DFunId] -> SDoc
--- Prints the dfun as an instance declaration
-pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon)
- 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta,
- pprClassPred clas tys])
- | dfun <- dfuns
- , let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ]
- -- Print without the for-all, which the programmer doesn't write
-
tidyInst :: TidyEnv -> Inst -> Inst
-tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc
-tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc
-tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
+tidyInst env (LitInst nm lit ty loc) = LitInst nm lit (tidyType env ty) loc
+tidyInst env (Dict nm pred loc) = Dict nm (tidyPred env pred) loc
+tidyInst env (Method u id tys theta loc) = Method u id (tidyTypes env tys) theta loc
tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
-- This function doesn't assume that the tyvars are in scope
%************************************************************************
\begin{code}
-tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
+tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
-- Add new locally-defined instances
tcExtendLocalInstEnv dfuns thing_inside
= do { traceDFuns dfuns
; env <- getGblEnv
- ; dflags <- getDOpts
- ; inst_env' <- foldlM (addInst dflags) (tcg_inst_env env) dfuns
+ ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
tcg_inst_env = inst_env' }
; setGblEnv env' thing_inside }
-addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv
+addLocalInst :: InstEnv -> Instance -> TcM InstEnv
-- Check that the proposed new instance is OK,
-- and then add it to the home inst env
-addInst dflags home_ie dfun
- = do { -- Load imported instances, so that we report
+addLocalInst home_ie ispec
+ = do { -- Instantiate the dfun type so that we extend the instance
+ -- envt with completely fresh template variables
+ -- This is important because the template variables must
+ -- not overlap with anything in the things being looked up
+ -- (since we do unification).
+ -- We use tcInstSkolType because we don't want to allocate fresh
+ -- *meta* type variables.
+ let dfun = instanceDFunId ispec
+ ; (tvs', theta', tau') <- tcInstSkolType (InstSkol dfun) (idType dfun)
+ ; let (cls, tys') = tcSplitDFunHead tau'
+ dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
+ ispec' = setInstanceDFunId ispec dfun'
+
+ -- Load imported instances, so that we report
-- duplicates correctly
- let (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
- ; pkg_ie <- loadImportedInsts cls tys
+ ; eps <- getEps
+ ; let inst_envs = (eps_inst_env eps, home_ie)
-- Check functional dependencies
- ; case checkFunDeps (pkg_ie, home_ie) dfun of
- Just dfuns -> funDepErr dfun dfuns
+ ; case checkFunDeps inst_envs ispec' of
+ Just specs -> funDepErr ispec' specs
Nothing -> return ()
-- Check for duplicate instance decls
- -- We instantiate the dfun type because the instance lookup
- -- requires nice fresh types in the thing to be looked up
- ; (tvs', _, tenv) <- tcInstTyVars tvs
- ; let { tys' = substTys tenv tys
- ; (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys'
- ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
- isJust (matchTys (mkVarSet tvs) tys' dup_tys)] }
- -- Find memebers of the match list which
- -- dfun itself matches. If the match is 2-way, it's a duplicate
- ; case dup_dfuns of
- dup_dfun : _ -> dupInstErr dfun dup_dfun
- [] -> return ()
+ ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
+ ; dup_ispecs = [ dup_ispec
+ | (_, dup_ispec) <- matches
+ , let (_,_,_,dup_tys) = instanceHead dup_ispec
+ , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
+ -- Find memebers of the match list which ispec itself matches.
+ -- If the match is 2-way, it's a duplicate
+ ; case dup_ispecs of
+ dup_ispec : _ -> dupInstErr ispec' dup_ispec
+ [] -> return ()
-- OK, now extend the envt
- ; return (extendInstEnv home_ie dfun) }
-
-
-traceDFuns dfuns
- = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
+ ; return (extendInstEnv home_ie ispec') }
+
+getOverlapFlag :: TcM OverlapFlag
+getOverlapFlag
+ = do { dflags <- getDOpts
+ ; let overlap_ok = dopt Opt_AllowOverlappingInstances dflags
+ incoherent_ok = dopt Opt_AllowIncoherentInstances dflags
+ overlap_flag | incoherent_ok = Incoherent
+ | overlap_ok = OverlapOk
+ | otherwise = NoOverlap
+
+ ; return overlap_flag }
+
+traceDFuns ispecs
+ = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
where
- pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
+ pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
+ -- Print the dfun name itself too
-funDepErr dfun dfuns
- = addDictLoc dfun $
+funDepErr ispec ispecs
+ = addDictLoc ispec $
addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
- 2 (pprDFuns (dfun:dfuns)))
-dupInstErr dfun dup_dfun
- = addDictLoc dfun $
+ 2 (pprInstances (ispec:ispecs)))
+dupInstErr ispec dup_ispec
+ = addDictLoc ispec $
addErr (hang (ptext SLIT("Duplicate instance declarations:"))
- 2 (pprDFuns [dfun, dup_dfun]))
+ 2 (pprInstances [ispec, dup_ispec]))
-addDictLoc dfun thing_inside
+addDictLoc ispec thing_inside
= setSrcSpan (mkSrcSpan loc loc) thing_inside
where
- loc = getSrcLoc dfun
+ loc = getSrcLoc ispec
\end{code}
+
%************************************************************************
%* *
%************************************************************************
\begin{code}
-data LookupInstResult s
+data LookupInstResult
= NoInstance
| SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal
| GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts
-lookupInst :: Inst -> TcM (LookupInstResult s)
+lookupInst :: Inst -> TcM LookupInstResult
-- It's important that lookupInst does not put any new stuff into
-- the LIE. Instead, any Insts needed by the lookup are returned in
-- the LookupInstResult, where they can be further processed by tcSimplify
-- Methods
-lookupInst inst@(Method _ id tys theta _ loc)
+lookupInst inst@(Method _ id tys theta loc)
= newDictsAtLoc loc theta `thenM` \ dicts ->
returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts)))
where
-- Look for short cuts first: if the literal is *definitely* a
-- int, integer, float or a double, generate the real thing here.
--- This is essential (see nofib/spectral/nucleic).
+-- This is essential (see nofib/spectral/nucleic).
-- [Same shortcut as in newOverloadedLit, but we
-- may have done some unification by now]
-
-lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
+lookupInst inst@(LitInst _nm (HsIntegral i from_integer_name) ty loc)
| Just expr <- shortCutIntLit i ty
- = returnM (GenInst [] expr) -- GenInst, not SimpleInst, because
+ = returnM (GenInst [] (noLoc expr)) -- GenInst, not SimpleInst, because
-- expr may be a constructor application
| otherwise
- = ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant
+ = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant
tcLookupId fromIntegerName `thenM` \ from_integer ->
tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
mkIntegerLit i `thenM` \ integer_lit ->
(mkHsApp (L (instLocSrcSpan loc)
(HsVar (instToId method_inst))) integer_lit))
-lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
+lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
| Just expr <- shortCutFracLit f ty
- = returnM (GenInst [] expr)
+ = returnM (GenInst [] (noLoc expr))
| otherwise
- = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
+ = ASSERT( from_rat_name `isHsVar` fromRationalName ) -- A LitInst invariant
tcLookupId fromRationalName `thenM` \ from_rational ->
tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
mkRatLit f `thenM` \ rat_lit ->
(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 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_`
+ { 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 mk_ty_arg to instantiate any un-substituted tyvars.
- getStage `thenM` \ use_stage ->
- checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
- (topIdLvl dfun_id) use_stage `thenM_`
- let
- (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
- mk_ty_arg tv = case lookupVarEnv tenv tv of
- Just ty -> returnM ty
- Nothing -> tcInstTyVar tv `thenM` \ tc_tv ->
- returnM (mkTyVarTy tc_tv)
- in
- mappM mk_ty_arg tyvars `thenM` \ ty_args ->
- let
- dfun_rho = substTy (zipTopTvSubst tyvars ty_args) rho
- -- Since the tyvars are freshly made,
- -- they cannot possibly be captured by
- -- any existing for-alls. Hence zipTopTyVarSubst
+ -- Hence the open_tvs to instantiate any un-substituted tyvars.
+ ; 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 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)) ty_args
- in
- if null theta then
+ ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id))
+ (map (substTyVar tenv') tyvars)
+ ; 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
- | isInternalName dfun_name = return () -- From this module
- | not (isHomePackageName dfun_name) = return () -- From another package package
- | otherwise = getGblEnv `thenM` \ tcg_env ->
- updMutVar (tcg_inst_uses tcg_env)
- (`addOneToNameSet` idName dfun_id)
- where
- dfun_name = 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 { eps <- getEps
+ ; tcg_env <- getGblEnv
+ ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
+ ; case lookupInstEnv inst_envs clas tys of {
+ ([(tenv, ispec)], [])
+ -> do { let dfun_id = is_dfun ispec
+ ; 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 { gbl <- getGblEnv
+ ; let dfun_name = idName dfun_id
+ dfun_mod = nameModule dfun_name
+ ; if isInternalName dfun_name || -- Internal name => defined in this module
+ not (isHomeModule (tcg_home_mods gbl) 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
%* *
%************************************************************************
-
Suppose we are doing the -fno-implicit-prelude thing, and we encounter
a do-expression. We have to find (>>) in the current environment, which is
done by the rename. Then we have to check that it has the same type as
-> TcType -- Type to instantiate it at
-> (Name, HsExpr Name) -- (Standard name, user name)
-> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
-
+-- *** NOW USED ONLY FOR CmdTop (sigh) ***
-- NB: tcSyntaxName calls tcExpr, and hence can do unification.
-- So we do not call it from lookupInst, which is called from tcSimplify
tcSyntaxName orig ty (std_nm, HsVar user_nm)
| std_nm == user_nm
- = tcStdSyntaxName orig ty std_nm
+ = newMethodFromName orig ty std_nm `thenM` \ id ->
+ returnM (std_nm, HsVar id)
tcSyntaxName orig ty (std_nm, user_nm_expr)
= tcLookupId std_nm `thenM` \ std_id ->
-- same type as the standard one.
-- Tiresome jiggling because tcCheckSigma takes a located expression
getSrcSpanM `thenM` \ span ->
- tcCheckSigma (L span user_nm_expr) sigma1 `thenM` \ expr ->
+ tcPolyExpr (L span user_nm_expr) sigma1 `thenM` \ expr ->
returnM (std_nm, unLoc expr)
-tcStdSyntaxName :: InstOrigin
- -> TcType -- Type to instantiate it at
- -> Name -- Standard name
- -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
-
-tcStdSyntaxName orig ty std_nm
- = newMethodFromName orig ty std_nm `thenM` \ id ->
- returnM (std_nm, HsVar id)
-
syntaxNameCtxt name orig ty tidy_env
= getInstLoc orig `thenM` \ inst_loc ->
let
projects / ghc-hetmet.git / blobdiff