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, famInstTyVars,
  10         pprFamInst, pprFamInstHdr, pprFamInsts,
  11         famInstHead, mkLocalFamInst, mkImportedFamInst,
  12
  13         FamInstEnvs, FamInstEnv, emptyFamInstEnv,
  14         extendFamInstEnv, extendFamInstEnvList,
  15         famInstEnvElts, familyInstances,
  16
  17         lookupFamInstEnv, lookupFamInstEnvUnify
  18     ) where
  19
  20 #include "HsVersions.h"
  21
  22 import InstEnv
  23 import Unify
  24 import TcGadt
  25 import TcType
  26 import Type
  27 import TyCon
  28 import VarSet
  29 import Var
  30 import Name
  31 import OccName
  32 import SrcLoc
  33 import UniqFM
  34 import Outputable
  35
  36 import Maybe
  37 \end{code}
  38
  39
  40 %************************************************************************
  41 %*                                                                      *
  42 \subsection{Type checked family instance heads}
  43 %*                                                                      *
  44 %************************************************************************
  45
  46 \begin{code}
  47 data FamInst
  48   = FamInst { fi_fam   :: Name          -- Family name
  49                 -- INVARIANT: fi_fam = case tyConFamInst_maybe fi_tycon of
  50                 --                         Just (tc, tys) -> tc
  51
  52                 -- Used for "rough matching"; same idea as for class instances
  53             , fi_tcs   :: [Maybe Name]  -- Top of type args
  54                 -- INVARIANT: fi_tcs = roughMatchTcs fi_tys
  55
  56                 -- Used for "proper matching"; ditto
  57             , fi_tvs   :: TyVarSet      -- Template tyvars for full match
  58             , fi_tys   :: [Type]        -- Full arg types
  59                 -- INVARIANT: fi_tvs = tyConTyVars fi_tycon
  60                 --            fi_tys = case tyConFamInst_maybe fi_tycon of
  61                 --                         Just (_, tys) -> tys
  62
  63             , fi_tycon :: TyCon         -- Representation tycon
  64             }
  65
  66 -- Obtain the representation tycon of a family instance.
  67 --
  68 famInstTyCon :: FamInst -> TyCon
  69 famInstTyCon = fi_tycon
  70
  71 famInstTyVars = fi_tvs
  72 \end{code}
  73
  74 \begin{code}
  75 instance NamedThing FamInst where
  76    getName = getName . fi_tycon
  77
  78 instance Outputable FamInst where
  79    ppr = pprFamInst
  80
  81 -- Prints the FamInst as a family instance declaration
  82 pprFamInst :: FamInst -> SDoc
  83 pprFamInst famInst
  84   = hang (pprFamInstHdr famInst)
  85         2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcLoc famInst)))
  86
  87 pprFamInstHdr :: FamInst -> SDoc
  88 pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon})
  89   = pprTyConSort <+> pprHead
  90   where
  91     pprHead = pprTypeApp (parenSymOcc (getOccName fam) (ppr fam)) tys
  92     pprTyConSort | isDataTyCon tycon = ptext SLIT("data instance")
  93                  | isNewTyCon  tycon = ptext SLIT("newtype instance")
  94                  | isSynTyCon  tycon = ptext SLIT("type instance")
  95                  | otherwise         = panic "FamInstEnv.pprFamInstHdr"
  96
  97 pprFamInsts :: [FamInst] -> SDoc
  98 pprFamInsts finsts = vcat (map pprFamInst finsts)
  99
 100 famInstHead :: FamInst -> ([TyVar], TyCon, [Type])
 101 famInstHead (FamInst {fi_tycon = tycon})
 102   = case tyConFamInst_maybe tycon of
 103       Nothing         -> panic "FamInstEnv.famInstHead"
 104       Just (fam, tys) -> (tyConTyVars tycon, fam, tys)
 105
 106 -- Make a family instance representation from a tycon.  This is used for local
 107 -- instances, where we can safely pull on the tycon.
 108 --
 109 mkLocalFamInst :: TyCon -> FamInst
 110 mkLocalFamInst tycon
 111   = case tyConFamInst_maybe tycon of
 112            Nothing         -> panic "FamInstEnv.mkLocalFamInst"
 113            Just (fam, tys) ->
 114              FamInst {
 115                fi_fam   = tyConName fam,
 116                fi_tcs   = roughMatchTcs tys,
 117                fi_tvs   = mkVarSet . tyConTyVars $ tycon,
 118                fi_tys   = tys,
 119                fi_tycon = tycon
 120              }
 121
 122 -- Make a family instance representation from the information found in an
 123 -- unterface file.  In particular, we get the rough match info from the iface
 124 -- (instead of computing it here).
 125 --
 126 mkImportedFamInst :: Name -> [Maybe Name] -> TyCon -> FamInst
 127 mkImportedFamInst fam mb_tcs tycon
 128   = FamInst {
 129       fi_fam   = fam,
 130       fi_tcs   = mb_tcs,
 131       fi_tvs   = mkVarSet . tyConTyVars $ tycon,
 132       fi_tys   = case tyConFamInst_maybe tycon of
 133                    Nothing       -> panic "FamInstEnv.mkImportedFamInst"
 134                    Just (_, tys) -> tys,
 135       fi_tycon = tycon
 136     }
 137 \end{code}
 138
 139
 140 %************************************************************************
 141 %*                                                                      *
 142                 FamInstEnv
 143 %*                                                                      *
 144 %************************************************************************
 145
 146 InstEnv maps a family name to the list of known instances for that family.
 147
 148 \begin{code}
 149 type FamInstEnv = UniqFM FamilyInstEnv  -- Maps a family to its instances
 150
 151 type FamInstEnvs = (FamInstEnv, FamInstEnv)
 152         -- External package inst-env, Home-package inst-env
 153
 154 data FamilyInstEnv
 155   = FamIE [FamInst]     -- The instances for a particular family, in any order
 156           Bool          -- True <=> there is an instance of form T a b c
 157                         --      If *not* then the common case of looking up
 158                         --      (T a b c) can fail immediately
 159
 160 -- INVARIANTS:
 161 --  * The fs_tvs are distinct in each FamInst
 162 --      of a range value of the map (so we can safely unify them)
 163
 164 emptyFamInstEnv :: FamInstEnv
 165 emptyFamInstEnv = emptyUFM
 166
 167 famInstEnvElts :: FamInstEnv -> [FamInst]
 168 famInstEnvElts fi = [elt | FamIE elts _ <- eltsUFM fi, elt <- elts]
 169
 170 familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst]
 171 familyInstances (pkg_fie, home_fie) fam
 172   = get home_fie ++ get pkg_fie
 173   where
 174     get env = case lookupUFM env fam of
 175                 Just (FamIE insts _) -> insts
 176                 Nothing              -> []
 177
 178 extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv
 179 extendFamInstEnvList inst_env fis = foldl extendFamInstEnv inst_env fis
 180
 181 extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv
 182 extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs})
 183   = addToUFM_C add inst_env cls_nm (FamIE [ins_item] ins_tyvar)
 184   where
 185     add (FamIE items tyvar) _ = FamIE (ins_item:items)
 186                                       (ins_tyvar || tyvar)
 187     ins_tyvar = not (any isJust mb_tcs)
 188 \end{code}
 189
 190 %************************************************************************
 191 %*                                                                      *
 192 \subsection{Looking up a family instance}
 193 %*                                                                      *
 194 %************************************************************************
 195
 196 @lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match.
 197 Multiple matches are only possible in case of type families (not data
 198 families), and then, it doesn't matter which match we choose (as the
 199 instances are guaranteed confluent).
 200
 201 \begin{code}
 202 lookupFamInstEnv :: FamInstEnvs
 203                  -> TyCon -> [Type]             -- What we are looking for
 204                  -> [(TvSubst, FamInst)]        -- Successful matches
 205 lookupFamInstEnv (pkg_ie, home_ie) fam tys
 206   = home_matches ++ pkg_matches
 207   where
 208     rough_tcs    = roughMatchTcs tys
 209     all_tvs      = all isNothing rough_tcs
 210     home_matches = lookup home_ie
 211     pkg_matches  = lookup pkg_ie
 212
 213     --------------
 214     lookup env = case lookupUFM env fam of
 215                    Nothing -> []        -- No instances for this class
 216                    Just (FamIE insts has_tv_insts)
 217                        -- Short cut for common case:
 218                        --   The thing we are looking up is of form (C a
 219                        --   b c), and the FamIE has no instances of
 220                        --   that form, so don't bother to search
 221                      | all_tvs && not has_tv_insts -> []
 222                      | otherwise                   -> find insts
 223
 224     --------------
 225     find [] = []
 226     find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs,
 227                           fi_tys = tpl_tys, fi_tycon = tycon }) : rest)
 228         -- Fast check for no match, uses the "rough match" fields
 229       | instanceCantMatch rough_tcs mb_tcs
 230       = find rest
 231
 232         -- Proper check
 233       | Just subst <- tcMatchTys tpl_tvs tpl_tys tys
 234       = (subst, item) : find rest
 235
 236         -- No match => try next
 237       | otherwise
 238       = find rest
 239 \end{code}
 240
 241 While @lookupFamInstEnv@ uses a one-way match, the next function
 242 @lookupFamInstEnvUnify@ uses two-way matching (ie, unification).  This is
 243 needed to check for overlapping instances.
 244
 245 For class instances, these two variants of lookup are combined into one
 246 function (cf, @InstEnv@).  We don't do that for family instances as the
 247 results of matching and unification are used in two different contexts.
 248 Moreover, matching is the wildly more frequently used operation in the case of
 249 indexed synonyms and we don't want to slow that down by needless unification.
 250
 251 \begin{code}
 252 lookupFamInstEnvUnify :: (FamInstEnv, FamInstEnv) -> TyCon -> [Type]
 253                       -> [(TvSubst, FamInst)]
 254 lookupFamInstEnvUnify (pkg_ie, home_ie) fam tys
 255   = home_matches ++ pkg_matches
 256   where
 257     rough_tcs    = roughMatchTcs tys
 258     all_tvs      = all isNothing rough_tcs
 259     home_matches = lookup home_ie
 260     pkg_matches  = lookup pkg_ie
 261
 262     --------------
 263     lookup env = case lookupUFM env fam of
 264                    Nothing -> []        -- No instances for this class
 265                    Just (FamIE insts has_tv_insts)
 266                        -- Short cut for common case:
 267                        --   The thing we are looking up is of form (C a
 268                        --   b c), and the FamIE has no instances of
 269                        --   that form, so don't bother to search
 270                      | all_tvs && not has_tv_insts -> []
 271                      | otherwise                   -> find insts
 272
 273     --------------
 274     find [] = []
 275     find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs,
 276                           fi_tys = tpl_tys, fi_tycon = tycon }) : rest)
 277         -- Fast check for no match, uses the "rough match" fields
 278       | instanceCantMatch rough_tcs mb_tcs
 279       = find rest
 280
 281       | otherwise
 282       = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tvs,
 283                  (ppr fam <+> ppr tys <+> ppr all_tvs) $$
 284                  (ppr tycon <+> ppr tpl_tvs <+> ppr tpl_tys)
 285                 )
 286                 -- Unification will break badly if the variables overlap
 287                 -- They shouldn't because we allocate separate uniques for them
 288         case tcUnifyTys bind_fn tpl_tys tys of
 289             Just subst -> (subst, item) : find rest
 290             Nothing    -> find rest
 291
 292 -- See explanation at @InstEnv.bind_fn@.
 293 --
 294 bind_fn tv | isTcTyVar tv && isExistentialTyVar tv = Skolem
 295            | otherwise                             = BindMe
 296 \end{code}