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