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