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 (getSrcSpan 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 We return the matching family instances and the type instance at which it
 202 matches.  For example, if we lookup 'T [Int]' and have a family instance
 203
 204   data instance T [a] = ..
 205
 206 desugared to
 207
 208   data :R42T a = ..
 209   coe :Co:R42T a :: T [a] ~ :R42T a
 210
 211 we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'.
 212
 213 \begin{code}
 214 type FamInstMatch = (FamInst, [Type])           -- Matching type instance
 215
 216 lookupFamInstEnv :: FamInstEnvs
 217                  -> TyCon -> [Type]             -- What we are looking for
 218                  -> [FamInstMatch]              -- Successful matches
 219 lookupFamInstEnv (pkg_ie, home_ie) fam tys
 220   = home_matches ++ pkg_matches
 221   where
 222     rough_tcs    = roughMatchTcs tys
 223     all_tvs      = all isNothing rough_tcs
 224     home_matches = lookup home_ie
 225     pkg_matches  = lookup pkg_ie
 226
 227     --------------
 228     lookup env = case lookupUFM env fam of
 229                    Nothing -> []        -- No instances for this class
 230                    Just (FamIE insts has_tv_insts)
 231                        -- Short cut for common case:
 232                        --   The thing we are looking up is of form (C a
 233                        --   b c), and the FamIE has no instances of
 234                        --   that form, so don't bother to search
 235                      | all_tvs && not has_tv_insts -> []
 236                      | otherwise                   -> find insts
 237
 238     --------------
 239     find [] = []
 240     find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs,
 241                           fi_tys = tpl_tys, fi_tycon = tycon }) : rest)
 242         -- Fast check for no match, uses the "rough match" fields
 243       | instanceCantMatch rough_tcs mb_tcs
 244       = find rest
 245
 246         -- Proper check
 247       | Just subst <- tcMatchTys tpl_tvs tpl_tys tys
 248       = (item, substTyVars subst (tyConTyVars tycon)) : find rest
 249
 250         -- No match => try next
 251       | otherwise
 252       = find rest
 253 \end{code}
 254
 255 While @lookupFamInstEnv@ uses a one-way match, the next function
 256 @lookupFamInstEnvUnify@ uses two-way matching (ie, unification).  This is
 257 needed to check for overlapping instances.
 258
 259 For class instances, these two variants of lookup are combined into one
 260 function (cf, @InstEnv@).  We don't do that for family instances as the
 261 results of matching and unification are used in two different contexts.
 262 Moreover, matching is the wildly more frequently used operation in the case of
 263 indexed synonyms and we don't want to slow that down by needless unification.
 264
 265 \begin{code}
 266 lookupFamInstEnvUnify :: (FamInstEnv, FamInstEnv) -> TyCon -> [Type]
 267                       -> [(FamInstMatch)]
 268 lookupFamInstEnvUnify (pkg_ie, home_ie) fam tys
 269   = home_matches ++ pkg_matches
 270   where
 271     rough_tcs    = roughMatchTcs tys
 272     all_tvs      = all isNothing rough_tcs
 273     home_matches = lookup home_ie
 274     pkg_matches  = lookup pkg_ie
 275
 276     --------------
 277     lookup env = case lookupUFM env fam of
 278                    Nothing -> []        -- No instances for this class
 279                    Just (FamIE insts has_tv_insts)
 280                        -- Short cut for common case:
 281                        --   The thing we are looking up is of form (C a
 282                        --   b c), and the FamIE has no instances of
 283                        --   that form, so don't bother to search
 284                      | all_tvs && not has_tv_insts -> []
 285                      | otherwise                   -> find insts
 286
 287     --------------
 288     find [] = []
 289     find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs,
 290                           fi_tys = tpl_tys, fi_tycon = tycon }) : rest)
 291         -- Fast check for no match, uses the "rough match" fields
 292       | instanceCantMatch rough_tcs mb_tcs
 293       = find rest
 294
 295       | otherwise
 296       = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tvs,
 297                  (ppr fam <+> ppr tys <+> ppr all_tvs) $$
 298                  (ppr tycon <+> ppr tpl_tvs <+> ppr tpl_tys)
 299                 )
 300                 -- Unification will break badly if the variables overlap
 301                 -- They shouldn't because we allocate separate uniques for them
 302         case tcUnifyTys bind_fn tpl_tys tys of
 303             Just subst -> let rep_tys = substTyVars subst (tyConTyVars tycon)
 304                           in
 305                           (item, rep_tys) : find rest
 306             Nothing    -> find rest
 307
 308 -- See explanation at @InstEnv.bind_fn@.
 309 --
 310 bind_fn tv | isTcTyVar tv && isExistentialTyVar tv = Skolem
 311            | otherwise                             = BindMe
 312 \end{code}