compiler/typecheck/FamInst.lhs

   1 The @FamInst@ type: family instance heads
   2
   3 \begin{code}
   4 module FamInst (
   5         tcExtendLocalFamInstEnv
   6     ) where
   7
   8 #include "HsVersions.h"
   9
  10 import HscTypes
  11 import FamInstEnv
  12 import TcMType
  13 import TcType
  14 import TcRnMonad
  15 import TyCon
  16 import Type
  17 import Name
  18 import SrcLoc
  19 import Outputable
  20
  21 import Monad
  22 \end{code}
  23
  24
  25 %************************************************************************
  26 %*                                                                      *
  27         Extending the family instance environment
  28 %*                                                                      *
  29 %************************************************************************
  30
  31 \begin{code}
  32
  33 -- Add new locally-defined family instances
  34 tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
  35 tcExtendLocalFamInstEnv fam_insts thing_inside
  36  = do { env <- getGblEnv
  37       ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts
  38       ; let env' = env { tcg_fam_insts    = fam_insts ++ tcg_fam_insts env,
  39                          tcg_fam_inst_env = inst_env' }
  40       ; setGblEnv env' thing_inside }
  41
  42
  43 -- Check that the proposed new instance is OK,
  44 -- and then add it to the home inst env
  45 addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv
  46 addLocalFamInst home_fie famInst
  47   = do  {       -- To instantiate the family instance type, extend the instance
  48                 -- envt with completely fresh template variables
  49                 -- This is important because the template variables must
  50                 -- not overlap with anything in the things being looked up
  51                 -- (since we do unification).
  52                 -- We use tcInstSkolType because we don't want to allocate
  53                 -- fresh *meta* type variables.
  54           let tycon = famInstTyCon famInst
  55               ty    = case tyConFamInst_maybe tycon of
  56                         Nothing        -> panic "FamInst.addLocalFamInst"
  57                         Just (tc, tys) -> tc `mkTyConApp` tys
  58         ; (tvs', _, tau') <- tcInstSkolType (FamInstSkol tycon) ty
  59
  60         ; let (fam, tys') = tcSplitTyConApp tau'
  61
  62                 -- Load imported instances, so that we report
  63                 -- overlaps correctly
  64         ; eps <- getEps
  65         ; let inst_envs = (eps_fam_inst_env eps, home_fie)
  66
  67                 -- Check for conflicting instance decls
  68         ; let { matches   = lookupFamInstEnvUnify inst_envs fam tys'
  69               ; conflicts = [ conflictingFamInst
  70                             | match@(_, conflictingFamInst) <- matches
  71                             , conflicting fam tys' tycon match
  72                             ]
  73               }
  74         ; unless (null conflicts) $
  75             conflictInstErr famInst (head conflicts)
  76
  77                 -- OK, now extend the envt
  78         ; return (extendFamInstEnv home_fie famInst)
  79         }
  80   where
  81     -- In the case of data/newtype instances, any overlap is a conflicts (as
  82     -- these instances imply injective type mappings).
  83     conflicting _   _    tycon _                 | isAlgTyCon tycon = True
  84     conflicting fam tys' tycon (subst, cFamInst) | otherwise      =
  85       panic "FamInst.addLocalFamInst: overlap check for indexed synonyms is still missing"
  86
  87 conflictInstErr famInst conflictingFamInst
  88   = addFamInstLoc famInst $
  89     addErr (hang (ptext SLIT("Conflicting family instance declarations:"))
  90                2 (pprFamInsts [famInst, conflictingFamInst]))
  91
  92 addFamInstLoc famInst thing_inside
  93   = setSrcSpan (mkSrcSpan loc loc) thing_inside
  94   where
  95     loc = getSrcLoc famInst
  96 \end{code}