ghc/compiler/envs/TCE.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[TCE]{Type constructor environment}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TCE (
  10         TCE(..), UniqFM,
  11         nullTCE, unitTCE,
  12         rngTCE,
  13         lookupTCE,
  14         plusTCE, checkTypeCycles,
  15 -- NOT REALLY USED: printTypeInfoForPop,
  16
  17         -- and to make the interface self-sufficient...
  18         MaybeErr, Name, TyCon,
  19         Error(..), SrcLoc, Pretty(..), PrettyRep
  20
  21         IF_ATTACK_PRAGMAS(COMMA emptyUFM COMMA plusUFM)
  22         IF_ATTACK_PRAGMAS(COMMA eltsUFM  COMMA singletonDirectlyUFM)
  23         IF_ATTACK_PRAGMAS(COMMA u2i)
  24    ) where
  25
  26 import AbsUniType       ( getMentionedTyCons, isDataTyCon, getTyConDataCons,
  27                           TyCon, Arity(..), Class, UniType
  28                           IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
  29                           IF_ATTACK_PRAGMAS(COMMA cmpUniType)
  30                         )
  31 import Digraph          ( topologicalSort )
  32 import Errors           -- notably typeCycleErr
  33 import Id               ( getDataConArity, Id, DataCon(..) )
  34 import Maybes           ( Maybe(..), MaybeErr(..) )
  35 import Name
  36 import Outputable
  37 import Pretty
  38 import UniqFM           -- basic environment handling
  39 import Unique           ( Unique )
  40 import Util
  41 \end{code}
  42
  43 \begin{code}
  44 --data TCE = MkTCE (UniqFM TyCon)
  45 type TCE = UniqFM TyCon
  46 #define MkTCE {--}
  47 -- also killed instance TCE, exported non-abstractly
  48
  49 nullTCE :: TCE
  50 nullTCE = MkTCE emptyUFM
  51
  52 unitTCE :: Unique -> TyCon -> TCE
  53 unitTCE uniq tycon = MkTCE (singletonDirectlyUFM uniq tycon)
  54
  55 rngTCE :: TCE -> [TyCon]
  56 rngTCE (MkTCE tce) = eltsUFM tce
  57
  58 lookupTCE :: TCE -> Name -> TyCon
  59 lookupTCE (MkTCE tce) name
  60   = case name of
  61       WiredInTyCon tycon       -> tycon
  62       PreludeTyCon key _ _ _   -> case (lookupDirectlyUFM tce key) of
  63                                     Just tycon -> tycon
  64                                     Nothing    -> err_msg
  65       OtherTyCon uniq _ _ _ _  -> case (lookupDirectlyUFM tce uniq) of
  66                                     Just tycon -> tycon
  67                                     Nothing    -> err_msg
  68   where
  69     err_msg = error ("ERROR: in looking up a type constructor! "++(ppShow 80 (ppr PprDebug name))++"\n(This can happen if you use `-fno-implicit-prelude'\nor you hide or change the system's Prelude.hi in some way.\nA -fhaskell-1.3 flag, or lack thereof, can trigger this error.)\n")
  70
  71 plusTCE :: TCE -> TCE -> TCE
  72 plusTCE (MkTCE tce1) (MkTCE tce2) = MkTCE (plusUFM tce1 tce2)
  73 \end{code}
  74
  75 \begin{code}
  76 checkTypeCycles :: TCE -> MaybeErr () Error
  77 checkTypeCycles tce
  78  = case (topologicalSort (==) edges vertices) of
  79     Succeeded ordering -> Succeeded ()
  80     Failed cycles
  81          -> Failed (typeCycleErr (map (\ c -> map fmt_tycon c) cycles))
  82               where
  83                 fmt_tycon c = (ppr PprForUser c, getSrcLoc c)
  84    where
  85    vertices = [ vertex1 | (vertex1, vertex2) <- edges]
  86    edges = concat (map get_edges (rngTCE tce))
  87             where
  88             get_edges tycon = [(tycon, dep) | dep <- getMentionedTyCons tycon]
  89                 -- Make an arc for every dependency
  90 \end{code}
  91
  92 \begin{code}
  93 {- NOT REALLY USED:
  94 printTypeInfoForPop :: TCE -> Pretty
  95
  96 printTypeInfoForPop (MkTCE tce)
  97   = ppAboves [ pp_type tc | tc <- eltsUFM tce, isDataTyCon tc ]
  98   where
  99     pp_type tycon
 100       = ppBesides [
 101             ppStr "data ",
 102             ppr PprForUser tycon, ppSP,
 103             ppInterleave ppSP (map pp_data_con (getTyConDataCons tycon)),
 104             ppSemi
 105         ]
 106       where
 107         pp_data_con data_con
 108           = ppCat [ppr PprForUser data_con, ppInt (getDataConArity data_con)]
 109 -}
 110 \end{code}