ghc/compiler/rename/RnHsSyn.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996
   3 %
   4 \section[RnHsSyn]{Specialisations of the @HsSyn@ syntax for the renamer}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module RnHsSyn where
  10
  11 import Ubiq
  12
  13 import HsSyn
  14
  15 import Name             ( isLocalName, nameUnique, Name, RdrName )
  16 import Id               ( GenId, Id(..) )
  17 import Outputable       ( Outputable(..) )
  18 import PprType          ( GenType, GenTyVar, TyCon )
  19 import PprStyle         ( PprStyle(..) )
  20 import Pretty
  21 import TyCon            ( TyCon )
  22 import TyVar            ( GenTyVar )
  23 import Unique           ( Unique )
  24 import Util             ( panic, pprPanic )
  25 \end{code}
  26
  27 \begin{code}
  28 data RnName
  29   = WiredInId       Id
  30   | WiredInTyCon    TyCon
  31   | RnName          Name        -- funtions/binders/tyvars
  32   | RnSyn           Name        -- type synonym
  33   | RnData          Name [Name] -- data type   (with constrs)
  34   | RnConstr        Name  Name  -- constructor (with data type)
  35   | RnClass         Name [Name] -- class       (with class ops)
  36   | RnClassOp       Name  Name  -- class op    (with class)
  37   | RnImplicit      Name        -- implicitly imported
  38   | RnImplicitTyCon Name        -- implicitly imported
  39   | RnImplicitClass Name        -- implicitly imported
  40   | RnUnbound       RdrName     -- place holder
  41
  42 mkRnName          = RnName
  43 mkRnImplicit      = RnImplicit
  44 mkRnImplicitTyCon = RnImplicitTyCon
  45 mkRnImplicitClass = RnImplicitClass
  46 mkRnUnbound       = RnUnbound
  47
  48 isRnWired (WiredInId _)    = True
  49 isRnWired (WiredInTyCon _) = True
  50 isRnWired _                = False
  51
  52 isRnLocal (RnName n) = isLocalName n
  53 isRnLocal _          = False
  54
  55
  56 isRnTyCon (WiredInTyCon _)    = True
  57 isRnTyCon (RnSyn _)           = True
  58 isRnTyCon (RnData _ _)        = True
  59 isRnTyCon (RnImplicitTyCon _) = True
  60 isRnTyCon _                   = False
  61
  62 isRnClass (RnClass _ _)       = True
  63 isRnClass (RnImplicitClass _) = True
  64 isRnClass _                   = False
  65
  66 isRnClassOp cls (RnClassOp _ op_cls) = eqUniqsNamed cls op_cls
  67 isRnClassOp cls (RnImplicit _)       = True     -- ho hummm ...
  68 isRnClassOp cls _                    = False
  69
  70 isRnImplicit (RnImplicit _)      = True
  71 isRnImplicit (RnImplicitTyCon _) = True
  72 isRnImplicit (RnImplicitClass _) = True
  73 isRnImplicit _                   = False
  74
  75 isRnUnbound (RnUnbound _) = True
  76 isRnUnbound _             = False
  77
  78 -- Very general NamedThing comparison, used when comparing
  79 -- Uniquable things with different types
  80
  81 eqUniqsNamed  n1 n2 = uniqueOf n1  ==   uniqueOf n2
  82 cmpUniqsNamed n1 n2 = uniqueOf n1 `cmp` uniqueOf n2
  83
  84 instance Eq RnName where
  85     a == b = eqUniqsNamed a b
  86
  87 instance Ord3 RnName where
  88     a `cmp` b = cmpUniqsNamed a b
  89
  90 instance Uniquable RnName where
  91     uniqueOf = nameUnique . getName
  92
  93 instance NamedThing RnName where
  94     getName (WiredInId id)    = getName id
  95     getName (WiredInTyCon tc) = getName tc
  96     getName (RnName n)        = n
  97     getName (RnSyn n)         = n
  98     getName (RnData n _)      = n
  99     getName (RnConstr n _)    = n
 100     getName (RnClass n _)     = n
 101     getName (RnClassOp n _)   = n
 102     getName (RnImplicit n)    = n
 103     getName (RnUnbound occ)   = pprPanic "getRnName:RnUnbound" (ppr PprDebug occ)
 104
 105 instance Outputable RnName where
 106 #ifdef DEBUG
 107     ppr sty@PprShowAll (RnData n cs)   = ppBesides [ppr sty n, ppStr "{-", ppr sty cs, ppStr "-}"]
 108     ppr sty@PprShowAll (RnConstr n d)  = ppBesides [ppr sty n, ppStr "{-", ppr sty d, ppStr "-}"]
 109     ppr sty@PprShowAll (RnClass n ops) = ppBesides [ppr sty n, ppStr "{-", ppr sty ops, ppStr "-}"]
 110     ppr sty@PprShowAll (RnClassOp n c) = ppBesides [ppr sty n, ppStr "{-", ppr sty c, ppStr "-}"]
 111 #endif
 112     ppr sty (WiredInId id)      = ppr sty id
 113     ppr sty (WiredInTyCon tycon)= ppr sty tycon
 114     ppr sty (RnUnbound occ)     = ppBeside (ppr sty occ) (ppPStr SLIT("{-UNBOUND-}"))
 115     ppr sty rn_name             = ppr sty (getName rn_name)
 116 \end{code}
 117
 118 \begin{code}
 119 type RenamedArithSeqInfo        = ArithSeqInfo          Fake Fake RnName RenamedPat
 120 type RenamedBind                = Bind                  Fake Fake RnName RenamedPat
 121 type RenamedClassDecl           = ClassDecl             Fake Fake RnName RenamedPat
 122 type RenamedClassOpSig          = Sig                   RnName
 123 type RenamedConDecl             = ConDecl               RnName
 124 type RenamedContext             = Context               RnName
 125 type RenamedSpecDataSig         = SpecDataSig           RnName
 126 type RenamedDefaultDecl         = DefaultDecl           RnName
 127 type RenamedFixityDecl          = FixityDecl            RnName
 128 type RenamedGRHS                = GRHS                  Fake Fake RnName RenamedPat
 129 type RenamedGRHSsAndBinds       = GRHSsAndBinds         Fake Fake RnName RenamedPat
 130 type RenamedHsBinds             = HsBinds               Fake Fake RnName RenamedPat
 131 type RenamedHsExpr              = HsExpr                Fake Fake RnName RenamedPat
 132 type RenamedHsModule            = HsModule              Fake Fake RnName RenamedPat
 133 type RenamedInstDecl            = InstDecl              Fake Fake RnName RenamedPat
 134 type RenamedMatch               = Match                 Fake Fake RnName RenamedPat
 135 type RenamedMonoBinds           = MonoBinds             Fake Fake RnName RenamedPat
 136 type RenamedMonoType            = MonoType              RnName
 137 type RenamedPat                 = InPat                 RnName
 138 type RenamedPolyType            = PolyType              RnName
 139 type RenamedRecordBinds         = HsRecordBinds         Fake Fake RnName RenamedPat
 140 type RenamedQual                = Qual                  Fake Fake RnName RenamedPat
 141 type RenamedSig                 = Sig                   RnName
 142 type RenamedSpecInstSig         = SpecInstSig           RnName
 143 type RenamedStmt                = Stmt                  Fake Fake RnName RenamedPat
 144 type RenamedTyDecl              = TyDecl                RnName
 145
 146 type RenamedClassOpPragmas      = ClassOpPragmas        RnName
 147 type RenamedClassPragmas        = ClassPragmas          RnName
 148 type RenamedDataPragmas         = DataPragmas           RnName
 149 type RenamedGenPragmas          = GenPragmas            RnName
 150 type RenamedInstancePragmas     = InstancePragmas       RnName
 151 \end{code}
 152
 153 \begin{code}
 154 collectQualBinders :: [RenamedQual] -> [RnName]
 155
 156 collectQualBinders quals
 157   = concat (map collect quals)
 158   where
 159     collect (GeneratorQual pat _) = collectPatBinders pat
 160     collect (FilterQual expr)     = []
 161     collect (LetQual    binds)    = collectTopLevelBinders binds
 162 \end{code}
 163