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