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