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         mkHsOpApp, mkClassDecl, mkClassOpSig, mkConDecl,
  59         mkHsNegApp, mkHsIntegralLit, mkHsFractionalLit, mkNPlusKPatIn,
  60
  61
  62         -- some built-in names (all :: RdrName)
  63         unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR,
  64         tupleCon_RDR, tupleTyCon_RDR, ubxTupleCon_RDR, ubxTupleTyCon_RDR,
  65         funTyCon_RDR,
  66
  67         cvBinds,
  68         cvMonoBindsAndSigs,
  69         cvTopDecls,
  70         cvValSig, cvClassOpSig, cvInstDeclSig
  71     ) where
  72
  73 #include "HsVersions.h"
  74
  75 import HsSyn            -- Lots of it
  76 import CmdLineOpts      ( opt_NoImplicitPrelude )
  77 import HsPat            ( collectSigTysFromPats )
  78 import OccName          ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
  79                           mkSuperDictSelOcc, mkDefaultMethodOcc,
  80                           varName, dataName, tcName
  81                         )
  82 import PrelNames        ( pRELUDE_Name, mkTupNameStr )
  83 import RdrName          ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc,
  84                           mkSrcUnqual, mkPreludeQual
  85                         )
  86 import HsPragmas
  87 import List             ( nub )
  88 import BasicTypes       ( Boxity(..), RecFlag(..) )
  89 \end{code}
  90
  91
  92 %************************************************************************
  93 %*                                                                      *
  94 \subsection{Type synonyms}
  95 %*                                                                      *
  96 %************************************************************************
  97
  98 \begin{code}
  99 type RdrNameArithSeqInfo        = ArithSeqInfo          RdrName RdrNamePat
 100 type RdrNameBangType            = BangType              RdrName
 101 type RdrNameClassOpSig          = Sig                   RdrName
 102 type RdrNameConDecl             = ConDecl               RdrName
 103 type RdrNameConDetails          = ConDetails            RdrName
 104 type RdrNameContext             = HsContext             RdrName
 105 type RdrNameHsDecl              = HsDecl                RdrName RdrNamePat
 106 type RdrNameSpecDataSig         = SpecDataSig           RdrName
 107 type RdrNameDefaultDecl         = DefaultDecl           RdrName
 108 type RdrNameForeignDecl         = ForeignDecl           RdrName
 109 type RdrNameGRHS                = GRHS                  RdrName RdrNamePat
 110 type RdrNameGRHSs               = GRHSs                 RdrName RdrNamePat
 111 type RdrNameHsBinds             = HsBinds               RdrName RdrNamePat
 112 type RdrNameHsExpr              = HsExpr                RdrName RdrNamePat
 113 type RdrNameHsModule            = HsModule              RdrName RdrNamePat
 114 type RdrNameIE                  = IE                    RdrName
 115 type RdrNameImportDecl          = ImportDecl            RdrName
 116 type RdrNameInstDecl            = InstDecl              RdrName RdrNamePat
 117 type RdrNameMatch               = Match                 RdrName RdrNamePat
 118 type RdrNameMonoBinds           = MonoBinds             RdrName RdrNamePat
 119 type RdrNamePat                 = InPat                 RdrName
 120 type RdrNameHsType              = HsType                RdrName
 121 type RdrNameHsTyVar             = HsTyVarBndr           RdrName
 122 type RdrNameSig                 = Sig                   RdrName
 123 type RdrNameStmt                = Stmt                  RdrName RdrNamePat
 124 type RdrNameTyClDecl            = TyClDecl              RdrName RdrNamePat
 125 type RdrNameRuleBndr            = RuleBndr              RdrName
 126 type RdrNameRuleDecl            = RuleDecl              RdrName RdrNamePat
 127 type RdrNameDeprecation         = DeprecDecl            RdrName
 128 type RdrNameFixitySig           = FixitySig             RdrName
 129
 130 type RdrNameHsRecordBinds       = HsRecordBinds         RdrName RdrNamePat
 131
 132 type RdrNameClassOpPragmas      = ClassOpPragmas        RdrName
 133 type RdrNameClassPragmas        = ClassPragmas          RdrName
 134 type RdrNameDataPragmas         = DataPragmas           RdrName
 135 type RdrNameGenPragmas          = GenPragmas            RdrName
 136 type RdrNameInstancePragmas     = InstancePragmas       RdrName
 137 \end{code}
 138
 139
 140 %************************************************************************
 141 %*                                                                      *
 142 \subsection{A few functions over HsSyn at RdrName}
 143 %*                                                                    *
 144 %************************************************************************
 145
 146 @extractHsTyRdrNames@ finds the free variables of a HsType
 147 It's used when making the for-alls explicit.
 148
 149 \begin{code}
 150 extractHsTyRdrNames :: HsType RdrName -> [RdrName]
 151 extractHsTyRdrNames ty = nub (extract_ty ty [])
 152
 153 extractHsTyRdrTyVars     :: RdrNameHsType -> [RdrName]
 154 extractHsTyRdrTyVars ty =  filter isRdrTyVar (extractHsTyRdrNames ty)
 155
 156 extractHsTysRdrTyVars     :: [RdrNameHsType] -> [RdrName]
 157 extractHsTysRdrTyVars tys =  filter isRdrTyVar (nub (extract_tys tys))
 158
 159 extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName]
 160 extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
 161                            where
 162                              go (RuleBndr _)       acc = acc
 163                              go (RuleBndrSig _ ty) acc = extract_ty ty acc
 164
 165 extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
 166 extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
 167 extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName]
 168 extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty)
 169
 170 extract_ctxt ctxt acc = foldr extract_pred acc ctxt
 171
 172 extract_pred (HsPClass cls tys) acc     = foldr extract_ty (cls : acc) tys
 173 extract_pred (HsPIParam n ty) acc       = extract_ty ty acc
 174
 175 extract_tys tys = foldr extract_ty [] tys
 176
 177 extract_ty (HsAppTy ty1 ty2)          acc = extract_ty ty1 (extract_ty ty2 acc)
 178 extract_ty (HsListTy ty)              acc = extract_ty ty acc
 179 extract_ty (HsTupleTy _ tys)          acc = foldr extract_ty acc tys
 180 extract_ty (HsFunTy ty1 ty2)          acc = extract_ty ty1 (extract_ty ty2 acc)
 181 extract_ty (HsPredTy p)               acc = extract_pred p acc
 182 extract_ty (HsUsgTy usg ty)           acc = extract_ty ty acc
 183 extract_ty (HsUsgForAllTy uv ty)      acc = extract_ty ty acc
 184 extract_ty (HsTyVar tv)               acc = tv : acc
 185 extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
 186 extract_ty (HsForAllTy (Just tvs) ctxt ty)
 187                                 acc = acc ++
 188                                       (filter (`notElem` locals) $
 189                                        extract_ctxt ctxt (extract_ty ty []))
 190                                     where
 191                                       locals = hsTyVarNames tvs
 192
 193
 194 extractPatsTyVars :: [RdrNamePat] -> [RdrName]
 195 extractPatsTyVars = filter isRdrTyVar .
 196                     nub .
 197                     extract_tys .
 198                     collectSigTysFromPats
 199 \end{code}
 200
 201
 202 %************************************************************************
 203 %*                                                                      *
 204 \subsection{Construction functions for Rdr stuff}
 205 %*                                                                    *
 206 %************************************************************************
 207
 208 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
 209 by deriving them from the name of the class.  We fill in the names for the
 210 tycon and datacon corresponding to the class, by deriving them from the
 211 name of the class itself.  This saves recording the names in the interface
 212 file (which would be equally good).
 213
 214 Similarly for mkConDecl, mkClassOpSig and default-method names.
 215
 216 \begin{code}
 217 mkClassDecl cxt cname tyvars fds sigs mbinds prags loc
 218   = ClassDecl cxt cname tyvars fds sigs mbinds prags tname dname dwname sc_sel_names loc
 219   where
 220     cls_occ  = rdrNameOcc cname
 221     data_occ = mkClassDataConOcc cls_occ
 222     dname    = mkRdrUnqual data_occ
 223     dwname   = mkRdrUnqual (mkWorkerOcc data_occ)
 224     tname    = mkRdrUnqual (mkClassTyConOcc   cls_occ)
 225     sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ)
 226                    | n <- [1..length cxt]]
 227       -- We number off the superclass selectors, 1, 2, 3 etc so that we
 228       -- can construct names for the selectors.  Thus
 229       --      class (C a, C b) => D a b where ...
 230       -- gives superclass selectors
 231       --      D_sc1, D_sc2
 232       -- (We used to call them D_C, but now we can have two different
 233       --  superclasses both called C!)
 234
 235 mkClassOpSig has_default_method op ty loc
 236   = ClassOpSig op (Just (dm_rn, has_default_method)) ty loc
 237   where
 238     dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
 239
 240 mkConDecl cname ex_vars cxt details loc
 241   = ConDecl cname wkr_name ex_vars cxt details loc
 242   where
 243     wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
 244 \end{code}
 245
 246 \begin{code}
 247 mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr
 248 -- If the type checker sees (negate 3#) it will barf, because negate
 249 -- can't take an unboxed arg.  But that is exactly what it will see when
 250 -- we write "-3#".  So we have to do the negation right now!
 251 --
 252 -- We also do the same service for boxed literals, because this function
 253 -- is also used for patterns (which, remember, are parsed as expressions)
 254 -- and pattern don't have negation in them.
 255 --
 256 -- Finally, it's important to represent minBound as minBound, and not
 257 -- as (negate (-minBound)), becuase the latter is out of range.
 258
 259 mkHsNegApp (HsLit (HsIntPrim i))    = HsLit (HsIntPrim (-i))
 260 mkHsNegApp (HsLit (HsFloatPrim i))  = HsLit (HsFloatPrim (-i))
 261 mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
 262
 263 mkHsNegApp (HsOverLit (HsIntegral   i n)) = HsOverLit (HsIntegral   (-i) n)
 264 mkHsNegApp (HsOverLit (HsFractional f n)) = HsOverLit (HsFractional (-f) n)
 265
 266 mkHsNegApp expr = NegApp expr (prelQual varName SLIT("negate"))
 267 \end{code}
 268
 269 \begin{code}
 270 mkHsIntegralLit :: Integer -> HsOverLit RdrName
 271 mkHsIntegralLit i = HsIntegral i (prelQual varName SLIT("fromInteger"))
 272
 273 mkHsFractionalLit :: Rational -> HsOverLit RdrName
 274 mkHsFractionalLit f = HsFractional f (prelQual varName SLIT("fromRational"))
 275
 276 mkNPlusKPatIn :: RdrName -> HsOverLit RdrName -> RdrNamePat
 277 mkNPlusKPatIn n k = NPlusKPatIn n k (prelQual varName SLIT("-"))
 278 \end{code}
 279
 280 A useful function for building @OpApps@.  The operator is always a
 281 variable, and we don't know the fixity yet.
 282
 283 \begin{code}
 284 mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
 285 \end{code}
 286
 287 \begin{code}
 288 -----------------------------------------------------------------------------
 289 -- Built-in names
 290 -- Qualified Prelude names are always in scope; so we can just say Prelude.[]
 291 -- for the list type constructor, say.   But it's not so easy when we say
 292 -- -fno-implicit-prelude.   Then you just get whatever "[]" happens to be in scope.
 293
 294 unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR :: RdrName
 295 tupleCon_RDR, tupleTyCon_RDR            :: Int -> RdrName
 296 ubxTupleCon_RDR, ubxTupleTyCon_RDR      :: Int -> RdrName
 297
 298 unitCon_RDR             = prelQual dataName SLIT("()")
 299 unitTyCon_RDR           = prelQual tcName   SLIT("()")
 300 nilCon_RDR              = prelQual dataName SLIT("[]")
 301 listTyCon_RDR           = prelQual tcName   SLIT("[]")
 302 funTyCon_RDR            = prelQual tcName   SLIT("(->)")
 303 tupleCon_RDR arity      = prelQual dataName (snd (mkTupNameStr Boxed arity))
 304 tupleTyCon_RDR arity    = prelQual tcName   (snd (mkTupNameStr Boxed arity))
 305 ubxTupleCon_RDR arity   = prelQual dataName (snd (mkTupNameStr Unboxed arity))
 306 ubxTupleTyCon_RDR arity = prelQual tcName   (snd (mkTupNameStr Unboxed arity))
 307
 308 prelQual ns occ | opt_NoImplicitPrelude = mkSrcUnqual   ns occ
 309                 | otherwise             = mkPreludeQual ns pRELUDE_Name occ
 310 \end{code}
 311
 312 %************************************************************************
 313 %*                                                                      *
 314 \subsection[rdrBinding]{Bindings straight out of the parser}
 315 %*                                                                      *
 316 %************************************************************************
 317
 318 \begin{code}
 319 data RdrBinding
 320   =   -- On input we use the Empty/And form rather than a list
 321     RdrNullBind
 322   | RdrAndBindings    RdrBinding RdrBinding
 323
 324       -- Value bindings havn't been united with their
 325       -- signatures yet
 326   | RdrValBinding     RdrNameMonoBinds
 327
 328       -- Signatures are mysterious; we can't
 329       -- tell if its a Sig or a ClassOpSig,
 330       -- so we just save the pieces:
 331   | RdrSig            RdrNameSig
 332
 333       -- The remainder all fit into the main HsDecl form
 334   | RdrHsDecl         RdrNameHsDecl
 335
 336 type SigConverter = RdrNameSig -> RdrNameSig
 337 \end{code}
 338
 339 \begin{code}
 340 data RdrMatch
 341   = RdrMatch
 342              [RdrNamePat]
 343              (Maybe RdrNameHsType)
 344              RdrNameGRHSs
 345 \end{code}
 346
 347 %************************************************************************
 348 %*                                                                      *
 349 \subsection[cvDecls]{Convert various top-level declarations}
 350 %*                                                                      *
 351 %************************************************************************
 352
 353 We make a point not to throw any user-pragma ``sigs'' at
 354 these conversion functions:
 355
 356 \begin{code}
 357 cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
 358
 359 cvValSig      sig = sig
 360
 361 cvInstDeclSig sig = sig
 362
 363 cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var Nothing poly_ty src_loc
 364 cvClassOpSig sig                       = sig
 365 \end{code}
 366
 367
 368 %************************************************************************
 369 %*                                                                      *
 370 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
 371 %*                                                                      *
 372 %************************************************************************
 373
 374 Function definitions are restructured here. Each is assumed to be recursive
 375 initially, and non recursive definitions are discovered by the dependency
 376 analyser.
 377
 378 \begin{code}
 379 cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds
 380         -- The mysterious SigConverter converts Sigs to ClassOpSigs
 381         -- in class declarations.  Mostly it's just an identity function
 382
 383 cvBinds sig_cvtr binding
 384   = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) ->
 385     MonoBind mbs sigs Recursive
 386     }
 387 \end{code}
 388
 389 \begin{code}
 390 cvMonoBindsAndSigs :: SigConverter
 391                    -> RdrBinding
 392                    -> (RdrNameMonoBinds, [RdrNameSig])
 393
 394 cvMonoBindsAndSigs sig_cvtr fb
 395   = mangle_bind (EmptyMonoBinds, []) fb
 396   where
 397     mangle_bind acc RdrNullBind
 398       = acc
 399
 400     mangle_bind acc (RdrAndBindings fb1 fb2)
 401       = mangle_bind (mangle_bind acc fb1) fb2
 402
 403     mangle_bind (b_acc, s_acc) (RdrSig sig)
 404       = (b_acc, sig_cvtr sig : s_acc)
 405
 406     mangle_bind (b_acc, s_acc) (RdrValBinding binding)
 407       = (b_acc `AndMonoBinds` binding, s_acc)
 408 \end{code}
 409
 410
 411 %************************************************************************
 412 %*                                                                      *
 413 \subsection[PrefixToHS-utils]{Utilities for conversion}
 414 %*                                                                      *
 415 %************************************************************************
 416
 417 Separate declarations into all the various kinds:
 418
 419 \begin{code}
 420 cvTopDecls :: RdrBinding -> [RdrNameHsDecl]
 421 cvTopDecls bind
 422   = let
 423         (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind
 424     in
 425     (ValD (MonoBind mono_binds sigs Recursive) : top_decls)
 426   where
 427     go acc                RdrNullBind            = acc
 428     go acc                (RdrAndBindings b1 b2) = go (go acc b1) b2
 429     go (topds, mbs, sigs) (RdrHsDecl d)          = (d : topds, mbs, sigs)
 430     go (topds, mbs, sigs) (RdrSig (FixSig d))    = (FixD d  : topds, mbs, sigs)
 431     go (topds, mbs, sigs) (RdrSig sig)           = (topds, mbs, sig:sigs)
 432     go (topds, mbs, sigs) (RdrValBinding bind)   = (topds, mbs `AndMonoBinds` bind, sigs)
 433 \end{code}