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