FamInst.hs 15.5 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
-- The @FamInst@ type: family instance heads
2

3
{-# LANGUAGE CPP, GADTs #-}
Ian Lynagh's avatar
Ian Lynagh committed
4

5 6
module FamInst (
        FamInstEnvs, tcGetFamInstEnvs,
7
        checkFamInstConsistency, tcExtendLocalFamInstEnv,
8
        tcLookupFamInst,
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
9 10
        tcLookupDataFamInst, tcLookupDataFamInst_maybe,
        tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe,
11
        newFamInst
12 13
    ) where

Simon Marlow's avatar
Simon Marlow committed
14 15
import HscTypes
import FamInstEnv
16
import InstEnv( roughMatchTcs )
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
17
import Coercion    hiding ( substTy )
18
import TcEvidence
19
import LoadIface
Simon Marlow's avatar
Simon Marlow committed
20 21
import TcRnMonad
import TyCon
22
import CoAxiom
23
import DynFlags
24
import Module
25
import Outputable
26
import UniqFM
27
import FastString
28
import Util
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
29 30
import RdrName
import DataCon ( dataConName )
31
import Maybes
32
import TcMType
33
import TcType
34
import Name
Ian Lynagh's avatar
Ian Lynagh committed
35
import Control.Monad
36 37
import Data.Map (Map)
import qualified Data.Map as Map
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
38
import Control.Arrow ( first, second )
39 40

#include "HsVersions.h"
41

Austin Seipp's avatar
Austin Seipp committed
42 43 44
{-
************************************************************************
*                                                                      *
45
                 Making a FamInst
Austin Seipp's avatar
Austin Seipp committed
46 47 48
*                                                                      *
************************************************************************
-}
49 50 51 52 53

-- All type variables in a FamInst 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.
54 55

newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcRnIf gbl lcl FamInst
56 57
-- Freshen the type variables of the FamInst branches
-- Called from the vectoriser monad too, hence the rather general type
58 59
newFamInst flavor axiom@(CoAxiom { co_ax_branches = FirstBranch branch
                                 , co_ax_tc = fam_tc })
60 61 62 63 64
  | CoAxBranch { cab_tvs = tvs
               , cab_lhs = lhs
               , cab_rhs = rhs } <- branch
  = do { (subst, tvs') <- freshenTyVarBndrs tvs
       ; return (FamInst { fi_fam      = tyConName fam_tc
65
                         , fi_flavor   = flavor
66 67 68 69
                         , fi_tcs      = roughMatchTcs lhs
                         , fi_tvs      = tvs'
                         , fi_tys      = substTys subst lhs
                         , fi_rhs      = substTy  subst rhs
70 71
                         , fi_axiom    = axiom }) }

Austin Seipp's avatar
Austin Seipp committed
72 73 74
{-
************************************************************************
*                                                                      *
75
        Optimised overlap checking for family instances
Austin Seipp's avatar
Austin Seipp committed
76 77
*                                                                      *
************************************************************************
78

79 80 81 82 83
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.

84 85 86 87 88 89
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
90 91 92 93

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

94 95 96 97 98
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.)
Austin Seipp's avatar
Austin Seipp committed
99
-}
100 101 102 103 104 105 106 107 108 109

-- 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)
110
                         | otherwise = (m2, m1)
111 112 113 114 115 116 117

instance Eq ModulePair where
  mp1 == mp2 = canon mp1 == canon mp2

instance Ord ModulePair where
  mp1 `compare` mp2 = canon mp1 `compare` canon mp2

118 119 120
instance Outputable ModulePair where
  ppr (ModulePair m1 m2) = angleBrackets (ppr m1 <> comma <+> ppr m2)

121 122
-- Sets of module pairs
--
123
type ModulePairSet = Map ModulePair ()
124

125
listToSet :: [ModulePair] -> ModulePairSet
126
listToSet l = Map.fromList (zip l (repeat ()))
127 128 129

checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
checkFamInstConsistency famInstMods directlyImpMods
130
  = do { dflags     <- getDynFlags
131 132 133
       ; (eps, hpt) <- getEpsAndHpt

       ; let { -- Fetch the iface of a given module.  Must succeed as
134 135 136
               -- all directly imported modules must already have been loaded.
               modIface mod =
                 case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
137 138 139
                   Nothing    -> panic "FamInst.checkFamInstConsistency"
                   Just iface -> iface

140
             ; hmiModule     = mi_module . hm_iface
141
             ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv
142
                               . md_fam_insts . hm_details
143 144 145 146 147 148 149 150
             ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi)
                                           | hmi <- eltsUFM hpt]
             ; 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
151
             ; toCheckPairs  = Map.keys $ criticalPairs `Map.difference` okPairs
152 153
                 -- the difference gives us the pairs we need to check now
             }
154

155
       ; mapM_ (check hpt_fam_insts) toCheckPairs
156 157 158 159 160
       }
  where
    allPairs []     = []
    allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms

161 162 163
    check hpt_fam_insts (ModulePair m1 m2)
      = do { env1 <- getFamInsts hpt_fam_insts m1
           ; env2 <- getFamInsts hpt_fam_insts m2
164
           ; mapM_ (checkForConflicts (emptyFamInstEnv, env2))
165 166 167 168 169 170 171 172 173 174 175
                   (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")
176

Austin Seipp's avatar
Austin Seipp committed
177 178 179
{-
************************************************************************
*                                                                      *
180
        Lookup
Austin Seipp's avatar
Austin Seipp committed
181 182
*                                                                      *
************************************************************************
183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202

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]'.
Austin Seipp's avatar
Austin Seipp committed
203
-}
204

205 206
tcLookupFamInst :: FamInstEnvs -> TyCon -> [Type] -> Maybe FamInstMatch
tcLookupFamInst fam_envs tycon tys
207
  | not (isOpenFamilyTyCon tycon)
208
  = Nothing
209
  | otherwise
210 211 212 213 214 215 216 217 218 219 220
  = case lookupFamInstEnv fam_envs tycon tys of
      match : _ -> Just match
      []        -> Nothing

-- | If @co :: T ts ~ rep_ty@ then:
--
-- > instNewTyCon_maybe T ts = Just (rep_ty, co)
--
-- Checks for a newtype, and for being saturated
-- Just like Coercion.instNewTyCon_maybe, but returns a TcCoercion
tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
221 222
tcInstNewTyCon_maybe tc tys = fmap (second TcCoercion) $
                              instNewTyCon_maybe tc tys
223

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
224 225
-- | Like 'tcLookupDataFamInst_maybe', but returns the arguments back if
-- there is no data family to unwrap.
226 227
tcLookupDataFamInst :: FamInstEnvs -> TyCon -> [TcType]
                    -> (TyCon, [TcType], TcCoercion)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
228 229 230 231 232 233 234 235 236
tcLookupDataFamInst fam_inst_envs tc tc_args
  | Just (rep_tc, rep_args, co)
      <- tcLookupDataFamInst_maybe fam_inst_envs tc tc_args
  = (rep_tc, rep_args, TcCoercion co)
  | otherwise
  = (tc, tc_args, mkTcRepReflCo (mkTyConApp tc tc_args))

tcLookupDataFamInst_maybe :: FamInstEnvs -> TyCon -> [TcType]
                          -> Maybe (TyCon, [TcType], Coercion)
237 238
-- ^ Converts a data family type (eg F [a]) to its representation type (eg FList a)
-- and returns a coercion between the two: co :: F [a] ~R FList a
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
239
tcLookupDataFamInst_maybe fam_inst_envs tc tc_args
240 241 242 243 244 245
  | isDataFamilyTyCon tc
  , match : _ <- lookupFamInstEnv fam_inst_envs tc tc_args
  , FamInstMatch { fim_instance = rep_fam
                 , fim_tys      = rep_args } <- match
  , let co_tc  = famInstAxiom rep_fam
        rep_tc = dataFamInstRepTyCon rep_fam
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
246 247
        co     = mkUnbranchedAxInstCo Representational co_tc rep_args
  = Just (rep_tc, rep_args, co)
248 249 250

  | otherwise
  = Nothing
251

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294
-- | Get rid of top-level newtypes, potentially looking through newtype
-- instances. Only unwraps newtypes that are in scope. This is used
-- for solving for `Coercible` in the solver. This version is careful
-- not to unwrap data/newtype instances if it can't continue unwrapping.
-- Such care is necessary for proper error messages.
--
-- Does not look through type families. Does not normalise arguments to a
-- tycon.
--
-- Always produces a representational coercion.
tcTopNormaliseNewTypeTF_maybe :: FamInstEnvs
                              -> GlobalRdrEnv
                              -> Type
                              -> Maybe (TcCoercion, Type)
tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty
-- cf. FamInstEnv.topNormaliseType_maybe and Coercion.topNormaliseNewType_maybe
  = fmap (first TcCoercion) $ topNormaliseTypeX_maybe stepper ty
  where
    stepper
      = unwrap_newtype
        `composeSteppers`
        \ rec_nts tc tys ->
        case tcLookupDataFamInst_maybe faminsts tc tys of
          Just (tc', tys', co) ->
            modifyStepResultCo (co `mkTransCo`)
                               (unwrap_newtype rec_nts tc' tys')
          Nothing -> NS_Done

    unwrap_newtype rec_nts tc tys
      | data_cons_in_scope tc
      = unwrapNewTypeStepper rec_nts tc tys

      | otherwise
      = NS_Done

    data_cons_in_scope :: TyCon -> Bool
    data_cons_in_scope tc
      = isWiredInName (tyConName tc) ||
        (not (isAbstractTyCon tc) && all in_scope data_con_names)
      where
        data_con_names = map dataConName (tyConDataCons tc)
        in_scope dc    = not $ null $ lookupGRE_Name rdr_env dc

Austin Seipp's avatar
Austin Seipp committed
295 296 297
{-
************************************************************************
*                                                                      *
298
        Extending the family instance environment
Austin Seipp's avatar
Austin Seipp committed
299 300 301
*                                                                      *
************************************************************************
-}
302 303

-- Add new locally-defined family instances
304
tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
305 306
tcExtendLocalFamInstEnv fam_insts thing_inside
 = do { env <- getGblEnv
307
      ; (inst_env', fam_insts') <- foldlM addLocalFamInst
Simon Peyton Jones's avatar
Simon Peyton Jones committed
308 309 310
                                          (tcg_fam_inst_env env, tcg_fam_insts env)
                                          fam_insts
      ; let env' = env { tcg_fam_insts    = fam_insts'
311
                       , tcg_fam_inst_env = inst_env' }
312
      ; setGblEnv env' thing_inside
313
      }
314

315
-- Check that the proposed new instance is OK,
316
-- and then add it to the home inst env
317 318
-- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match]
-- in FamInstEnv.lhs
319
addLocalFamInst :: (FamInstEnv,[FamInst]) -> FamInst -> TcM (FamInstEnv, [FamInst])
320
addLocalFamInst (home_fie, my_fis) fam_inst
Simon Peyton Jones's avatar
Simon Peyton Jones committed
321 322
        -- home_fie includes home package and this module
        -- my_fies is just the ones from this module
323
  = do { traceTc "addLocalFamInst" (ppr fam_inst)
324

325
       ; isGHCi <- getIsGHCi
326 327 328
       ; mod <- getModule
       ; traceTc "alfi" (ppr mod $$ ppr isGHCi)

Simon Peyton Jones's avatar
Simon Peyton Jones committed
329 330
           -- In GHCi, we *override* any identical instances
           -- that are also defined in the interactive context
331 332
           -- Trac #7102
       ; let (home_fie', my_fis')
333 334
               | isGHCi    = ( deleteFromFamInstEnv home_fie fam_inst
                             , filterOut (identicalFamInst fam_inst) my_fis)
335
               | otherwise = (home_fie, my_fis)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
336 337 338 339 340

           -- Load imported instances, so that we report
           -- overlaps correctly
       ; eps <- getEps
       ; let inst_envs  = (eps_fam_inst_env eps, home_fie')
341
             home_fie'' = extendFamInstEnv home_fie fam_inst
Simon Peyton Jones's avatar
Simon Peyton Jones committed
342 343

           -- Check for conflicting instance decls
344
       ; no_conflict <- checkForConflicts inst_envs fam_inst
345
       ; if no_conflict then
346
            return (home_fie'', fam_inst : my_fis')
347
         else
348
            return (home_fie,   my_fis) }
349

Austin Seipp's avatar
Austin Seipp committed
350 351 352
{-
************************************************************************
*                                                                      *
353
        Checking an instance against conflicts with an instance env
Austin Seipp's avatar
Austin Seipp committed
354 355
*                                                                      *
************************************************************************
356 357 358

Check whether a single family instance conflicts with those in two instance
environments (one for the EPS and one for the HPT).
Austin Seipp's avatar
Austin Seipp committed
359
-}
360

361 362 363 364
checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool
checkForConflicts inst_envs fam_inst
  = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst
             no_conflicts = null conflicts
365 366 367 368 369
       ; traceTc "checkForConflicts" $
         vcat [ ppr (map fim_instance conflicts)
              , ppr fam_inst
              -- , ppr inst_envs
         ]
370
       ; unless no_conflicts $ conflictInstErr fam_inst conflicts
371
       ; return no_conflicts }
372

373 374 375
conflictInstErr :: FamInst -> [FamInstMatch] -> TcRn ()
conflictInstErr fam_inst conflictingMatch
  | (FamInstMatch { fim_instance = confInst }) : _ <- conflictingMatch
376
  = addFamInstsErr (ptext (sLit "Conflicting family instance declarations:"))
377
                   [fam_inst, confInst]
378
  | otherwise
379
  = panic "conflictInstErr"
380

381
addFamInstsErr :: SDoc -> [FamInst] -> TcRn ()
382
addFamInstsErr herald insts
383 384 385
  = ASSERT( not (null insts) )
    setSrcSpan srcSpan $ addErr $
    hang herald
386 387
       2 (vcat [ pprCoAxBranchHdr (famInstAxiom fi) 0
               | fi <- sorted ])
388
 where
389
   getSpan   = getSrcLoc . famInstAxiom
390
   sorted    = sortWith getSpan insts
391 392
   fi1       = head sorted
   srcSpan   = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1))
393 394 395
   -- The sortWith just arranges that instances are dislayed in order
   -- of source location, which reduced wobbling in error messages,
   -- and is better for users
396

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