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