ghc/compiler/types/FunDeps.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 2000
   3 %
   4 \section[FunDeps]{FunDeps - functional dependencies}
   5
   6 It's better to read it as: "if we know these, then we're going to know these"
   7
   8 \begin{code}
   9 module FunDeps (
  10         oclose,
  11         instantiateFdClassTys,
  12         pprFundeps
  13     ) where
  14
  15 #include "HsVersions.h"
  16
  17 import Var              ( TyVar )
  18 import Class            ( Class, FunDep, classTvsFds )
  19 import Type             ( Type, tyVarsOfTypes )
  20 import Outputable       ( Outputable, SDoc, interppSP, ptext, empty, hsep, punctuate, comma )
  21 import UniqSet
  22 import VarSet
  23 import VarEnv
  24 import Util             ( zipEqual )
  25 \end{code}
  26
  27
  28 \begin{code}
  29 oclose :: [FunDep Type] -> TyVarSet -> TyVarSet
  30 -- (oclose fds tvs) closes the set of type variables tvs,
  31 -- wrt the functional dependencies fds.  The result is a superset
  32 -- of the argument set.
  33 --
  34 -- In fact the functional dependencies are *instantiated*, so we
  35 -- first have to extract the free vars.
  36 --
  37 -- For example,
  38 --      oclose [a -> b] {a}     = {a,b}
  39 --      oclose [a b -> c] {a}   = {a}
  40 --      oclose [a b -> c] {a,b} = {a,b,c}
  41 -- If all of the things on the left of an arrow are in the set, add
  42 -- the things on the right of that arrow.
  43
  44 oclose fds vs
  45   = go vs
  46   where
  47     go vs = case oclose1 tv_fds vs of
  48                 (vs', False) -> vs'
  49                 (vs', True)  -> go vs'
  50
  51     tv_fds  :: [FunDep TyVar]
  52     tv_fds  = [(get_tvs xs, get_tvs ys) | (xs, ys) <- fds]
  53     get_tvs = varSetElems . tyVarsOfTypes
  54
  55 oclose1 [] vs = (vs, False)
  56 oclose1 (fd@(ls, rs):fds) vs =
  57     if osubset ls vs then
  58         (vs'', b1 || b2)
  59     else
  60         vs'b1
  61     where
  62         vs'b1@(vs', b1) = oclose1 fds vs
  63         (vs'', b2) = ounion rs vs'
  64
  65 osubset [] vs = True
  66 osubset (u:us) vs = if u `elementOfUniqSet` vs then osubset us vs else False
  67
  68 ounion [] ys = (ys, False)
  69 ounion (x:xs) ys
  70     | x `elementOfUniqSet` ys = (ys', b)
  71     | otherwise               = (addOneToUniqSet ys' x, True)
  72     where
  73         (ys', b) = ounion xs ys
  74
  75 instantiateFdClassTys :: Class -> [Type] -> [FunDep Type]
  76 -- Get the FDs of the class, and instantiate them
  77 instantiateFdClassTys clas tys
  78   = [(map lookup us, map lookup vs) | (us,vs) <- fundeps]
  79   where
  80     (tyvars, fundeps) = classTvsFds clas
  81     env       = mkVarEnv (zipEqual "instantiateFdClassTys" tyvars tys)
  82     lookup tv = lookupVarEnv_NF env tv
  83
  84
  85 pprFundeps :: Outputable a => [FunDep a] -> SDoc
  86 pprFundeps [] = empty
  87 pprFundeps fds = hsep (ptext SLIT("|") : punctuate comma (map ppr_fd fds))
  88
  89 ppr_fd (us, vs) = hsep [interppSP us, ptext SLIT("->"), interppSP vs]
  90 \end{code}