ghc/compiler/reader/RdrHsSyn.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996-1998
   3 %
   4 \section[RdrHsSyn]{Specialisations of the @HsSyn@ syntax for the reader}
   5
   6 (Well, really, for specialisations involving @RdrName@s, even if
   7 they are used somewhat later on in the compiler...)
   8
   9 \begin{code}
  10 module RdrHsSyn (
  11         RdrNameArithSeqInfo,
  12         RdrNameBangType,
  13         RdrNameClassOpSig,
  14         RdrNameConDecl,
  15         RdrNameContext,
  16         RdrNameSpecDataSig,
  17         RdrNameDefaultDecl,
  18         RdrNameForeignDecl,
  19         RdrNameGRHS,
  20         RdrNameGRHSs,
  21         RdrNameHsBinds,
  22         RdrNameHsDecl,
  23         RdrNameHsExpr,
  24         RdrNameHsModule,
  25         RdrNameIE,
  26         RdrNameImportDecl,
  27         RdrNameInstDecl,
  28         RdrNameMatch,
  29         RdrNameMonoBinds,
  30         RdrNamePat,
  31         RdrNameHsType,
  32         RdrNameSig,
  33         RdrNameStmt,
  34         RdrNameTyClDecl,
  35
  36         RdrNameClassOpPragmas,
  37         RdrNameClassPragmas,
  38         RdrNameDataPragmas,
  39         RdrNameGenPragmas,
  40         RdrNameInstancePragmas,
  41         extractHsTyVars, extractHsCtxtTyVars, extractPatsTyVars,
  42
  43         RdrName(..),
  44         qual, varQual, tcQual, varUnqual,
  45         dummyRdrVarName, dummyRdrTcName,
  46         isUnqual, isQual,
  47         rdrNameOcc, rdrNameModule, ieOcc,
  48         cmpRdr,
  49         mkOpApp, mkClassDecl
  50
  51     ) where
  52
  53 #include "HsVersions.h"
  54
  55 import HsSyn
  56 import BasicTypes       ( IfaceFlavour(..), Unused )
  57 import Name             ( NamedThing(..),
  58                           Module, pprModule, mkModuleFS,
  59                           OccName, srcTCOcc, srcVarOcc, isTvOcc,
  60                           pprOccName, mkClassTyConOcc, mkClassDataConOcc
  61                         )
  62 import PrelMods         ( mkTupNameStr, mkUbxTupNameStr )
  63 import Util             ( thenCmp )
  64 import HsPragmas        ( GenPragmas, ClassPragmas, DataPragmas, ClassOpPragmas, InstancePragmas )
  65 import List             ( nub )
  66 import Outputable
  67 \end{code}
  68
  69 \begin{code}
  70 type RdrNameArithSeqInfo        = ArithSeqInfo          RdrName RdrNamePat
  71 type RdrNameBangType            = BangType              RdrName
  72 type RdrNameClassOpSig          = Sig                   RdrName
  73 type RdrNameConDecl             = ConDecl               RdrName
  74 type RdrNameContext             = Context               RdrName
  75 type RdrNameHsDecl              = HsDecl                RdrName RdrNamePat
  76 type RdrNameSpecDataSig         = SpecDataSig           RdrName
  77 type RdrNameDefaultDecl         = DefaultDecl           RdrName
  78 type RdrNameForeignDecl         = ForeignDecl           RdrName
  79 type RdrNameGRHS                = GRHS                  RdrName RdrNamePat
  80 type RdrNameGRHSs               = GRHSs                 RdrName RdrNamePat
  81 type RdrNameHsBinds             = HsBinds               RdrName RdrNamePat
  82 type RdrNameHsExpr              = HsExpr                RdrName RdrNamePat
  83 type RdrNameHsModule            = HsModule              RdrName RdrNamePat
  84 type RdrNameIE                  = IE                    RdrName
  85 type RdrNameImportDecl          = ImportDecl            RdrName
  86 type RdrNameInstDecl            = InstDecl              RdrName RdrNamePat
  87 type RdrNameMatch               = Match                 RdrName RdrNamePat
  88 type RdrNameMonoBinds           = MonoBinds             RdrName RdrNamePat
  89 type RdrNamePat                 = InPat                 RdrName
  90 type RdrNameHsType              = HsType                RdrName
  91 type RdrNameSig                 = Sig                   RdrName
  92 type RdrNameStmt                = Stmt                  RdrName RdrNamePat
  93 type RdrNameTyClDecl            = TyClDecl              RdrName RdrNamePat
  94
  95 type RdrNameClassOpPragmas      = ClassOpPragmas        RdrName
  96 type RdrNameClassPragmas        = ClassPragmas          RdrName
  97 type RdrNameDataPragmas         = DataPragmas           RdrName
  98 type RdrNameGenPragmas          = GenPragmas            RdrName
  99 type RdrNameInstancePragmas     = InstancePragmas       RdrName
 100 \end{code}
 101
 102 @extractHsTyVars@ looks just for things that could be type variables.
 103 It's used when making the for-alls explicit.
 104
 105 \begin{code}
 106 extractHsTyVars :: HsType RdrName -> [RdrName]
 107 extractHsTyVars ty = nub (extract_ty ty [])
 108
 109 extractHsCtxtTyVars :: Context RdrName -> [RdrName]
 110 extractHsCtxtTyVars ty = nub (extract_ctxt ty [])
 111
 112 extract_ctxt ctxt acc = foldr extract_ass acc ctxt
 113                       where
 114                         extract_ass (cls, tys) acc = foldr extract_ty acc tys
 115
 116 extract_ty (MonoTyApp ty1 ty2)      acc = extract_ty ty1 (extract_ty ty2 acc)
 117 extract_ty (MonoListTy ty)          acc = extract_ty ty acc
 118 extract_ty (MonoTupleTy tys _)      acc = foldr extract_ty acc tys
 119 extract_ty (MonoFunTy ty1 ty2)      acc = extract_ty ty1 (extract_ty ty2 acc)
 120 extract_ty (MonoDictTy cls tys)     acc = foldr extract_ty acc tys
 121 extract_ty (MonoTyVar tv)           acc = insertTV tv acc
 122 extract_ty (HsForAllTy tvs ctxt ty) acc = acc ++
 123                                           (filter (`notElem` locals) $
 124                                            extract_ctxt ctxt (extract_ty ty []))
 125                                         where
 126                                           locals = map getTyVarName tvs
 127
 128 insertTV name@(Unqual occ) acc | isTvOcc occ = name : acc
 129 insertTV other             acc               = acc
 130
 131 extractPatsTyVars :: [RdrNamePat] -> [RdrName]
 132 extractPatsTyVars pats = nub (foldr extract_pat [] pats)
 133
 134 extract_pat (SigPatIn pat ty)      acc = extract_ty ty acc
 135 extract_pat WildPatIn              acc = acc
 136 extract_pat (VarPatIn var)         acc = acc
 137 extract_pat (LitPatIn _)           acc = acc
 138 extract_pat (LazyPatIn pat)        acc = extract_pat pat acc
 139 extract_pat (AsPatIn a pat)        acc = extract_pat pat acc
 140 extract_pat (NPlusKPatIn n _)      acc = acc
 141 extract_pat (ConPatIn c pats)      acc = foldr extract_pat acc pats
 142 extract_pat (ConOpPatIn p1 c f p2) acc = extract_pat p1 (extract_pat p2 acc)
 143 extract_pat (NegPatIn  pat)        acc = extract_pat pat acc
 144 extract_pat (ParPatIn  pat)        acc = extract_pat pat acc
 145 extract_pat (ListPatIn pats)       acc = foldr extract_pat acc pats
 146 extract_pat (TuplePatIn pats _)    acc = foldr extract_pat acc pats
 147 extract_pat (RecPatIn c fields)    acc = foldr (\ (f,pat,_) acc -> extract_pat pat acc) acc fields
 148 \end{code}
 149
 150
 151 A useful function for building @OpApps@.  The operator is always a variable,
 152 and we don't know the fixity yet.
 153
 154 \begin{code}
 155 mkOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
 156 \end{code}
 157
 158 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
 159 by deriving them from the name of the class.
 160
 161 \begin{code}
 162 mkClassDecl cxt cname tyvars sigs mbinds prags loc
 163   = ClassDecl cxt cname tyvars sigs mbinds prags tname dname loc
 164   where
 165   -- The datacon and tycon are called "_DC" and "_TC", where the class is C
 166   -- This prevents name clashes with user-defined tycons or datacons C
 167     (dname, tname) = case cname of
 168                        Qual m occ hif -> (Qual m (mkClassDataConOcc occ) hif,
 169                                           Qual m (mkClassTyConOcc   occ) hif)
 170                        Unqual occ     -> (Unqual (mkClassDataConOcc occ),
 171                                           Unqual (mkClassTyConOcc   occ))
 172 \end{code}
 173
 174 %************************************************************************
 175 %*                                                                      *
 176 \subsection[RdrName]{The @RdrName@ datatype; names read from files}
 177 %*                                                                      *
 178 %************************************************************************
 179
 180 \begin{code}
 181 data RdrName
 182   = Unqual OccName
 183   | Qual   Module OccName IfaceFlavour  -- HiBootFile for M!.t (interface files only),
 184                                         -- HiFile for the common M.t
 185
 186 -- These ones are used for making RdrNames for known-key things,
 187 -- Or in code constructed from derivings
 188 qual     (m,n) = Qual m n HiFile
 189 tcQual   (m,n) = Qual m (srcTCOcc n) HiFile
 190 varQual  (m,n) = Qual m (srcVarOcc n) HiFile
 191 varUnqual n    = Unqual (srcVarOcc n)
 192
 193         -- This guy is used by the reader when HsSyn has a slot for
 194         -- an implicit name that's going to be filled in by
 195         -- the renamer.  We can't just put "error..." because
 196         -- we sometimes want to print out stuff after reading but
 197         -- before renaming
 198 dummyRdrVarName = Unqual (srcVarOcc SLIT("V-DUMMY"))
 199 dummyRdrTcName  = Unqual (srcVarOcc SLIT("TC-DUMMY"))
 200
 201
 202 isUnqual (Unqual _)   = True
 203 isUnqual (Qual _ _ _) = False
 204
 205 isQual (Unqual _)   = False
 206 isQual (Qual _ _ _) = True
 207
 208
 209 cmpRdr (Unqual  n1) (Unqual  n2)     = n1 `compare` n2
 210 cmpRdr (Unqual  n1) (Qual m2 n2 _)   = LT
 211 cmpRdr (Qual m1 n1 _) (Unqual  n2)   = GT
 212 cmpRdr (Qual m1 n1 _) (Qual m2 n2 _) = (n1 `compare` n2) `thenCmp` (m1 `compare` m2)
 213                                    -- always compare module-names *second*
 214
 215 rdrNameOcc :: RdrName -> OccName
 216 rdrNameOcc (Unqual occ)   = occ
 217 rdrNameOcc (Qual _ occ _) = occ
 218
 219 rdrNameModule :: RdrName -> Module
 220 rdrNameModule (Qual m _ _) = m
 221
 222 ieOcc :: RdrNameIE -> OccName
 223 ieOcc ie = rdrNameOcc (ieName ie)
 224
 225 instance Show RdrName where -- debugging
 226     showsPrec p rn = showsPrecSDoc p (ppr rn)
 227
 228 instance Eq RdrName where
 229     a == b = case (a `compare` b) of { EQ -> True;  _ -> False }
 230     a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
 231
 232 instance Ord RdrName where
 233     a <= b = case (a `compare` b) of { LT -> True;      EQ -> True;  GT -> False }
 234     a <  b = case (a `compare` b) of { LT -> True;      EQ -> False; GT -> False }
 235     a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }
 236     a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }
 237     compare a b = cmpRdr a b
 238
 239 instance Outputable RdrName where
 240     ppr (Unqual n)   = pprOccName n
 241     ppr (Qual m n _) = hcat [pprModule m, char '.', pprOccName n]
 242
 243 instance NamedThing RdrName where               -- Just so that pretty-printing of expressions works
 244     getOccName = rdrNameOcc
 245     getName = panic "no getName for RdrNames"
 246 \end{code}
 247