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 Class            ( classTvsFds )
  19 import Type             ( tyVarsOfType )
  20 import Outputable       ( interppSP, ptext, empty, hsep, punctuate, comma )
  21 import UniqSet          ( elementOfUniqSet, addOneToUniqSet,
  22                           uniqSetToList, unionManyUniqSets )
  23 import List             ( elemIndex )
  24 \end{code}
  25
  26
  27 \begin{code}
  28 oclose fds vs =
  29     case oclose1 fds vs of
  30       (vs', False) -> vs'
  31       (vs', True) -> oclose fds vs'
  32
  33 oclose1 [] vs = (vs, False)
  34 oclose1 (fd@(ls, rs):fds) vs =
  35     if osubset ls vs then
  36         (vs'', b1 || b2)
  37     else
  38         vs'b1
  39     where
  40         vs'b1@(vs', b1) = oclose1 fds vs
  41         (vs'', b2) = ounion rs vs'
  42
  43 osubset [] vs = True
  44 osubset (u:us) vs = if u `elementOfUniqSet` vs then osubset us vs else False
  45
  46 ounion [] ys = (ys, False)
  47 ounion (x:xs) ys =
  48     if x `elementOfUniqSet` ys then (ys', b) else (addOneToUniqSet ys' x, True)
  49     where
  50         (ys', b) = ounion xs ys
  51
  52 instantiateFdClassTys clas ts =
  53     map (lookupInstFundep tyvars ts) fundeps
  54     where
  55         (tyvars, fundeps) = classTvsFds clas
  56         lookupInstFundep tyvars ts (us, vs) =
  57             (lookupInstTys tyvars ts us, lookupInstTys tyvars ts vs)
  58 lookupInstTys tyvars ts = map (lookupInstTy tyvars ts)
  59 lookupInstTy tyvars ts u = ts !! i
  60     where Just i = elemIndex u tyvars
  61
  62 tyVarFunDep fdtys =
  63     map (\(xs, ys) -> (unionMap getTyVars xs, unionMap getTyVars ys)) fdtys
  64     where
  65         getTyVars ty = tyVarsOfType ty
  66         unionMap f xs = uniqSetToList (unionManyUniqSets (map f xs))
  67
  68 pprFundeps [] = empty
  69 pprFundeps fds = hsep (ptext SLIT("|") : punctuate comma (map ppr_fd fds))
  70
  71 ppr_fd (us, vs) = hsep [interppSP us, ptext SLIT("->"), interppSP vs]
  72
  73 \end{code}