Commit 54f91886 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Refactor skolemising, and newClsInst

This makes newClsInst (was mkInstance) look more like newFamInst, and simplifies
the plumbing of the overlap flag, and ensures that freshening (required by
the InstEnv stuff) happens in one place.

On the way I also tided up the rather ragged family of tcInstSkolTyVars and
friends.  The result at least has more uniform naming.
parent 9c81db45
......@@ -56,21 +56,17 @@ newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcRnIf gbl lcl FamInst
-- Called from the vectoriser monad too, hence the rather general type
newFamInst flavor axiom@(CoAxiom { co_ax_branches = FirstBranch branch
, co_ax_tc = fam_tc })
= do { (subst, tvs') <- tcInstSigTyVarsLoc loc tvs
; return (FamInst { fi_fam = fam_tc_name
| CoAxBranch { cab_tvs = tvs
, cab_lhs = lhs
, cab_rhs = rhs } <- branch
= do { (subst, tvs') <- freshenTyVarBndrs tvs
; return (FamInst { fi_fam = tyConName fam_tc
, fi_flavor = flavor
, fi_tcs = roughMatchTcs lhs
, fi_tvs = tvs'
, fi_tys = substTys subst lhs
, fi_rhs = substTy subst rhs
, fi_axiom = axiom }) }
where
fam_tc_name = tyConName fam_tc
CoAxBranch { cab_loc = loc
, cab_tvs = tvs
, cab_lhs = lhs
, cab_rhs = rhs } = branch
\end{code}
......
......@@ -15,6 +15,7 @@ module Inst (
newOverloadedLit, mkOverLit,
newClsInst,
tcGetInsts, tcGetInstEnvs, getOverlapFlag,
tcExtendLocalInstEnv, instCallConstraints, newMethodFromName,
tcSyntaxName,
......@@ -44,6 +45,8 @@ import Type
import Coercion ( Role(..) )
import TcType
import HscTypes
import Class( Class )
import MkId( mkDictFunId )
import Id
import Name
import Var ( EvVar, varType, setVarType )
......@@ -383,18 +386,19 @@ syntaxNameCtxt name orig ty tidy_env
%************************************************************************
\begin{code}
getOverlapFlag :: TcM OverlapFlag
getOverlapFlag
getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
getOverlapFlag overlap_mode
= do { dflags <- getDynFlags
; let overlap_ok = xopt Opt_OverlappingInstances dflags
incoherent_ok = xopt Opt_IncoherentInstances dflags
use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
, overlapMode = x }
overlap_flag | incoherent_ok = use Incoherent
| overlap_ok = use Overlaps
| otherwise = use NoOverlap
default_oflag | incoherent_ok = use Incoherent
| overlap_ok = use Overlaps
| otherwise = use NoOverlap
; return overlap_flag }
final_oflag = setOverlapModeMaybe default_oflag overlap_mode
; return final_oflag }
tcGetInstEnvs :: TcM (InstEnv, InstEnv)
-- Gets both the external-package inst-env
......@@ -406,6 +410,22 @@ tcGetInsts :: TcM [ClsInst]
-- Gets the local class instances.
tcGetInsts = fmap tcg_insts getGblEnv
newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType
-> Class -> [Type] -> TcM ClsInst
newClsInst overlap_mode dfun_name tvs theta clas tys
= do { (subst, tvs') <- freshenTyVarBndrs tvs
-- Be sure to freshen those type variables,
-- so they are sure not to appear in any lookup
; let tys' = substTys subst tys
theta' = substTheta subst theta
dfun = mkDictFunId dfun_name tvs' theta' clas tys'
-- Substituting in the DFun type just makes sure that
-- we are using TyVars rather than TcTyVars
-- Not sure if this is really the right place to do so,
-- but it'll do fine
; oflag <- getOverlapFlag overlap_mode
; return (mkLocalInstance dfun oflag tvs' clas tys') }
tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
-- Add new locally-defined instances
tcExtendLocalInstEnv dfuns thing_inside
......
......@@ -39,12 +39,10 @@ import HscTypes
import Avail
import Unify( tcUnifyTy )
import Id( idType )
import Class
import Type
import Kind( isKind )
import ErrUtils
import MkId
import DataCon
import Maybes
import RdrName
......@@ -369,16 +367,15 @@ tcDeriving tycl_decls inst_decls deriv_decls
-- Generic1 should use the same TcGenGenerics.MetaTyCons)
; (commonAuxs, auxDerivStuff) <- commonAuxiliaries $ map forgetTheta early_specs
; overlap_flag <- getOverlapFlag
; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
; insts1 <- mapM (genInst True overlap_flag commonAuxs) given_specs
; insts1 <- mapM (genInst commonAuxs) given_specs
-- the stand-alone derived instances (@insts1@) are used when inferring
-- the contexts for "deriving" clauses' instances (@infer_specs@)
; final_specs <- extendLocalInstEnv (map (iSpec . fstOf3) insts1) $
inferInstanceContexts overlap_flag infer_specs
inferInstanceContexts infer_specs
; insts2 <- mapM (genInst False overlap_flag commonAuxs) final_specs
; insts2 <- mapM (genInst commonAuxs) final_specs
; let (inst_infos, deriv_stuff, maybe_fvs) = unzip3 (insts1 ++ insts2)
; loc <- getSrcSpanM
......@@ -1704,11 +1701,11 @@ ordered by sorting on type varible, tv, (major key) and then class, k,
\end{itemize}
\begin{code}
inferInstanceContexts :: OverlapFlag -> [DerivSpec ThetaOrigin] -> TcM [DerivSpec ThetaType]
inferInstanceContexts :: [DerivSpec ThetaOrigin] -> TcM [DerivSpec ThetaType]
inferInstanceContexts _ [] = return []
inferInstanceContexts [] = return []
inferInstanceContexts oflag infer_specs
inferInstanceContexts infer_specs
= do { traceTc "inferInstanceContexts" $ vcat (map pprDerivSpec infer_specs)
; iterate_deriv 1 initial_solutions }
where
......@@ -1734,7 +1731,7 @@ inferInstanceContexts oflag infer_specs
| otherwise
= do { -- Extend the inst info from the explicit instance decls
-- with the current set of solutions, and simplify each RHS
inst_specs <- zipWithM (mkInstance oflag) current_solns infer_specs
inst_specs <- zipWithM newDerivClsInst current_solns infer_specs
; new_solns <- checkNoErrs $
extendLocalInstEnv inst_specs $
mapM gen_soln infer_specs
......@@ -1767,15 +1764,10 @@ inferInstanceContexts oflag infer_specs
the_pred = mkClassPred clas inst_tys
------------------------------------------------------------------
mkInstance :: OverlapFlag -> ThetaType -> DerivSpec theta -> TcM ClsInst
mkInstance overlap_flag theta
(DS { ds_name = dfun_name
, ds_tvs = tvs, ds_cls = clas, ds_tys = tys })
= do { (subst, tvs') <- tcInstSkolTyVars tvs
; return (mkLocalInstance dfun overlap_flag tvs' clas (substTys subst tys)) }
where
dfun = mkDictFunId dfun_name tvs theta clas tys
newDerivClsInst :: ThetaType -> DerivSpec theta -> TcM ClsInst
newDerivClsInst theta (DS { ds_name = dfun_name, ds_overlap = overlap_mode
, ds_tvs = tvs, ds_cls = clas, ds_tys = tys })
= newClsInst overlap_mode dfun_name tvs theta clas tys
extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
-- Add new locally-defined instances; don't bother to check
......@@ -1989,18 +1981,15 @@ the renamer. What a great hack!
-- Representation tycons differ from the tycon in the instance signature in
-- case of instances for indexed families.
--
genInst :: Bool -- True <=> standalone deriving
-> OverlapFlag
-> CommonAuxiliaries
-> DerivSpec ThetaType
genInst :: CommonAuxiliaries
-> DerivSpec ThetaType
-> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name)
genInst _standalone_deriv default_oflag comauxs
genInst comauxs
spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args
, ds_theta = theta, ds_newtype = is_newtype, ds_tys = tys
, ds_overlap = overlap_mode
, ds_name = dfun_name, ds_cls = clas, ds_loc = loc })
| is_newtype -- See Note [Bindings for Generalised Newtype Deriving]
= do { inst_spec <- mkInstance oflag theta spec
= do { inst_spec <- newDerivClsInst theta spec
; traceTc "genInst/is_newtype" (vcat [ppr loc, ppr clas, ppr tvs, ppr tys, ppr rhs_ty])
; return ( InstInfo
{ iSpec = inst_spec
......@@ -2015,10 +2004,11 @@ genInst _standalone_deriv default_oflag comauxs
-- See Note [Newtype deriving and unused constructors]
| otherwise
= do { (meth_binds, deriv_stuff) <- genDerivStuff loc clas
= do { (meth_binds, deriv_stuff) <- genDerivStuff loc clas
dfun_name rep_tycon
(lookup rep_tycon comauxs)
; inst_spec <- mkInstance oflag theta spec
; inst_spec <- newDerivClsInst theta spec
; traceTc "newder" (ppr inst_spec)
; let inst_info = InstInfo { iSpec = inst_spec
, iBinds = InstBindings
{ ib_binds = meth_binds
......@@ -2027,7 +2017,6 @@ genInst _standalone_deriv default_oflag comauxs
, ib_derived = True } }
; return ( inst_info, deriv_stuff, Nothing ) }
where
oflag = setOverlapModeMaybe default_oflag overlap_mode
rhs_ty = newTyConInstRhs rep_tycon rep_tc_args
genDerivStuff :: SrcSpan -> Class -> Name -> TyCon
......
......@@ -538,15 +538,8 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
-- Dfun location is that of instance *header*
; overlap_flag <-
do defaultOverlapFlag <- getOverlapFlag
return $ setOverlapModeMaybe defaultOverlapFlag overlap_mode
; (subst, tyvars') <- tcInstSkolTyVars tyvars
; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys
ispec = mkLocalInstance dfun overlap_flag tyvars' clas (substTys subst inst_tys)
-- Be sure to freshen those type variables,
-- so they are sure not to appear in any lookup
inst_info = InstInfo { iSpec = ispec
; ispec <- newClsInst overlap_mode dfun_name tyvars theta clas inst_tys
; let inst_info = InstInfo { iSpec = ispec
, iBinds = InstBindings
{ ib_binds = binds
, ib_pragmas = uprags
......
......@@ -37,11 +37,13 @@ module TcMType (
-- Instantiation
tcInstTyVars, newSigTyVar,
tcInstType,
tcInstSkolTyVars, tcInstSuperSkolTyVars,tcInstSuperSkolTyVarsX,
tcInstSkolTyVars, tcInstSuperSkolTyVarsX,
tcInstSigTyVarsLoc, tcInstSigTyVars,
tcInstSkolTyVar, tcInstSkolType,
tcInstSkolType,
tcSkolDFunType, tcSuperSkolTyVars,
instSkolTyVars, freshenTyVarBndrs,
--------------------------------
-- Zonking
zonkTcPredType,
......@@ -195,10 +197,9 @@ tcInstType inst_tyvars ty
; return (tyvars', theta, tau) }
tcSkolDFunType :: Type -> TcM ([TcTyVar], TcThetaType, TcType)
-- Instantiate a type signature with skolem constants, but
-- do *not* give them fresh names, because we want the name to
-- be in the type environment: it is lexically scoped.
tcSkolDFunType ty = tcInstType (\tvs -> return (tcSuperSkolTyVars tvs)) ty
-- Instantiate a type signature with skolem constants.
-- We could give them fresh names, but no need to do so
tcSkolDFunType ty = tcInstType tcInstSuperSkolTyVars ty
tcSuperSkolTyVars :: [TyVar] -> (TvSubst, [TcTyVar])
-- Make skolem constants, but do *not* give them new names, as above
......@@ -214,73 +215,73 @@ tcSuperSkolTyVar subst tv
kind = substTy subst (tyVarKind tv)
new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv
tcInstSkolTyVar :: SrcSpan -> Bool -> TvSubst -> TyVar
-> TcRnIf gbl lcl (TvSubst, TcTyVar)
-- Instantiate the tyvar, using
-- * the occ-name and kind of the supplied tyvar,
-- * the unique from the monad,
-- * the location either from the tyvar (skol_info = SigSkol)
-- or from the monad (otherwise)
tcInstSkolTyVar loc overlappable subst tyvar
= do { uniq <- newUnique
; let new_name = mkInternalName uniq occ loc
new_tv = mkTcTyVar new_name kind (SkolemTv overlappable)
; return (extendTvSubst subst tyvar (mkTyVarTy new_tv), new_tv) }
where
old_name = tyVarName tyvar
occ = nameOccName old_name
kind = substTy subst (tyVarKind tyvar)
-- Wrappers
-- we need to be able to do this from outside the TcM monad:
tcInstSkolTyVars :: [TyVar] -> TcM (TvSubst, [TcTyVar])
tcInstSkolTyVars = tcInstSkolTyVarsX (mkTopTvSubst [])
tcInstSkolTyVars = tcInstSkolTyVars' False emptyTvSubst
tcInstSuperSkolTyVars :: [TyVar] -> TcM [TcTyVar]
tcInstSuperSkolTyVars = fmap snd . tcInstSkolTyVars' True (mkTopTvSubst [])
tcInstSuperSkolTyVars :: [TyVar] -> TcM (TvSubst, [TcTyVar])
tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTvSubst
tcInstSkolTyVarsX, tcInstSuperSkolTyVarsX
:: TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar])
tcInstSkolTyVarsX subst = tcInstSkolTyVars' False subst
tcInstSuperSkolTyVarsX subst = tcInstSkolTyVars' True subst
tcInstSuperSkolTyVarsX :: TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar])
tcInstSuperSkolTyVarsX subst = tcInstSkolTyVars' True subst
tcInstSkolTyVars' :: Bool -> TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar])
-- Precondition: tyvars should be ordered (kind vars first)
-- see Note [Kind substitution when instantiating]
-- Get the location from the monad; this is a complete freshening operation
tcInstSkolTyVars' isSuperSkol subst tvs
tcInstSkolTyVars' overlappable subst tvs
= do { loc <- getSrcSpanM
; mapAccumLM (tcInstSkolTyVar loc isSuperSkol) subst tvs }
; instSkolTyVarsX (mkTcSkolTyVar loc overlappable) subst tvs }
mkTcSkolTyVar :: SrcSpan -> Bool -> Unique -> Name -> Kind -> TcTyVar
mkTcSkolTyVar loc overlappable uniq old_name kind
= mkTcTyVar (mkInternalName uniq (getOccName old_name) loc)
kind
(SkolemTv overlappable)
tcInstSigTyVarsLoc :: SrcSpan -> [TyVar] -> TcRnIf gbl lcl (TvSubst, [TcTyVar])
-- We specify the location
tcInstSigTyVarsLoc loc = mapAccumLM (tcInstSkolTyVar loc False) (mkTopTvSubst [])
tcInstSigTyVarsLoc loc = instSkolTyVars (mkTcSkolTyVar loc False)
tcInstSigTyVars :: [TyVar] -> TcRnIf gbl lcl (TvSubst, [TcTyVar])
-- Get the location from the TyVar itself, not the monad
tcInstSigTyVars = mapAccumLM inst_tv (mkTopTvSubst [])
tcInstSigTyVars
= instSkolTyVars mk_tv
where
inst_tv subst tv = tcInstSkolTyVar (getSrcSpan tv) False subst tv
mk_tv uniq old_name kind
= mkTcTyVar (setNameUnique old_name uniq) kind (SkolemTv False)
tcInstSkolType :: TcType -> TcM ([TcTyVar], TcThetaType, TcType)
-- Instantiate a type with fresh skolem constants
-- Binding location comes from the monad
tcInstSkolType ty = tcInstType tcInstSkolTyVars ty
newSigTyVar :: Name -> Kind -> TcM TcTyVar
newSigTyVar name kind
= do { uniq <- newUnique
; let name' = setNameUnique name uniq
-- Use the same OccName so that the tidy-er
-- doesn't gratuitously rename 'a' to 'a0' etc
; details <- newMetaDetails SigTv
; return (mkTcTyVar name' kind details) }
------------------
freshenTyVarBndrs :: [TyVar] -> TcRnIf gbl lcl (TvSubst, [TyVar])
-- ^ Give fresh uniques to a bunch of TyVars, but they stay
-- as TyVars, rather than becoming TcTyVars
-- Used in FamInst.newFamInst, and Inst.newClsInst
freshenTyVarBndrs = instSkolTyVars mk_tv
where
mk_tv uniq old_name kind = mkTyVar (setNameUnique old_name uniq) kind
newMetaDetails :: MetaInfo -> TcM TcTyVarDetails
newMetaDetails info
= do { ref <- newMutVar Flexi
; untch <- getUntouchables
; return (MetaTv { mtv_info = info, mtv_ref = ref, mtv_untch = untch }) }
------------------
instSkolTyVars :: (Unique -> Name -> Kind -> TyVar)
-> [TyVar] -> TcRnIf gbl lcl (TvSubst, [TyVar])
instSkolTyVars mk_tv = instSkolTyVarsX mk_tv emptyTvSubst
instSkolTyVarsX :: (Unique -> Name -> Kind -> TyVar)
-> TvSubst -> [TyVar] -> TcRnIf gbl lcl (TvSubst, [TyVar])
instSkolTyVarsX mk_tv = mapAccumLM (instSkolTyVarX mk_tv)
instSkolTyVarX :: (Unique -> Name -> Kind -> TyVar)
-> TvSubst -> TyVar -> TcRnIf gbl lcl (TvSubst, TyVar)
instSkolTyVarX mk_tv subst tyvar
= do { uniq <- newUnique
; let new_tv = mk_tv uniq old_name kind
; return (extendTvSubst subst tyvar (mkTyVarTy new_tv), new_tv) }
where
old_name = tyVarName tyvar
kind = substTy subst (tyVarKind tyvar)
\end{code}
Note [Kind substitution when instantiating]
......@@ -318,6 +319,21 @@ newMetaTyVar meta_info kind
; details <- newMetaDetails meta_info
; return (mkTcTyVar name kind details) }
newSigTyVar :: Name -> Kind -> TcM TcTyVar
newSigTyVar name kind
= do { uniq <- newUnique
; let name' = setNameUnique name uniq
-- Use the same OccName so that the tidy-er
-- doesn't gratuitously rename 'a' to 'a0' etc
; details <- newMetaDetails SigTv
; return (mkTcTyVar name' kind details) }
newMetaDetails :: MetaInfo -> TcM TcTyVarDetails
newMetaDetails info
= do { ref <- newMutVar Flexi
; untch <- getUntouchables
; return (MetaTv { mtv_info = info, mtv_ref = ref, mtv_untch = untch }) }
cloneMetaTyVar :: TcTyVar -> TcM TcTyVar
cloneMetaTyVar tv
= ASSERT( isTcTyVar tv )
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment