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