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