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         tyVarFunDep,
  13         pprFundeps
  14     ) where
  15
  16 #include "HsVersions.h"
  17
  18 import Var              ( TyVar )
  19 import Class            ( Class, FunDep, classTvsFds )
  20 import Type             ( Type, tyVarsOfTypes )
  21 import Outputable       ( Outputable, SDoc, interppSP, ptext, empty, hsep, punctuate, comma )
  22 import UniqSet
  23 import VarSet
  24 import Unique           ( Uniquable )
  25 import List             ( elemIndex )
  26 \end{code}
  27
  28
  29 \begin{code}
  30 oclose :: Uniquable a => [FunDep a] -> UniqSet a -> UniqSet a
  31 -- (oclose fds tvs) closes the set of type variables tvs,
  32 -- wrt the functional dependencies fds.  The result is a superset
  33 -- of the argument set.
  34 --
  35 -- For example,
  36 --      oclose [a -> b] {a}     = {a,b}
  37 --      oclose [a b -> c] {a}   = {a}
  38 --      oclose [a b -> c] {a,b} = {a,b,c}
  39 -- If all of the things on the left of an arrow are in the set, add
  40 -- the things on the right of that arrow.
  41
  42 oclose fds vs =
  43     case oclose1 fds vs of
  44       (vs', False) -> vs'
  45       (vs', True)  -> oclose fds vs'
  46
  47 oclose1 [] vs = (vs, False)
  48 oclose1 (fd@(ls, rs):fds) vs =
  49     if osubset ls vs then
  50         (vs'', b1 || b2)
  51     else
  52         vs'b1
  53     where
  54         vs'b1@(vs', b1) = oclose1 fds vs
  55         (vs'', b2) = ounion rs vs'
  56
  57 osubset [] vs = True
  58 osubset (u:us) vs = if u `elementOfUniqSet` vs then osubset us vs else False
  59
  60 ounion [] ys = (ys, False)
  61 ounion (x:xs) ys
  62     | x `elementOfUniqSet` ys = (ys', b)
  63     | otherwise               = (addOneToUniqSet ys' x, True)
  64     where
  65         (ys', b) = ounion xs ys
  66
  67 instantiateFdClassTys :: Class -> [a] -> [([a], [a])]
  68 -- Get the FDs of the class, and instantiate them
  69 instantiateFdClassTys clas ts
  70   = map (lookupInstFundep tyvars ts) fundeps
  71   where
  72     (tyvars, fundeps) = classTvsFds clas
  73     lookupInstFundep tyvars ts (us, vs)
  74         = (lookupInstTys tyvars ts us, lookupInstTys tyvars ts vs)
  75
  76 lookupInstTys tyvars ts = map (lookupInstTy tyvars ts)
  77 lookupInstTy tyvars ts u = ts !! i
  78     where Just i = elemIndex u tyvars
  79
  80 tyVarFunDep :: [FunDep Type] -> [FunDep TyVar]
  81 tyVarFunDep fdtys
  82   = [(getTyvars xs, getTyvars ys) | (xs, ys) <- fdtys]
  83   where getTyvars = varSetElems . tyVarsOfTypes
  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}