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