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