2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
4 \section[CE]{Class environment}
7 #include "HsVersions.h"
11 nullCE, unitCE, rngCE,
15 -- imported things so we're self-contained...
17 Class, MaybeErr, Name, Pretty(..), PprStyle,
20 IF_ATTACK_PRAGMAS(COMMA emptyUFM COMMA plusUFM)
21 IF_ATTACK_PRAGMAS(COMMA eltsUFM COMMA singletonDirectlyUFM)
22 IF_ATTACK_PRAGMAS(COMMA u2i)
25 import AbsUniType ( getClassSig, Class, ClassOp, TyCon, FullName, Arity(..)
26 IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
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.
34 import Outputable -- def of ppr
35 import Unique -- for ClassKey uniques
39 %************************************************************************
41 %* The main representation *
43 %************************************************************************
46 --data CE = MkCE (FiniteMap Unique Class) -- keyed off Class's Uniques
47 type CE = UniqFM Class
49 -- also killed instance CE, exported non-abstractly
52 nullCE = MkCE emptyUFM
54 rngCE :: CE -> [Class]
55 rngCE (MkCE env) = eltsUFM env
57 unitCE :: Unique{-ClassKey-} -> Class -> CE
58 unitCE u c = MkCE (singletonDirectlyUFM u c)
60 plusCE :: CE -> CE -> CE
61 plusCE (MkCE ce1) (MkCE ce2) = MkCE (plusUFM ce1 ce2)
63 lookupCE :: CE -> Name -> Class
64 lookupCE (MkCE ce) name
66 PreludeClass key _ -> case (lookupDirectlyUFM ce key) of
69 OtherClass uniq _ _ -> case (lookupDirectlyUFM ce uniq) of
71 Nothing -> panic "lookupCE! (non-prelude)"
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")
75 checkClassCycles :: CE -> MaybeErr () Error
76 checkClassCycles (MkCE stuff)
77 = case (topologicalSort (==) edges classes) of
78 Succeeded _ -> Succeeded ()
80 -> Failed (classCycleErr [ map fmt_tycon c | c <- cycles ])
82 fmt_tycon c = (ppr PprForUser c, getSrcLoc c)
84 classes = eltsUFM stuff -- the "vertices"
85 edges = concat (map get_edges classes)
88 = let (_, super_classes, _) = getClassSig clas in
89 [ (clas, super_class) | super_class <- super_classes ]