ghc/compiler/reader/ReadPrefix.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1998
   3 %
   4 \section{Read parse tree built by Yacc parser}
   5
   6 \begin{code}
   7 module ReadPrefix ( rdModule )  where
   8
   9 #include "HsVersions.h"
  10
  11 import UgenAll          -- all Yacc parser gumpff...
  12 import PrefixSyn        -- and various syntaxen.
  13 import HsSyn
  14 import HsTypes          ( HsTyVar(..) )
  15 import HsPragmas        ( noDataPragmas, noClassPragmas )
  16 import RdrHsSyn
  17 import BasicTypes       ( Fixity(..), FixityDirection(..), NewOrData(..) )
  18 import PrelMods         ( pRELUDE_Name )
  19 import PrefixToHs
  20 import CallConv
  21
  22 import CmdLineOpts      ( opt_NoImplicitPrelude, opt_GlasgowExts, opt_D_dump_rdr )
  23 import Module           ( ModuleName, mkSrcModuleFS, WhereFrom(..) )
  24 import OccName          ( NameSpace, tcName, clsName, tcClsName, varName, dataName, tvName,
  25                           isLexCon
  26                         )
  27 import RdrName          ( RdrName, isRdrDataCon, mkSrcQual, mkSrcUnqual, mkPreludeQual,
  28                           dummyRdrVarName
  29                         )
  30 import Outputable
  31 import ErrUtils         ( dumpIfSet )
  32 import SrcLoc           ( SrcLoc )
  33 import FastString       ( mkFastCharString )
  34 import PrelRead         ( readRational__ )
  35 \end{code}
  36
  37 %************************************************************************
  38 %*                                                                      *
  39 \subsection[rdModule]{@rdModule@: reads in a Haskell module}
  40 %*                                                                      *
  41 %************************************************************************
  42
  43 \begin{code}
  44 rdModule :: IO (ModuleName,         -- this module's name
  45                 RdrNameHsModule)    -- the main goods
  46
  47 rdModule
  48   =     -- call the Yacc parser!
  49     _ccall_ hspmain                             >>= \ pt ->
  50
  51         -- Read from the Yacc tree
  52     initUgn (read_module pt)                    >>= \ (mod_name, rdr_module) ->
  53
  54         -- Dump if reqd
  55     dumpIfSet opt_D_dump_rdr "Reader"
  56               (ppr rdr_module)                  >>
  57
  58         -- And return
  59     return (mod_name, rdr_module)
  60
  61 read_module :: ParseTree -> UgnM (ModuleName, RdrNameHsModule)
  62 read_module pt
  63   = rdU_tree pt `thenUgn` \ (U_hmodule mod_fs himplist hexplist
  64                                        hmodlist srciface_version srcline) ->
  65     let
  66         srcfile  = mkFastCharString ``input_filename'' -- What A Great Hack! (TM)
  67         mod_name = mkSrcModuleFS mod_fs
  68     in
  69
  70     setSrcFileUgn srcfile               $
  71     mkSrcLocUgn srcline                 $ \ src_loc     ->
  72
  73     wlkMaybe rdEntities hexplist `thenUgn` \ exports    ->
  74     wlkList  rdImport   himplist `thenUgn` \ imports    ->
  75     wlkBinding          hmodlist `thenUgn` \ binding    ->
  76
  77     let
  78         top_decls  = cvTopDecls srcfile binding
  79         rdr_module = HsModule mod_name
  80                               (case srciface_version of { 0 -> Nothing; n -> Just n })
  81                               exports
  82                               imports
  83                               top_decls
  84                               src_loc
  85     in
  86     returnUgn (mod_name, rdr_module)
  87 \end{code}
  88
  89 %************************************************************************
  90 %*                                                                      *
  91 \subsection[wlkExprOrPat]{@wlkExpr@ and @wlkPat@}
  92 %*                                                                      *
  93 %************************************************************************
  94
  95 \begin{code}
  96 rdExpr :: ParseTree -> UgnM RdrNameHsExpr
  97 rdPat  :: ParseTree -> UgnM RdrNamePat
  98
  99 rdExpr pt = rdU_tree pt `thenUgn` wlkExpr
 100 rdPat  pt = rdU_tree pt `thenUgn` wlkPat
 101
 102 wlkExpr :: U_tree -> UgnM RdrNameHsExpr
 103 wlkPat  :: U_tree -> UgnM RdrNamePat
 104
 105 wlkExpr expr
 106   = case expr of
 107       U_par pexpr -> -- parenthesised expr
 108         wlkExpr pexpr   `thenUgn` \ expr ->
 109         returnUgn (HsPar expr)
 110
 111       U_lsection lsexp lop -> -- left section
 112         wlkExpr lsexp   `thenUgn` \ expr ->
 113         wlkVarId  lop   `thenUgn` \ op   ->
 114         returnUgn (SectionL expr (HsVar op))
 115
 116       U_rsection rop rsexp -> -- right section
 117         wlkVarId  rop   `thenUgn` \ op   ->
 118         wlkExpr rsexp   `thenUgn` \ expr ->
 119         returnUgn (SectionR (HsVar op) expr)
 120
 121       U_ccall fun flavor ccargs -> -- ccall/casm
 122         wlkList rdExpr ccargs   `thenUgn` \ args ->
 123         let
 124             tag = _HEAD_ flavor
 125         in
 126         returnUgn (CCall fun args
 127                     (tag == 'p' || tag == 'P') -- may invoke GC
 128                     (tag == 'N' || tag == 'P') -- really a "casm"
 129                     (panic "CCall:result_ty"))
 130
 131       U_scc label sccexp -> -- scc (set-cost-centre) expression
 132         wlkExpr   sccexp        `thenUgn` \ expr  ->
 133         returnUgn (HsSCC label expr)
 134
 135       U_lambda match -> -- lambda expression
 136         wlkMatch match          `thenUgn` \ match' ->
 137         returnUgn (HsLam match')
 138
 139       U_casee caseexpr casebody srcline ->      -- case expression
 140         mkSrcLocUgn srcline              $ \ src_loc ->
 141         wlkExpr         caseexpr `thenUgn` \ expr ->
 142         wlkList rdMatch casebody `thenUgn` \ mats ->
 143         returnUgn (HsCase expr mats src_loc)
 144
 145       U_ife ifpred ifthen ifelse srcline ->     -- if expression
 146         mkSrcLocUgn srcline             $ \ src_loc ->
 147         wlkExpr ifpred          `thenUgn` \ e1 ->
 148         wlkExpr ifthen          `thenUgn` \ e2 ->
 149         wlkExpr ifelse          `thenUgn` \ e3 ->
 150         returnUgn (HsIf e1 e2 e3 src_loc)
 151
 152       U_let letvdefs letvexpr ->                -- let expression
 153         wlkLocalBinding letvdefs        `thenUgn` \ binding ->
 154         wlkExpr    letvexpr             `thenUgn` \ expr    ->
 155         returnUgn (HsLet binding expr)
 156
 157       U_doe gdo srcline ->                      -- do expression
 158         mkSrcLocUgn srcline             $ \ src_loc ->
 159         wlkList rd_stmt gdo     `thenUgn` \ stmts ->
 160         returnUgn (HsDo DoStmt stmts src_loc)
 161         where
 162         rd_stmt pt
 163           = rdU_tree pt `thenUgn` \ bind ->
 164             case bind of
 165               U_doexp exp srcline ->
 166                 mkSrcLocUgn srcline             $ \ src_loc ->
 167                 wlkExpr exp             `thenUgn` \ expr ->
 168                 returnUgn (ExprStmt expr src_loc)
 169
 170               U_dobind pat exp srcline ->
 171                 mkSrcLocUgn srcline             $ \ src_loc ->
 172                 wlkPat  pat             `thenUgn` \ patt ->
 173                 wlkExpr exp             `thenUgn` \ expr ->
 174                 returnUgn (BindStmt patt expr src_loc)
 175
 176               U_seqlet seqlet ->
 177                 wlkLocalBinding seqlet  `thenUgn` \ binds ->
 178                 returnUgn (LetStmt binds)
 179
 180       U_comprh cexp cquals -> -- list comprehension
 181         wlkExpr cexp            `thenUgn` \ expr  ->
 182         wlkQuals cquals         `thenUgn` \ quals ->
 183         getSrcLocUgn            `thenUgn` \ loc ->
 184         returnUgn (HsDo ListComp (quals ++ [ReturnStmt expr]) loc)
 185
 186       U_eenum efrom estep eto -> -- arithmetic sequence
 187         wlkExpr efrom           `thenUgn` \ e1  ->
 188         wlkMaybe rdExpr estep   `thenUgn` \ es2 ->
 189         wlkMaybe rdExpr eto     `thenUgn` \ es3 ->
 190         returnUgn (cv_arith_seq e1 es2 es3)
 191         where
 192            cv_arith_seq e1 Nothing   Nothing   = ArithSeqIn (From       e1)
 193            cv_arith_seq e1 Nothing   (Just e3) = ArithSeqIn (FromTo     e1 e3)
 194            cv_arith_seq e1 (Just e2) Nothing   = ArithSeqIn (FromThen   e1 e2)
 195            cv_arith_seq e1 (Just e2) (Just e3) = ArithSeqIn (FromThenTo e1 e2 e3)
 196
 197       U_restr restre restrt ->  -- expression with type signature
 198         wlkExpr     restre      `thenUgn` \ expr ->
 199         wlkHsSigType restrt     `thenUgn` \ ty   ->
 200         returnUgn (ExprWithTySig expr ty)
 201
 202       --------------------------------------------------------------
 203       -- now the prefix items that can either be an expression or
 204       -- pattern, except we know they are *expressions* here
 205       -- (this code could be commoned up with the pattern version;
 206       -- but it probably isn't worth it)
 207       --------------------------------------------------------------
 208       U_lit lit ->
 209         wlkLiteral lit  `thenUgn` \ lit ->
 210         returnUgn (HsLit lit)
 211
 212       U_ident n ->                      -- simple identifier
 213         wlkVarId n      `thenUgn` \ var ->
 214         returnUgn (HsVar var)
 215
 216       U_ap fun arg ->                   -- application
 217         wlkExpr fun     `thenUgn` \ expr1 ->
 218         wlkExpr arg     `thenUgn` \ expr2 ->
 219         returnUgn (HsApp expr1 expr2)
 220
 221       U_infixap fun arg1 arg2 ->        -- infix application
 222         wlkVarId  fun   `thenUgn` \ op    ->
 223         wlkExpr arg1    `thenUgn` \ expr1 ->
 224         wlkExpr arg2    `thenUgn` \ expr2 ->
 225         returnUgn (mkOpApp expr1 op expr2)
 226
 227       U_negate nexp ->                  -- prefix negation
 228         wlkExpr nexp    `thenUgn` \ expr ->
 229         returnUgn (NegApp expr (HsVar dummyRdrVarName))
 230
 231       U_llist llist -> -- explicit list
 232         wlkList rdExpr llist `thenUgn` \ exprs ->
 233         returnUgn (ExplicitList exprs)
 234
 235       U_tuple tuplelist -> -- explicit tuple
 236         wlkList rdExpr tuplelist `thenUgn` \ exprs ->
 237         returnUgn (ExplicitTuple exprs True)
 238
 239       U_utuple tuplelist -> -- explicit tuple
 240         wlkList rdExpr tuplelist `thenUgn` \ exprs ->
 241         returnUgn (ExplicitTuple exprs False)
 242
 243       U_record con rbinds -> -- record construction
 244         wlkDataId  con          `thenUgn` \ rcon     ->
 245         wlkList rdRbind rbinds  `thenUgn` \ recbinds ->
 246         returnUgn (RecordCon rcon recbinds)
 247
 248       U_rupdate updexp updbinds -> -- record update
 249         wlkExpr updexp           `thenUgn` \ aexp ->
 250         wlkList rdRbind updbinds `thenUgn` \ recbinds ->
 251         returnUgn (RecordUpd aexp recbinds)
 252
 253 #ifdef DEBUG
 254       U_hmodule _ _ _ _ _ _   -> error "U_hmodule"
 255       U_as _ _                -> error "U_as"
 256       U_lazyp _               -> error "U_lazyp"
 257       U_qual _ _              -> error "U_qual"
 258       U_guard _               -> error "U_guard"
 259       U_seqlet _              -> error "U_seqlet"
 260       U_dobind _ _ _          -> error "U_dobind"
 261       U_doexp _ _             -> error "U_doexp"
 262       U_rbind _ _             -> error "U_rbind"
 263 #endif
 264
 265 rdRbind pt
 266   = rdU_tree pt         `thenUgn` \ (U_rbind var exp) ->
 267     wlkVarId   var      `thenUgn` \ rvar ->
 268     wlkMaybe rdExpr exp `thenUgn` \ expr_maybe ->
 269     returnUgn (
 270       case expr_maybe of
 271         Nothing -> (rvar, HsVar rvar, True{-pun-})
 272         Just re -> (rvar, re,         False)
 273     )
 274
 275 wlkQuals cquals
 276   = wlkList rd_qual cquals
 277   where
 278           rd_qual pt
 279             = rdU_tree pt       `thenUgn` \ qual ->
 280               wlk_qual qual
 281
 282           wlk_qual qual
 283             = case qual of
 284                 U_guard exp ->
 285                   wlkExpr exp   `thenUgn` \ expr ->
 286                   getSrcLocUgn  `thenUgn` \ loc ->
 287                   returnUgn (GuardStmt expr loc)
 288
 289                 U_qual qpat qexp ->
 290                   wlkPat  qpat  `thenUgn` \ pat  ->
 291                   wlkExpr qexp  `thenUgn` \ expr ->
 292                   getSrcLocUgn  `thenUgn` \ loc ->
 293                   returnUgn (BindStmt pat expr loc)
 294
 295                 U_seqlet seqlet ->
 296                   wlkLocalBinding seqlet        `thenUgn` \ binds ->
 297                   returnUgn (LetStmt binds)
 298
 299                 U_let letvdefs letvexpr ->
 300                     wlkLocalBinding letvdefs    `thenUgn` \ binds ->
 301                     wlkExpr    letvexpr         `thenUgn` \ expr    ->
 302                     getSrcLocUgn                `thenUgn` \ loc ->
 303                     returnUgn (GuardStmt (HsLet binds expr) loc)
 304 \end{code}
 305
 306 Patterns: just bear in mind that lists of patterns are represented as
 307 a series of ``applications''.
 308 \begin{code}
 309 wlkPat pat
 310   = case pat of
 311       U_par ppat ->                     -- parenthesised pattern
 312         wlkPat ppat     `thenUgn` \ pat ->
 313         -- tidy things up a little:
 314         returnUgn (
 315         case pat of
 316           VarPatIn _ -> pat
 317           WildPatIn  -> pat
 318           other      -> ParPatIn pat
 319         )
 320
 321       U_as avar as_pat ->               -- "as" pattern
 322         wlkVarId avar   `thenUgn` \ var ->
 323         wlkPat as_pat   `thenUgn` \ pat ->
 324         returnUgn (AsPatIn var pat)
 325
 326       U_restr pat ty ->
 327         wlkPat pat      `thenUgn` \ pat' ->
 328         wlkHsType ty    `thenUgn` \ ty' ->
 329         returnUgn (SigPatIn pat' ty')
 330
 331       U_lazyp lazyp ->                  -- irrefutable ("twiddle") pattern
 332         wlkPat lazyp    `thenUgn` \ pat ->
 333         returnUgn (LazyPatIn pat)
 334
 335       U_plusp avar lit ->
 336         wlkVarId avar   `thenUgn` \ var ->
 337         wlkLiteral lit  `thenUgn` \ lit ->
 338         returnUgn (NPlusKPatIn var lit)
 339
 340       U_lit lit ->                      -- literal pattern
 341         wlkLiteral lit  `thenUgn` \ lit ->
 342         returnUgn (LitPatIn lit)
 343
 344       U_ident (U_noqual s) | s == SLIT("_")->  returnUgn WildPatIn      -- Wild-card pattern
 345
 346       U_ident nn ->             -- simple identifier
 347         wlkVarId nn     `thenUgn` \ n ->
 348         returnUgn (
 349           if isRdrDataCon n then
 350                 ConPatIn n []
 351           else
 352                 VarPatIn n
 353         )
 354
 355       U_ap l r ->       -- "application": there's a list of patterns lurking here!
 356         wlkPat r                `thenUgn` \ rpat         ->
 357         collect_pats l [rpat]   `thenUgn` \ (lpat,lpats) ->
 358         (case lpat of
 359             VarPatIn x          -> returnUgn (x,  lpats)
 360             ConPatIn x []       -> returnUgn (x,  lpats)
 361             ConOpPatIn x op _ y -> returnUgn (op, x:y:lpats)
 362             _ -> getSrcLocUgn   `thenUgn` \ loc ->
 363                  pprPanic "Illegal pattern `application'"
 364                           (ppr loc <> colon <+> hsep (map ppr (lpat:lpats)))
 365
 366         )                       `thenUgn` \ (n, arg_pats) ->
 367         returnUgn (ConPatIn n arg_pats)
 368         where
 369           collect_pats pat acc
 370             = case pat of
 371                 U_ap l r ->
 372                   wlkPat r      `thenUgn` \ rpat  ->
 373                   collect_pats l (rpat:acc)
 374                 U_par l ->
 375                   collect_pats l acc
 376                 other ->
 377                   wlkPat other  `thenUgn` \ pat ->
 378                   returnUgn (pat,acc)
 379
 380       U_infixap fun arg1 arg2 ->        -- infix pattern
 381         wlkVarId fun    `thenUgn` \ op   ->
 382         wlkPat arg1     `thenUgn` \ pat1 ->
 383         wlkPat arg2     `thenUgn` \ pat2 ->
 384         returnUgn (ConOpPatIn pat1 op (error "ConOpPatIn:fixity") pat2)
 385
 386       U_negate npat ->                  -- negated pattern
 387         wlkPat npat     `thenUgn` \ pat ->
 388         returnUgn (NegPatIn pat)
 389
 390       U_llist llist ->                  -- explicit list
 391         wlkList rdPat llist     `thenUgn` \ pats ->
 392         returnUgn (ListPatIn pats)
 393
 394       U_tuple tuplelist ->              -- explicit tuple
 395         wlkList rdPat tuplelist `thenUgn` \ pats ->
 396         returnUgn (TuplePatIn pats True)
 397
 398       U_utuple tuplelist ->             -- explicit tuple
 399         wlkList rdPat tuplelist `thenUgn` \ pats ->
 400         returnUgn (TuplePatIn pats False)
 401
 402       U_record con rpats ->             -- record destruction
 403         wlkDataId  con          `thenUgn` \ rcon     ->
 404         wlkList rdRpat rpats    `thenUgn` \ recpats ->
 405         returnUgn (RecPatIn rcon recpats)
 406         where
 407           rdRpat pt
 408             = rdU_tree pt        `thenUgn` \ (U_rbind var pat) ->
 409               wlkVarId   var     `thenUgn` \ rvar ->
 410               wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
 411               returnUgn (
 412                 case pat_maybe of
 413                   Nothing -> (rvar, VarPatIn rvar, True{-pun-})
 414                   Just rp -> (rvar, rp,            False)
 415               )
 416 \end{code}
 417
 418 \begin{code}
 419 wlkLiteral :: U_literal -> UgnM HsLit
 420
 421 wlkLiteral ulit
 422   = returnUgn (
 423     case ulit of
 424       U_integer    s -> HsInt        (as_integer  s)
 425       U_floatr     s -> HsFrac       (as_rational s)
 426       U_intprim    s -> HsIntPrim    (as_integer  s)
 427       U_doubleprim s -> HsDoublePrim (as_rational s)
 428       U_floatprim  s -> HsFloatPrim  (as_rational s)
 429       U_charr      s -> HsChar       (as_char     s)
 430       U_charprim   s -> HsCharPrim   (as_char     s)
 431       U_string     s -> HsString     (as_string   s)
 432       U_stringprim s -> HsStringPrim (as_string   s)
 433       U_clitlit    s -> HsLitLit     (as_string   s)
 434     )
 435   where
 436     as_char s     = _HEAD_ s
 437     as_integer s  = readInteger (_UNPK_ s)
 438     as_rational s = readRational__ (_UNPK_ s) -- use non-std readRational__
 439                                               -- to handle rationals with leading '-'
 440     as_string s   = s
 441 \end{code}
 442
 443 %************************************************************************
 444 %*                                                                      *
 445 \subsection{wlkBinding}
 446 %*                                                                      *
 447 %************************************************************************
 448
 449 \begin{code}
 450 wlkLocalBinding bind
 451   = wlkBinding bind     `thenUgn` \ bind' ->
 452     getSrcFileUgn       `thenUgn` \ sf    ->
 453     returnUgn (cvBinds sf cvValSig bind')
 454
 455 wlkBinding :: U_binding -> UgnM RdrBinding
 456
 457 wlkBinding binding
 458   = case binding of
 459         -- null binding
 460       U_nullbind ->
 461         returnUgn RdrNullBind
 462
 463         -- "and" binding (just glue, really)
 464       U_abind a b ->
 465         wlkBinding a    `thenUgn` \ binding1 ->
 466         wlkBinding b    `thenUgn` \ binding2 ->
 467         returnUgn (RdrAndBindings binding1 binding2)
 468
 469         -- fixity declaration
 470       U_fixd op dir_n prec srcline ->
 471         let
 472               dir = case dir_n of
 473                         (-1) -> InfixL
 474                         0    -> InfixN
 475                         1    -> InfixR
 476         in
 477         wlkVarId op             `thenUgn` \ op ->
 478         mkSrcLocUgn srcline     $ \ src_loc ->
 479         returnUgn (RdrSig (FixSig (FixitySig op (Fixity prec dir) src_loc)))
 480
 481
 482         -- "data" declaration
 483       U_tbind tctxt ttype tcons tderivs srcline ->
 484         mkSrcLocUgn        srcline          $ \ src_loc     ->
 485         wlkContext         tctxt    `thenUgn` \ ctxt        ->
 486         wlkConAndTyVars    ttype    `thenUgn` \ (tycon, tyvars) ->
 487         wlkList rdConDecl  tcons    `thenUgn` \ cons        ->
 488         wlkDerivings       tderivs  `thenUgn` \ derivings   ->
 489         returnUgn (RdrHsDecl (TyClD (TyData DataType ctxt tycon tyvars cons
 490                                             derivings noDataPragmas src_loc)))
 491
 492         -- "newtype" declaration
 493       U_ntbind ntctxt nttype ntcon ntderivs srcline ->
 494         mkSrcLocUgn        srcline          $ \ src_loc     ->
 495         wlkContext         ntctxt   `thenUgn` \ ctxt        ->
 496         wlkConAndTyVars    nttype   `thenUgn` \ (tycon, tyvars) ->
 497         wlkList rdConDecl  ntcon    `thenUgn` \ cons        ->
 498         wlkDerivings       ntderivs `thenUgn` \ derivings   ->
 499         returnUgn (RdrHsDecl (TyClD (TyData NewType ctxt tycon tyvars cons
 500                                             derivings noDataPragmas src_loc)))
 501
 502         -- "type" declaration
 503       U_nbind nbindid nbindas srcline ->
 504         mkSrcLocUgn       srcline         $ \ src_loc       ->
 505         wlkConAndTyVars   nbindid `thenUgn` \ (tycon, tyvars) ->
 506         wlkHsType         nbindas `thenUgn` \ expansion     ->
 507         returnUgn (RdrHsDecl (TyClD (TySynonym tycon tyvars expansion src_loc)))
 508
 509         -- function binding
 510       U_fbind fbindm srcline ->
 511         mkSrcLocUgn     srcline         $ \ src_loc ->
 512         wlkList rdMatch fbindm          `thenUgn` \ matches ->
 513         returnUgn (RdrValBinding (mkRdrFunctionBinding matches src_loc))
 514
 515         -- pattern binding
 516       U_pbind pbindl pbindr srcline ->
 517         mkSrcLocUgn srcline             $ \ src_loc ->
 518         rdPat pbindl                    `thenUgn` \ pat ->
 519         rdGRHSs pbindr                  `thenUgn` \ grhss ->
 520         returnUgn (RdrValBinding (PatMonoBind pat grhss src_loc))
 521
 522         -- "class" declaration
 523       U_cbind cbindc cbindid cbindw srcline ->
 524         mkSrcLocUgn      srcline        $ \ src_loc         ->
 525         wlkContext       cbindc  `thenUgn` \ ctxt           ->
 526         wlkConAndTyVars  cbindid `thenUgn` \ (clas, tyvars) ->
 527         wlkBinding       cbindw  `thenUgn` \ binding        ->
 528         getSrcFileUgn            `thenUgn` \ sf             ->
 529         let
 530             (final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding
 531         in
 532         returnUgn (RdrHsDecl (TyClD (mkClassDecl ctxt clas tyvars final_sigs
 533                                                  final_methods noClassPragmas src_loc)))
 534
 535         -- "instance" declaration
 536       U_ibind ty ibindw srcline ->
 537         -- The "ty" contains the instance context too
 538         -- So for "instance Eq a => Eq [a]" the type will be
 539         --      Eq a => Eq [a]
 540         mkSrcLocUgn     srcline         $ \ src_loc ->
 541         wlkInstType       ty            `thenUgn` \ inst_ty    ->
 542         wlkBinding      ibindw          `thenUgn` \ binding ->
 543         getSrcFileUgn                   `thenUgn` \ sf      ->
 544         let
 545             (binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding
 546         in
 547         returnUgn (RdrHsDecl (InstD (InstDecl inst_ty binds uprags
 548                                               dummyRdrVarName {- No dfun id yet -}
 549                                               src_loc)))
 550
 551         -- "default" declaration
 552       U_dbind dbindts srcline ->
 553         mkSrcLocUgn        srcline      $ \ src_loc ->
 554         wlkList rdMonoType dbindts  `thenUgn` \ tys ->
 555         returnUgn (RdrHsDecl (DefD (DefaultDecl tys src_loc)))
 556
 557         -- "foreign" declaration
 558       U_fobind id ty ext_name unsafe_flag cconv imp_exp srcline ->
 559         mkSrcLocUgn        srcline                 $ \ src_loc ->
 560         wlkVarId id                                `thenUgn` \ h_id ->
 561         wlkHsSigType ty                            `thenUgn` \ h_ty ->
 562         wlkExtName ext_name                        `thenUgn` \ h_ext_name ->
 563         rdCallConv cconv                           `thenUgn` \ h_cconv ->
 564         rdForKind imp_exp (cvFlag unsafe_flag)    `thenUgn` \ h_imp_exp ->
 565         returnUgn (RdrHsDecl (ForD (ForeignDecl h_id h_imp_exp h_ty h_ext_name h_cconv src_loc)))
 566
 567       U_sbind sbindids sbindid srcline ->
 568         -- Type signature
 569         mkSrcLocUgn srcline             $ \ src_loc ->
 570         wlkList rdVarId sbindids        `thenUgn` \ vars    ->
 571         wlkHsSigType    sbindid         `thenUgn` \ poly_ty ->
 572         returnUgn (foldr1 RdrAndBindings [RdrSig (Sig var poly_ty src_loc) | var <- vars])
 573
 574       U_vspec_uprag uvar vspec_tys srcline ->
 575         -- value specialisation user-pragma
 576         mkSrcLocUgn srcline             $ \ src_loc ->
 577         wlkVarId uvar                   `thenUgn` \ var ->
 578         wlkList rdHsSigType vspec_tys   `thenUgn` \ tys ->
 579         returnUgn (foldr1 RdrAndBindings [ RdrSig (SpecSig var ty src_loc)
 580                                          | ty <- tys ])
 581
 582       U_ispec_uprag ispec_ty srcline ->
 583         -- instance specialisation user-pragma
 584         mkSrcLocUgn srcline             $ \ src_loc ->
 585         wlkInstType  ispec_ty           `thenUgn` \ ty    ->
 586         returnUgn (RdrSig (SpecInstSig ty src_loc))
 587
 588       U_inline_uprag ivar srcline ->
 589         -- value inlining user-pragma
 590         mkSrcLocUgn     srcline         $ \ src_loc ->
 591         wlkVarId        ivar            `thenUgn` \ var     ->
 592         returnUgn (RdrSig (InlineSig var src_loc))
 593
 594       U_noinline_uprag ivar srcline ->
 595         -- No-inline pragma
 596         mkSrcLocUgn     srcline         $ \ src_loc ->
 597         wlkVarId        ivar            `thenUgn` \ var     ->
 598         returnUgn (RdrSig (NoInlineSig var src_loc))
 599
 600       U_rule_prag name ivars ilhs irhs srcline ->
 601         -- Transforamation rule
 602         mkSrcLocUgn srcline             $ \ src_loc ->
 603         wlkList rdRuleBndr ivars        `thenUgn` \ vars ->
 604         rdExpr ilhs                     `thenUgn` \ lhs ->
 605         rdExpr irhs                     `thenUgn` \ rhs ->
 606         returnUgn (RdrHsDecl (RuleD (RuleDecl name [] vars lhs rhs src_loc)))
 607
 608 mkRdrFunctionBinding :: [RdrNameMatch] -> SrcLoc -> RdrNameMonoBinds
 609 mkRdrFunctionBinding fun_matches src_loc
 610   = FunMonoBind (head fns) (head infs) matches src_loc
 611   where
 612     (fns, infs, matches) = unzip3 (map de_fun_match fun_matches)
 613
 614     de_fun_match (Match _ [ConPatIn fn pats]      sig grhss) = (fn, False, Match [] pats    sig grhss)
 615     de_fun_match (Match _ [ConOpPatIn p1 fn _ p2] sig grhss) = (fn, True,  Match [] [p1,p2] sig grhss)
 616
 617
 618 rdRuleBndr :: ParseTree -> UgnM RdrNameRuleBndr
 619 rdRuleBndr pt = rdU_rulevar pt  `thenUgn` wlkRuleBndr
 620
 621 wlkRuleBndr :: U_rulevar -> UgnM RdrNameRuleBndr
 622 wlkRuleBndr (U_prulevar v)
 623   = returnUgn (RuleBndr (mkSrcUnqual varName v))
 624 wlkRuleBndr (U_prulevarsig v ty)
 625   = wlkHsType ty        `thenUgn` \ ty'  ->
 626     returnUgn (RuleBndrSig (mkSrcUnqual varName v) ty')
 627
 628
 629
 630 rdGRHSs :: ParseTree -> UgnM RdrNameGRHSs
 631 rdGRHSs pt = rdU_grhsb pt `thenUgn` wlkGRHSs
 632
 633 wlkGRHSs :: U_grhsb -> UgnM RdrNameGRHSs
 634 wlkGRHSs (U_pguards rhss bind)
 635   = wlkList rdGdExp rhss        `thenUgn` \ gdexps ->
 636     wlkLocalBinding bind        `thenUgn` \ bind' ->
 637     returnUgn (GRHSs gdexps bind' Nothing)
 638 wlkGRHSs (U_pnoguards srcline rhs bind)
 639   = mkSrcLocUgn srcline         $ \ src_loc ->
 640     rdExpr rhs                  `thenUgn` \ rhs' ->
 641     wlkLocalBinding bind        `thenUgn` \ bind' ->
 642     returnUgn (GRHSs (unguardedRHS rhs' src_loc) bind' Nothing)
 643
 644
 645 rdGdExp :: ParseTree -> UgnM RdrNameGRHS
 646 rdGdExp pt = rdU_gdexp pt               `thenUgn` \ (U_pgdexp guards srcline rhs) ->
 647              wlkQuals guards            `thenUgn` \ guards' ->
 648              mkSrcLocUgn srcline        $ \ src_loc ->
 649              wlkExpr rhs                `thenUgn` \ expr'  ->
 650              returnUgn (GRHS (guards' ++ [ExprStmt expr' src_loc]) src_loc)
 651 \end{code}
 652
 653 \begin{code}
 654 wlkDerivings :: U_maybe -> UgnM (Maybe [RdrName])
 655
 656 wlkDerivings (U_nothing) = returnUgn Nothing
 657 wlkDerivings (U_just pt)
 658   = rdU_list pt          `thenUgn` \ ds     ->
 659     wlkList rdTCId ds    `thenUgn` \ derivs ->
 660     returnUgn (Just derivs)
 661 \end{code}
 662
 663 %************************************************************************
 664 %*                                                                      *
 665 \subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
 666 %*                                                                      *
 667 %************************************************************************
 668
 669 \begin{code}
 670 rdHsSigType :: ParseTree -> UgnM RdrNameHsType
 671 rdHsType    :: ParseTree -> UgnM RdrNameHsType
 672 rdMonoType  :: ParseTree -> UgnM RdrNameHsType
 673
 674 rdHsSigType pt = rdU_ttype pt `thenUgn` wlkHsSigType
 675 rdHsType    pt = rdU_ttype pt `thenUgn` wlkHsType
 676 rdMonoType  pt = rdU_ttype pt `thenUgn` wlkHsType
 677
 678 wlkHsConstrArgType ttype
 679         -- Used for the argument types of contructors
 680         -- Only an implicit quantification point if -fglasgow-exts
 681   | opt_GlasgowExts = wlkHsSigType ttype
 682   | otherwise       = wlkHsType    ttype
 683
 684         -- wlkHsSigType is used for type signatures: any place there
 685         -- should be *implicit* quantification
 686 wlkHsSigType ttype
 687   = wlkHsType ttype     `thenUgn` \ ty ->
 688         -- This is an implicit quantification point, so
 689         -- make sure it starts with a ForAll
 690     case ty of
 691         HsForAllTy _ _ _ -> returnUgn ty
 692         other            -> returnUgn (HsForAllTy Nothing [] ty)
 693
 694 wlkHsType :: U_ttype -> UgnM RdrNameHsType
 695 wlkHsType ttype
 696   = case ttype of
 697       U_forall u_tyvars u_theta u_ty -> -- Explicit forall
 698         wlkList rdTvId u_tyvars         `thenUgn` \ tyvars ->
 699         wlkContext u_theta              `thenUgn` \ theta ->
 700         wlkHsType u_ty                  `thenUgn` \ ty   ->
 701         returnUgn (HsForAllTy (Just (map UserTyVar tyvars)) theta ty)
 702
 703       U_imp_forall u_theta u_ty ->      -- Implicit forall
 704         wlkContext u_theta              `thenUgn` \ theta ->
 705         wlkHsType u_ty                  `thenUgn` \ ty   ->
 706         returnUgn (HsForAllTy Nothing theta ty)
 707
 708       U_namedtvar tv -> -- type variable
 709         wlkTvId tv      `thenUgn` \ tyvar ->
 710         returnUgn (MonoTyVar tyvar)
 711
 712       U_tname tcon -> -- type constructor
 713         wlkTcId tcon    `thenUgn` \ tycon ->
 714         returnUgn (MonoTyVar tycon)
 715
 716       U_tapp t1 t2 ->
 717         wlkHsType t1            `thenUgn` \ ty1 ->
 718         wlkHsType t2            `thenUgn` \ ty2 ->
 719         returnUgn (MonoTyApp ty1 ty2)
 720
 721       U_tllist tlist -> -- list type
 722         wlkHsType tlist `thenUgn` \ ty ->
 723         returnUgn (MonoListTy ty)
 724
 725       U_ttuple ttuple ->
 726         wlkList rdMonoType ttuple `thenUgn` \ tys ->
 727         returnUgn (MonoTupleTy tys True)
 728
 729       U_tutuple ttuple ->
 730         wlkList rdMonoType ttuple `thenUgn` \ tys ->
 731         returnUgn (MonoTupleTy tys False)
 732
 733       U_tfun tfun targ ->
 734         wlkHsType tfun  `thenUgn` \ ty1 ->
 735         wlkHsType targ  `thenUgn` \ ty2 ->
 736         returnUgn (MonoFunTy ty1 ty2)
 737
 738 wlkInstType ttype
 739   = case ttype of
 740       U_forall u_tyvars u_theta inst_head ->
 741         wlkList rdTvId u_tyvars         `thenUgn` \ tyvars ->
 742         wlkContext  u_theta             `thenUgn` \ theta ->
 743         wlkClsTys inst_head             `thenUgn` \ (clas, tys)  ->
 744         returnUgn (HsForAllTy (Just (map UserTyVar tyvars)) theta (MonoDictTy clas tys))
 745
 746       U_imp_forall u_theta inst_head ->
 747         wlkContext  u_theta             `thenUgn` \ theta ->
 748         wlkClsTys inst_head             `thenUgn` \ (clas, tys)  ->
 749         returnUgn (HsForAllTy Nothing theta (MonoDictTy clas tys))
 750
 751       other -> -- something else
 752         wlkClsTys other   `thenUgn` \ (clas, tys) ->
 753         returnUgn (HsForAllTy Nothing [] (MonoDictTy clas tys))
 754 \end{code}
 755
 756 \begin{code}
 757 wlkConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
 758 wlkConAndTyVars ttype
 759   = wlkHsType ttype     `thenUgn` \ ty ->
 760     let
 761         split (MonoTyApp fun (MonoTyVar arg)) args = split fun (UserTyVar arg : args)
 762         split (MonoTyVar tycon)               args = (tycon,args)
 763         split other                           args = pprPanic "ERROR: malformed type: "
 764                                                      (ppr other)
 765     in
 766     returnUgn (split ty [])
 767
 768
 769 wlkContext :: U_list  -> UgnM RdrNameContext
 770 rdClsTys   :: ParseTree -> UgnM (RdrName, [HsType RdrName])
 771
 772 wlkContext list = wlkList rdClsTys list
 773
 774 rdClsTys pt = rdU_ttype pt `thenUgn` wlkClsTys
 775
 776 wlkClsTys ttype
 777   = go ttype []
 778   where
 779     go (U_tname tcon) tys = wlkClsId tcon       `thenUgn` \ cls ->
 780                             returnUgn (cls, tys)
 781
 782     go (U_tapp t1 t2) tys = wlkHsType t2                `thenUgn` \ ty2 ->
 783                             go t1 (ty2 : tys)
 784 \end{code}
 785
 786 \begin{code}
 787 rdConDecl :: ParseTree -> UgnM RdrNameConDecl
 788 rdConDecl pt = rdU_constr pt    `thenUgn` wlkConDecl
 789
 790 wlkConDecl :: U_constr -> UgnM RdrNameConDecl
 791
 792 wlkConDecl (U_constrex u_tvs ccxt ccdecl)
 793   = wlkList rdTvId u_tvs        `thenUgn` \ tyvars ->
 794     wlkContext ccxt             `thenUgn` \ theta ->
 795     wlkConDecl ccdecl           `thenUgn` \ (ConDecl con _ _ details loc) ->
 796     returnUgn (ConDecl con (map UserTyVar tyvars) theta details loc)
 797
 798 wlkConDecl (U_constrpre ccon ctys srcline)
 799   = mkSrcLocUgn srcline                 $ \ src_loc ->
 800     wlkDataId   ccon            `thenUgn` \ con     ->
 801     wlkList     rdBangType ctys `thenUgn` \ tys     ->
 802     returnUgn (ConDecl con [] [] (VanillaCon tys) src_loc)
 803
 804 wlkConDecl (U_constrinf cty1 cop cty2 srcline)
 805   = mkSrcLocUgn srcline                 $ \ src_loc ->
 806     wlkBangType cty1            `thenUgn` \ ty1     ->
 807     wlkDataId   cop             `thenUgn` \ op      ->
 808     wlkBangType cty2            `thenUgn` \ ty2     ->
 809     returnUgn (ConDecl op [] [] (InfixCon ty1 ty2) src_loc)
 810
 811 wlkConDecl (U_constrnew ccon cty mb_lab srcline)
 812   = mkSrcLocUgn srcline                  $ \ src_loc ->
 813     wlkDataId   ccon             `thenUgn` \ con            ->
 814     wlkHsSigType cty             `thenUgn` \ ty     ->
 815     wlkMaybe     rdVarId  mb_lab `thenUgn` \ mb_lab  ->
 816     returnUgn (ConDecl con [] [] (NewCon ty mb_lab) src_loc)
 817
 818 wlkConDecl (U_constrrec ccon cfields srcline)
 819   = mkSrcLocUgn srcline                 $ \ src_loc      ->
 820     wlkDataId   ccon            `thenUgn` \ con          ->
 821     wlkList rd_field cfields    `thenUgn` \ fields_lists ->
 822     returnUgn (ConDecl con [] [] (RecCon fields_lists) src_loc)
 823    where
 824     rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
 825     rd_field pt =
 826       rdU_constr pt             `thenUgn` \ (U_field fvars fty) ->
 827       wlkList rdVarId   fvars   `thenUgn` \ vars ->
 828       wlkBangType fty           `thenUgn` \ ty ->
 829       returnUgn (vars, ty)
 830
 831 -----------------
 832 rdBangType pt = rdU_ttype pt `thenUgn` wlkBangType
 833
 834 wlkBangType :: U_ttype -> UgnM (BangType RdrName)
 835
 836 wlkBangType (U_tbang bty) = wlkHsConstrArgType bty      `thenUgn` \ ty ->
 837                             returnUgn (Banged   ty)
 838 wlkBangType uty           = wlkHsConstrArgType uty      `thenUgn` \ ty ->
 839                             returnUgn (Unbanged ty)
 840 \end{code}
 841
 842 %************************************************************************
 843 %*                                                                      *
 844 \subsection{Read a ``match''}
 845 %*                                                                      *
 846 %************************************************************************
 847
 848 \begin{code}
 849 rdMatch :: ParseTree -> UgnM RdrNameMatch
 850 rdMatch pt = rdU_match pt `thenUgn` wlkMatch
 851
 852 wlkMatch :: U_match -> UgnM RdrNameMatch
 853 wlkMatch (U_pmatch pats sig grhsb)
 854   = wlkList rdPat pats          `thenUgn` \ pats'   ->
 855     wlkMaybe rdHsType sig       `thenUgn` \ maybe_ty ->
 856     wlkGRHSs grhsb              `thenUgn` \ grhss' ->
 857     returnUgn (Match [] pats' maybe_ty grhss')
 858 \end{code}
 859
 860 %************************************************************************
 861 %*                                                                      *
 862 \subsection[rdImport]{Read an import decl}
 863 %*                                                                      *
 864 %************************************************************************
 865
 866 \begin{code}
 867 rdImport :: ParseTree
 868          -> UgnM RdrNameImportDecl
 869
 870 rdImport pt
 871   = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec isrc srcline) ->
 872     mkSrcLocUgn srcline                         $ \ src_loc      ->
 873     wlkMaybe rdU_stringId ias           `thenUgn` \ maybe_as    ->
 874     wlkMaybe rd_spec ispec              `thenUgn` \ maybe_spec  ->
 875     returnUgn (ImportDecl (mkSrcModuleFS imod)
 876                           (cvImportSource isrc)
 877                           (cvFlag iqual)
 878                           (case maybe_as of { Just m -> Just (mkSrcModuleFS m); Nothing -> Nothing })
 879                           maybe_spec src_loc)
 880   where
 881     rd_spec pt = rdU_either pt          `thenUgn` \ spec ->
 882       case spec of
 883         U_left pt  -> rdEntities pt     `thenUgn` \ ents ->
 884                       returnUgn (False, ents)
 885         U_right pt -> rdEntities pt     `thenUgn` \ ents ->
 886                       returnUgn (True, ents)
 887
 888 cvImportSource 0 = ImportByUser                 -- No pragam
 889 cvImportSource 1 = ImportByUserSource           -- {-# SOURCE #-}
 890 \end{code}
 891
 892 \begin{code}
 893 rdEntities pt = rdU_list pt `thenUgn` wlkList rdEntity
 894
 895 rdEntity :: ParseTree -> UgnM (IE RdrName)
 896
 897 rdEntity pt
 898   = rdU_entidt pt `thenUgn` \ entity ->
 899     case entity of
 900       U_entid evar ->           -- just a value
 901         wlkEntId evar           `thenUgn` \ var ->
 902         returnUgn (IEVar var)
 903
 904       U_enttype x ->            -- abstract type constructor/class
 905         wlkTcClsId x            `thenUgn` \ thing ->
 906         returnUgn (IEThingAbs thing)
 907
 908       U_enttypeall x ->         -- non-abstract type constructor/class
 909         wlkTcClsId x            `thenUgn` \ thing ->
 910         returnUgn (IEThingAll thing)
 911
 912       U_enttypenamed x ns ->    -- non-abstract type constructor/class
 913                                 -- with specified constrs/methods
 914         wlkTcClsId x            `thenUgn` \ thing ->
 915         wlkList rdVarId ns      `thenUgn` \ names ->
 916         returnUgn (IEThingWith thing names)
 917
 918       U_entmod mod ->           -- everything provided unqualified by a module
 919         returnUgn (IEModuleContents (mkSrcModuleFS mod))
 920 \end{code}
 921
 922
 923 %************************************************************************
 924 %*                                                                      *
 925 \subsection[rdExtName]{Read an external name}
 926 %*                                                                      *
 927 %************************************************************************
 928
 929 \begin{code}
 930 wlkExtName :: U_maybe -> UgnM ExtName
 931 wlkExtName (U_nothing) = returnUgn Dynamic
 932 wlkExtName (U_just pt)
 933   = rdU_list pt             `thenUgn` \ ds ->
 934     wlkList rdU_hstring ds  `thenUgn` \ ss ->
 935     case ss of
 936       [nm]     -> returnUgn (ExtName nm Nothing)
 937       [mod,nm] -> returnUgn (ExtName nm (Just mod))
 938
 939 rdCallConv :: Int -> UgnM CallConv
 940 rdCallConv x =
 941    -- this tracks the #defines in parser/utils.h
 942   case x of
 943     (-1) -> -- no calling convention specified, use default.
 944           returnUgn defaultCallConv
 945     _    -> returnUgn x
 946
 947 rdForKind :: Int -> Bool -> UgnM ForKind
 948 rdForKind 0 isUnsafe = -- foreign import
 949   returnUgn (FoImport isUnsafe)
 950 rdForKind 1 _ = -- foreign export
 951   returnUgn FoExport
 952 rdForKind 2 _ = -- foreign label
 953   returnUgn FoLabel
 954
 955 \end{code}
 956
 957 %************************************************************************
 958 %*                                                                      *
 959 \subsection[ReadPrefix-help]{Help Functions}
 960 %*                                                                      *
 961 %************************************************************************
 962
 963 \begin{code}
 964 wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a]
 965
 966 wlkList wlk_it U_lnil = returnUgn []
 967
 968 wlkList wlk_it (U_lcons hd tl)
 969   = wlk_it  hd          `thenUgn` \ hd_it ->
 970     wlkList wlk_it tl   `thenUgn` \ tl_it ->
 971     returnUgn (hd_it : tl_it)
 972 \end{code}
 973
 974 \begin{code}
 975 wlkMaybe :: (U_VOID_STAR -> UgnM a) -> U_maybe -> UgnM (Maybe a)
 976
 977 wlkMaybe wlk_it U_nothing  = returnUgn Nothing
 978 wlkMaybe wlk_it (U_just x)
 979   = wlk_it  x           `thenUgn` \ it ->
 980     returnUgn (Just it)
 981 \end{code}
 982
 983 \begin{code}
 984 wlkTcClsId = wlkQid (\_ -> tcClsName)
 985 wlkTcId    = wlkQid (\_ -> tcName)
 986 wlkClsId   = wlkQid (\_ -> clsName)
 987 wlkVarId   = wlkQid (\occ -> if isLexCon occ
 988                              then dataName
 989                              else varName)
 990 wlkDataId  = wlkQid (\_ -> dataName)
 991 wlkEntId   = wlkQid (\occ -> if isLexCon occ
 992                              then tcClsName
 993                              else varName)
 994
 995 wlkQid  :: (FAST_STRING -> NameSpace) -> U_qid -> UgnM RdrName
 996
 997 -- There are three kinds of qid:
 998 --      qualified name (aqual)          A.x
 999 --      unqualified name (noqual)       x
1000 --      special name (gid)              [], (), ->, (,,,)
1001 -- The special names always mean "Prelude.whatever"; that's why
1002 -- they are distinct.  So if you write "()", it's just as if  you
1003 -- had written "Prelude.()".
1004 -- NB: The (qualified) prelude is always in scope, so the renamer will find it.
1005
1006 -- EXCEPT: when we're compiling with -fno-implicit-prelude, in which
1007 -- case we need to unqualify these things. -- SDM.
1008
1009 wlkQid mk_name_space (U_noqual name)
1010   = returnUgn (mkSrcUnqual (mk_name_space name) name)
1011 wlkQid mk_name_space (U_aqual  mod name)
1012   = returnUgn (mkSrcQual (mk_name_space name) mod name)
1013 wlkQid mk_name_space (U_gid n name)     -- Built in Prelude things
1014   | opt_NoImplicitPrelude
1015   = returnUgn (mkSrcUnqual (mk_name_space name) name)
1016   | otherwise
1017   = returnUgn (mkPreludeQual (mk_name_space name) pRELUDE_Name name)
1018
1019
1020 rdTCId  pt = rdU_qid pt `thenUgn` wlkTcId
1021 rdVarId pt = rdU_qid pt `thenUgn` wlkVarId
1022
1023 rdTvId  pt = rdU_stringId pt `thenUgn` \ string -> wlkTvId string
1024 wlkTvId string = returnUgn (mkSrcUnqual tvName string)
1025
1026 -- Unqualified variables, used in the 'forall' of a RULE
1027 rdUVarId  pt = rdU_stringId pt `thenUgn` \ string -> wlkUVarId string
1028 wlkUVarId string = returnUgn (mkSrcUnqual varName string)
1029
1030 cvFlag :: U_long -> Bool
1031 cvFlag 0 = False
1032 cvFlag 1 = True
1033 \end{code}
1034