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         RdrNameClassDecl,
  14         RdrNameClassOpSig,
  15         RdrNameConDecl,
  16         RdrNameContext,
  17         RdrNameSpecDataSig,
  18         RdrNameDefaultDecl,
  19         RdrNameForeignDecl,
  20         RdrNameFixityDecl,
  21         RdrNameGRHS,
  22         RdrNameGRHSsAndBinds,
  23         RdrNameHsBinds,
  24         RdrNameHsDecl,
  25         RdrNameHsExpr,
  26         RdrNameHsModule,
  27         RdrNameIE,
  28         RdrNameImportDecl,
  29         RdrNameInstDecl,
  30         RdrNameMatch,
  31         RdrNameMonoBinds,
  32         RdrNamePat,
  33         RdrNameHsType,
  34         RdrNameSig,
  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         mkTupConRdrName, mkUbxTupConRdrName,
  48         dummyRdrVarName, dummyRdrTcName,
  49         isUnqual, isQual,
  50         rdrNameOcc, rdrNameModule, ieOcc,
  51         cmpRdr, prefixRdrName,
  52         mkOpApp, mkClassDecl, isClassDataConRdrName
  53
  54     ) where
  55
  56 #include "HsVersions.h"
  57
  58 import HsSyn
  59 import BasicTypes       ( Module, IfaceFlavour(..), Unused )
  60 import Name             ( pprModule, OccName(..), pprOccName,
  61                           mkTupNameStr, mkUbxTupNameStr,
  62                           prefixOccName, NamedThing(..),
  63                           mkClassTyConStr, mkClassDataConStr )
  64 import Util             ( thenCmp )
  65 import HsPragmas        ( GenPragmas, ClassPragmas, DataPragmas, ClassOpPragmas, InstancePragmas )
  66 import List             ( nub )
  67 import Outputable
  68
  69 import Char             ( isUpper )
  70 \end{code}
  71
  72 \begin{code}
  73 type RdrNameArithSeqInfo        = ArithSeqInfo          Unused RdrName RdrNamePat
  74 type RdrNameBangType            = BangType              RdrName
  75 type RdrNameClassDecl           = ClassDecl             Unused RdrName RdrNamePat
  76 type RdrNameClassOpSig          = Sig                   RdrName
  77 type RdrNameConDecl             = ConDecl               RdrName
  78 type RdrNameContext             = Context               RdrName
  79 type RdrNameHsDecl              = HsDecl                Unused RdrName RdrNamePat
  80 type RdrNameSpecDataSig         = SpecDataSig           RdrName
  81 type RdrNameDefaultDecl         = DefaultDecl           RdrName
  82 type RdrNameForeignDecl         = ForeignDecl           RdrName
  83 type RdrNameFixityDecl          = FixityDecl            RdrName
  84 type RdrNameGRHS                = GRHS                  Unused RdrName RdrNamePat
  85 type RdrNameGRHSsAndBinds       = GRHSsAndBinds         Unused RdrName RdrNamePat
  86 type RdrNameHsBinds             = HsBinds               Unused RdrName RdrNamePat
  87 type RdrNameHsExpr              = HsExpr                Unused RdrName RdrNamePat
  88 type RdrNameHsModule            = HsModule              Unused RdrName RdrNamePat
  89 type RdrNameIE                  = IE                    RdrName
  90 type RdrNameImportDecl          = ImportDecl            RdrName
  91 type RdrNameInstDecl            = InstDecl              Unused RdrName RdrNamePat
  92 type RdrNameMatch               = Match                 Unused RdrName RdrNamePat
  93 type RdrNameMonoBinds           = MonoBinds             Unused RdrName RdrNamePat
  94 type RdrNamePat                 = InPat                 RdrName
  95 type RdrNameHsType              = HsType                RdrName
  96 type RdrNameSig                 = Sig                   RdrName
  97 type RdrNameStmt                = Stmt                  Unused RdrName RdrNamePat
  98 type RdrNameTyDecl              = TyDecl                RdrName
  99
 100 type RdrNameClassOpPragmas      = ClassOpPragmas        RdrName
 101 type RdrNameClassPragmas        = ClassPragmas          RdrName
 102 type RdrNameDataPragmas         = DataPragmas           RdrName
 103 type RdrNameGenPragmas          = GenPragmas            RdrName
 104 type RdrNameInstancePragmas     = InstancePragmas       RdrName
 105 \end{code}
 106
 107 @extractHsTyVars@ looks just for things that could be type variables.
 108 It's used when making the for-alls explicit.
 109
 110 \begin{code}
 111 extractHsTyVars :: HsType RdrName -> [RdrName]
 112 extractHsTyVars ty = nub (extract_ty ty [])
 113
 114 extractHsCtxtTyVars :: Context RdrName -> [RdrName]
 115 extractHsCtxtTyVars ty = nub (extract_ctxt ty [])
 116
 117 extract_ctxt ctxt acc = foldr extract_ass acc ctxt
 118                       where
 119                         extract_ass (cls, tys) acc = foldr extract_ty acc tys
 120
 121 extract_ty (MonoTyApp ty1 ty2)      acc = extract_ty ty1 (extract_ty ty2 acc)
 122 extract_ty (MonoListTy ty)          acc = extract_ty ty acc
 123 extract_ty (MonoTupleTy tys _)      acc = foldr extract_ty acc tys
 124 extract_ty (MonoFunTy ty1 ty2)      acc = extract_ty ty1 (extract_ty ty2 acc)
 125 extract_ty (MonoDictTy cls tys)     acc = foldr extract_ty acc tys
 126 extract_ty (MonoTyVar tv)           acc = insert tv acc
 127 extract_ty (HsForAllTy tvs ctxt ty) acc = acc ++
 128                                           (filter (`notElem` locals) $
 129                                            extract_ctxt ctxt (extract_ty ty []))
 130                                         where
 131                                           locals = map getTyVarName tvs
 132
 133 insert (Qual _ _ _)       acc = acc
 134 insert (Unqual (TCOcc _)) acc = acc
 135 insert other              acc = other : acc
 136 \end{code}
 137
 138
 139 A useful function for building @OpApps@.  The operator is always a variable,
 140 and we don't know the fixity yet.
 141
 142 \begin{code}
 143 mkOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
 144 \end{code}
 145
 146 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
 147 by deriving them from the name of the class.
 148
 149 \begin{code}
 150 mkClassDecl cxt cname tyvars sigs mbinds prags loc
 151   = ClassDecl cxt cname tyvars sigs mbinds prags tname dname loc
 152   where
 153   -- The datacon and tycon are called ":C" where the class is C
 154   -- This prevents name clashes with user-defined tycons or datacons C
 155     (dname, tname) = case cname of
 156                        Qual m (TCOcc s) hif -> (Qual m (VarOcc s1) hif, Qual m (TCOcc s1) hif)
 157                                             where
 158                                                s1 = mkClassTyConStr s
 159
 160                        Unqual (TCOcc s)     -> (Unqual (VarOcc s1),     Unqual (TCOcc s1))
 161                                             where
 162                                                s1 = mkClassDataConStr s
 163
 164 -- This nasty little function tests for whether a RdrName was
 165 -- constructed by the above process.  It's used only for filtering
 166 -- out duff error messages.  Maybe there's a tidier way of doing this
 167 -- but I can't work up the energy to find it.
 168
 169 isClassDataConRdrName rdr_name
 170  = case rdrNameOcc rdr_name of
 171         TCOcc s -> case _UNPK_ s of
 172                         ':' : c : _ -> isUpper c
 173                         other       -> False
 174         other -> False
 175 \end{code}
 176
 177 %************************************************************************
 178 %*                                                                      *
 179 \subsection[RdrName]{The @RdrName@ datatype; names read from files}
 180 %*                                                                      *
 181 %************************************************************************
 182
 183 \begin{code}
 184 data RdrName
 185   = Unqual OccName
 186   | Qual   Module OccName IfaceFlavour  -- HiBootFile for M!.t (interface files only),
 187                                         -- HiFile for the common M.t
 188
 189 qual     (m,n) = Qual m n HiFile
 190 tcQual   (m,n) = Qual m (TCOcc n) HiFile
 191 varQual  (m,n) = Qual m (VarOcc n) HiFile
 192
 193 mkTupConRdrName :: Int -> RdrName  -- The name for the tuple data construtor
 194                                    -- Hence VarOcc
 195 mkTupConRdrName arity = case mkTupNameStr arity of
 196                            (mod, occ) -> Qual mod (VarOcc occ) HiFile
 197
 198 mkUbxTupConRdrName :: Int -> RdrName  -- The name for the tuple data construtor
 199                                       -- Hence VarOcc
 200 mkUbxTupConRdrName arity = case mkUbxTupNameStr arity of
 201                               (mod, occ) -> Qual mod (VarOcc occ) HiFile
 202
 203 lexTcQual  (m,n,hif) = Qual m (TCOcc n) hif
 204 lexVarQual (m,n,hif) = Qual m (VarOcc n) hif
 205
 206         -- This guy is used by the reader when HsSyn has a slot for
 207         -- an implicit name that's going to be filled in by
 208         -- the renamer.  We can't just put "error..." because
 209         -- we sometimes want to print out stuff after reading but
 210         -- before renaming
 211 dummyRdrVarName = Unqual (VarOcc SLIT("V-DUMMY"))
 212 dummyRdrTcName = Unqual (VarOcc SLIT("TC-DUMMY"))
 213
 214
 215 varUnqual n = Unqual (VarOcc n)
 216
 217 isUnqual (Unqual _)   = True
 218 isUnqual (Qual _ _ _) = False
 219
 220 isQual (Unqual _)   = False
 221 isQual (Qual _ _ _) = True
 222
 223
 224         -- Used for adding a prefix to a RdrName
 225 prefixRdrName :: FAST_STRING -> RdrName -> RdrName
 226 prefixRdrName prefix (Qual m n hif) = Qual m (prefixOccName prefix n) hif
 227 prefixRdrName prefix (Unqual n)     = Unqual (prefixOccName prefix n)
 228
 229 cmpRdr (Unqual  n1) (Unqual  n2)     = n1 `compare` n2
 230 cmpRdr (Unqual  n1) (Qual m2 n2 _)   = LT
 231 cmpRdr (Qual m1 n1 _) (Unqual  n2)   = GT
 232 cmpRdr (Qual m1 n1 _) (Qual m2 n2 _) = (n1 `compare` n2) `thenCmp` (m1 `compare` m2)
 233                                    -- always compare module-names *second*
 234
 235 rdrNameOcc :: RdrName -> OccName
 236 rdrNameOcc (Unqual occ)   = occ
 237 rdrNameOcc (Qual _ occ _) = occ
 238
 239 rdrNameModule :: RdrName -> Module
 240 rdrNameModule (Qual m _ _) = m
 241
 242 ieOcc :: RdrNameIE -> OccName
 243 ieOcc ie = rdrNameOcc (ieName ie)
 244
 245 instance Show RdrName where -- debugging
 246     showsPrec p rn = showsPrecSDoc p (ppr rn)
 247
 248 instance Eq RdrName where
 249     a == b = case (a `compare` b) of { EQ -> True;  _ -> False }
 250     a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
 251
 252 instance Ord RdrName where
 253     a <= b = case (a `compare` b) of { LT -> True;      EQ -> True;  GT -> False }
 254     a <  b = case (a `compare` b) of { LT -> True;      EQ -> False; GT -> False }
 255     a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }
 256     a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }
 257     compare a b = cmpRdr a b
 258
 259 instance Outputable RdrName where
 260     ppr (Unqual n)   = pprOccName n
 261     ppr (Qual m n _) = hcat [pprModule m, char '.', pprOccName n]
 262
 263 instance NamedThing RdrName where               -- Just so that pretty-printing of expressions works
 264     getOccName = rdrNameOcc
 265     getName = panic "no getName for RdrNames"
 266 \end{code}
 267