ghc/compiler/types/FunDeps.lhs

   1 It's better to read it as: "if we know these, then we're going to know these"
   2
   3 \begin{code}
   4 module FunDeps(oclose, instantiateFundeps, instantiateFdTys, instantiateFdClassTys, pprFundeps) where
   5
   6 #include "HsVersions.h"
   7
   8 import Inst             (getDictClassTys)
   9 import Class            (classTvsFds)
  10 import Type             (getTyVar_maybe, tyVarsOfType)
  11 import Outputable       (interppSP, ptext, empty, hsep, punctuate, comma)
  12 import UniqSet          (elementOfUniqSet, addOneToUniqSet,
  13                          uniqSetToList, unionManyUniqSets)
  14 import List             (elemIndex)
  15 import Maybe            (catMaybes)
  16 import FastString
  17
  18 oclose fds vs =
  19     case oclose1 fds vs of
  20       (vs', False) -> vs'
  21       (vs', True) -> oclose fds vs'
  22
  23 oclose1 [] vs = (vs, False)
  24 oclose1 (fd@(ls, rs):fds) vs =
  25     if osubset ls vs then
  26         (vs'', b1 || b2)
  27     else
  28         vs'b1
  29     where
  30         vs'b1@(vs', b1) = oclose1 fds vs
  31         (vs'', b2) = ounion rs vs'
  32
  33 osubset [] vs = True
  34 osubset (u:us) vs = if u `elementOfUniqSet` vs then osubset us vs else False
  35
  36 ounion [] ys = (ys, False)
  37 ounion (x:xs) ys =
  38     if x `elementOfUniqSet` ys then (ys', b) else (addOneToUniqSet ys' x, True)
  39     where
  40         (ys', b) = ounion xs ys
  41
  42 -- instantiate fundeps to type variables
  43 instantiateFundeps dict =
  44     map (\(xs, ys) -> (unionMap getTyVars xs, unionMap getTyVars ys)) fdtys
  45     where
  46         fdtys = instantiateFdTys dict
  47         getTyVars ty = tyVarsOfType ty
  48         unionMap f xs = uniqSetToList (unionManyUniqSets (map f xs))
  49
  50 -- instantiate fundeps to types
  51 instantiateFdTys dict = instantiateFdClassTys clas ts
  52     where (clas, ts) = getDictClassTys dict
  53 instantiateFdClassTys clas ts =
  54     map (lookupInstFundep tyvars ts) fundeps
  55     where
  56         (tyvars, fundeps) = classTvsFds clas
  57         lookupInstFundep tyvars ts (us, vs) =
  58             (lookupInstTys tyvars ts us, lookupInstTys tyvars ts vs)
  59 lookupInstTys tyvars ts = map (lookupInstTy tyvars ts)
  60 lookupInstTy tyvars ts u = ts !! i
  61     where Just i = elemIndex u tyvars
  62
  63 pprFundeps [] = empty
  64 pprFundeps fds = hsep (ptext SLIT("|") : punctuate comma (map ppr_fd fds))
  65
  66 ppr_fd (us, vs) = hsep [interppSP us, ptext SLIT("->"), interppSP vs]
  67
  68 \end{code}