1 \section[FamInst]{The @FamInst@ type: family instance heads}
5 tcExtendLocalFamInstEnv
8 #include "HsVersions.h"
10 import HscTypes ( ExternalPackageState(..) )
11 import FamInstEnv ( FamInstEnv, FamInst(..), famInstTyCon, extendFamInstEnv,
12 pprFamInst, pprFamInsts )
13 import TcMType ( tcInstSkolType )
14 import TcType ( SkolemInfo(..), tcSplitTyConApp )
15 import TcRnMonad ( TcM, TcGblEnv(..), setGblEnv, getGblEnv, foldlM,
16 setSrcSpan, addErr, getEps )
17 import TyCon ( tyConFamInst_maybe )
18 import Type ( mkTyConApp )
19 import Name ( getSrcLoc )
20 import SrcLoc ( mkSrcSpan )
25 %************************************************************************
27 Extending the family instance environment
29 %************************************************************************
33 -- Add new locally-defined family instances
34 tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
35 tcExtendLocalFamInstEnv fam_insts thing_inside
36 = do { env <- getGblEnv
37 ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts
38 ; let env' = env { tcg_fam_insts = fam_insts ++ tcg_fam_insts env,
39 tcg_fam_inst_env = inst_env' }
40 ; setGblEnv env' thing_inside }
43 -- Check that the proposed new instance is OK,
44 -- and then add it to the home inst env
45 addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv
46 addLocalFamInst home_fie famInst
47 = do { -- To instantiate the family instance type, extend the instance
48 -- envt with completely fresh template variables
49 -- This is important because the template variables must
50 -- not overlap with anything in the things being looked up
51 -- (since we do unification).
52 -- We use tcInstSkolType because we don't want to allocate
53 -- fresh *meta* type variables.
54 let tycon = famInstTyCon famInst
55 ty = case tyConFamInst_maybe tycon of
56 Nothing -> panic "FamInst.addLocalFamInst"
57 Just (tc, tys) -> tc `mkTyConApp` tys
58 ; (tvs', theta', tau') <- tcInstSkolType (FamInstSkol tycon) ty
60 ; let (fam, tys') = tcSplitTyConApp tau'
62 -- Load imported instances, so that we report
65 ; let inst_envs = (eps_fam_inst_env eps, home_fie)
67 {- !!!TODO: Need to complete this:
68 -- Check for overlapping instance decls
69 ; let { (matches, _) = lookupFamInstEnv inst_envs fam tys'
70 ; dup_ispecs = [ dup_ispec --!!!adapt
71 | (_, dup_ispec) <- matches
72 , let (_,_,_,dup_tys) = instanceHead dup_ispec
73 , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
74 -- Find memebers of the match list which ispec itself matches.
75 -- If the match is 2-way, it's a duplicate
77 dup_ispec : _ -> dupInstErr famInst dup_ispec
81 -- OK, now extend the envt
82 ; return (extendFamInstEnv home_fie famInst) }
84 overlapErr famInst dupFamInst
85 = addFamInstLoc famInst $
86 addErr (hang (ptext SLIT("Overlapping family instance declarations:"))
87 2 (pprFamInsts [famInst, dupFamInst]))
89 addFamInstLoc famInst thing_inside
90 = setSrcSpan (mkSrcSpan loc loc) thing_inside
92 loc = getSrcLoc famInst