compiler/types/FamInstEnv.lhs

   1 \section[FamInstEnv]{Type checked family instance declarations}
   2
   3 \begin{code}
   4 module FamInstEnv (
   5         FamInst(..), famInstTyCon, extractFamInsts,
   6         pprFamInst, pprFamInstHdr, pprFamInsts,
   7         {-famInstHead, mkLocalFamInst, mkImportedFamInst-}
   8
   9         FamInstEnv, emptyFamInstEnv, extendFamInstEnv, extendFamInstEnvList,
  10         famInstEnvElts, familyInstances,
  11         {-lookupFamInstEnv-}
  12     ) where
  13
  14 #include "HsVersions.h"
  15
  16 import TcType           ( Type )
  17 import Type             ( TyThing (ATyCon), pprParendType )
  18 import TyCon            ( TyCon, isDataTyCon, isNewTyCon, isSynTyCon,
  19                           tyConName, tyConTyVars, tyConFamInst_maybe )
  20 import VarSet           ( TyVarSet, mkVarSet )
  21 import Name             ( Name, getOccName, NamedThing(..), getSrcLoc )
  22 import OccName          ( parenSymOcc )
  23 import SrcLoc           ( pprDefnLoc )
  24 import UniqFM           ( UniqFM, lookupUFM, emptyUFM, addToUFM_C, eltsUFM )
  25 import Outputable
  26
  27 import Monad            ( mzero )
  28 \end{code}
  29
  30
  31 %************************************************************************
  32 %*                                                                      *
  33 \subsection{Type checked family instance heads}
  34 %*                                                                      *
  35 %************************************************************************
  36
  37 \begin{code}
  38 data FamInst
  39   = FamInst { fi_fam   :: Name          -- Family name
  40             , fi_tvs   :: TyVarSet      -- Template tyvars for full match
  41             , fi_tys   :: [Type]        -- Full arg types
  42
  43             , fi_tycon :: TyCon         -- Representation tycon
  44             }
  45
  46 -- Obtain the representation tycon of a family instance.
  47 --
  48 famInstTyCon :: FamInst -> TyCon
  49 famInstTyCon = fi_tycon
  50
  51 -- Extract all family instances.
  52 --
  53 extractFamInsts :: [TyThing] -> [FamInst]
  54 extractFamInsts tythings
  55   = do { ATyCon tycon <- tythings
  56        ; case tyConFamInst_maybe tycon of
  57            Nothing         -> mzero
  58            Just (fam, tys) ->
  59              return $ FamInst { fi_fam   = tyConName fam
  60                               , fi_tvs   = mkVarSet . tyConTyVars $ tycon
  61                               , fi_tys   = tys
  62                               , fi_tycon = tycon
  63                               }
  64        }
  65 \end{code}
  66
  67 \begin{code}
  68 instance NamedThing FamInst where
  69    getName = getName . fi_tycon
  70
  71 instance Outputable FamInst where
  72    ppr = pprFamInst
  73
  74 -- Prints the FamInst as a family instance declaration
  75 pprFamInst :: FamInst -> SDoc
  76 pprFamInst famInst
  77   = hang (pprFamInstHdr famInst)
  78         2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcLoc famInst)))
  79
  80 pprFamInstHdr :: FamInst -> SDoc
  81 pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon})
  82   = pprTyConSort <+> pprHead
  83   where
  84     pprHead = parenSymOcc (getOccName fam) (ppr fam) <+>
  85               sep (map pprParendType tys)
  86     pprTyConSort | isDataTyCon tycon = ptext SLIT("data instance")
  87                  | isNewTyCon  tycon = ptext SLIT("newtype instance")
  88                  | isSynTyCon  tycon = ptext SLIT("type instance")
  89                  | otherwise         = panic "FamInstEnv.pprFamInstHdr"
  90
  91 pprFamInsts :: [FamInst] -> SDoc
  92 pprFamInsts finsts = vcat (map pprFamInst finsts)
  93 \end{code}
  94
  95
  96 %************************************************************************
  97 %*                                                                      *
  98                 FamInstEnv
  99 %*                                                                      *
 100 %************************************************************************
 101
 102 InstEnv maps a family name to the list of known instances for that family.
 103
 104 \begin{code}
 105 type FamInstEnv = UniqFM [FamInst]      -- Maps a family to its instances
 106
 107 -- INVARIANTS:
 108 --  * The fs_tvs are distinct in each FamInst
 109 --      of a range value of the map (so we can safely unify them)
 110
 111 emptyFamInstEnv :: FamInstEnv
 112 emptyFamInstEnv = emptyUFM
 113
 114 famInstEnvElts :: FamInstEnv -> [FamInst]
 115 famInstEnvElts = concat . eltsUFM
 116
 117 familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst]
 118 familyInstances (pkg_fie, home_fie) fam
 119   = get home_fie ++ get pkg_fie
 120   where
 121     get env = case lookupUFM env fam of
 122                 Just insts -> insts
 123                 Nothing    -> []
 124
 125 extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv
 126 extendFamInstEnvList inst_env fis = foldl extendFamInstEnv inst_env fis
 127
 128 extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv
 129 extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm})
 130   = addToUFM_C add inst_env cls_nm [ins_item]
 131   where
 132     add items _ = ins_item:items
 133 \end{code}
 134