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