Fix build with 6.10
[ghc-hetmet.git] / compiler / typecheck / FamInst.lhs
1 The @FamInst@ type: family instance heads
2
3 \begin{code}
4 module FamInst ( 
5         checkFamInstConsistency, tcExtendLocalFamInstEnv, tcGetFamInstEnvs
6     ) where
7
8 import HscTypes
9 import FamInstEnv
10 import TcMType
11 import TcRnMonad
12 import TyCon
13 import Name
14 import Module
15 import SrcLoc
16 import Outputable
17 import UniqFM
18 import FiniteMap
19 import FastString
20
21 import Maybes
22 import Control.Monad
23 \end{code}
24
25
26 %************************************************************************
27 %*                                                                      *
28         Optimised overlap checking for family instances
29 %*                                                                      *
30 %************************************************************************
31
32 For any two family instance modules that we import directly or indirectly, we
33 check whether the instances in the two modules are consistent, *unless* we can
34 be certain that the instances of the two modules have already been checked for
35 consistency during the compilation of modules that we import.
36
37 Why do we need to check?  Consider 
38    module X1 where                module X2 where
39     data T1                         data T2
40     type instance F T1 b = Int      type instance F a T2 = Char
41     f1 :: F T1 a -> Int             f2 :: Char -> F a T2
42     f1 x = x                        f2 x = x
43
44 Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char.
45 Notice that neither instance is an orphan.
46
47 How do we know which pairs of modules have already been checked?  Any pair of
48 modules where both modules occur in the `HscTypes.dep_finsts' set (of the
49 `HscTypes.Dependencies') of one of our directly imported modules must have
50 already been checked.  Everything else, we check now.  (So that we can be
51 certain that the modules in our `HscTypes.dep_finsts' are consistent.)
52
53 \begin{code}
54 -- The optimisation of overlap tests is based on determining pairs of modules
55 -- whose family instances need to be checked for consistency.
56 --
57 data ModulePair = ModulePair Module Module
58
59 -- canonical order of the components of a module pair
60 --
61 canon :: ModulePair -> (Module, Module)
62 canon (ModulePair m1 m2) | m1 < m2   = (m1, m2)
63                          | otherwise = (m2, m1)
64
65 instance Eq ModulePair where
66   mp1 == mp2 = canon mp1 == canon mp2
67
68 instance Ord ModulePair where
69   mp1 `compare` mp2 = canon mp1 `compare` canon mp2
70
71 -- Sets of module pairs
72 --
73 type ModulePairSet = FiniteMap ModulePair ()
74
75 listToSet :: [ModulePair] -> ModulePairSet
76 listToSet l = listToFM (zip l (repeat ()))
77
78 checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
79 checkFamInstConsistency famInstMods directlyImpMods
80   = do { dflags     <- getDOpts
81        ; (eps, hpt) <- getEpsAndHpt
82
83        ; let { -- Fetch the iface of a given module.  Must succeed as
84                -- all imported modules must already have been loaded.
85                modIface mod = 
86                  case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
87                    Nothing    -> panic "FamInst.checkFamInstConsistency"
88                    Just iface -> iface
89
90              ; hmiModule     = mi_module . hm_iface
91              ; hmiFamInstEnv = mkFamInstEnv . md_fam_insts . hm_details
92              ; mkFamInstEnv  = extendFamInstEnvList emptyFamInstEnv
93              ; hptModInsts   = [ (hmiModule hmi, hmiFamInstEnv hmi) 
94                                | hmi <- eltsUFM hpt]
95              ; modInstsEnv   = eps_mod_fam_inst_env eps -- external modules
96                                `extendModuleEnvList`    -- plus
97                                hptModInsts              -- home package modules
98              ; groups        = map (dep_finsts . mi_deps . modIface) 
99                                    directlyImpMods
100              ; okPairs       = listToSet $ concatMap allPairs groups
101                  -- instances of okPairs are consistent
102              ; criticalPairs = listToSet $ allPairs famInstMods
103                  -- all pairs that we need to consider
104              ; toCheckPairs  = keysFM $ criticalPairs `minusFM` okPairs
105                  -- the difference gives us the pairs we need to check now
106              }
107
108        ; mapM_ (check modInstsEnv) toCheckPairs
109        }
110   where
111     allPairs []     = []
112     allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
113
114     -- The modules are guaranteed to be in the environment, as they are either
115     -- already loaded in the EPS or they are in the HPT.
116     --
117     check modInstsEnv (ModulePair m1 m2)
118       = let { instEnv1 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m1
119             ; instEnv2 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m2
120             ; insts1   = famInstEnvElts instEnv1
121             }
122         in
123         mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1
124 \end{code}
125
126 %************************************************************************
127 %*                                                                      *
128         Extending the family instance environment
129 %*                                                                      *
130 %************************************************************************
131
132 \begin{code}
133 -- Add new locally-defined family instances
134 tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
135 tcExtendLocalFamInstEnv fam_insts thing_inside
136  = do { env <- getGblEnv
137       ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts
138       ; let env' = env { tcg_fam_insts    = fam_insts ++ tcg_fam_insts env,
139                          tcg_fam_inst_env = inst_env' }
140       ; setGblEnv env' thing_inside 
141       }
142
143 -- Check that the proposed new instance is OK, 
144 -- and then add it to the home inst env
145 addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv
146 addLocalFamInst home_fie famInst
147   = do {       -- Load imported instances, so that we report
148                -- overlaps correctly
149        ; eps <- getEps
150        ; let inst_envs = (eps_fam_inst_env eps, home_fie)
151
152                -- Check for conflicting instance decls
153        ; checkForConflicts inst_envs famInst
154
155                -- OK, now extend the envt
156        ; return (extendFamInstEnv home_fie famInst) 
157        }
158 \end{code}
159
160 %************************************************************************
161 %*                                                                      *
162         Checking an instance against conflicts with an instance env
163 %*                                                                      *
164 %************************************************************************
165
166 Check whether a single family instance conflicts with those in two instance
167 environments (one for the EPS and one for the HPT).
168
169 \begin{code}
170 checkForConflicts :: (FamInstEnv, FamInstEnv) -> FamInst -> TcM ()
171 checkForConflicts inst_envs famInst
172   = do {        -- To instantiate the family instance type, extend the instance
173                 -- envt with completely fresh template variables
174                 -- This is important because the template variables must
175                 -- not overlap with anything in the things being looked up
176                 -- (since we do unification).  
177                 -- We use tcInstSkolType because we don't want to allocate
178                 -- fresh *meta* type variables.  
179
180        ; skol_tvs <- tcInstSkolTyVars FamInstSkol 
181                                       (tyConTyVars (famInstTyCon famInst))
182        ; let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs
183        ; unless (null conflicts) $
184            conflictInstErr famInst (fst (head conflicts))
185        }
186   where
187
188 conflictInstErr :: FamInst -> FamInst -> TcRn ()
189 conflictInstErr famInst conflictingFamInst
190   = addFamInstLoc famInst $
191     addErr (hang (ptext (sLit "Conflicting family instance declarations:"))
192                2 (pprFamInsts [famInst, conflictingFamInst]))
193
194 addFamInstLoc :: FamInst -> TcRn a -> TcRn a
195 addFamInstLoc famInst thing_inside
196   = setSrcSpan (mkSrcSpan loc loc) thing_inside
197   where
198     loc = getSrcLoc famInst
199 \end{code} 
200
201 \begin{code} 
202
203 tcGetFamInstEnvs :: TcM (FamInstEnv, FamInstEnv)
204 -- Gets both the external-package inst-env
205 -- and the home-pkg inst env (includes module being compiled)
206 tcGetFamInstEnvs 
207   = do { eps <- getEps; env <- getGblEnv
208        ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) 
209        }
210
211
212 \end{code}