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