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