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

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
4
5
6
7
8
9
10
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

11
module FamInst ( 
12
13
        checkFamInstConsistency, tcExtendLocalFamInstEnv,
	tcLookupFamInst, tcLookupDataFamInst,
14
15
16
17
        tcGetFamInstEnvs,

        freshenFamInstEqn, freshenFamInstEqnLoc,
        mkFreshenedSynInst, mkFreshenedSynInstLoc
18
19
    ) where

Simon Marlow's avatar
Simon Marlow committed
20
21
import HscTypes
import FamInstEnv
22
import LoadIface
23
import TypeRep
Simon Marlow's avatar
Simon Marlow committed
24
25
import TcRnMonad
import TyCon
26
import CoAxiom
27
import DynFlags
28
import SrcLoc
29
import Module
30
import Outputable
31
import UniqFM
32
import FastString
33
import Util
34
import Maybes
35
36
import TcMType
import Type
37
import Name
Ian Lynagh's avatar
Ian Lynagh committed
38
import Control.Monad
39
40
import Data.Map (Map)
import qualified Data.Map as Map
41
42

#include "HsVersions.h"
43
44
45
46
47
\end{code}


%************************************************************************
%*									*
48
	Optimised overlap checking for family instances
49
50
51
%*									*
%************************************************************************

52
53
54
55
56
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.

57
58
59
60
61
62
63
64
65
66
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.

67
68
69
70
71
72
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.)

73
\begin{code}
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
-- 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

91
92
93
instance Outputable ModulePair where
  ppr (ModulePair m1 m2) = angleBrackets (ppr m1 <> comma <+> ppr m2)

94
95
-- Sets of module pairs
--
96
type ModulePairSet = Map ModulePair ()
97

98
listToSet :: [ModulePair] -> ModulePairSet
99
listToSet l = Map.fromList (zip l (repeat ()))
100
101
102

checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
checkFamInstConsistency famInstMods directlyImpMods
103
  = do { dflags     <- getDynFlags
104
105
106
       ; (eps, hpt) <- getEpsAndHpt

       ; let { -- Fetch the iface of a given module.  Must succeed as
107
 	       -- all directly imported modules must already have been loaded.
108
109
110
111
112
	       modIface mod = 
	         case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
                   Nothing    -> panic "FamInst.checkFamInstConsistency"
                   Just iface -> iface

113
             ; hmiModule     = mi_module . hm_iface
114
115
116
117
	     ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv 
                               . md_fam_insts . hm_details
             ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi) 
			                   | hmi <- eltsUFM hpt]
118
119
120
121
122
123
	     ; 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
124
             ; toCheckPairs  = Map.keys $ criticalPairs `Map.difference` okPairs
125
126
127
	         -- the difference gives us the pairs we need to check now
	     }

128
       ; mapM_ (check hpt_fam_insts) toCheckPairs
129
130
131
132
133
       }
  where
    allPairs []     = []
    allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms

134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
    check hpt_fam_insts (ModulePair m1 m2)
      = do { env1 <- getFamInsts hpt_fam_insts m1
           ; env2 <- getFamInsts hpt_fam_insts m2
           ; mapM_ (checkForConflicts (emptyFamInstEnv, env2))   
                   (famInstEnvElts env1) }

getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv
getFamInsts hpt_fam_insts mod
  | Just env <- lookupModuleEnv hpt_fam_insts mod = return env
  | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod)
                   ; eps <- getEps
                   ; return (expectJust "checkFamInstConsistency" $
                             lookupModuleEnv (eps_mod_fam_inst_env eps) mod) }
  where
    doc = ppr mod <+> ptext (sLit "is a family-instance module")
149
150
\end{code}

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
%************************************************************************
%*									*
	Lookup
%*									*
%************************************************************************

Look up the instance tycon of a family instance.

The match may be ambiguous (as we know that overlapping instances have
identical right-hand sides under overlapping substitutions - see
'FamInstEnv.lookupFamInstEnvConflicts').  However, the type arguments used
for matching must be equal to or be more specific than those of the family
instance declaration.  We pick one of the matches in case of ambiguity; as
the right-hand sides are identical under the match substitution, the choice
does not matter.

Return the instance tycon and its type instance.  For example, if we have

 tcLookupFamInst 'T' '[Int]' yields (':R42T', 'Int')

then we have a coercion (ie, type instance of family instance coercion)

 :Co:R42T Int :: T [Int] ~ :R42T Int

which implies that :R42T was declared as 'data instance T [a]'.

\begin{code}
178
tcLookupFamInst :: TyCon -> [Type] -> TcM (Maybe FamInstMatch)
179
180
181
182
183
tcLookupFamInst tycon tys
  | not (isFamilyTyCon tycon)
  = return Nothing
  | otherwise
  = do { instEnv <- tcGetFamInstEnvs
184
       ; let mb_match = lookupFamInstEnv instEnv tycon tys 
185
186
187
--       ; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ 
--                                  pprTvBndrs (varSetElems (tyVarsOfTypes tys)) $$ 
--                                  ppr mb_match $$ ppr instEnv)
188
189
       ; case mb_match of
	   [] -> return Nothing
190
191
	   (match:_) 
              -> return $ Just match
192
193
194
195
196
197
198
199
200
201
202
203
       }

tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type])
-- Find the instance of a data family
-- Note [Looking up family instances for deriving]
tcLookupDataFamInst tycon tys
  | not (isFamilyTyCon tycon)
  = return (tycon, tys)
  | otherwise
  = ASSERT( isAlgTyCon tycon )
    do { maybeFamInst <- tcLookupFamInst tycon tys
       ; case maybeFamInst of
204
           Nothing             -> famInstNotFound tycon tys
205
206
207
208
209
210
           Just (FamInstMatch { fim_instance = famInst
                              , fim_index    = index
                              , fim_tys      = tys })
             -> ASSERT( index == 0 )
                let tycon' = dataFamInstRepTyCon famInst
                in return (tycon', tys) }
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242

famInstNotFound :: TyCon -> [Type] -> TcM a
famInstNotFound tycon tys 
  = failWithTc (ptext (sLit "No family instance for")
			<+> quotes (pprTypeApp tycon tys))
\end{code}

Note [Looking up family instances for deriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tcLookupFamInstExact is an auxiliary lookup wrapper which requires
that looked-up family instances exist.  If called with a vanilla
tycon, the old type application is simply returned.

If we have
  data instance F () = ... deriving Eq
  data instance F () = ... deriving Eq
then tcLookupFamInstExact will be confused by the two matches;
but that can't happen because tcInstDecls1 doesn't call tcDeriving
if there are any overlaps.

There are two other things that might go wrong with the lookup.
First, we might see a standalone deriving clause
	deriving Eq (F ())
when there is no data instance F () in scope. 

Note that it's OK to have
  data instance F [a] = ...
  deriving Eq (F [(a,b)])
where the match is not exact; the same holds for ordinary data types
with standalone deriving declrations.


243
244
245
246
247
%************************************************************************
%*									*
	Extending the family instance environment
%*									*
%************************************************************************
248

249
\begin{code}
250
-- Add new locally-defined family instances
251
tcExtendLocalFamInstEnv :: [FamInst br] -> TcM a -> TcM a
252
253
tcExtendLocalFamInstEnv fam_insts thing_inside
 = do { env <- getGblEnv
Simon Peyton Jones's avatar
Simon Peyton Jones committed
254
255
256
257
258
      ; (inst_env', fam_insts') <- foldlM addLocalFamInst  
                                          (tcg_fam_inst_env env, tcg_fam_insts env)
                                          fam_insts
      ; let env' = env { tcg_fam_insts    = fam_insts'
		       , tcg_fam_inst_env = inst_env' }
259
260
      ; setGblEnv env' thing_inside 
      }
261
262
263

-- Check that the proposed new instance is OK, 
-- and then add it to the home inst env
264
265
266
267
-- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match]
-- in FamInstEnv.lhs
addLocalFamInst :: (FamInstEnv,[FamInst Branched]) -> FamInst br -> TcM (FamInstEnv, [FamInst Branched])
addLocalFamInst (home_fie, my_fis) fam_inst
Simon Peyton Jones's avatar
Simon Peyton Jones committed
268
269
        -- home_fie includes home package and this module
        -- my_fies is just the ones from this module
270
  = do { traceTc "addLocalFamInst" (ppr fam_inst)
271

272
       ; isGHCi <- getIsGHCi
Simon Peyton Jones's avatar
Simon Peyton Jones committed
273
274
275
 
           -- In GHCi, we *override* any identical instances
           -- that are also defined in the interactive context
276
       ; let (home_fie', my_fis') 
277
278
               | isGHCi    = ( deleteFromFamInstEnv home_fie fam_inst
                             , filterOut (identicalFamInst fam_inst) my_fis)
279
               | otherwise = (home_fie, my_fis)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
280
281
282
283
284

           -- Load imported instances, so that we report
           -- overlaps correctly
       ; eps <- getEps
       ; let inst_envs  = (eps_fam_inst_env eps, home_fie')
285
             fam_inst'  = toBranchedFamInst fam_inst
286
             home_fie'' = extendFamInstEnv home_fie fam_inst'
Simon Peyton Jones's avatar
Simon Peyton Jones committed
287
288

           -- Check for conflicting instance decls
289
       ; no_conflict <- checkForConflicts inst_envs fam_inst'
290
       ; if no_conflict then
291
            return (home_fie'', fam_inst' : my_fis')
292
293
         else 
            return (home_fie,   my_fis) }
294

295
296
297
298
299
300
301
302
303
304
305
306
\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}
307
308
309
310
311
checkForConflicts :: FamInstEnvs -> FamInst Branched -> TcM Bool
checkForConflicts inst_envs fam_inst@(FamInst { fi_branches = branches
                                              , fi_group = group })
  = do { let conflicts = brListMap (lookupFamInstEnvConflicts inst_envs group fam_tc) branches
             no_conflicts = all null conflicts
312
313
       ; traceTc "checkForConflicts" (ppr conflicts $$ ppr fam_inst $$ ppr inst_envs)
       ; unless no_conflicts $
314
	   zipWithM_ (conflictInstErr fam_inst) (brListIndices branches) conflicts
315
       ; return no_conflicts }
316
    where fam_tc = famInstTyCon fam_inst
317

318
conflictInstErr :: FamInst Branched -> BranchIndex -> [FamInstMatch] -> TcRn ()
319
320
321
conflictInstErr fam_inst branch conflictingMatch
  | (FamInstMatch { fim_instance = confInst
                  , fim_index = confIndex }) : _ <- conflictingMatch
322
  = addFamInstsErr (ptext (sLit "Conflicting family instance declarations:"))
323
                   [(fam_inst, branch),
324
                    (confInst, confIndex) ]
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
325
326
  | otherwise -- no conflict on this branch; see Trac #7560
  = return ()
327

328
addFamInstsErr :: SDoc -> [(FamInst Branched, Int)] -> TcRn ()
329
addFamInstsErr herald insts
330
331
332
333
334
  = ASSERT( not (null insts) )
    setSrcSpan srcSpan $ addErr $
    hang herald
       2 (vcat [ pprCoAxBranchHdr (famInstAxiom fi) index 
               | (fi,index) <- sorted ])
335
 where
336
337
338
339
   getSpan   = getSrcLoc . famInstAxiom . fst
   sorted    = sortWith getSpan insts
   (fi1,ix1) = head sorted
   srcSpan   = coAxBranchSpan (coAxiomNthBranch (famInstAxiom fi1) ix1)
340
341
342
   -- The sortWith just arranges that instances are dislayed in order
   -- of source location, which reduced wobbling in error messages,
   -- and is better for users
343

344
tcGetFamInstEnvs :: TcM FamInstEnvs
345
346
347
348
-- Gets both the external-package inst-env
-- and the home-pkg inst env (includes module being compiled)
tcGetFamInstEnvs 
  = do { eps <- getEps; env <- getGblEnv
349
       ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) }
350
\end{code}
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400

%************************************************************************
%*									*
	Freshening type variables
%*									*
%************************************************************************

\begin{code}

-- All type variables in a FamInst/CoAxiom must be fresh. This function
-- creates the fresh variables and applies the necessary substitution
-- It is defined here to avoid a dependency from FamInstEnv on the monad
-- code.
freshenFamInstEqn :: [TyVar] -- original, possibly stale, tyvars
                  -> [Type]  -- LHS patterns
                  -> Type    -- RHS
                  -> TcM ([TyVar], [Type], Type)
freshenFamInstEqn tvs lhs rhs
  = do { loc <- getSrcSpanM
       ; freshenFamInstEqnLoc loc tvs lhs rhs }

-- freshenFamInstEqn needs to be called outside the TcM monad:
freshenFamInstEqnLoc :: SrcSpan
                     -> [TyVar] -> [Type] -> Type
                     -> TcRnIf gbl lcl ([TyVar], [Type], Type)
freshenFamInstEqnLoc loc tvs lhs rhs
  = do { (subst, tvs') <- tcInstSkolTyVarsLoc loc tvs
       ; let lhs' = substTys subst lhs
             rhs' = substTy  subst rhs
       ; return (tvs', lhs', rhs') }

-- Makes an unbranched synonym FamInst, with freshened tyvars
mkFreshenedSynInst :: Name    -- Unique name for the coercion tycon
                   -> [TyVar] -- possibly stale tyvars of the coercion
                   -> TyCon   -- Family tycon
                   -> [Type]  -- LHS patterns
                   -> Type    -- RHS
                   -> TcM (FamInst Unbranched)
mkFreshenedSynInst name tvs fam_tc inst_tys rep_ty
  = do { loc <- getSrcSpanM
       ; mkFreshenedSynInstLoc loc name tvs fam_tc inst_tys rep_ty }

mkFreshenedSynInstLoc :: SrcSpan
                      -> Name -> [TyVar] -> TyCon -> [Type] -> Type
                      -> TcRnIf gbl lcl (FamInst Unbranched)
mkFreshenedSynInstLoc loc name tvs fam_tc inst_tys rep_ty
  = do { (tvs', inst_tys', rep_ty') <- freshenFamInstEqnLoc loc tvs inst_tys rep_ty
       ; return $ mkSingleSynFamInst name tvs' fam_tc inst_tys' rep_ty' }

\end{code}