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