1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
|
The @FamInst@ type: family instance heads
\begin{code}
{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
-- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
-- for details
module FamInst (
checkFamInstConsistency, tcExtendLocalFamInstEnv
) where
#include "HsVersions.h"
import HscTypes
import FamInstEnv
import TcMType
import TcType
import TcRnMonad
import TyCon
import Type
import Name
import Module
import SrcLoc
import Outputable
import UniqFM
import FiniteMap
import Maybe
import Monad
\end{code}
%************************************************************************
%* *
Optimised overlap checking for family instances
%* *
%************************************************************************
For any two family instance modules that we import directly or indirectly, we
check whether the instances in the two modules are consistent, *unless* we can
be certain that the instances of the two modules have already been checked for
consistency during the compilation of modules that we import.
How do we know which pairs of modules have already been checked? Any pair of
modules where both modules occur in the `HscTypes.dep_finsts' set (of the
`HscTypes.Dependencies') of one of our directly imported modules must have
already been checked. Everything else, we check now. (So that we can be
certain that the modules in our `HscTypes.dep_finsts' are consistent.)
\begin{code}
-- The optimisation of overlap tests is based on determining pairs of modules
-- whose family instances need to be checked for consistency.
--
data ModulePair = ModulePair Module Module
-- canonical order of the components of a module pair
--
canon :: ModulePair -> (Module, Module)
canon (ModulePair m1 m2) | m1 < m2 = (m1, m2)
| otherwise = (m2, m1)
instance Eq ModulePair where
mp1 == mp2 = canon mp1 == canon mp2
instance Ord ModulePair where
mp1 `compare` mp2 = canon mp1 `compare` canon mp2
-- Sets of module pairs
--
type ModulePairSet = FiniteMap ModulePair ()
listToSet :: [ModulePair] -> ModulePairSet
listToSet l = listToFM (zip l (repeat ()))
checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
checkFamInstConsistency famInstMods directlyImpMods
= do { dflags <- getDOpts
; (eps, hpt) <- getEpsAndHpt
; let { -- Fetch the iface of a given module. Must succeed as
-- all imported modules must already have been loaded.
modIface mod =
case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
Nothing -> panic "FamInst.checkFamInstConsistency"
Just iface -> iface
; hmiModule = mi_module . hm_iface
; hmiFamInstEnv = mkFamInstEnv . md_fam_insts . hm_details
; mkFamInstEnv = extendFamInstEnvList emptyFamInstEnv
; hptModInsts = [ (hmiModule hmi, hmiFamInstEnv hmi)
| hmi <- eltsUFM hpt]
; modInstsEnv = eps_mod_fam_inst_env eps -- external modules
`extendModuleEnvList` -- plus
hptModInsts -- home package modules
; groups = map (dep_finsts . mi_deps . modIface)
directlyImpMods
; okPairs = listToSet $ concatMap allPairs groups
-- instances of okPairs are consistent
; criticalPairs = listToSet $ allPairs famInstMods
-- all pairs that we need to consider
; toCheckPairs = keysFM $ criticalPairs `minusFM` okPairs
-- the difference gives us the pairs we need to check now
}
; mapM_ (check modInstsEnv) toCheckPairs
}
where
allPairs [] = []
allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
-- The modules are guaranteed to be in the environment, as they are either
-- already loaded in the EPS or they are in the HPT.
--
check modInstsEnv (ModulePair m1 m2)
= let { instEnv1 = fromJust . lookupModuleEnv modInstsEnv $ m1
; instEnv2 = fromJust . lookupModuleEnv modInstsEnv $ m2
; insts1 = famInstEnvElts instEnv1
}
in
mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1
\end{code}
%************************************************************************
%* *
Extending the family instance environment
%* *
%************************************************************************
\begin{code}
-- Add new locally-defined family instances
tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
tcExtendLocalFamInstEnv fam_insts thing_inside
= do { env <- getGblEnv
; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts
; let env' = env { tcg_fam_insts = fam_insts ++ tcg_fam_insts env,
tcg_fam_inst_env = inst_env' }
; setGblEnv env' thing_inside
}
-- Check that the proposed new instance is OK,
-- and then add it to the home inst env
addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv
addLocalFamInst home_fie famInst
= do { -- Load imported instances, so that we report
-- overlaps correctly
; eps <- getEps
; let inst_envs = (eps_fam_inst_env eps, home_fie)
-- Check for conflicting instance decls
; checkForConflicts inst_envs famInst
-- OK, now extend the envt
; return (extendFamInstEnv home_fie famInst)
}
\end{code}
%************************************************************************
%* *
Checking an instance against conflicts with an instance env
%* *
%************************************************************************
Check whether a single family instance conflicts with those in two instance
environments (one for the EPS and one for the HPT).
\begin{code}
checkForConflicts :: (FamInstEnv, FamInstEnv) -> FamInst -> TcM ()
checkForConflicts inst_envs famInst
= do { -- To instantiate the family instance type, 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 { tycon = famInstTyCon famInst
; ty = case tyConFamInst_maybe tycon of
Nothing -> panic "FamInst.checkForConflicts"
Just (tc, tys) -> tc `mkTyConApp` tys
}
; (tvs', _, tau') <- tcInstSkolType FamInstSkol ty
; let (fam, tys') = tcSplitTyConApp tau'
; let { matches = lookupFamInstEnvUnify inst_envs fam tys'
; conflicts = [ conflictingFamInst
| match@((conflictingFamInst, _), _) <- matches
, conflicting tycon match
]
}
; unless (null conflicts) $
conflictInstErr famInst (head conflicts)
}
where
-- * In the case of data family instances, any overlap is fundamentally a
-- conflict (as these instances imply injective type mappings).
-- * In the case of type family instances, overlap is admitted as long as
-- the right-hand sides of the overlapping rules coincide under the
-- overlap substitution. We require that they are syntactically equal;
-- anything else would be difficult to test for at this stage.
conflicting tycon1 ((famInst2, _), subst)
| isAlgTyCon tycon1 = True
| otherwise = not (rhs1 `tcEqType` rhs2)
where
tycon2 = famInstTyCon famInst2
rhs1 = substTy subst $ synTyConType tycon1
rhs2 = substTy subst $ synTyConType tycon2
conflictInstErr famInst conflictingFamInst
= addFamInstLoc famInst $
addErr (hang (ptext SLIT("Conflicting family instance declarations:"))
2 (pprFamInsts [famInst, conflictingFamInst]))
addFamInstLoc famInst thing_inside
= setSrcSpan (mkSrcSpan loc loc) thing_inside
where
loc = getSrcLoc famInst
\end{code}
|
