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