+ Extending the instance environment
+%* *
+%************************************************************************
+
+\begin{code}
+tcExtendLocalInstEnv :: [DFunId] -> 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
+ ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
+ tcg_inst_env = inst_env' }
+ ; setGblEnv env' thing_inside }
+
+addInst :: DynFlags -> InstEnv -> DFunId -> 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 { -- 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 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')
+
+ -- Load imported instances, so that we report
+ -- duplicates correctly
+ ; pkg_ie <- loadImportedInsts cls tys'
+
+ -- Check functional dependencies
+ ; case checkFunDeps (pkg_ie, home_ie) dfun' of
+ Just dfuns -> funDepErr dfun dfuns
+ Nothing -> return ()
+
+ -- Check for duplicate instance decls
+ ; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys'
+ ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
+ isJust (tcMatchTys (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 ()
+
+ -- OK, now extend the envt
+ ; return (extendInstEnv home_ie dfun') }
+
+
+traceDFuns dfuns
+ = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
+ where
+ pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
+
+funDepErr dfun dfuns
+ = addDictLoc dfun $
+ addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
+ 2 (pprDFuns (dfun:dfuns)))
+dupInstErr dfun dup_dfun
+ = addDictLoc dfun $
+ addErr (hang (ptext SLIT("Duplicate instance declarations:"))
+ 2 (pprDFuns [dfun, dup_dfun]))
+
+addDictLoc dfun thing_inside
+ = setSrcSpan (mkSrcSpan loc loc) thing_inside
+ where
+ loc = getSrcLoc dfun
+\end{code}
+
+
+%************************************************************************
+%* *