compiler/typecheck/FamInst.lhs

   1 \section[FamInst]{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   ( ExternalPackageState(..) )
  11 import FamInstEnv ( FamInstEnv, FamInst(..), famInstTyCon, extendFamInstEnv,
  12                     pprFamInst, pprFamInsts )
  13 import TcMType    ( tcInstSkolType )
  14 import TcType     ( SkolemInfo(..), tcSplitTyConApp )
  15 import TcRnMonad  ( TcM, TcGblEnv(..), setGblEnv, getGblEnv, foldlM,
  16                     setSrcSpan, addErr, getEps )
  17 import TyCon      ( tyConFamInst_maybe )
  18 import Type       ( mkTyConApp )
  19 import Name       ( getSrcLoc )
  20 import SrcLoc     ( mkSrcSpan )
  21 import Outputable
  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', theta', 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 {- !!!TODO: Need to complete this:
  68                 -- Check for overlapping instance decls
  69         ; let { (matches, _) = lookupFamInstEnv inst_envs fam tys'
  70               ; dup_ispecs = [ dup_ispec   --!!!adapt
  71                              | (_, dup_ispec) <- matches
  72                              , let (_,_,_,dup_tys) = instanceHead dup_ispec
  73                              , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
  74                 -- Find memebers of the match list which ispec itself matches.
  75                 -- If the match is 2-way, it's a duplicate
  76         ; case dup_ispecs of
  77             dup_ispec : _ -> dupInstErr famInst dup_ispec
  78             []            -> return ()
  79  -}
  80
  81                 -- OK, now extend the envt
  82         ; return (extendFamInstEnv home_fie famInst) }
  83
  84 overlapErr famInst dupFamInst
  85   = addFamInstLoc famInst $
  86     addErr (hang (ptext SLIT("Overlapping family instance declarations:"))
  87                2 (pprFamInsts [famInst, dupFamInst]))
  88
  89 addFamInstLoc famInst thing_inside
  90   = setSrcSpan (mkSrcSpan loc loc) thing_inside
  91   where
  92     loc = getSrcLoc famInst
  93 \end{code}