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 @lookupFamInstEnvExact@ looks up in a @FamInstEnv@ using an exact match.
 192 This is used when we want the @TyCon@ of a particular family instance (e.g.,
 193 during deriving classes).
 194
 195 \begin{code}
 196 {-              NOT NEEDED ANY MORE
 197 lookupFamInstEnvExact :: (FamInstEnv            -- External package inst-env
 198                          ,FamInstEnv)           -- Home-package inst-env
 199                       -> TyCon -> [Type]        -- What we are looking for
 200                       -> Maybe FamInst
 201 lookupFamInstEnvExact (pkg_ie, home_ie) fam tys
 202   = home_matches `mplus` pkg_matches
 203   where
 204     rough_tcs    = roughMatchTcs tys
 205     all_tvs      = all isNothing rough_tcs
 206     home_matches = lookup home_ie
 207     pkg_matches  = lookup pkg_ie
 208
 209     --------------
 210     lookup env = case lookupUFM env fam of
 211                    Nothing -> Nothing           -- No instances for this class
 212                    Just (FamIE insts has_tv_insts)
 213                        -- Short cut for common case:
 214                        --   The thing we are looking up is of form (C a
 215                        --   b c), and the FamIE has no instances of
 216                        --   that form, so don't bother to search
 217                      | all_tvs && not has_tv_insts -> Nothing
 218                      | otherwise                   -> find insts
 219
 220     --------------
 221     find [] = Nothing
 222     find (item@(FamInst { fi_tcs = mb_tcs, fi_tys = tpl_tys }) : 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       | tcEqTypes tpl_tys tys
 229       = Just item
 230
 231         -- No match => try next
 232       | otherwise
 233       = find rest
 234 -}
 235 \end{code}
 236
 237 @lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match.
 238 Multiple matches are only possible in case of type families (not data
 239 families), and then, it doesn't matter which match we choose (as the
 240 instances are guaranteed confluent).
 241
 242 \begin{code}
 243 lookupFamInstEnv :: FamInstEnvs
 244                  -> TyCon -> [Type]             -- What we are looking for
 245                  -> [(TvSubst, FamInst)]        -- Successful matches
 246 lookupFamInstEnv (pkg_ie, home_ie) fam tys
 247   = home_matches ++ pkg_matches
 248   where
 249     rough_tcs    = roughMatchTcs tys
 250     all_tvs      = all isNothing rough_tcs
 251     home_matches = lookup home_ie
 252     pkg_matches  = lookup pkg_ie
 253
 254     --------------
 255     lookup env = case lookupUFM env fam of
 256                    Nothing -> []        -- No instances for this class
 257                    Just (FamIE insts has_tv_insts)
 258                        -- Short cut for common case:
 259                        --   The thing we are looking up is of form (C a
 260                        --   b c), and the FamIE has no instances of
 261                        --   that form, so don't bother to search
 262                      | all_tvs && not has_tv_insts -> []
 263                      | otherwise                   -> find insts
 264
 265     --------------
 266     find [] = []
 267     find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs,
 268                           fi_tys = tpl_tys, fi_tycon = tycon }) : rest)
 269         -- Fast check for no match, uses the "rough match" fields
 270       | instanceCantMatch rough_tcs mb_tcs
 271       = find rest
 272
 273         -- Proper check
 274       | Just subst <- tcMatchTys tpl_tvs tpl_tys tys
 275       = (subst, item) : find rest
 276
 277         -- No match => try next
 278       | otherwise
 279       = find rest
 280 \end{code}
 281
 282 While @lookupFamInstEnv@ uses a one-way match, the next function
 283 @lookupFamInstEnvUnify@ uses two-way matching (ie, unification).  This is
 284 needed to check for overlapping instances.
 285
 286 For class instances, these two variants of lookup are combined into one
 287 function (cf, @InstEnv@).  We don't do that for family instances as the
 288 results of matching and unification are used in two different contexts.
 289 Moreover, matching is the wildly more frequently used operation in the case of
 290 indexed synonyms and we don't want to slow that down by needless unification.
 291
 292 \begin{code}
 293 lookupFamInstEnvUnify :: (FamInstEnv, FamInstEnv) -> TyCon -> [Type]
 294                       -> [(TvSubst, FamInst)]
 295 lookupFamInstEnvUnify (pkg_ie, home_ie) fam tys
 296   = home_matches ++ pkg_matches
 297   where
 298     rough_tcs    = roughMatchTcs tys
 299     all_tvs      = all isNothing rough_tcs
 300     home_matches = lookup home_ie
 301     pkg_matches  = lookup pkg_ie
 302
 303     --------------
 304     lookup env = case lookupUFM env fam of
 305                    Nothing -> []        -- No instances for this class
 306                    Just (FamIE insts has_tv_insts)
 307                        -- Short cut for common case:
 308                        --   The thing we are looking up is of form (C a
 309                        --   b c), and the FamIE has no instances of
 310                        --   that form, so don't bother to search
 311                      | all_tvs && not has_tv_insts -> []
 312                      | otherwise                   -> find insts
 313
 314     --------------
 315     find [] = []
 316     find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs,
 317                           fi_tys = tpl_tys, fi_tycon = tycon }) : rest)
 318         -- Fast check for no match, uses the "rough match" fields
 319       | instanceCantMatch rough_tcs mb_tcs
 320       = find rest
 321
 322       | otherwise
 323       = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tvs,
 324                  (ppr fam <+> ppr tys <+> ppr all_tvs) $$
 325                  (ppr tycon <+> ppr tpl_tvs <+> ppr tpl_tys)
 326                 )
 327                 -- Unification will break badly if the variables overlap
 328                 -- They shouldn't because we allocate separate uniques for them
 329         case tcUnifyTys bind_fn tpl_tys tys of
 330             Just subst -> (subst, item) : find rest
 331             Nothing    -> find rest
 332
 333 -- See explanation at @InstEnv.bind_fn@.
 334 --
 335 bind_fn tv | isTcTyVar tv && isExistentialTyVar tv = Skolem
 336            | otherwise                             = BindMe
 337 \end{code}