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         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         RdrNameHsTyVar,
  33         RdrNameSig,
  34         RdrNameStmt,
  35         RdrNameTyClDecl,
  36         RdrNameRuleDecl,
  37         RdrNameRuleBndr,
  38         RdrNameDeprecation,
  39         RdrNameHsRecordBinds,
  40         RdrNameFixitySig,
  41
  42         RdrBinding(..),
  43         RdrMatch(..),
  44         SigConverter,
  45
  46         extractHsTyRdrNames,  extractSomeHsTyRdrNames,
  47         extractHsTysRdrNames, extractSomeHsTysRdrNames,
  48         extractRuleBndrsTyVars,
  49         extractHsCtxtRdrTyVars, extractGenericPatTyVars,
  50
  51         mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl,
  52         mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional,
  53
  54         cvBinds,
  55         cvMonoBindsAndSigs,
  56         cvTopDecls,
  57         cvValSig, cvClassOpSig, cvInstDeclSig,
  58         mkTyData
  59     ) where
  60
  61 #include "HsVersions.h"
  62
  63 import HsSyn            -- Lots of it
  64 import OccName          ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
  65                           mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
  66                           mkGenOcc2,
  67                         )
  68 import PrelNames        ( minusName, negateName, fromIntegerName, fromRationalName )
  69 import RdrName          ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc,
  70                         )
  71 import List             ( nub )
  72 import BasicTypes       ( RecFlag(..) )
  73 import Class            ( DefMeth (..) )
  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             = HsContext             RdrName
  90 type RdrNameHsDecl              = HsDecl                RdrName RdrNamePat
  91 type RdrNameDefaultDecl         = DefaultDecl           RdrName
  92 type RdrNameForeignDecl         = ForeignDecl           RdrName
  93 type RdrNameGRHS                = GRHS                  RdrName RdrNamePat
  94 type RdrNameGRHSs               = GRHSs                 RdrName RdrNamePat
  95 type RdrNameHsBinds             = HsBinds               RdrName RdrNamePat
  96 type RdrNameHsExpr              = HsExpr                RdrName RdrNamePat
  97 type RdrNameHsModule            = HsModule              RdrName RdrNamePat
  98 type RdrNameIE                  = IE                    RdrName
  99 type RdrNameImportDecl          = ImportDecl            RdrName
 100 type RdrNameInstDecl            = InstDecl              RdrName RdrNamePat
 101 type RdrNameMatch               = Match                 RdrName RdrNamePat
 102 type RdrNameMonoBinds           = MonoBinds             RdrName RdrNamePat
 103 type RdrNamePat                 = InPat                 RdrName
 104 type RdrNameHsType              = HsType                RdrName
 105 type RdrNameHsTyVar             = HsTyVarBndr           RdrName
 106 type RdrNameSig                 = Sig                   RdrName
 107 type RdrNameStmt                = Stmt                  RdrName RdrNamePat
 108 type RdrNameTyClDecl            = TyClDecl              RdrName RdrNamePat
 109
 110 type RdrNameRuleBndr            = RuleBndr              RdrName
 111 type RdrNameRuleDecl            = RuleDecl              RdrName RdrNamePat
 112 type RdrNameDeprecation         = DeprecDecl            RdrName
 113 type RdrNameFixitySig           = FixitySig             RdrName
 114
 115 type RdrNameHsRecordBinds       = HsRecordBinds         RdrName RdrNamePat
 116 \end{code}
 117
 118
 119 %************************************************************************
 120 %*                                                                      *
 121 \subsection{A few functions over HsSyn at RdrName}
 122 %*                                                                    *
 123 %************************************************************************
 124
 125 @extractHsTyRdrNames@ finds the free variables of a HsType
 126 It's used when making the for-alls explicit.
 127
 128 \begin{code}
 129 extractHsTyRdrNames :: RdrNameHsType -> [RdrName]
 130 extractHsTyRdrNames ty = nub (extract_ty ty [])
 131
 132 extractHsTysRdrNames :: [RdrNameHsType] -> [RdrName]
 133 extractHsTysRdrNames tys = nub (extract_tys tys)
 134
 135 extractSomeHsTyRdrNames  :: (RdrName -> Bool) -> RdrNameHsType -> [RdrName]
 136 extractSomeHsTyRdrNames ok ty = nub (filter ok (extract_ty ty []))
 137
 138 extractSomeHsTysRdrNames :: (RdrName -> Bool) -> [RdrNameHsType] -> [RdrName]
 139 extractSomeHsTysRdrNames ok tys = nub (filter ok (extract_tys tys))
 140
 141 extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName]
 142 extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
 143                            where
 144                              go (RuleBndr _)       acc = acc
 145                              go (RuleBndrSig _ ty) acc = extract_ty ty acc
 146
 147 extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
 148 extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
 149 extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName]
 150 extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty)
 151
 152 extract_ctxt ctxt acc = foldr extract_pred acc ctxt
 153
 154 extract_pred (HsClassP cls tys) acc     = foldr extract_ty (cls : acc) tys
 155 extract_pred (HsIParam n ty) acc        = extract_ty ty acc
 156
 157 extract_tys tys = foldr extract_ty [] tys
 158
 159 extract_ty (HsAppTy ty1 ty2)          acc = extract_ty ty1 (extract_ty ty2 acc)
 160 extract_ty (HsListTy ty)              acc = extract_ty ty acc
 161 extract_ty (HsTupleTy _ tys)          acc = foldr extract_ty acc tys
 162 extract_ty (HsFunTy ty1 ty2)          acc = extract_ty ty1 (extract_ty ty2 acc)
 163 extract_ty (HsPredTy p)               acc = extract_pred p acc
 164 extract_ty (HsTyVar tv)               acc = tv : acc
 165 extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
 166 -- Generics
 167 extract_ty (HsOpTy ty1 nam ty2)         acc = extract_ty ty1 (extract_ty ty2 acc)
 168 extract_ty (HsNumTy num)              acc = acc
 169 -- Generics
 170 extract_ty (HsForAllTy (Just tvs) ctxt ty)
 171                                 acc = acc ++
 172                                       (filter (`notElem` locals) $
 173                                        extract_ctxt ctxt (extract_ty ty []))
 174                                     where
 175                                       locals = hsTyVarNames tvs
 176
 177 extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
 178 -- Get the type variables out of the type patterns in a bunch of
 179 -- possibly-generic bindings in a class declaration
 180 extractGenericPatTyVars binds
 181   = filter isRdrTyVar (nub (get binds []))
 182   where
 183     get (AndMonoBinds b1 b2)   acc = get b1 (get b2 acc)
 184     get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
 185     get other                  acc = acc
 186
 187     get_m (Match _ (TypePatIn ty : _) _ _) acc = extract_ty ty acc
 188     get_m other                            acc = acc
 189 \end{code}
 190
 191
 192 %************************************************************************
 193 %*                                                                      *
 194 \subsection{Construction functions for Rdr stuff}
 195 %*                                                                    *
 196 %************************************************************************
 197
 198 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
 199 by deriving them from the name of the class.  We fill in the names for the
 200 tycon and datacon corresponding to the class, by deriving them from the
 201 name of the class itself.  This saves recording the names in the interface
 202 file (which would be equally good).
 203
 204 Similarly for mkConDecl, mkClassOpSig and default-method names.
 205
 206         *** See "THE NAMING STORY" in HsDecls ****
 207
 208 \begin{code}
 209 mkClassDecl cxt cname tyvars fds sigs mbinds loc
 210   = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars,
 211                 tcdFDs = fds,  tcdSigs = sigs,  tcdMeths = mbinds,
 212                 tcdSysNames = new_names, tcdLoc = loc }
 213   where
 214     cls_occ  = rdrNameOcc cname
 215     data_occ = mkClassDataConOcc cls_occ
 216     dname    = mkRdrUnqual data_occ
 217     dwname   = mkRdrUnqual (mkWorkerOcc data_occ)
 218     tname    = mkRdrUnqual (mkClassTyConOcc   cls_occ)
 219     sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ)
 220                    | n <- [1..length cxt]]
 221       -- We number off the superclass selectors, 1, 2, 3 etc so that we
 222       -- can construct names for the selectors.  Thus
 223       --      class (C a, C b) => D a b where ...
 224       -- gives superclass selectors
 225       --      D_sc1, D_sc2
 226       -- (We used to call them D_C, but now we can have two different
 227       --  superclasses both called C!)
 228     new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
 229
 230 -- mkTyData :: ??
 231 mkTyData new_or_data context tname list_var list_con i maybe src
 232   = let t_occ  = rdrNameOcc tname
 233         name1 = mkRdrUnqual (mkGenOcc1 t_occ)
 234         name2 = mkRdrUnqual (mkGenOcc2 t_occ)
 235     in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
 236                 tcdTyVars = list_var, tcdCons = list_con, tcdNCons = i,
 237                 tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] }
 238
 239 mkClassOpSigDM op ty loc
 240   = ClassOpSig op (DefMeth dm_rn) ty loc
 241   where
 242     dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
 243
 244 mkConDecl cname ex_vars cxt details loc
 245   = ConDecl cname wkr_name ex_vars cxt details loc
 246   where
 247     wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
 248 \end{code}
 249
 250 \begin{code}
 251 mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr
 252 -- If the type checker sees (negate 3#) it will barf, because negate
 253 -- can't take an unboxed arg.  But that is exactly what it will see when
 254 -- we write "-3#".  So we have to do the negation right now!
 255 --
 256 -- We also do the same service for boxed literals, because this function
 257 -- is also used for patterns (which, remember, are parsed as expressions)
 258 -- and pattern don't have negation in them.
 259 --
 260 -- Finally, it's important to represent minBound as minBound, and not
 261 -- as (negate (-minBound)), becuase the latter is out of range.
 262
 263 mkHsNegApp (HsLit (HsIntPrim i))    = HsLit (HsIntPrim (-i))
 264 mkHsNegApp (HsLit (HsFloatPrim i))  = HsLit (HsFloatPrim (-i))
 265 mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
 266
 267 mkHsNegApp (HsOverLit (HsIntegral   i n)) = HsOverLit (HsIntegral   (-i) n)
 268 mkHsNegApp (HsOverLit (HsFractional f n)) = HsOverLit (HsFractional (-f) n)
 269 mkHsNegApp expr                           = NegApp expr negateName
 270 \end{code}
 271
 272 A useful function for building @OpApps@.  The operator is always a
 273 variable, and we don't know the fixity yet.
 274
 275 \begin{code}
 276 mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
 277 \end{code}
 278
 279 These are the bits of syntax that contain rebindable names
 280 See RnEnv.lookupSyntaxName
 281
 282 \begin{code}
 283 mkHsIntegral   i = HsIntegral   i fromIntegerName
 284 mkHsFractional f = HsFractional f fromRationalName
 285 mkNPlusKPat n k  = NPlusKPatIn n k minusName
 286 \end{code}
 287
 288
 289 %************************************************************************
 290 %*                                                                      *
 291 \subsection[rdrBinding]{Bindings straight out of the parser}
 292 %*                                                                      *
 293 %************************************************************************
 294
 295 \begin{code}
 296 data RdrBinding
 297   =   -- On input we use the Empty/And form rather than a list
 298     RdrNullBind
 299   | RdrAndBindings    RdrBinding RdrBinding
 300
 301       -- Value bindings havn't been united with their
 302       -- signatures yet
 303   | RdrValBinding     RdrNameMonoBinds
 304
 305       -- Signatures are mysterious; we can't
 306       -- tell if its a Sig or a ClassOpSig,
 307       -- so we just save the pieces:
 308   | RdrSig            RdrNameSig
 309
 310       -- The remainder all fit into the main HsDecl form
 311   | RdrHsDecl         RdrNameHsDecl
 312
 313 type SigConverter = RdrNameSig -> RdrNameSig
 314 \end{code}
 315
 316 \begin{code}
 317 data RdrMatch
 318   = RdrMatch
 319              [RdrNamePat]
 320              (Maybe RdrNameHsType)
 321              RdrNameGRHSs
 322 \end{code}
 323
 324 %************************************************************************
 325 %*                                                                      *
 326 \subsection[cvDecls]{Convert various top-level declarations}
 327 %*                                                                      *
 328 %************************************************************************
 329
 330 We make a point not to throw any user-pragma ``sigs'' at
 331 these conversion functions:
 332
 333 \begin{code}
 334 cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
 335
 336 cvValSig      sig = sig
 337
 338 cvInstDeclSig sig = sig
 339
 340 cvClassOpSig (Sig var poly_ty src_loc) = mkClassOpSigDM var poly_ty src_loc
 341 cvClassOpSig sig                       = sig
 342 \end{code}
 343
 344
 345 %************************************************************************
 346 %*                                                                      *
 347 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
 348 %*                                                                      *
 349 %************************************************************************
 350
 351 Function definitions are restructured here. Each is assumed to be recursive
 352 initially, and non recursive definitions are discovered by the dependency
 353 analyser.
 354
 355 \begin{code}
 356 cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds
 357         -- The mysterious SigConverter converts Sigs to ClassOpSigs
 358         -- in class declarations.  Mostly it's just an identity function
 359
 360 cvBinds sig_cvtr binding
 361   = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) ->
 362     MonoBind mbs sigs Recursive
 363     }
 364 \end{code}
 365
 366 \begin{code}
 367 cvMonoBindsAndSigs :: SigConverter
 368                    -> RdrBinding
 369                    -> (RdrNameMonoBinds, [RdrNameSig])
 370
 371 cvMonoBindsAndSigs sig_cvtr fb
 372   = mangle_bind (EmptyMonoBinds, []) fb
 373   where
 374     mangle_bind acc RdrNullBind
 375       = acc
 376
 377     mangle_bind acc (RdrAndBindings fb1 fb2)
 378       = mangle_bind (mangle_bind acc fb1) fb2
 379
 380     mangle_bind (b_acc, s_acc) (RdrSig sig)
 381       = (b_acc, sig_cvtr sig : s_acc)
 382
 383     mangle_bind (b_acc, s_acc) (RdrValBinding binding)
 384       = (b_acc `AndMonoBinds` binding, s_acc)
 385 \end{code}
 386
 387
 388 %************************************************************************
 389 %*                                                                      *
 390 \subsection[PrefixToHS-utils]{Utilities for conversion}
 391 %*                                                                      *
 392 %************************************************************************
 393
 394 Separate declarations into all the various kinds:
 395
 396 \begin{code}
 397 cvTopDecls :: RdrBinding -> [RdrNameHsDecl]
 398 cvTopDecls bind
 399   = let
 400         (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind
 401     in
 402     (ValD (MonoBind mono_binds sigs Recursive) : top_decls)
 403   where
 404     go acc                RdrNullBind            = acc
 405     go acc                (RdrAndBindings b1 b2) = go (go acc b1) b2
 406     go (topds, mbs, sigs) (RdrHsDecl d)          = (d : topds, mbs, sigs)
 407     go (topds, mbs, sigs) (RdrSig (FixSig d))    = (FixD d  : topds, mbs, sigs)
 408     go (topds, mbs, sigs) (RdrSig sig)           = (topds, mbs, sig:sigs)
 409     go (topds, mbs, sigs) (RdrValBinding bind)   = (topds, mbs `AndMonoBinds` bind, sigs)
 410 \end{code}