compiler/types/FamInstEnv.lhs

   1 \section[FamInstEnv]{Type checked family instance declarations}
   2
   3 \begin{code}
   4 module FamInstEnv (
   5         FamInst(..), famInstTyCon, pprFamInst, pprFamInstHdr, pprFamInsts,
   6         famInstHead, mkLocalFamInst, mkImportedFamInst,
   7
   8         FamInstEnv, emptyFamInstEnv, extendFamInstEnv, extendFamInstEnvList,
   9         famInstEnvElts, familyInstances,
  10         lookupFamInstEnv
  11     ) where
  12
  13 #include "HsVersions.h"
  14
  15 import InstEnv          ( roughMatchTcs, instanceCantMatch )
  16 import Unify            ( tcMatchTys )
  17 import TcType           ( Type )
  18 import Type             ( TvSubst, TyThing (ATyCon), pprParendType )
  19 import TyCon            ( TyCon, isDataTyCon, isNewTyCon, isSynTyCon,
  20                           tyConName, tyConTyVars, tyConFamInst_maybe )
  21 import VarSet           ( TyVarSet, mkVarSet )
  22 import Var              ( TyVar )
  23 import Name             ( Name, getOccName, NamedThing(..), getSrcLoc )
  24 import OccName          ( parenSymOcc )
  25 import SrcLoc           ( pprDefnLoc )
  26 import UniqFM           ( UniqFM, lookupUFM, emptyUFM, addToUFM_C, eltsUFM )
  27 import Outputable
  28
  29 import Maybe            ( isJust, isNothing )
  30 import Monad            ( mzero )
  31 \end{code}
  32
  33
  34 %************************************************************************
  35 %*                                                                      *
  36 \subsection{Type checked family instance heads}
  37 %*                                                                      *
  38 %************************************************************************
  39
  40 \begin{code}
  41 data FamInst
  42   = FamInst { fi_fam   :: Name          -- Family name
  43
  44                 -- Used for "rough matching"; same idea as for class instances
  45             , fi_tcs   :: [Maybe Name]  -- Top of type args
  46
  47                 -- Used for "proper matching"; ditto
  48             , fi_tvs   :: TyVarSet      -- Template tyvars for full match
  49             , fi_tys   :: [Type]        -- Full arg types
  50
  51             , fi_tycon :: TyCon         -- Representation tycon
  52             }
  53
  54 -- Obtain the representation tycon of a family instance.
  55 --
  56 famInstTyCon :: FamInst -> TyCon
  57 famInstTyCon = fi_tycon
  58 \end{code}
  59
  60 \begin{code}
  61 instance NamedThing FamInst where
  62    getName = getName . fi_tycon
  63
  64 instance Outputable FamInst where
  65    ppr = pprFamInst
  66
  67 -- Prints the FamInst as a family instance declaration
  68 pprFamInst :: FamInst -> SDoc
  69 pprFamInst famInst
  70   = hang (pprFamInstHdr famInst)
  71         2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcLoc famInst)))
  72
  73 pprFamInstHdr :: FamInst -> SDoc
  74 pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon})
  75   = pprTyConSort <+> pprHead
  76   where
  77     pprHead = parenSymOcc (getOccName fam) (ppr fam) <+>
  78               sep (map pprParendType tys)
  79     pprTyConSort | isDataTyCon tycon = ptext SLIT("data instance")
  80                  | isNewTyCon  tycon = ptext SLIT("newtype instance")
  81                  | isSynTyCon  tycon = ptext SLIT("type instance")
  82                  | otherwise         = panic "FamInstEnv.pprFamInstHdr"
  83
  84 pprFamInsts :: [FamInst] -> SDoc
  85 pprFamInsts finsts = vcat (map pprFamInst finsts)
  86
  87 famInstHead :: FamInst -> ([TyVar], TyCon, [Type])
  88 famInstHead (FamInst {fi_tycon = tycon})
  89   = case tyConFamInst_maybe tycon of
  90       Nothing         -> panic "FamInstEnv.famInstHead"
  91       Just (fam, tys) -> (tyConTyVars tycon, fam, tys)
  92
  93 -- Make a family instance representation from a tycon.  This is used for local
  94 -- instances, where we can safely pull on the tycon.
  95 --
  96 mkLocalFamInst :: TyCon -> FamInst
  97 mkLocalFamInst tycon
  98   = case tyConFamInst_maybe tycon of
  99            Nothing         -> panic "FamInstEnv.mkLocalFamInst"
 100            Just (fam, tys) ->
 101              FamInst {
 102                fi_fam   = tyConName fam,
 103                fi_tcs   = roughMatchTcs tys,
 104                fi_tvs   = mkVarSet . tyConTyVars $ tycon,
 105                fi_tys   = tys,
 106                fi_tycon = tycon
 107              }
 108
 109 -- Make a family instance representation from the information found in an
 110 -- unterface file.  In particular, we get the rough match info from the iface
 111 -- (instead of computing it here).
 112 --
 113 mkImportedFamInst :: Name -> [Maybe Name] -> TyCon -> FamInst
 114 mkImportedFamInst fam mb_tcs tycon
 115   = FamInst {
 116       fi_fam   = fam,
 117       fi_tcs   = mb_tcs,
 118       fi_tvs   = mkVarSet . tyConTyVars $ tycon,
 119       fi_tys   = case tyConFamInst_maybe tycon of
 120                    Nothing       -> panic "FamInstEnv.mkImportedFamInst"
 121                    Just (_, tys) -> tys,
 122       fi_tycon = tycon
 123     }
 124 \end{code}
 125
 126
 127 %************************************************************************
 128 %*                                                                      *
 129                 FamInstEnv
 130 %*                                                                      *
 131 %************************************************************************
 132
 133 InstEnv maps a family name to the list of known instances for that family.
 134
 135 \begin{code}
 136 type FamInstEnv = UniqFM FamilyInstEnv  -- Maps a family to its instances
 137
 138 data FamilyInstEnv
 139   = FamIE [FamInst]     -- The instances for a particular family, in any order
 140           Bool          -- True <=> there is an instance of form T a b c
 141                         --      If *not* then the common case of looking up
 142                         --      (T a b c) can fail immediately
 143
 144 -- INVARIANTS:
 145 --  * The fs_tvs are distinct in each FamInst
 146 --      of a range value of the map (so we can safely unify them)
 147
 148 emptyFamInstEnv :: FamInstEnv
 149 emptyFamInstEnv = emptyUFM
 150
 151 famInstEnvElts :: FamInstEnv -> [FamInst]
 152 famInstEnvElts fi = [elt | FamIE elts _ <- eltsUFM fi, elt <- elts]
 153
 154 familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst]
 155 familyInstances (pkg_fie, home_fie) fam
 156   = get home_fie ++ get pkg_fie
 157   where
 158     get env = case lookupUFM env fam of
 159                 Just (FamIE insts _) -> insts
 160                 Nothing              -> []
 161
 162 extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv
 163 extendFamInstEnvList inst_env fis = foldl extendFamInstEnv inst_env fis
 164
 165 extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv
 166 extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs})
 167   = addToUFM_C add inst_env cls_nm (FamIE [ins_item] ins_tyvar)
 168   where
 169     add (FamIE items tyvar) _ = FamIE (ins_item:items)
 170                                       (ins_tyvar || tyvar)
 171     ins_tyvar = not (any isJust mb_tcs)
 172 \end{code}
 173
 174 %************************************************************************
 175 %*                                                                      *
 176 \subsection{Looking up a family instance}
 177 %*                                                                      *
 178 %************************************************************************
 179
 180 @lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match.
 181 Multiple matches are only possible in case of type families (not data
 182 families), and then, it doesn't matter which match we choose (as the
 183 instances are guaranteed confluent).
 184
 185 \begin{code}
 186 lookupFamInstEnv :: (FamInstEnv         -- External package inst-env
 187                     ,FamInstEnv)        -- Home-package inst-env
 188                  -> TyCon -> [Type]             -- What we are looking for
 189                  -> [(TvSubst, FamInst)]        -- Successful matches
 190 lookupFamInstEnv (pkg_ie, home_ie) fam tys
 191   = home_matches ++ pkg_matches
 192   where
 193     rough_tcs    = roughMatchTcs tys
 194     all_tvs      = all isNothing rough_tcs
 195     home_matches = lookup home_ie
 196     pkg_matches  = lookup pkg_ie
 197
 198     --------------
 199     lookup env = case lookupUFM env fam of
 200                    Nothing -> []        -- No instances for this class
 201                    Just (FamIE insts has_tv_insts)
 202                        -- Short cut for common case:
 203                        --   The thing we are looking up is of form (C a
 204                        --   b c), and the FamIE has no instances of
 205                        --   that form, so don't bother to search
 206                      | all_tvs && not has_tv_insts -> []
 207                      | otherwise                   -> find insts
 208
 209     --------------
 210     find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs,
 211                           fi_tys = tpl_tys, fi_tycon = tycon }) : rest)
 212         -- Fast check for no match, uses the "rough match" fields
 213       | instanceCantMatch rough_tcs mb_tcs
 214       = find rest
 215
 216         -- Proper check
 217       | Just subst <- tcMatchTys tpl_tvs tpl_tys tys
 218       = (subst, item) : find rest
 219
 220         -- No match => try next
 221       | otherwise
 222       = find rest
 223 \end{code}