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         RdrNameRuleBndr,
  36         RdrNameRuleDecl,
  37
  38         RdrNameClassOpPragmas,
  39         RdrNameClassPragmas,
  40         RdrNameDataPragmas,
  41         RdrNameGenPragmas,
  42         RdrNameInstancePragmas,
  43         extractHsTyRdrNames,
  44         extractPatsTyVars, extractRuleBndrsTyVars,
  45
  46         mkOpApp, mkClassDecl, mkClassOpSig
  47     ) where
  48
  49 #include "HsVersions.h"
  50
  51 import HsSyn
  52 import OccName          ( mkClassTyConOcc, mkClassDataConOcc,
  53                           mkSuperDictSelOcc, mkDefaultMethodOcc
  54                         )
  55 import RdrName          ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc )
  56 import Util             ( thenCmp )
  57 import HsPragmas        ( GenPragmas, ClassPragmas, DataPragmas, ClassOpPragmas, InstancePragmas )
  58 import List             ( nub )
  59 import Outputable
  60 \end{code}
  61
  62
  63 %************************************************************************
  64 %*                                                                      *
  65 \subsection{Type synonyms}
  66 %*                                                                      *
  67 %************************************************************************
  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 type RdrNameRuleBndr            = RuleBndr              RdrName
  95 type RdrNameRuleDecl            = RuleDecl              RdrName RdrNamePat
  96
  97 type RdrNameClassOpPragmas      = ClassOpPragmas        RdrName
  98 type RdrNameClassPragmas        = ClassPragmas          RdrName
  99 type RdrNameDataPragmas         = DataPragmas           RdrName
 100 type RdrNameGenPragmas          = GenPragmas            RdrName
 101 type RdrNameInstancePragmas     = InstancePragmas       RdrName
 102 \end{code}
 103
 104
 105 %************************************************************************
 106 %*                                                                      *
 107 \subsection{A few functions over HsSyn at RdrName}
 108 %*                                                                      *
 109 %************************************************************************
 110
 111 @extractHsTyRdrNames@ finds the free variables of a HsType
 112 It's used when making the for-alls explicit.
 113
 114 \begin{code}
 115 extractHsTyRdrNames :: HsType RdrName -> [RdrName]
 116 extractHsTyRdrNames ty = nub (extract_ty ty [])
 117
 118 extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName]
 119 extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
 120                              where
 121                                go (RuleBndr _)       acc = acc
 122                                go (RuleBndrSig _ ty) acc = extract_ty ty acc
 123
 124 extractHsCtxtRdrNames :: Context RdrName -> [RdrName]
 125 extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
 126
 127 extract_ctxt ctxt acc = foldr extract_ass acc ctxt
 128                       where
 129                         extract_ass (cls, tys) acc = foldr extract_ty (cls : acc) tys
 130
 131 extract_ty (MonoTyApp ty1 ty2)  acc = extract_ty ty1 (extract_ty ty2 acc)
 132 extract_ty (MonoListTy ty)      acc = extract_ty ty acc
 133 extract_ty (MonoTupleTy tys _)  acc = foldr extract_ty acc tys
 134 extract_ty (MonoFunTy ty1 ty2)  acc = extract_ty ty1 (extract_ty ty2 acc)
 135 extract_ty (MonoDictTy cls tys) acc = foldr extract_ty (cls : acc) tys
 136 extract_ty (MonoUsgTy usg ty)   acc = extract_ty ty acc
 137 extract_ty (MonoTyVar tv)       acc = tv : acc
 138 extract_ty (HsForAllTy (Just tvs) ctxt ty)
 139                                 acc = acc ++
 140                                       (filter (`notElem` locals) $
 141                                        extract_ctxt ctxt (extract_ty ty []))
 142                                     where
 143                                       locals = map getTyVarName tvs
 144
 145
 146 extractPatsTyVars :: [RdrNamePat] -> [RdrName]
 147 extractPatsTyVars pats = nub (foldr extract_pat [] pats)
 148
 149 extract_pat (SigPatIn pat ty)      acc = extract_ty ty acc
 150 extract_pat WildPatIn              acc = acc
 151 extract_pat (VarPatIn var)         acc = acc
 152 extract_pat (LitPatIn _)           acc = acc
 153 extract_pat (LazyPatIn pat)        acc = extract_pat pat acc
 154 extract_pat (AsPatIn a pat)        acc = extract_pat pat acc
 155 extract_pat (NPlusKPatIn n _)      acc = acc
 156 extract_pat (ConPatIn c pats)      acc = foldr extract_pat acc pats
 157 extract_pat (ConOpPatIn p1 c f p2) acc = extract_pat p1 (extract_pat p2 acc)
 158 extract_pat (NegPatIn  pat)        acc = extract_pat pat acc
 159 extract_pat (ParPatIn  pat)        acc = extract_pat pat acc
 160 extract_pat (ListPatIn pats)       acc = foldr extract_pat acc pats
 161 extract_pat (TuplePatIn pats _)    acc = foldr extract_pat acc pats
 162 extract_pat (RecPatIn c fields)    acc = foldr (\ (f,pat,_) acc -> extract_pat pat acc) acc fields
 163 \end{code}
 164
 165
 166 A useful function for building @OpApps@.  The operator is always a variable,
 167 and we don't know the fixity yet.
 168
 169 \begin{code}
 170 mkOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
 171 \end{code}
 172
 173 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
 174 by deriving them from the name of the class.  We fill in the names for the
 175 tycon and datacon corresponding to the class, by deriving them from the
 176 name of the class itself.  This saves recording the names in the interface
 177 file (which would be equally good).
 178
 179 Similarly for mkClassOpSig and default-method names.
 180
 181 \begin{code}
 182 mkClassDecl cxt cname tyvars sigs mbinds prags loc
 183   = ClassDecl cxt cname tyvars sigs mbinds prags tname dname sc_sel_names loc
 184   where
 185     cls_occ = rdrNameOcc cname
 186     dname   = mkRdrUnqual (mkClassDataConOcc cls_occ)
 187     tname   = mkRdrUnqual (mkClassTyConOcc   cls_occ)
 188     sc_sel_names = [mkRdrUnqual (mkSuperDictSelOcc n cls_occ) | n <- [1..length cxt]]
 189         -- We number off the superclass selectors, 1, 2, 3 etc so that we can construct
 190         -- names for the selectors.  Thus
 191         --      class (C a, C b) => D a b where ...
 192         -- gives superclass selectors
 193         --      D_sc1, D_sc2
 194         -- (We used to call them D_C, but now we can have two different
 195         --  superclasses both called C!)
 196
 197 mkClassOpSig has_default_method op ty loc
 198   | not has_default_method = ClassOpSig op Nothing      ty loc
 199   | otherwise              = ClassOpSig op (Just dm_rn) ty loc
 200   where
 201     dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
 202 \end{code}