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, 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 (HsUsgTy usg ty)           acc = extract_ty ty acc
 164 extract_ty (HsUsgForAllTy uv ty)      acc = extract_ty ty acc
 165 extract_ty (HsTyVar tv)               acc = tv : acc
 166 extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
 167 -- Generics
 168 extract_ty (HsOpTy ty1 nam ty2)         acc = extract_ty ty1 (extract_ty ty2 acc)
 169 extract_ty (HsNumTy num)              acc = acc
 170 -- Generics
 171 extract_ty (HsForAllTy (Just tvs) ctxt ty)
 172                                 acc = acc ++
 173                                       (filter (`notElem` locals) $
 174                                        extract_ctxt ctxt (extract_ty ty []))
 175                                     where
 176                                       locals = hsTyVarNames tvs
 177
 178
 179 extractPatsTyVars :: [RdrNamePat] -> [RdrName]
 180 extractPatsTyVars = filter isRdrTyVar .
 181                     nub .
 182                     extract_tys .
 183                     collectSigTysFromPats
 184
 185 extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
 186 -- Get the type variables out of the type patterns in a bunch of
 187 -- possibly-generic bindings in a class declaration
 188 extractGenericPatTyVars binds
 189   = filter isRdrTyVar (nub (get binds []))
 190   where
 191     get (AndMonoBinds b1 b2)   acc = get b1 (get b2 acc)
 192     get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
 193     get other                  acc = acc
 194
 195     get_m (Match _ (TypePatIn ty : _) _ _) acc = extract_ty ty acc
 196     get_m other                            acc = acc
 197 \end{code}
 198
 199
 200 %************************************************************************
 201 %*                                                                      *
 202 \subsection{Construction functions for Rdr stuff}
 203 %*                                                                    *
 204 %************************************************************************
 205
 206 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
 207 by deriving them from the name of the class.  We fill in the names for the
 208 tycon and datacon corresponding to the class, by deriving them from the
 209 name of the class itself.  This saves recording the names in the interface
 210 file (which would be equally good).
 211
 212 Similarly for mkConDecl, mkClassOpSig and default-method names.
 213
 214 \begin{code}
 215 mkClassDecl cxt cname tyvars fds sigs mbinds loc
 216   = ClassDecl cxt cname tyvars fds sigs mbinds new_names 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 new_or_data context
 240               tname list_var list_con i maybe src name1 name2
 241
 242 mkClassOpSig (DefMeth x) op ty loc
 243   = ClassOpSig op (Just (DefMeth dm_rn)) ty loc
 244   where
 245     dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
 246 mkClassOpSig x op ty loc =
 247     ClassOpSig op (Just x) ty loc
 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 n)) = HsOverLit (HsIntegral   (-i) n)
 273 mkHsNegApp (HsOverLit (HsFractional f n)) = HsOverLit (HsFractional (-f) n)
 274 mkHsNegApp expr                           = NegApp expr negate_RDR
 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) = ClassOpSig var Nothing 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}