ghc/compiler/envs/CE.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
   3 %
   4 \section[CE]{Class environment}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module CE (
  10         CE(..),
  11         nullCE, unitCE, rngCE,
  12         plusCE, lookupCE,
  13         checkClassCycles,
  14
  15         -- imported things so we're self-contained...
  16         Unique, UniqFM,
  17         Class, MaybeErr, Name, Pretty(..), PprStyle,
  18         PrettyRep, Error(..)
  19
  20         IF_ATTACK_PRAGMAS(COMMA emptyUFM COMMA plusUFM)
  21         IF_ATTACK_PRAGMAS(COMMA eltsUFM  COMMA singletonDirectlyUFM)
  22         IF_ATTACK_PRAGMAS(COMMA u2i)
  23     ) where
  24
  25 import AbsUniType       ( getClassSig, Class, ClassOp, TyCon, FullName, Arity(..)
  26                           IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
  27                         )
  28 import Digraph          ( topologicalSort )
  29 import Errors           -- notably classCycleErr
  30 import UniqFM           -- basic environment handling
  31 import Maybes           ( Maybe(..), MaybeErr(..) )
  32 import Name             -- Name(..), etc.
  33 import Pretty
  34 import Outputable       -- def of ppr
  35 import Unique           -- for ClassKey uniques
  36 import Util
  37 \end{code}
  38
  39 %************************************************************************
  40 %*                                                                      *
  41 %*              The main representation                                 *
  42 %*                                                                      *
  43 %************************************************************************
  44
  45 \begin{code}
  46 --data CE = MkCE (FiniteMap Unique Class) -- keyed off Class's Uniques
  47 type CE = UniqFM Class
  48 #define MkCE {--}
  49 -- also killed instance CE, exported non-abstractly
  50
  51 nullCE :: CE
  52 nullCE = MkCE emptyUFM
  53
  54 rngCE :: CE -> [Class]
  55 rngCE (MkCE env) = eltsUFM env
  56
  57 unitCE :: Unique{-ClassKey-} -> Class -> CE
  58 unitCE u c = MkCE (singletonDirectlyUFM u c)
  59
  60 plusCE :: CE -> CE -> CE
  61 plusCE (MkCE ce1) (MkCE ce2) = MkCE (plusUFM ce1 ce2)
  62
  63 lookupCE :: CE -> Name -> Class
  64 lookupCE (MkCE ce) name
  65   = case name of
  66       PreludeClass key _  -> case (lookupDirectlyUFM ce key) of
  67                                 Just clas -> clas
  68                                 Nothing -> err_msg
  69       OtherClass uniq _ _ -> case (lookupDirectlyUFM ce uniq) of
  70                                 Just clas -> clas
  71                                 Nothing -> panic "lookupCE! (non-prelude)"
  72   where
  73     err_msg = error ("ERROR: in looking up a Prelude class! "++(ppShow 80 (ppr PprDebug name))++"\n(This can happen if you use `-fno-implicit-prelude'\nor you hide the system's Prelude.hi in some way.)\n")
  74
  75 checkClassCycles :: CE -> MaybeErr () Error
  76 checkClassCycles (MkCE stuff)
  77   = case (topologicalSort (==) edges classes) of
  78       Succeeded _ -> Succeeded ()
  79       Failed cycles
  80            -> Failed (classCycleErr [ map fmt_tycon c | c <- cycles ])
  81                 where
  82                   fmt_tycon c = (ppr PprForUser c, getSrcLoc c)
  83   where
  84     classes = eltsUFM stuff     -- the "vertices"
  85     edges   = concat (map get_edges classes)
  86
  87     get_edges clas
  88       = let  (_, super_classes, _) = getClassSig clas  in
  89         [ (clas, super_class) | super_class <- super_classes ]
  90 \end{code}