compiler/types/FamInstEnv.lhs

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