ghc/compiler/parser/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         RdrNameConDetails,
  16         RdrNameContext,
  17         RdrNameSpecDataSig,
  18         RdrNameDefaultDecl,
  19         RdrNameForeignDecl,
  20         RdrNameGRHS,
  21         RdrNameGRHSs,
  22         RdrNameHsBinds,
  23         RdrNameHsDecl,
  24         RdrNameHsExpr,
  25         RdrNameHsModule,
  26         RdrNameIE,
  27         RdrNameImportDecl,
  28         RdrNameInstDecl,
  29         RdrNameMatch,
  30         RdrNameMonoBinds,
  31         RdrNamePat,
  32         RdrNameHsType,
  33         RdrNameHsTyVar,
  34         RdrNameSig,
  35         RdrNameStmt,
  36         RdrNameTyClDecl,
  37         RdrNameRuleDecl,
  38         RdrNameRuleBndr,
  39         RdrNameHsRecordBinds,
  40
  41         RdrBinding(..),
  42         RdrMatch(..),
  43         SigConverter,
  44
  45         RdrNameClassOpPragmas,
  46         RdrNameClassPragmas,
  47         RdrNameDataPragmas,
  48         RdrNameGenPragmas,
  49         RdrNameInstancePragmas,
  50         extractHsTyRdrNames,
  51         extractPatsTyVars, extractRuleBndrsTyVars,
  52
  53         mkOpApp, mkClassDecl, mkClassOpSig,
  54
  55         cvBinds,
  56         cvMonoBindsAndSigs,
  57         cvTopDecls,
  58         cvValSig, cvClassOpSig, cvInstDeclSig
  59     ) where
  60
  61 #include "HsVersions.h"
  62
  63 import HsSyn
  64 import Name             ( mkClassTyConOcc, mkClassDataConOcc )
  65 import OccName          ( mkClassTyConOcc, mkClassDataConOcc,
  66                           mkSuperDictSelOcc, mkDefaultMethodOcc
  67                         )
  68 import RdrName          ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc )
  69 import Util             ( thenCmp )
  70 import HsPragmas
  71 import List             ( nub )
  72 import BasicTypes       ( RecFlag(..) )
  73 import Outputable
  74 \end{code}
  75
  76
  77 %************************************************************************
  78 %*                                                                      *
  79 \subsection{Type synonyms}
  80 %*                                                                      *
  81 %************************************************************************
  82
  83 \begin{code}
  84 type RdrNameArithSeqInfo        = ArithSeqInfo          RdrName RdrNamePat
  85 type RdrNameBangType            = BangType              RdrName
  86 type RdrNameClassOpSig          = Sig                   RdrName
  87 type RdrNameConDecl             = ConDecl               RdrName
  88 type RdrNameConDetails          = ConDetails            RdrName
  89 type RdrNameContext             = Context               RdrName
  90 type RdrNameHsDecl              = HsDecl                RdrName RdrNamePat
  91 type RdrNameSpecDataSig         = SpecDataSig           RdrName
  92 type RdrNameDefaultDecl         = DefaultDecl           RdrName
  93 type RdrNameForeignDecl         = ForeignDecl           RdrName
  94 type RdrNameGRHS                = GRHS                  RdrName RdrNamePat
  95 type RdrNameGRHSs               = GRHSs                 RdrName RdrNamePat
  96 type RdrNameHsBinds             = HsBinds               RdrName RdrNamePat
  97 type RdrNameHsExpr              = HsExpr                RdrName RdrNamePat
  98 type RdrNameHsModule            = HsModule              RdrName RdrNamePat
  99 type RdrNameIE                  = IE                    RdrName
 100 type RdrNameImportDecl          = ImportDecl            RdrName
 101 type RdrNameInstDecl            = InstDecl              RdrName RdrNamePat
 102 type RdrNameMatch               = Match                 RdrName RdrNamePat
 103 type RdrNameMonoBinds           = MonoBinds             RdrName RdrNamePat
 104 type RdrNamePat                 = InPat                 RdrName
 105 type RdrNameHsType              = HsType                RdrName
 106 type RdrNameHsTyVar             = HsTyVar               RdrName
 107 type RdrNameSig                 = Sig                   RdrName
 108 type RdrNameStmt                = Stmt                  RdrName RdrNamePat
 109 type RdrNameTyClDecl            = TyClDecl              RdrName RdrNamePat
 110 type RdrNameRuleBndr            = RuleBndr              RdrName
 111 type RdrNameRuleDecl            = RuleDecl              RdrName RdrNamePat
 112
 113 type RdrNameHsRecordBinds       = HsRecordBinds         RdrName RdrNamePat
 114
 115 type RdrNameClassOpPragmas      = ClassOpPragmas        RdrName
 116 type RdrNameClassPragmas        = ClassPragmas          RdrName
 117 type RdrNameDataPragmas         = DataPragmas           RdrName
 118 type RdrNameGenPragmas          = GenPragmas            RdrName
 119 type RdrNameInstancePragmas     = InstancePragmas       RdrName
 120 \end{code}
 121
 122
 123 %************************************************************************
 124 %*                                                                      *
 125 \subsection{A few functions over HsSyn at RdrName}
 126 %*                                                                    *
 127 %************************************************************************
 128
 129 @extractHsTyRdrNames@ finds the free variables of a HsType
 130 It's used when making the for-alls explicit.
 131
 132 \begin{code}
 133 extractHsTyRdrNames :: HsType RdrName -> [RdrName]
 134 extractHsTyRdrNames ty = nub (extract_ty ty [])
 135
 136 extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName]
 137 extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
 138                            where
 139                              go (RuleBndr _)       acc = acc
 140                              go (RuleBndrSig _ ty) acc = extract_ty ty acc
 141
 142 extractHsCtxtRdrNames :: Context RdrName -> [RdrName]
 143 extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
 144
 145 extract_ctxt ctxt acc = foldr extract_ass acc ctxt
 146                     where
 147                       extract_ass (cls, tys) acc = foldr extract_ty (cls : acc) tys
 148
 149 extract_ty (MonoTyApp ty1 ty2)        acc = extract_ty ty1 (extract_ty ty2 acc)
 150 extract_ty (MonoListTy ty)    acc = extract_ty ty acc
 151 extract_ty (MonoTupleTy tys _)  acc = foldr extract_ty acc tys
 152 extract_ty (MonoFunTy ty1 ty2)        acc = extract_ty ty1 (extract_ty ty2 acc)
 153 extract_ty (MonoDictTy cls tys)       acc = foldr extract_ty (cls : acc) tys
 154 extract_ty (MonoUsgTy usg ty) acc = extract_ty ty acc
 155 extract_ty (MonoTyVar tv)       acc = tv : acc
 156 extract_ty (HsForAllTy (Just tvs) ctxt ty)
 157                                 acc = acc ++
 158                                       (filter (`notElem` locals) $
 159                                        extract_ctxt ctxt (extract_ty ty []))
 160                                     where
 161                                       locals = map getTyVarName tvs
 162
 163
 164 extractPatsTyVars :: [RdrNamePat] -> [RdrName]
 165 extractPatsTyVars pats = nub (foldr extract_pat [] pats)
 166
 167 extract_pat (SigPatIn pat ty)      acc = extract_ty ty acc
 168 extract_pat WildPatIn              acc = acc
 169 extract_pat (VarPatIn var)         acc = acc
 170 extract_pat (LitPatIn _)           acc = acc
 171 extract_pat (LazyPatIn pat)        acc = extract_pat pat acc
 172 extract_pat (AsPatIn a pat)        acc = extract_pat pat acc
 173 extract_pat (NPlusKPatIn n _)      acc = acc
 174 extract_pat (ConPatIn c pats)      acc = foldr extract_pat acc pats
 175 extract_pat (ConOpPatIn p1 c f p2) acc = extract_pat p1 (extract_pat p2 acc)
 176 extract_pat (NegPatIn  pat)        acc = extract_pat pat acc
 177 extract_pat (ParPatIn  pat)        acc = extract_pat pat acc
 178 extract_pat (ListPatIn pats)       acc = foldr extract_pat acc pats
 179 extract_pat (TuplePatIn pats _)    acc = foldr extract_pat acc pats
 180 extract_pat (RecPatIn c fields)    acc = foldr (\ (f,pat,_) acc -> extract_pat pat acc) acc fields
 181 \end{code}
 182
 183 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
 184 by deriving them from the name of the class.  We fill in the names for the
 185 tycon and datacon corresponding to the class, by deriving them from the
 186 name of the class itself.  This saves recording the names in the interface
 187 file (which would be equally good).
 188
 189 Similarly for mkClassOpSig and default-method names.
 190
 191 \begin{code}
 192 mkClassDecl cxt cname tyvars sigs mbinds prags loc
 193   = ClassDecl cxt cname tyvars sigs mbinds prags tname dname sc_sel_names loc
 194   where
 195     cls_occ = rdrNameOcc cname
 196     dname   = mkRdrUnqual (mkClassDataConOcc cls_occ)
 197     tname   = mkRdrUnqual (mkClassTyConOcc   cls_occ)
 198     sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ)
 199                    | n <- [1..length cxt]]
 200       -- We number off the superclass selectors, 1, 2, 3 etc so that we
 201       -- can construct names for the selectors.  Thus
 202       --      class (C a, C b) => D a b where ...
 203       -- gives superclass selectors
 204       --      D_sc1, D_sc2
 205       -- (We used to call them D_C, but now we can have two different
 206       --  superclasses both called C!)
 207
 208 mkClassOpSig has_default_method op ty loc
 209   | not has_default_method = ClassOpSig op Nothing    ty loc
 210   | otherwise              = ClassOpSig op (Just dm_rn) ty loc
 211   where
 212     dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
 213 \end{code}
 214
 215 A useful function for building @OpApps@.  The operator is always a variable,
 216 and we don't know the fixity yet.
 217
 218 \begin{code}
 219 mkOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
 220 \end{code}
 221
 222 %************************************************************************
 223 %*                                                                      *
 224 \subsection[rdrBinding]{Bindings straight out of the parser}
 225 %*                                                                      *
 226 %************************************************************************
 227
 228 \begin{code}
 229 data RdrBinding
 230   =   -- On input we use the Empty/And form rather than a list
 231     RdrNullBind
 232   | RdrAndBindings    RdrBinding RdrBinding
 233
 234       -- Value bindings havn't been united with their
 235       -- signatures yet
 236   | RdrValBinding     RdrNameMonoBinds
 237
 238       -- Signatures are mysterious; we can't
 239       -- tell if its a Sig or a ClassOpSig,
 240       -- so we just save the pieces:
 241   | RdrSig            RdrNameSig
 242
 243       -- The remainder all fit into the main HsDecl form
 244   | RdrHsDecl         RdrNameHsDecl
 245
 246 type SigConverter = RdrNameSig -> RdrNameSig
 247 \end{code}
 248
 249 \begin{code}
 250 data RdrMatch
 251   = RdrMatch
 252              [RdrNamePat]
 253              (Maybe RdrNameHsType)
 254              RdrNameGRHSs
 255 \end{code}
 256
 257 %************************************************************************
 258 %*                                                                      *
 259 \subsection[cvDecls]{Convert various top-level declarations}
 260 %*                                                                      *
 261 %************************************************************************
 262
 263 We make a point not to throw any user-pragma ``sigs'' at
 264 these conversion functions:
 265
 266 \begin{code}
 267 cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
 268
 269 cvValSig      sig = sig
 270
 271 cvInstDeclSig sig = sig
 272
 273 cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var Nothing poly_ty src_loc
 274 cvClassOpSig sig                       = sig
 275 \end{code}
 276
 277
 278 %************************************************************************
 279 %*                                                                      *
 280 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
 281 %*                                                                      *
 282 %************************************************************************
 283
 284 Function definitions are restructured here. Each is assumed to be recursive
 285 initially, and non recursive definitions are discovered by the dependency
 286 analyser.
 287
 288 \begin{code}
 289 cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds
 290         -- The mysterious SigConverter converts Sigs to ClassOpSigs
 291         -- in class declarations.  Mostly it's just an identity function
 292
 293 cvBinds sig_cvtr binding
 294   = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) ->
 295     MonoBind mbs sigs Recursive
 296     }
 297 \end{code}
 298
 299 \begin{code}
 300 cvMonoBindsAndSigs :: SigConverter
 301                    -> RdrBinding
 302                    -> (RdrNameMonoBinds, [RdrNameSig])
 303
 304 cvMonoBindsAndSigs sig_cvtr fb
 305   = mangle_bind (EmptyMonoBinds, []) fb
 306   where
 307     mangle_bind acc RdrNullBind
 308       = acc
 309
 310     mangle_bind acc (RdrAndBindings fb1 fb2)
 311       = mangle_bind (mangle_bind acc fb1) fb2
 312
 313     mangle_bind (b_acc, s_acc) (RdrSig sig)
 314       = (b_acc, sig_cvtr sig : s_acc)
 315
 316     mangle_bind (b_acc, s_acc) (RdrValBinding binding)
 317       = (b_acc `AndMonoBinds` binding, s_acc)
 318 \end{code}
 319
 320
 321 %************************************************************************
 322 %*                                                                      *
 323 \subsection[PrefixToHS-utils]{Utilities for conversion}
 324 %*                                                                      *
 325 %************************************************************************
 326
 327 Separate declarations into all the various kinds:
 328
 329 \begin{code}
 330 cvTopDecls :: RdrBinding -> [RdrNameHsDecl]
 331 cvTopDecls bind
 332   = let
 333         (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind
 334     in
 335     (ValD (MonoBind mono_binds sigs Recursive) : top_decls)
 336   where
 337     go acc                RdrNullBind            = acc
 338     go acc                (RdrAndBindings b1 b2) = go (go acc b1) b2
 339     go (topds, mbs, sigs) (RdrHsDecl d)          = (d : topds, mbs, sigs)
 340     go (topds, mbs, sigs) (RdrSig (FixSig d))    = (FixD d  : topds, mbs, sigs)
 341     go (topds, mbs, sigs) (RdrSig sig)           = (topds, mbs, sig:sigs)
 342     go (topds, mbs, sigs) (RdrValBinding bind)   = (topds, mbs `AndMonoBinds` bind, sigs)
 343 \end{code}