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