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