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, mkClassOpSig, 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, mkRdrIfaceUnqual, 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 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 (HsUsgTy usg ty)           acc = extract_ty ty acc
 163 extract_ty (HsUsgForAllTy uv ty)      acc = extract_ty ty acc
 164 extract_ty (HsTyVar tv)               acc = tv : acc
 165 extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
 166 -- Generics
 167 extract_ty (HsOpTy ty1 nam ty2)         acc = extract_ty ty1 (extract_ty ty2 acc)
 168 extract_ty (HsNumTy num)              acc = acc
 169 -- Generics
 170 extract_ty (HsForAllTy (Just tvs) ctxt ty)
 171                                 acc = acc ++
 172                                       (filter (`notElem` locals) $
 173                                        extract_ctxt ctxt (extract_ty ty []))
 174                                     where
 175                                       locals = hsTyVarNames tvs
 176
 177
 178 extractPatsTyVars :: [RdrNamePat] -> [RdrName]
 179 extractPatsTyVars = filter isRdrTyVar .
 180                     nub .
 181                     extract_tys .
 182                     collectSigTysFromPats
 183
 184 extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
 185 -- Get the type variables out of the type patterns in a bunch of
 186 -- possibly-generic bindings in a class declaration
 187 extractGenericPatTyVars binds
 188   = filter isRdrTyVar (nub (get binds []))
 189   where
 190     get (AndMonoBinds b1 b2)   acc = get b1 (get b2 acc)
 191     get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
 192     get other                  acc = acc
 193
 194     get_m (Match _ (TypePatIn ty : _) _ _) acc = extract_ty ty acc
 195     get_m other                            acc = acc
 196 \end{code}
 197
 198
 199 %************************************************************************
 200 %*                                                                      *
 201 \subsection{Construction functions for Rdr stuff}
 202 %*                                                                    *
 203 %************************************************************************
 204
 205 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
 206 by deriving them from the name of the class.  We fill in the names for the
 207 tycon and datacon corresponding to the class, by deriving them from the
 208 name of the class itself.  This saves recording the names in the interface
 209 file (which would be equally good).
 210
 211 Similarly for mkConDecl, mkClassOpSig and default-method names.
 212
 213 \begin{code}
 214 mkClassDecl cxt cname tyvars fds sigs mbinds loc
 215   = ClassDecl cxt cname tyvars fds sigs mbinds new_names loc
 216   where
 217     cls_occ  = rdrNameOcc cname
 218     data_occ = mkClassDataConOcc cls_occ
 219     dname    = mkRdrIfaceUnqual data_occ
 220     dwname   = mkRdrIfaceUnqual (mkWorkerOcc data_occ)
 221     tname    = mkRdrIfaceUnqual (mkClassTyConOcc   cls_occ)
 222     sc_sel_names = [ mkRdrIfaceUnqual (mkSuperDictSelOcc n cls_occ)
 223                    | n <- [1..length cxt]]
 224       -- We number off the superclass selectors, 1, 2, 3 etc so that we
 225       -- can construct names for the selectors.  Thus
 226       --      class (C a, C b) => D a b where ...
 227       -- gives superclass selectors
 228       --      D_sc1, D_sc2
 229       -- (We used to call them D_C, but now we can have two different
 230       --  superclasses both called C!)
 231     new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
 232
 233 -- mkTyData :: ??
 234 mkTyData new_or_data context tname list_var list_con i maybe src
 235   = let t_occ  = rdrNameOcc tname
 236         name1 = mkRdrIfaceUnqual (mkGenOcc1 t_occ)
 237         name2 = mkRdrIfaceUnqual (mkGenOcc2 t_occ)
 238     in TyData new_or_data context
 239               tname list_var list_con i maybe src name1 name2
 240
 241 mkClassOpSig (DefMeth x) op ty loc
 242   = ClassOpSig op (Just (DefMeth dm_rn)) ty loc
 243   where
 244     dm_rn = mkRdrIfaceUnqual (mkDefaultMethodOcc (rdrNameOcc op))
 245 mkClassOpSig x op ty loc =
 246     ClassOpSig op (Just x) ty loc
 247
 248 mkConDecl cname ex_vars cxt details loc
 249   = ConDecl cname wkr_name ex_vars cxt details loc
 250   where
 251     wkr_name = mkRdrIfaceUnqual (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) = ClassOpSig var Nothing 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}