FamInst.lhs 7.32 KB
Newer Older
Simon Marlow's avatar
Simon Marlow committed
1
The @FamInst@ type: family instance heads
2
3
4

\begin{code}
module FamInst ( 
5
        checkFamInstConsistency, tcExtendLocalFamInstEnv, tcGetFamInstEnvs
6
7
    ) where

Simon Marlow's avatar
Simon Marlow committed
8
9
10
11
12
import HscTypes
import FamInstEnv
import TcMType
import TcRnMonad
import TyCon
13
import Name
14
import Module
15
import SrcLoc
16
import Outputable
17
import UniqFM
18
import FastString
19

20
import Maybes
Ian Lynagh's avatar
Ian Lynagh committed
21
import Control.Monad
22
23
import Data.Map (Map)
import qualified Data.Map as Map
24
25
26
27
28
\end{code}


%************************************************************************
%*									*
29
	Optimised overlap checking for family instances
30
31
32
%*									*
%************************************************************************

33
34
35
36
37
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.

38
39
40
41
42
43
44
45
46
47
Why do we need to check?  Consider 
   module X1 where	  	  module X2 where
    data T1			    data T2
    type instance F T1 b = Int	    type instance F a T2 = Char
    f1 :: F T1 a -> Int		    f2 :: Char -> F a T2
    f1 x = x			    f2 x = x

Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char.
Notice that neither instance is an orphan.

48
49
50
51
52
53
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.)

54
\begin{code}
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
-- 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
--
74
type ModulePairSet = Map ModulePair ()
75

76
listToSet :: [ModulePair] -> ModulePairSet
77
listToSet l = Map.fromList (zip l (repeat ()))
78
79
80
81
82
83
84
85
86
87
88
89
90

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

91
92
93
94
95
96
97
98
             ; 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
99
100
101
102
103
104
	     ; 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
105
             ; toCheckPairs  = Map.keys $ criticalPairs `Map.difference` okPairs
106
107
108
109
110
111
112
113
114
	         -- 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

115
116
117
    -- The modules are guaranteed to be in the environment, as they are either
    -- already loaded in the EPS or they are in the HPT.
    --
118
    check modInstsEnv (ModulePair m1 m2)
119
120
      = let { instEnv1 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m1
	    ; instEnv2 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m2
121
122
123
124
125
126
127
128
129
130
131
	    ; insts1   = famInstEnvElts instEnv1
	    }
        in
	mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1
\end{code}

%************************************************************************
%*									*
	Extending the family instance environment
%*									*
%************************************************************************
132

133
\begin{code}
134
135
136
137
138
-- 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
139
140
      ; let env' = env { tcg_fam_insts    = fam_insts ++ tcg_fam_insts env,
			 tcg_fam_inst_env = inst_env' }
141
142
      ; setGblEnv env' thing_inside 
      }
143
144
145
146
147

-- 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
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
  = 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
174
175
176
177
178
179
		-- 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.  
180

181
       ; skol_tvs <- tcInstSkolTyVars (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

Ian Lynagh's avatar
Ian Lynagh committed
188
conflictInstErr :: FamInst -> FamInst -> TcRn ()
189
conflictInstErr famInst conflictingFamInst
190
  = addFamInstLoc famInst $
Ian Lynagh's avatar
Ian Lynagh committed
191
    addErr (hang (ptext (sLit "Conflicting family instance declarations:"))
192
	       2 (pprFamInsts [famInst, conflictingFamInst]))
193

Ian Lynagh's avatar
Ian Lynagh committed
194
addFamInstLoc :: FamInst -> TcRn a -> TcRn a
195
196
197
198
addFamInstLoc famInst thing_inside
  = setSrcSpan (mkSrcSpan loc loc) thing_inside
  where
    loc = getSrcLoc famInst
199
200
201
202
203
204
205
206
207
208
209
210
211
\end{code} 

\begin{code} 

tcGetFamInstEnvs :: TcM (FamInstEnv, FamInstEnv)
-- Gets both the external-package inst-env
-- and the home-pkg inst env (includes module being compiled)
tcGetFamInstEnvs 
  = do { eps <- getEps; env <- getGblEnv
       ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) 
       }


212
\end{code}