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