ghc/compiler/reader/RdrHsSyn.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996
   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         RdrNameClassDecl,
  14         RdrNameClassOpSig,
  15         RdrNameConDecl,
  16         RdrNameContext,
  17         RdrNameSpecDataSig,
  18         RdrNameDefaultDecl,
  19         RdrNameFixityDecl,
  20         RdrNameGRHS,
  21         RdrNameGRHSsAndBinds,
  22         RdrNameHsBinds,
  23         RdrNameHsDecl,
  24         RdrNameHsExpr,
  25         RdrNameHsModule,
  26         RdrNameIE,
  27         RdrNameImportDecl,
  28         RdrNameInstDecl,
  29         RdrNameMatch,
  30         RdrNameMonoBinds,
  31         RdrNamePat,
  32         RdrNameHsType,
  33         RdrNameSig,
  34         RdrNameSpecInstSig,
  35         RdrNameStmt,
  36         RdrNameTyDecl,
  37
  38         RdrNameClassOpPragmas,
  39         RdrNameClassPragmas,
  40         RdrNameDataPragmas,
  41         RdrNameGenPragmas,
  42         RdrNameInstancePragmas,
  43         extractHsTyVars, extractHsCtxtTyVars,
  44
  45         RdrName(..),
  46         qual, varQual, tcQual, varUnqual, lexVarQual, lexTcQual,
  47         dummyRdrVarName, dummyRdrTcName,
  48         isUnqual, isQual,
  49         showRdr, rdrNameOcc, ieOcc,
  50         cmpRdr, prefixRdrName,
  51         mkOpApp, mkClassDecl
  52
  53     ) where
  54
  55 #include "HsVersions.h"
  56
  57 import HsSyn
  58 import Lex
  59 import PrelMods         ( pRELUDE )
  60 import BasicTypes       ( Module(..), NewOrData, IfaceFlavour(..), Unused )
  61 import Name             ( ExportFlag(..), pprModule,
  62                           OccName(..), pprOccName,
  63                           prefixOccName, NamedThing )
  64 import Util             ( thenCmp )
  65 import CoreSyn          ( GenCoreExpr )
  66 import HsPragmas        ( GenPragmas, ClassPragmas, DataPragmas, ClassOpPragmas, InstancePragmas )
  67 import List             ( nub )
  68 import Outputable
  69 \end{code}
  70
  71 \begin{code}
  72 type RdrNameArithSeqInfo        = ArithSeqInfo          Unused RdrName RdrNamePat
  73 type RdrNameBangType            = BangType              RdrName
  74 type RdrNameClassDecl           = ClassDecl             Unused RdrName RdrNamePat
  75 type RdrNameClassOpSig          = Sig                   RdrName
  76 type RdrNameConDecl             = ConDecl               RdrName
  77 type RdrNameContext             = Context               RdrName
  78 type RdrNameHsDecl              = HsDecl                Unused RdrName RdrNamePat
  79 type RdrNameSpecDataSig         = SpecDataSig           RdrName
  80 type RdrNameDefaultDecl         = DefaultDecl           RdrName
  81 type RdrNameFixityDecl          = FixityDecl            RdrName
  82 type RdrNameGRHS                = GRHS                  Unused RdrName RdrNamePat
  83 type RdrNameGRHSsAndBinds       = GRHSsAndBinds         Unused RdrName RdrNamePat
  84 type RdrNameHsBinds             = HsBinds               Unused RdrName RdrNamePat
  85 type RdrNameHsExpr              = HsExpr                Unused RdrName RdrNamePat
  86 type RdrNameHsModule            = HsModule              Unused RdrName RdrNamePat
  87 type RdrNameIE                  = IE                    RdrName
  88 type RdrNameImportDecl          = ImportDecl            RdrName
  89 type RdrNameInstDecl            = InstDecl              Unused RdrName RdrNamePat
  90 type RdrNameMatch               = Match                 Unused RdrName RdrNamePat
  91 type RdrNameMonoBinds           = MonoBinds             Unused RdrName RdrNamePat
  92 type RdrNamePat                 = InPat                 RdrName
  93 type RdrNameHsType              = HsType                RdrName
  94 type RdrNameSig                 = Sig                   RdrName
  95 type RdrNameSpecInstSig         = SpecInstSig           RdrName
  96 type RdrNameStmt                = Stmt                  Unused RdrName RdrNamePat
  97 type RdrNameTyDecl              = TyDecl                RdrName
  98
  99 type RdrNameClassOpPragmas      = ClassOpPragmas        RdrName
 100 type RdrNameClassPragmas        = ClassPragmas          RdrName
 101 type RdrNameDataPragmas         = DataPragmas           RdrName
 102 type RdrNameGenPragmas          = GenPragmas            RdrName
 103 type RdrNameInstancePragmas     = InstancePragmas       RdrName
 104 \end{code}
 105
 106 @extractHsTyVars@ looks just for things that could be type variables.
 107 It's used when making the for-alls explicit.
 108
 109 \begin{code}
 110 extractHsTyVars :: HsType RdrName -> [RdrName]
 111 extractHsTyVars ty = nub (extract_ty ty [])
 112
 113 extractHsCtxtTyVars :: Context RdrName -> [RdrName]
 114 extractHsCtxtTyVars ty = nub (extract_ctxt ty [])
 115
 116 extract_ctxt ctxt acc = foldr extract_ass [] ctxt
 117                       where
 118                         extract_ass (cls, tys) acc = foldr extract_ty acc tys
 119
 120 extract_ty (MonoTyApp ty1 ty2)   acc = extract_ty ty1 (extract_ty ty2 acc)
 121 extract_ty (MonoListTy tc ty)    acc = extract_ty ty acc
 122 extract_ty (MonoTupleTy tc tys)  acc = foldr extract_ty acc tys
 123 extract_ty (MonoFunTy ty1 ty2)   acc = extract_ty ty1 (extract_ty ty2 acc)
 124 extract_ty (MonoDictTy cls tys)  acc = foldr extract_ty acc tys
 125 extract_ty (MonoTyVar tv)        acc = insert tv acc
 126
 127         -- In (All a => a -> a) -> Int, there are no free tyvars
 128         -- We just assume that we quantify over all type variables mentioned in the context.
 129 extract_ty (HsPreForAllTy ctxt ty)  acc = filter (`notElem` locals) (extract_ty ty [])
 130                                           ++ acc
 131                                         where
 132                                           locals = extract_ctxt ctxt []
 133
 134 extract_ty (HsForAllTy tvs ctxt ty) acc = acc ++
 135                                           (filter (`notElem` locals) $
 136                                            extract_ctxt ctxt (extract_ty ty []))
 137                                         where
 138                                           locals = map getTyVarName tvs
 139
 140
 141 insert (Qual _ _ _)       acc = acc
 142 insert (Unqual (TCOcc _)) acc = acc
 143 insert other              acc = other : acc
 144 \end{code}
 145
 146
 147 A useful function for building @OpApps@.  The operator is always a variable,
 148 and we don't know the fixity yet.
 149
 150 \begin{code}
 151 mkOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
 152 \end{code}
 153
 154 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
 155 by deriving them from the name of the class.
 156
 157 \begin{code}
 158 mkClassDecl cxt cname tyvars sigs mbinds prags loc
 159   = ClassDecl cxt cname tyvars sigs mbinds prags tname dname loc
 160   where
 161   -- The datacon and tycon are called ":C" where the class is C
 162   -- This prevents name clashes with user-defined tycons or datacons C
 163     (dname, tname) = case cname of
 164                        Qual m (TCOcc s) hif -> (Qual m (VarOcc s1) hif, Qual m (TCOcc s1) hif)
 165                                             where
 166                                                s1 = SLIT(":") _APPEND_ s
 167
 168                        Unqual (TCOcc s)     -> (Unqual (VarOcc s1),     Unqual (TCOcc s1))
 169                                             where
 170                                                s1 = SLIT(":") _APPEND_ s
 171
 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 qual     (m,n) = Qual m n HiFile
 187 tcQual   (m,n) = Qual m (TCOcc n) HiFile
 188 varQual  (m,n) = Qual m (VarOcc n) HiFile
 189
 190 lexTcQual  (m,n,hif) = Qual m (TCOcc n) hif
 191 lexVarQual (m,n,hif) = Qual m (VarOcc n) hif
 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 (VarOcc SLIT("V-DUMMY"))
 199 dummyRdrTcName = Unqual (VarOcc SLIT("TC-DUMMY"))
 200
 201 varUnqual n = Unqual (VarOcc n)
 202
 203 isUnqual (Unqual _)   = True
 204 isUnqual (Qual _ _ _) = False
 205
 206 isQual (Unqual _)   = False
 207 isQual (Qual _ _ _) = True
 208
 209         -- Used for adding a prefix to a RdrName
 210 prefixRdrName :: FAST_STRING -> RdrName -> RdrName
 211 prefixRdrName prefix (Qual m n hif) = Qual m (prefixOccName prefix n) hif
 212 prefixRdrName prefix (Unqual n)     = Unqual (prefixOccName prefix n)
 213
 214 cmpRdr (Unqual  n1) (Unqual  n2)     = n1 `compare` n2
 215 cmpRdr (Unqual  n1) (Qual m2 n2 _)   = LT
 216 cmpRdr (Qual m1 n1 _) (Unqual  n2)   = GT
 217 cmpRdr (Qual m1 n1 _) (Qual m2 n2 _) = (n1 `compare` n2) `thenCmp` (m1 `compare` m2)
 218                                    -- always compare module-names *second*
 219
 220 rdrNameOcc :: RdrName -> OccName
 221 rdrNameOcc (Unqual occ)   = occ
 222 rdrNameOcc (Qual _ occ _) = occ
 223
 224 ieOcc :: RdrNameIE -> OccName
 225 ieOcc ie = rdrNameOcc (ieName ie)
 226
 227 instance Text RdrName where -- debugging
 228     showsPrec _ rn = showString (showSDoc (ppr rn))
 229
 230 instance Eq RdrName where
 231     a == b = case (a `compare` b) of { EQ -> True;  _ -> False }
 232     a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
 233
 234 instance Ord RdrName where
 235     a <= b = case (a `compare` b) of { LT -> True;      EQ -> True;  GT -> False }
 236     a <  b = case (a `compare` b) of { LT -> True;      EQ -> False; GT -> False }
 237     a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }
 238     a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }
 239     compare a b = cmpRdr a b
 240
 241 instance Outputable RdrName where
 242     ppr (Unqual n)   = pprOccName n
 243     ppr (Qual m n _) = hcat [pprModule m, char '.', pprOccName n]
 244
 245 instance NamedThing RdrName where               -- Just so that pretty-printing of expressions works
 246     getOccName = rdrNameOcc
 247     getName = panic "no getName for RdrNames"
 248
 249 showRdr rdr = showSDoc (ppr rdr)
 250 \end{code}
 251