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