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