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