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 FamInstEnv ( FamInstEnv, FamInst(..), famInstTyCon, extendFamInstEnv,
  11                     pprFamInst, pprFamInsts )
  12 import TcMType    ( tcInstSkolType )
  13 import TcType     ( SkolemInfo(..), tcSplitTyConApp )
  14 import TcRnMonad  ( TcM, TcGblEnv(..), setGblEnv, getGblEnv, foldlM,
  15                     setSrcSpan, addErr )
  16 import TyCon      ( tyConFamInst_maybe )
  17 import Type       ( mkTyConApp )
  18 import Name       ( getSrcLoc )
  19 import SrcLoc     ( mkSrcSpan )
  20 import Outputable
  21 \end{code}
  22
  23
  24 %************************************************************************
  25 %*                                                                      *
  26         Extending the family instance environment
  27 %*                                                                      *
  28 %************************************************************************
  29
  30 \begin{code}
  31
  32 -- Add new locally-defined family instances
  33 tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
  34 tcExtendLocalFamInstEnv fam_insts thing_inside
  35  = do { env <- getGblEnv
  36       ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts
  37       ; let env' = env { tcg_fam_inst_env = inst_env' }
  38       ; setGblEnv env' thing_inside }
  39
  40
  41 -- Check that the proposed new instance is OK,
  42 -- and then add it to the home inst env
  43 addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv
  44 addLocalFamInst home_fie famInst
  45   = do  {       -- Instantiate the family instance type extend the instance
  46                 -- envt with completely fresh template variables
  47                 -- This is important because the template variables must
  48                 -- not overlap with anything in the things being looked up
  49                 -- (since we do unification).
  50                 -- We use tcInstSkolType because we don't want to allocate
  51                 -- fresh *meta* type variables.
  52           let tycon = famInstTyCon famInst
  53               ty    = case tyConFamInst_maybe tycon of
  54                         Nothing        -> panic "FamInst.addLocalFamInst"
  55                         Just (tc, tys) -> tc `mkTyConApp` tys
  56         ; (tvs', theta', tau') <- tcInstSkolType (FamInstSkol tycon) ty
  57
  58         ; let   (fam, tys') = tcSplitTyConApp tau'
  59
  60 {- !!!TODO: Need to complete this:
  61                 -- Load imported instances, so that we report
  62                 -- overlaps correctly
  63         ; eps <- getEps
  64         ; let inst_envs = (eps_fam_inst_env eps, home_fie)
  65
  66                 -- Check for overlapping instance decls
  67         ; let { (matches, _) = lookupFamInstEnv inst_envs fam tys'
  68               ; dup_ispecs = [ dup_ispec   --!!!adapt
  69                              | (_, dup_ispec) <- matches
  70                              , let (_,_,_,dup_tys) = instanceHead dup_ispec
  71                              , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
  72                 -- Find memebers of the match list which ispec itself matches.
  73                 -- If the match is 2-way, it's a duplicate
  74         ; case dup_ispecs of
  75             dup_ispec : _ -> dupInstErr famInst dup_ispec
  76             []            -> return ()
  77  -}
  78
  79                 -- OK, now extend the envt
  80         ; return (extendFamInstEnv home_fie famInst) }
  81
  82 overlapErr famInst dupFamInst
  83   = addFamInstLoc famInst $
  84     addErr (hang (ptext SLIT("Overlapping family instance declarations:"))
  85                2 (pprFamInsts [famInst, dupFamInst]))
  86
  87 addFamInstLoc famInst thing_inside
  88   = setSrcSpan (mkSrcSpan loc loc) thing_inside
  89   where
  90     loc = getSrcLoc famInst
  91 \end{code}