1 \section[FamInstEnv]{Type checked family instance declarations}
5 FamInst(..), famInstTyCon, extractFamInsts,
6 pprFamInst, pprFamInstHdr, pprFamInsts,
7 {-famInstHead, mkLocalFamInst, mkImportedFamInst-}
9 FamInstEnv, emptyFamInstEnv, extendFamInstEnv, extendFamInstEnvList,
10 famInstEnvElts, familyInstances,
14 #include "HsVersions.h"
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 )
27 import Monad ( mzero )
31 %************************************************************************
33 \subsection{Type checked family instance heads}
35 %************************************************************************
39 = FamInst { fi_fam :: Name -- Family name
40 , fi_tvs :: TyVarSet -- Template tyvars for full match
41 , fi_tys :: [Type] -- Full arg types
43 , fi_tycon :: TyCon -- Representation tycon
46 -- Obtain the representation tycon of a family instance.
48 famInstTyCon :: FamInst -> TyCon
49 famInstTyCon = fi_tycon
51 -- Extract all family instances.
53 extractFamInsts :: [TyThing] -> [FamInst]
54 extractFamInsts tythings
55 = do { ATyCon tycon <- tythings
56 ; case tyConFamInst_maybe tycon of
59 return $ FamInst { fi_fam = tyConName fam
60 , fi_tvs = mkVarSet . tyConTyVars $ tycon
68 instance NamedThing FamInst where
69 getName = getName . fi_tycon
71 instance Outputable FamInst where
74 -- Prints the FamInst as a family instance declaration
75 pprFamInst :: FamInst -> SDoc
77 = hang (pprFamInstHdr famInst)
78 2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcLoc famInst)))
80 pprFamInstHdr :: FamInst -> SDoc
81 pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon})
82 = pprTyConSort <+> pprHead
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"
91 pprFamInsts :: [FamInst] -> SDoc
92 pprFamInsts finsts = vcat (map pprFamInst finsts)
96 %************************************************************************
100 %************************************************************************
102 InstEnv maps a family name to the list of known instances for that family.
105 type FamInstEnv = UniqFM [FamInst] -- Maps a family to its instances
108 -- * The fs_tvs are distinct in each FamInst
109 -- of a range value of the map (so we can safely unify them)
111 emptyFamInstEnv :: FamInstEnv
112 emptyFamInstEnv = emptyUFM
114 famInstEnvElts :: FamInstEnv -> [FamInst]
115 famInstEnvElts = concat . eltsUFM
117 familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst]
118 familyInstances (pkg_fie, home_fie) fam
119 = get home_fie ++ get pkg_fie
121 get env = case lookupUFM env fam of
125 extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv
126 extendFamInstEnvList inst_env fis = foldl extendFamInstEnv inst_env fis
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]
132 add items _ = ins_item:items