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 \begin{code}
 213 mkClassDecl cxt cname tyvars fds sigs mbinds loc
 214   = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars,
 215                 tcdFDs = fds,  tcdSigs = sigs,  tcdMeths = mbinds,
 216                 tcdSysNames = new_names, tcdLoc = loc }
 217   where
 218     cls_occ  = rdrNameOcc cname
 219     data_occ = mkClassDataConOcc cls_occ
 220     dname    = mkRdrUnqual data_occ
 221     dwname   = mkRdrUnqual (mkWorkerOcc data_occ)
 222     tname    = mkRdrUnqual (mkClassTyConOcc   cls_occ)
 223     sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ)
 224                    | n <- [1..length cxt]]
 225       -- We number off the superclass selectors, 1, 2, 3 etc so that we
 226       -- can construct names for the selectors.  Thus
 227       --      class (C a, C b) => D a b where ...
 228       -- gives superclass selectors
 229       --      D_sc1, D_sc2
 230       -- (We used to call them D_C, but now we can have two different
 231       --  superclasses both called C!)
 232     new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
 233
 234 -- mkTyData :: ??
 235 mkTyData new_or_data context tname list_var list_con i maybe src
 236   = let t_occ  = rdrNameOcc tname
 237         name1 = mkRdrUnqual (mkGenOcc1 t_occ)
 238         name2 = mkRdrUnqual (mkGenOcc2 t_occ)
 239     in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
 240                 tcdTyVars = list_var, tcdCons = list_con, tcdNCons = i,
 241                 tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] }
 242
 243 mkClassOpSigDM op ty loc
 244   = ClassOpSig op (DefMeth dm_rn) ty loc
 245   where
 246     dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
 247
 248 mkConDecl cname ex_vars cxt details loc
 249   = ConDecl cname wkr_name ex_vars cxt details loc
 250   where
 251     wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
 252 \end{code}
 253
 254 \begin{code}
 255 mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr
 256 -- If the type checker sees (negate 3#) it will barf, because negate
 257 -- can't take an unboxed arg.  But that is exactly what it will see when
 258 -- we write "-3#".  So we have to do the negation right now!
 259 --
 260 -- We also do the same service for boxed literals, because this function
 261 -- is also used for patterns (which, remember, are parsed as expressions)
 262 -- and pattern don't have negation in them.
 263 --
 264 -- Finally, it's important to represent minBound as minBound, and not
 265 -- as (negate (-minBound)), becuase the latter is out of range.
 266
 267 mkHsNegApp (HsLit (HsIntPrim i))    = HsLit (HsIntPrim (-i))
 268 mkHsNegApp (HsLit (HsFloatPrim i))  = HsLit (HsFloatPrim (-i))
 269 mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
 270
 271 mkHsNegApp (HsOverLit (HsIntegral   i n)) = HsOverLit (HsIntegral   (-i) n)
 272 mkHsNegApp (HsOverLit (HsFractional f n)) = HsOverLit (HsFractional (-f) n)
 273 mkHsNegApp expr                           = NegApp expr negate_RDR
 274 \end{code}
 275
 276 A useful function for building @OpApps@.  The operator is always a
 277 variable, and we don't know the fixity yet.
 278
 279 \begin{code}
 280 mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
 281 \end{code}
 282
 283
 284 %************************************************************************
 285 %*                                                                      *
 286 \subsection[rdrBinding]{Bindings straight out of the parser}
 287 %*                                                                      *
 288 %************************************************************************
 289
 290 \begin{code}
 291 data RdrBinding
 292   =   -- On input we use the Empty/And form rather than a list
 293     RdrNullBind
 294   | RdrAndBindings    RdrBinding RdrBinding
 295
 296       -- Value bindings havn't been united with their
 297       -- signatures yet
 298   | RdrValBinding     RdrNameMonoBinds
 299
 300       -- Signatures are mysterious; we can't
 301       -- tell if its a Sig or a ClassOpSig,
 302       -- so we just save the pieces:
 303   | RdrSig            RdrNameSig
 304
 305       -- The remainder all fit into the main HsDecl form
 306   | RdrHsDecl         RdrNameHsDecl
 307
 308 type SigConverter = RdrNameSig -> RdrNameSig
 309 \end{code}
 310
 311 \begin{code}
 312 data RdrMatch
 313   = RdrMatch
 314              [RdrNamePat]
 315              (Maybe RdrNameHsType)
 316              RdrNameGRHSs
 317 \end{code}
 318
 319 %************************************************************************
 320 %*                                                                      *
 321 \subsection[cvDecls]{Convert various top-level declarations}
 322 %*                                                                      *
 323 %************************************************************************
 324
 325 We make a point not to throw any user-pragma ``sigs'' at
 326 these conversion functions:
 327
 328 \begin{code}
 329 cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
 330
 331 cvValSig      sig = sig
 332
 333 cvInstDeclSig sig = sig
 334
 335 cvClassOpSig (Sig var poly_ty src_loc) = mkClassOpSigDM var poly_ty src_loc
 336 cvClassOpSig sig                       = sig
 337 \end{code}
 338
 339
 340 %************************************************************************
 341 %*                                                                      *
 342 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
 343 %*                                                                      *
 344 %************************************************************************
 345
 346 Function definitions are restructured here. Each is assumed to be recursive
 347 initially, and non recursive definitions are discovered by the dependency
 348 analyser.
 349
 350 \begin{code}
 351 cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds
 352         -- The mysterious SigConverter converts Sigs to ClassOpSigs
 353         -- in class declarations.  Mostly it's just an identity function
 354
 355 cvBinds sig_cvtr binding
 356   = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) ->
 357     MonoBind mbs sigs Recursive
 358     }
 359 \end{code}
 360
 361 \begin{code}
 362 cvMonoBindsAndSigs :: SigConverter
 363                    -> RdrBinding
 364                    -> (RdrNameMonoBinds, [RdrNameSig])
 365
 366 cvMonoBindsAndSigs sig_cvtr fb
 367   = mangle_bind (EmptyMonoBinds, []) fb
 368   where
 369     mangle_bind acc RdrNullBind
 370       = acc
 371
 372     mangle_bind acc (RdrAndBindings fb1 fb2)
 373       = mangle_bind (mangle_bind acc fb1) fb2
 374
 375     mangle_bind (b_acc, s_acc) (RdrSig sig)
 376       = (b_acc, sig_cvtr sig : s_acc)
 377
 378     mangle_bind (b_acc, s_acc) (RdrValBinding binding)
 379       = (b_acc `AndMonoBinds` binding, s_acc)
 380 \end{code}
 381
 382
 383 %************************************************************************
 384 %*                                                                      *
 385 \subsection[PrefixToHS-utils]{Utilities for conversion}
 386 %*                                                                      *
 387 %************************************************************************
 388
 389 Separate declarations into all the various kinds:
 390
 391 \begin{code}
 392 cvTopDecls :: RdrBinding -> [RdrNameHsDecl]
 393 cvTopDecls bind
 394   = let
 395         (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind
 396     in
 397     (ValD (MonoBind mono_binds sigs Recursive) : top_decls)
 398   where
 399     go acc                RdrNullBind            = acc
 400     go acc                (RdrAndBindings b1 b2) = go (go acc b1) b2
 401     go (topds, mbs, sigs) (RdrHsDecl d)          = (d : topds, mbs, sigs)
 402     go (topds, mbs, sigs) (RdrSig (FixSig d))    = (FixD d  : topds, mbs, sigs)
 403     go (topds, mbs, sigs) (RdrSig sig)           = (topds, mbs, sig:sigs)
 404     go (topds, mbs, sigs) (RdrValBinding bind)   = (topds, mbs `AndMonoBinds` bind, sigs)
 405 \end{code}