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         RdrNameSpecDataSig,
  18         RdrNameDefaultDecl,
  19         RdrNameForeignDecl,
  20         RdrNameGRHS,
  21         RdrNameGRHSs,
  22         RdrNameHsBinds,
  23         RdrNameHsDecl,
  24         RdrNameHsExpr,
  25         RdrNameHsModule,
  26         RdrNameIE,
  27         RdrNameImportDecl,
  28         RdrNameInstDecl,
  29         RdrNameMatch,
  30         RdrNameMonoBinds,
  31         RdrNamePat,
  32         RdrNameHsType,
  33         RdrNameHsTyVar,
  34         RdrNameSig,
  35         RdrNameStmt,
  36         RdrNameTyClDecl,
  37         RdrNameRuleDecl,
  38         RdrNameRuleBndr,
  39         RdrNameDeprecation,
  40         RdrNameHsRecordBinds,
  41         RdrNameFixitySig,
  42
  43         RdrBinding(..),
  44         RdrMatch(..),
  45         SigConverter,
  46
  47         RdrNameClassOpPragmas,
  48         RdrNameClassPragmas,
  49         RdrNameDataPragmas,
  50         RdrNameGenPragmas,
  51         RdrNameInstancePragmas,
  52         extractHsTyRdrNames,
  53         extractHsTyRdrTyVars, extractHsTysRdrTyVars,
  54         extractPatsTyVars,
  55         extractRuleBndrsTyVars,
  56         extractHsCtxtRdrTyVars,
  57
  58         mkOpApp, mkClassDecl, mkClassOpSig, mkConDecl,
  59
  60         cvBinds,
  61         cvMonoBindsAndSigs,
  62         cvTopDecls,
  63         cvValSig, cvClassOpSig, cvInstDeclSig
  64     ) where
  65
  66 #include "HsVersions.h"
  67
  68 import HsSyn
  69 import Name             ( mkClassTyConOcc, mkClassDataConOcc )
  70 import OccName          ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
  71                           mkSuperDictSelOcc, mkDefaultMethodOcc
  72                         )
  73 import RdrName          ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc )
  74 import Util             ( thenCmp )
  75 import HsPragmas
  76 import List             ( nub )
  77 import BasicTypes       ( RecFlag(..) )
  78 import Outputable
  79 \end{code}
  80
  81
  82 %************************************************************************
  83 %*                                                                      *
  84 \subsection{Type synonyms}
  85 %*                                                                      *
  86 %************************************************************************
  87
  88 \begin{code}
  89 type RdrNameArithSeqInfo        = ArithSeqInfo          RdrName RdrNamePat
  90 type RdrNameBangType            = BangType              RdrName
  91 type RdrNameClassOpSig          = Sig                   RdrName
  92 type RdrNameConDecl             = ConDecl               RdrName
  93 type RdrNameConDetails          = ConDetails            RdrName
  94 type RdrNameContext             = HsContext             RdrName
  95 type RdrNameHsDecl              = HsDecl                RdrName RdrNamePat
  96 type RdrNameSpecDataSig         = SpecDataSig           RdrName
  97 type RdrNameDefaultDecl         = DefaultDecl           RdrName
  98 type RdrNameForeignDecl         = ForeignDecl           RdrName
  99 type RdrNameGRHS                = GRHS                  RdrName RdrNamePat
 100 type RdrNameGRHSs               = GRHSs                 RdrName RdrNamePat
 101 type RdrNameHsBinds             = HsBinds               RdrName RdrNamePat
 102 type RdrNameHsExpr              = HsExpr                RdrName RdrNamePat
 103 type RdrNameHsModule            = HsModule              RdrName RdrNamePat
 104 type RdrNameIE                  = IE                    RdrName
 105 type RdrNameImportDecl          = ImportDecl            RdrName
 106 type RdrNameInstDecl            = InstDecl              RdrName RdrNamePat
 107 type RdrNameMatch               = Match                 RdrName RdrNamePat
 108 type RdrNameMonoBinds           = MonoBinds             RdrName RdrNamePat
 109 type RdrNamePat                 = InPat                 RdrName
 110 type RdrNameHsType              = HsType                RdrName
 111 type RdrNameHsTyVar             = HsTyVarBndr           RdrName
 112 type RdrNameSig                 = Sig                   RdrName
 113 type RdrNameStmt                = Stmt                  RdrName RdrNamePat
 114 type RdrNameTyClDecl            = TyClDecl              RdrName RdrNamePat
 115 type RdrNameRuleBndr            = RuleBndr              RdrName
 116 type RdrNameRuleDecl            = RuleDecl              RdrName RdrNamePat
 117 type RdrNameDeprecation         = DeprecDecl            RdrName
 118 type RdrNameFixitySig           = FixitySig             RdrName
 119
 120 type RdrNameHsRecordBinds       = HsRecordBinds         RdrName RdrNamePat
 121
 122 type RdrNameClassOpPragmas      = ClassOpPragmas        RdrName
 123 type RdrNameClassPragmas        = ClassPragmas          RdrName
 124 type RdrNameDataPragmas         = DataPragmas           RdrName
 125 type RdrNameGenPragmas          = GenPragmas            RdrName
 126 type RdrNameInstancePragmas     = InstancePragmas       RdrName
 127 \end{code}
 128
 129
 130 %************************************************************************
 131 %*                                                                      *
 132 \subsection{A few functions over HsSyn at RdrName}
 133 %*                                                                    *
 134 %************************************************************************
 135
 136 @extractHsTyRdrNames@ finds the free variables of a HsType
 137 It's used when making the for-alls explicit.
 138
 139 \begin{code}
 140 extractHsTyRdrNames :: HsType RdrName -> [RdrName]
 141 extractHsTyRdrNames ty = nub (extract_ty ty [])
 142
 143 extractHsTyRdrTyVars     :: RdrNameHsType -> [RdrName]
 144 extractHsTyRdrTyVars ty =  filter isRdrTyVar (extractHsTyRdrNames ty)
 145
 146 extractHsTysRdrTyVars     :: [RdrNameHsType] -> [RdrName]
 147 extractHsTysRdrTyVars tys =  filter isRdrTyVar (nub (extract_tys tys []))
 148
 149 extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName]
 150 extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
 151                            where
 152                              go (RuleBndr _)       acc = acc
 153                              go (RuleBndrSig _ ty) acc = extract_ty ty acc
 154
 155 extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
 156 extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
 157 extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName]
 158 extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty)
 159
 160 extract_ctxt ctxt acc = foldr extract_pred acc ctxt
 161
 162 extract_pred (HsPClass cls tys) acc     = foldr extract_ty (cls : acc) tys
 163 extract_pred (HsPIParam n ty) acc       = extract_ty ty acc
 164
 165 extract_tys tys acc = foldr extract_ty acc tys
 166
 167 extract_ty (HsAppTy ty1 ty2)          acc = extract_ty ty1 (extract_ty ty2 acc)
 168 extract_ty (HsListTy ty)              acc = extract_ty ty acc
 169 extract_ty (HsTupleTy _ tys)          acc = foldr extract_ty acc tys
 170 extract_ty (HsFunTy ty1 ty2)          acc = extract_ty ty1 (extract_ty ty2 acc)
 171 extract_ty (HsPredTy p)               acc = extract_pred p acc
 172 extract_ty (HsUsgTy usg ty)           acc = extract_ty ty acc
 173 extract_ty (HsUsgForAllTy uv ty)      acc = extract_ty ty acc
 174 extract_ty (HsTyVar tv)               acc = tv : acc
 175 extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
 176 extract_ty (HsForAllTy (Just tvs) ctxt ty)
 177                                 acc = acc ++
 178                                       (filter (`notElem` locals) $
 179                                        extract_ctxt ctxt (extract_ty ty []))
 180                                     where
 181                                       locals = map getTyVarName tvs
 182
 183
 184 extractPatsTyVars :: [RdrNamePat] -> [RdrName]
 185 extractPatsTyVars pats = filter isRdrTyVar (nub (foldr extract_pat [] pats))
 186
 187 extract_pat (SigPatIn pat ty)      acc = extract_ty ty acc
 188 extract_pat WildPatIn              acc = acc
 189 extract_pat (VarPatIn var)         acc = acc
 190 extract_pat (LitPatIn _)           acc = acc
 191 extract_pat (LazyPatIn pat)        acc = extract_pat pat acc
 192 extract_pat (AsPatIn a pat)        acc = extract_pat pat acc
 193 extract_pat (NPlusKPatIn n _)      acc = acc
 194 extract_pat (ConPatIn c pats)      acc = foldr extract_pat acc pats
 195 extract_pat (ConOpPatIn p1 c f p2) acc = extract_pat p1 (extract_pat p2 acc)
 196 extract_pat (NegPatIn  pat)        acc = extract_pat pat acc
 197 extract_pat (ParPatIn  pat)        acc = extract_pat pat acc
 198 extract_pat (ListPatIn pats)       acc = foldr extract_pat acc pats
 199 extract_pat (TuplePatIn pats _)    acc = foldr extract_pat acc pats
 200 extract_pat (RecPatIn c fields)    acc = foldr (\ (f,pat,_) acc -> extract_pat pat acc) acc fields
 201 \end{code}
 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 \begin{code}
 212 mkClassDecl cxt cname tyvars fds sigs mbinds prags loc
 213   = ClassDecl cxt cname tyvars fds sigs mbinds prags tname dname dwname sc_sel_names loc
 214   where
 215     cls_occ  = rdrNameOcc cname
 216     data_occ = mkClassDataConOcc cls_occ
 217     dname    = mkRdrUnqual data_occ
 218     dwname   = mkRdrUnqual (mkWorkerOcc data_occ)
 219     tname    = mkRdrUnqual (mkClassTyConOcc   cls_occ)
 220     sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ)
 221                    | n <- [1..length cxt]]
 222       -- We number off the superclass selectors, 1, 2, 3 etc so that we
 223       -- can construct names for the selectors.  Thus
 224       --      class (C a, C b) => D a b where ...
 225       -- gives superclass selectors
 226       --      D_sc1, D_sc2
 227       -- (We used to call them D_C, but now we can have two different
 228       --  superclasses both called C!)
 229
 230 mkClassOpSig has_default_method op ty loc
 231   = ClassOpSig op dm_rn has_default_method ty loc
 232   where
 233     dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
 234
 235 mkConDecl cname ex_vars cxt details loc
 236   = ConDecl cname wkr_name ex_vars cxt details loc
 237   where
 238     wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
 239 \end{code}
 240
 241 A useful function for building @OpApps@.  The operator is always a variable,
 242 and we don't know the fixity yet.
 243
 244 \begin{code}
 245 mkOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
 246 \end{code}
 247
 248 %************************************************************************
 249 %*                                                                      *
 250 \subsection[rdrBinding]{Bindings straight out of the parser}
 251 %*                                                                      *
 252 %************************************************************************
 253
 254 \begin{code}
 255 data RdrBinding
 256   =   -- On input we use the Empty/And form rather than a list
 257     RdrNullBind
 258   | RdrAndBindings    RdrBinding RdrBinding
 259
 260       -- Value bindings havn't been united with their
 261       -- signatures yet
 262   | RdrValBinding     RdrNameMonoBinds
 263
 264       -- Signatures are mysterious; we can't
 265       -- tell if its a Sig or a ClassOpSig,
 266       -- so we just save the pieces:
 267   | RdrSig            RdrNameSig
 268
 269       -- The remainder all fit into the main HsDecl form
 270   | RdrHsDecl         RdrNameHsDecl
 271
 272 type SigConverter = RdrNameSig -> RdrNameSig
 273 \end{code}
 274
 275 \begin{code}
 276 data RdrMatch
 277   = RdrMatch
 278              [RdrNamePat]
 279              (Maybe RdrNameHsType)
 280              RdrNameGRHSs
 281 \end{code}
 282
 283 %************************************************************************
 284 %*                                                                      *
 285 \subsection[cvDecls]{Convert various top-level declarations}
 286 %*                                                                      *
 287 %************************************************************************
 288
 289 We make a point not to throw any user-pragma ``sigs'' at
 290 these conversion functions:
 291
 292 \begin{code}
 293 cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
 294
 295 cvValSig      sig = sig
 296
 297 cvInstDeclSig sig = sig
 298
 299 cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var (panic "cvClassOpSig:dm_name")
 300                                                         False
 301                                                         poly_ty src_loc
 302 cvClassOpSig sig                       = sig
 303 \end{code}
 304
 305
 306 %************************************************************************
 307 %*                                                                      *
 308 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
 309 %*                                                                      *
 310 %************************************************************************
 311
 312 Function definitions are restructured here. Each is assumed to be recursive
 313 initially, and non recursive definitions are discovered by the dependency
 314 analyser.
 315
 316 \begin{code}
 317 cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds
 318         -- The mysterious SigConverter converts Sigs to ClassOpSigs
 319         -- in class declarations.  Mostly it's just an identity function
 320
 321 cvBinds sig_cvtr binding
 322   = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) ->
 323     MonoBind mbs sigs Recursive
 324     }
 325 \end{code}
 326
 327 \begin{code}
 328 cvMonoBindsAndSigs :: SigConverter
 329                    -> RdrBinding
 330                    -> (RdrNameMonoBinds, [RdrNameSig])
 331
 332 cvMonoBindsAndSigs sig_cvtr fb
 333   = mangle_bind (EmptyMonoBinds, []) fb
 334   where
 335     mangle_bind acc RdrNullBind
 336       = acc
 337
 338     mangle_bind acc (RdrAndBindings fb1 fb2)
 339       = mangle_bind (mangle_bind acc fb1) fb2
 340
 341     mangle_bind (b_acc, s_acc) (RdrSig sig)
 342       = (b_acc, sig_cvtr sig : s_acc)
 343
 344     mangle_bind (b_acc, s_acc) (RdrValBinding binding)
 345       = (b_acc `AndMonoBinds` binding, s_acc)
 346 \end{code}
 347
 348
 349 %************************************************************************
 350 %*                                                                      *
 351 \subsection[PrefixToHS-utils]{Utilities for conversion}
 352 %*                                                                      *
 353 %************************************************************************
 354
 355 Separate declarations into all the various kinds:
 356
 357 \begin{code}
 358 cvTopDecls :: RdrBinding -> [RdrNameHsDecl]
 359 cvTopDecls bind
 360   = let
 361         (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind
 362     in
 363     (ValD (MonoBind mono_binds sigs Recursive) : top_decls)
 364   where
 365     go acc                RdrNullBind            = acc
 366     go acc                (RdrAndBindings b1 b2) = go (go acc b1) b2
 367     go (topds, mbs, sigs) (RdrHsDecl d)          = (d : topds, mbs, sigs)
 368     go (topds, mbs, sigs) (RdrSig (FixSig d))    = (FixD d  : topds, mbs, sigs)
 369     go (topds, mbs, sigs) (RdrSig sig)           = (topds, mbs, sig:sigs)
 370     go (topds, mbs, sigs) (RdrValBinding bind)   = (topds, mbs `AndMonoBinds` bind, sigs)
 371 \end{code}