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