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         mkHsDo,
  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 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 (HsPArrTy ty)              acc = extract_ty ty acc
 147 extract_ty (HsTupleTy _ tys)          acc = foldr extract_ty acc tys
 148 extract_ty (HsFunTy ty1 ty2)          acc = extract_ty ty1 (extract_ty ty2 acc)
 149 extract_ty (HsPredTy p)               acc = extract_pred p acc
 150 extract_ty (HsTyVar tv)               acc = tv : acc
 151 extract_ty (HsForAllTy Nothing cx ty) acc = extract_ctxt cx (extract_ty ty acc)
 152 extract_ty (HsOpTy ty1 nam ty2)       acc = extract_ty ty1 (extract_ty ty2 acc)
 153 extract_ty (HsParTy ty)               acc = extract_ty ty acc
 154 -- Generics
 155 extract_ty (HsNumTy num)              acc = acc
 156 extract_ty (HsKindSig ty k)           acc = extract_ty ty acc
 157 extract_ty (HsForAllTy (Just tvs) ctxt ty)
 158                                 acc = acc ++
 159                                       (filter (`notElem` locals) $
 160                                        extract_ctxt ctxt (extract_ty ty []))
 161                                     where
 162                                       locals = hsTyVarNames tvs
 163
 164 extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
 165 -- Get the type variables out of the type patterns in a bunch of
 166 -- possibly-generic bindings in a class declaration
 167 extractGenericPatTyVars binds
 168   = filter isRdrTyVar (nub (get binds []))
 169   where
 170     get (AndMonoBinds b1 b2)   acc = get b1 (get b2 acc)
 171     get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
 172     get other                  acc = acc
 173
 174     get_m (Match (TypePatIn ty : _) _ _) acc = extract_ty ty acc
 175     get_m other                          acc = acc
 176 \end{code}
 177
 178
 179 %************************************************************************
 180 %*                                                                      *
 181 \subsection{Construction functions for Rdr stuff}
 182 %*                                                                    *
 183 %************************************************************************
 184
 185 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
 186 by deriving them from the name of the class.  We fill in the names for the
 187 tycon and datacon corresponding to the class, by deriving them from the
 188 name of the class itself.  This saves recording the names in the interface
 189 file (which would be equally good).
 190
 191 Similarly for mkConDecl, mkClassOpSig and default-method names.
 192
 193         *** See "THE NAMING STORY" in HsDecls ****
 194
 195 \begin{code}
 196 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc
 197   = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars,
 198                 tcdFDs = fds,  tcdSigs = sigs,  tcdMeths = mbinds,
 199                 tcdSysNames = new_names, tcdLoc = loc }
 200   where
 201     cls_occ  = rdrNameOcc cname
 202     data_occ = mkClassDataConOcc cls_occ
 203     dname    = mkRdrUnqual data_occ
 204     dwname   = mkRdrUnqual (mkWorkerOcc data_occ)
 205     tname    = mkRdrUnqual (mkClassTyConOcc   cls_occ)
 206     sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ)
 207                    | n <- [1..length cxt]]
 208       -- We number off the superclass selectors, 1, 2, 3 etc so that we
 209       -- can construct names for the selectors.  Thus
 210       --      class (C a, C b) => D a b where ...
 211       -- gives superclass selectors
 212       --      D_sc1, D_sc2
 213       -- (We used to call them D_C, but now we can have two different
 214       --  superclasses both called C!)
 215     new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
 216
 217 mkTyData new_or_data (context, tname, tyvars) data_cons maybe src
 218   = let t_occ  = rdrNameOcc tname
 219         name1 = mkRdrUnqual (mkGenOcc1 t_occ)
 220         name2 = mkRdrUnqual (mkGenOcc2 t_occ)
 221     in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
 222                 tcdTyVars = tyvars, tcdCons = data_cons,
 223                 tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] }
 224
 225 mkClassOpSigDM op ty loc
 226   = ClassOpSig op (DefMeth dm_rn) ty loc
 227   where
 228     dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
 229
 230 mkConDecl cname ex_vars cxt details loc
 231   = ConDecl cname wkr_name ex_vars cxt details loc
 232   where
 233     wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
 234 \end{code}
 235
 236 \begin{code}
 237 mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr
 238 -- If the type checker sees (negate 3#) it will barf, because negate
 239 -- can't take an unboxed arg.  But that is exactly what it will see when
 240 -- we write "-3#".  So we have to do the negation right now!
 241
 242 mkHsNegApp (HsLit (HsIntPrim i))    = HsLit (HsIntPrim (-i))
 243 mkHsNegApp (HsLit (HsFloatPrim i))  = HsLit (HsFloatPrim (-i))
 244 mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
 245 mkHsNegApp expr                     = NegApp expr     placeHolderName
 246 \end{code}
 247
 248 A useful function for building @OpApps@.  The operator is always a
 249 variable, and we don't know the fixity yet.
 250
 251 \begin{code}
 252 mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
 253 \end{code}
 254
 255 These are the bits of syntax that contain rebindable names
 256 See RnEnv.lookupSyntaxName
 257
 258 \begin{code}
 259 mkHsIntegral   i      = HsIntegral   i  placeHolderName
 260 mkHsFractional f      = HsFractional f  placeHolderName
 261 mkNPlusKPat n k       = NPlusKPatIn n k placeHolderName
 262 mkHsDo ctxt stmts loc = HsDo ctxt stmts [] placeHolderType loc
 263 \end{code}
 264
 265
 266 %************************************************************************
 267 %*                                                                      *
 268 \subsection[rdrBinding]{Bindings straight out of the parser}
 269 %*                                                                      *
 270 %************************************************************************
 271
 272 \begin{code}
 273 data RdrBinding
 274   =   -- On input we use the Empty/And form rather than a list
 275     RdrNullBind
 276   | RdrAndBindings    RdrBinding RdrBinding
 277
 278       -- Value bindings havn't been united with their
 279       -- signatures yet
 280   | RdrValBinding     RdrNameMonoBinds
 281
 282       -- Signatures are mysterious; we can't
 283       -- tell if its a Sig or a ClassOpSig,
 284       -- so we just save the pieces:
 285   | RdrSig            RdrNameSig
 286
 287       -- The remainder all fit into the main HsDecl form
 288   | RdrHsDecl         RdrNameHsDecl
 289
 290 type SigConverter = RdrNameSig -> RdrNameSig
 291 \end{code}
 292
 293 \begin{code}
 294 data RdrMatch
 295   = RdrMatch
 296              [RdrNamePat]
 297              (Maybe RdrNameHsType)
 298              RdrNameGRHSs
 299 \end{code}
 300
 301 %************************************************************************
 302 %*                                                                      *
 303 \subsection[cvDecls]{Convert various top-level declarations}
 304 %*                                                                      *
 305 %************************************************************************
 306
 307 We make a point not to throw any user-pragma ``sigs'' at
 308 these conversion functions:
 309
 310 \begin{code}
 311 cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
 312
 313 cvValSig      sig = sig
 314
 315 cvInstDeclSig sig = sig
 316
 317 cvClassOpSig (Sig var poly_ty src_loc) = mkClassOpSigDM var poly_ty src_loc
 318 cvClassOpSig sig                       = sig
 319 \end{code}
 320
 321
 322 %************************************************************************
 323 %*                                                                      *
 324 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
 325 %*                                                                      *
 326 %************************************************************************
 327
 328 Function definitions are restructured here. Each is assumed to be recursive
 329 initially, and non recursive definitions are discovered by the dependency
 330 analyser.
 331
 332 \begin{code}
 333 cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds
 334         -- The mysterious SigConverter converts Sigs to ClassOpSigs
 335         -- in class declarations.  Mostly it's just an identity function
 336
 337 cvBinds sig_cvtr binding
 338   = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) ->
 339     MonoBind mbs sigs Recursive
 340     }
 341 \end{code}
 342
 343 \begin{code}
 344 cvMonoBindsAndSigs :: SigConverter
 345                    -> RdrBinding
 346                    -> (RdrNameMonoBinds, [RdrNameSig])
 347
 348 cvMonoBindsAndSigs sig_cvtr fb
 349   = mangle_bind (EmptyMonoBinds, []) fb
 350   where
 351     mangle_bind acc RdrNullBind
 352       = acc
 353
 354     mangle_bind acc (RdrAndBindings fb1 fb2)
 355       = mangle_bind (mangle_bind acc fb1) fb2
 356
 357     mangle_bind (b_acc, s_acc) (RdrSig sig)
 358       = (b_acc, sig_cvtr sig : s_acc)
 359
 360     mangle_bind (b_acc, s_acc) (RdrValBinding binding)
 361       = (b_acc `AndMonoBinds` binding, s_acc)
 362 \end{code}
 363
 364
 365 %************************************************************************
 366 %*                                                                      *
 367 \subsection[PrefixToHS-utils]{Utilities for conversion}
 368 %*                                                                      *
 369 %************************************************************************
 370
 371 Separate declarations into all the various kinds:
 372
 373 \begin{code}
 374 cvTopDecls :: RdrBinding -> [RdrNameHsDecl]
 375 cvTopDecls bind
 376   = let
 377         (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind
 378     in
 379     (ValD (MonoBind mono_binds sigs Recursive) : top_decls)
 380   where
 381     go acc                RdrNullBind            = acc
 382     go acc                (RdrAndBindings b1 b2) = go (go acc b1) b2
 383     go (topds, mbs, sigs) (RdrHsDecl d)          = (d : topds, mbs, sigs)
 384     go (topds, mbs, sigs) (RdrSig (FixSig d))    = (FixD d  : topds, mbs, sigs)
 385     go (topds, mbs, sigs) (RdrSig sig)           = (topds, mbs, sig:sigs)
 386     go (topds, mbs, sigs) (RdrValBinding bind)   = (topds, mbs `AndMonoBinds` bind, sigs)
 387 \end{code}