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