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 IMP_Ubiq()
  12
  13 import HsSyn
  14
  15 import Id               ( isDataCon, GenId, SYN_IE(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           ( mkAlphaTyVarUnique, 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                -- functions/binders/tyvars
  34   | RnSyn           Name                -- type synonym
  35   | RnData          Name [Name] [Name]  -- data type   (with constrs and fields)
  36   | RnConstr        Name  Name          -- constructor (with data type)
  37   | RnField         Name  Name          -- field       (with data type)
  38   | RnClass         Name [Name]         -- class       (with class ops)
  39   | RnClassOp       Name  Name          -- class op    (with class)
  40   | RnImplicit      Name                -- implicitly imported
  41   | RnImplicitTyCon Name                -- implicitly imported
  42   | RnImplicitClass Name                -- implicitly imported
  43   | RnUnbound       RdrName             -- place holder
  44
  45 mkRnName          = RnName
  46 mkRnImplicit      = RnImplicit
  47 mkRnImplicitTyCon = RnImplicitTyCon
  48 mkRnImplicitClass = RnImplicitClass
  49 mkRnUnbound       = RnUnbound
  50
  51 isRnWired (WiredInId _)    = True
  52 isRnWired (WiredInTyCon _) = True
  53 isRnWired _                = False
  54
  55 isRnLocal (RnName n) = isLocalName n
  56 isRnLocal _          = False
  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 -- a common need: isRnTyCon || isRnClass:
  69 isRnTyConOrClass (WiredInTyCon _)    = True
  70 isRnTyConOrClass (RnSyn _)           = True
  71 isRnTyConOrClass (RnData _ _ _)      = True
  72 isRnTyConOrClass (RnImplicitTyCon _) = True
  73 isRnTyConOrClass (RnClass _ _)       = True
  74 isRnTyConOrClass (RnImplicitClass _) = True
  75 isRnTyConOrClass _                   = False
  76
  77 isRnConstr (RnConstr _ _) = True
  78 isRnConstr (WiredInId id) = isDataCon id
  79 isRnConstr  _             = False
  80
  81 isRnField  (RnField _ _)  = True
  82 isRnField  _              = False
  83
  84 isRnClassOp cls (RnClassOp _ op_cls) = eqUniqsNamed cls op_cls
  85 isRnClassOp cls n                    = pprTrace "isRnClassOp:" (ppr PprShowAll n) $ True -- let it past anyway
  86
  87 isRnImplicit (RnImplicit _)      = True
  88 isRnImplicit (RnImplicitTyCon _) = True
  89 isRnImplicit (RnImplicitClass _) = True
  90 isRnImplicit _                   = False
  91
  92 isRnUnbound (RnUnbound _) = True
  93 isRnUnbound _             = False
  94
  95 isRnEntity (WiredInId _)       = True
  96 isRnEntity (WiredInTyCon _)    = True
  97 isRnEntity (RnName n)          = not (isLocalName n)
  98 isRnEntity (RnSyn _)           = True
  99 isRnEntity (RnData _ _ _)      = True
 100 isRnEntity (RnClass _ _)       = True
 101 isRnEntity _                   = False
 102
 103 -- Very general NamedThing comparison, used when comparing
 104 -- Uniquable things with different types
 105
 106 eqUniqsNamed  n1 n2 = uniqueOf n1  ==   uniqueOf n2
 107 cmpUniqsNamed n1 n2 = uniqueOf n1 `cmp` uniqueOf n2
 108
 109 instance Eq RnName where
 110     a == b = eqUniqsNamed a b
 111
 112 instance Ord3 RnName where
 113     a `cmp` b = cmpUniqsNamed a b
 114
 115 instance Uniquable RnName where
 116     uniqueOf = nameUnique . getName
 117
 118 instance NamedThing RnName where
 119     getName (WiredInId id)      = getName id
 120     getName (WiredInTyCon tc)   = getName tc
 121     getName (RnName n)          = n
 122     getName (RnSyn n)           = n
 123     getName (RnData n _ _)      = n
 124     getName (RnConstr n _)      = n
 125     getName (RnField n _)       = n
 126     getName (RnClass n _)       = n
 127     getName (RnClassOp n _)     = n
 128     getName (RnImplicit n)      = n
 129     getName (RnImplicitTyCon n) = n
 130     getName (RnImplicitClass n) = n
 131     getName (RnUnbound occ)     = --pprTrace "getRnName:RnUnbound: " (ppr PprDebug occ)
 132                                   (case occ of
 133                                      Unqual n -> mkLocalName bottom n False bottom2
 134                                      Qual m n -> mkLocalName bottom n False bottom2)
 135                                 where bottom = mkAlphaTyVarUnique 0 -- anything; just something that will print
 136                                       bottom2 = panic "getRnName: srcloc"
 137
 138 instance Outputable RnName where
 139 #ifdef DEBUG
 140     ppr sty@PprShowAll (RnData n cs fs)  = ppBesides [ppr sty n, ppStr "{-", ppr sty cs, ppr sty fs, ppStr "-}"]
 141     ppr sty@PprShowAll (RnConstr n d)    = ppBesides [ppr sty n, ppStr "{-", ppr sty d, ppStr "-}"]
 142     ppr sty@PprShowAll (RnField  n d)    = ppBesides [ppr sty n, ppStr "{-", ppr sty d, ppStr "-}"]
 143     ppr sty@PprShowAll (RnClass n ops)   = ppBesides [ppr sty n, ppStr "{-", ppr sty ops, ppStr "-}"]
 144     ppr sty@PprShowAll (RnClassOp n c)   = ppBesides [ppr sty n, ppStr "{-", ppr sty c, ppStr "-}"]
 145 #endif
 146     ppr sty (WiredInId id)      = ppr sty id
 147     ppr sty (WiredInTyCon tycon)= ppr sty tycon
 148     ppr sty (RnUnbound occ)     = ppBeside (ppr sty occ) (ppPStr SLIT("{-UNBOUND-}"))
 149     ppr sty rn_name             = ppr sty (getName rn_name)
 150 \end{code}
 151
 152 \begin{code}
 153 type RenamedArithSeqInfo        = ArithSeqInfo          Fake Fake RnName RenamedPat
 154 type RenamedBind                = Bind                  Fake Fake RnName RenamedPat
 155 type RenamedClassDecl           = ClassDecl             Fake Fake RnName RenamedPat
 156 type RenamedClassOpSig          = Sig                   RnName
 157 type RenamedConDecl             = ConDecl               RnName
 158 type RenamedContext             = Context               RnName
 159 type RenamedSpecDataSig         = SpecDataSig           RnName
 160 type RenamedDefaultDecl         = DefaultDecl           RnName
 161 type RenamedFixityDecl          = FixityDecl            RnName
 162 type RenamedGRHS                = GRHS                  Fake Fake RnName RenamedPat
 163 type RenamedGRHSsAndBinds       = GRHSsAndBinds         Fake Fake RnName RenamedPat
 164 type RenamedHsBinds             = HsBinds               Fake Fake RnName RenamedPat
 165 type RenamedHsExpr              = HsExpr                Fake Fake RnName RenamedPat
 166 type RenamedHsModule            = HsModule              Fake Fake RnName RenamedPat
 167 type RenamedInstDecl            = InstDecl              Fake Fake RnName RenamedPat
 168 type RenamedMatch               = Match                 Fake Fake RnName RenamedPat
 169 type RenamedMonoBinds           = MonoBinds             Fake Fake RnName RenamedPat
 170 type RenamedMonoType            = MonoType              RnName
 171 type RenamedPat                 = InPat                 RnName
 172 type RenamedPolyType            = PolyType              RnName
 173 type RenamedRecordBinds         = HsRecordBinds         Fake Fake RnName RenamedPat
 174 type RenamedQual                = Qualifier             Fake Fake RnName RenamedPat
 175 type RenamedSig                 = Sig                   RnName
 176 type RenamedSpecInstSig         = SpecInstSig           RnName
 177 type RenamedStmt                = Stmt                  Fake Fake RnName RenamedPat
 178 type RenamedTyDecl              = TyDecl                RnName
 179
 180 type RenamedClassOpPragmas      = ClassOpPragmas        RnName
 181 type RenamedClassPragmas        = ClassPragmas          RnName
 182 type RenamedDataPragmas         = DataPragmas           RnName
 183 type RenamedGenPragmas          = GenPragmas            RnName
 184 type RenamedInstancePragmas     = InstancePragmas       RnName
 185 \end{code}
 186
 187 \begin{code}
 188 collectQualBinders :: [RenamedQual] -> [RnName]
 189
 190 collectQualBinders quals
 191   = concat (map collect quals)
 192   where
 193     collect (GeneratorQual pat _) = collectPatBinders pat
 194     collect (FilterQual expr)     = []
 195     collect (LetQual    binds)    = collectTopLevelBinders binds
 196
 197 fixDeclName :: FixityDecl name -> name
 198 fixDeclName (InfixL name i) = name
 199 fixDeclName (InfixR name i) = name
 200 fixDeclName (InfixN name i) = name
 201 \end{code}
 202