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