ghc/compiler/reader/ReadPragmas.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
   3 %
   4 \section{Read pragmatic interface info, including Core}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module ReadPragmas (
  10         ProtoUfBinder(..),
  11
  12         wlkClassPragma,
  13         wlkDataPragma,
  14         wlkInstPragma,
  15         wlkTySigPragmas
  16     ) where
  17
  18 import Ubiq{-uitous-}
  19
  20 import RdrLoop  -- break dependency loop
  21
  22 import UgenAll          -- all Yacc parser gumpff...
  23 import PrefixSyn        -- and various syntaxen.
  24 import HsSyn
  25 import RdrHsSyn
  26 import HsPragmas        -- NB: we are concerned with grimy
  27 import HsCore           -- *Pragmas and *Core stuff here
  28
  29 -- others:
  30 import CoreUnfold       ( UnfoldingGuidance(..) )
  31 import Id               ( mkTupleCon )
  32 import IdInfo
  33 import IdUtils          ( primOpNameInfo )
  34 import Literal          ( mkMachInt, Literal(..) )
  35 import Name             ( Name(..) )
  36 import PrelInfo         ( nilDataCon )
  37 import PrimOp           ( PrimOp(..), allThePrimOps )
  38 import PrimRep          ( guessPrimRep ) -- really, VERY horrible...
  39 import ProtoName        ( ProtoName(..) )
  40 import Util             ( assertPanic, panic )
  41 \end{code}
  42
  43 Only used here:
  44 \begin{code}
  45 readUnfoldingPrimOp :: FAST_STRING -> PrimOp
  46
  47 readUnfoldingPrimOp
  48   = let
  49         -- "reverse" lookup table
  50         tbl = map (\ o -> let { (str,_) = primOpNameInfo o } in (str, o)) allThePrimOps
  51     in
  52     \ str -> case [ op | (s, op) <- tbl, s == str ] of
  53                (op:_) -> op
  54 #ifdef DEBUG
  55                [] -> panic "readUnfoldingPrimOp" -- ++ _UNPK_ str ++"::"++show (map fst tbl))
  56 #endif
  57 \end{code}
  58
  59 \begin{code}
  60 wlkDataPragma :: U_hpragma -> UgnM ProtoNameDataPragmas
  61
  62 wlkDataPragma pragma
  63   = case pragma of
  64       U_no_pragma    -> returnUgn (DataPragmas [] [])
  65       U_idata_pragma cs ss ->
  66         wlkList rdConDecl cs `thenUgn` \ cons  ->
  67         wlkList rd_spec   ss `thenUgn` \ specs ->
  68         returnUgn (DataPragmas cons specs)
  69   where
  70     rd_spec pt
  71       = rdU_hpragma pt  `thenUgn` \ stuff ->
  72         case stuff of { U_idata_pragma_4s ss ->
  73
  74         wlkList rdMonoTypeMaybe ss `thenUgn` \ specs ->
  75         returnUgn specs }
  76 \end{code}
  77
  78 \begin{code}
  79 wlkClassPragma :: U_hpragma -> UgnM ProtoNameClassPragmas
  80
  81 wlkClassPragma pragma
  82   = case pragma of
  83       U_no_pragma    -> returnUgn NoClassPragmas
  84       U_iclas_pragma gens ->
  85         wlkList rdGenPragma gens `thenUgn` \ gen_pragmas ->
  86         ASSERT(not (null gen_pragmas))
  87         returnUgn (SuperDictPragmas gen_pragmas)
  88 \end{code}
  89
  90 \begin{code}
  91 wlkInstPragma :: U_hpragma -> UgnM ProtoNameInstancePragmas
  92
  93 wlkInstPragma pragma
  94   = case pragma of
  95       U_no_pragma ->
  96         returnUgn NoInstancePragmas
  97
  98       U_iinst_simpl_pragma dfun_gen ->
  99         wlkGenPragma dfun_gen   `thenUgn` \ gen_pragmas ->
 100         returnUgn (SimpleInstancePragma gen_pragmas)
 101
 102       U_iinst_const_pragma dfun_gen constm_stuff ->
 103         wlkGenPragma      dfun_gen     `thenUgn` \ gen_pragma    ->
 104         wlkList rd_constm constm_stuff `thenUgn` \ constm_pragmas ->
 105         returnUgn (ConstantInstancePragma gen_pragma constm_pragmas)
 106
 107 rd_constm pt
 108   = rdU_hpragma pt  `thenUgn` \ stuff ->
 109     case stuff of { U_iname_pragma_pr name gen ->
 110
 111     wlkGenPragma gen `thenUgn` \ prag ->
 112     returnUgn (name, prag) }
 113 \end{code}
 114
 115 \begin{code}
 116 rdGenPragma :: ParseTree -> UgnM ProtoNameGenPragmas
 117
 118 rdGenPragma pt = rdU_hpragma pt `thenUgn` \ prag -> wlkGenPragma prag
 119
 120 wlkGenPragma :: U_hpragma -> UgnM ProtoNameGenPragmas
 121
 122 wlkGenPragma pragma
 123   = case pragma of
 124       U_no_pragma -> returnUgn noGenPragmas
 125
 126       U_igen_pragma aritee update deforest strct uf speccs ->
 127         wlk_arity       aritee   `thenUgn` \ arity   ->
 128         wlk_update      update   `thenUgn` \ upd     ->
 129         wlk_deforest    deforest `thenUgn` \ def     ->
 130         wlk_strict      strct    `thenUgn` \ strict  ->
 131         wlk_unfold      uf       `thenUgn` \ unfold  ->
 132         wlkList rd_spec speccs   `thenUgn` \ specs   ->
 133         returnUgn (GenPragmas arity upd def strict unfold specs)
 134   where
 135     wlk_arity stuff
 136       = case stuff of
 137           U_no_pragma -> returnUgn Nothing
 138           U_iarity_pragma arity ->
 139             returnUgn (Just arity)
 140
 141     ------------
 142     wlk_update stuff
 143       = case stuff of
 144           U_no_pragma -> returnUgn Nothing
 145           U_iupdate_pragma upd_spec ->
 146             returnUgn (Just ((read (_UNPK_ upd_spec))::UpdateInfo))
 147
 148     ------------
 149     wlk_deforest stuff
 150       = case stuff of
 151           U_no_pragma -> returnUgn Don'tDeforest
 152           U_ideforest_pragma -> returnUgn DoDeforest
 153
 154     ------------
 155     wlk_unfold stuff
 156       = case stuff of
 157           U_no_pragma -> returnUgn NoImpUnfolding
 158
 159           U_imagic_unfolding_pragma magic ->
 160             returnUgn (ImpMagicUnfolding magic)
 161
 162           U_iunfolding_pragma guide core ->
 163             wlkGuidance guide   `thenUgn` \ guidance ->
 164             wlkCoreExpr core    `thenUgn` \ coresyn  ->
 165             returnUgn (ImpUnfolding guidance coresyn)
 166
 167     ------------
 168     wlk_strict stuff
 169       = case stuff of
 170           U_no_pragma -> returnUgn NoImpStrictness
 171
 172           U_istrictness_pragma strict_spec wrkr_stuff ->
 173             wlkGenPragma wrkr_stuff  `thenUgn` \ wrkr_pragma ->
 174             let
 175                 strict_spec_str = _UNPK_ strict_spec
 176                 (is_bot, ww_strict_info)
 177                   = if (strict_spec_str == "B")
 178                     then (True,  [])
 179                     else (False, (read strict_spec_str)::[Demand])
 180             in
 181             returnUgn (ImpStrictness is_bot ww_strict_info wrkr_pragma)
 182
 183     ------------
 184     rd_spec pt
 185       = rdU_hpragma pt  `thenUgn` \ stuff ->
 186         case stuff of { U_itype_pragma_pr maybe_tys num_dicts prag ->
 187
 188         wlkList rdMonoTypeMaybe maybe_tys `thenUgn` \ mono_tys_maybe ->
 189         wlkGenPragma            prag      `thenUgn` \ gen_prag       ->
 190         returnUgn (mono_tys_maybe, num_dicts, gen_prag) }
 191 \end{code}
 192
 193 The only tricky case is pragmas on signatures; we have no way of
 194 knowing whether it is a @GenPragma@ or a @ClassOp@ pragma.  So we read
 195 whatever comes, store it in a @RdrTySigPragmas@ structure, and someone
 196 will sort it out later.
 197 \begin{code}
 198 wlkTySigPragmas :: U_hpragma -> UgnM RdrTySigPragmas
 199
 200 wlkTySigPragmas pragma
 201   = case pragma of
 202       U_no_pragma -> returnUgn RdrNoPragma
 203
 204       U_iclasop_pragma dsel defm ->
 205         wlkGenPragma dsel   `thenUgn` \ dsel_pragma ->
 206         wlkGenPragma defm   `thenUgn` \ defm_pragma ->
 207         returnUgn (RdrClassOpPragmas (ClassOpPragmas dsel_pragma defm_pragma))
 208
 209       other ->
 210         wlkGenPragma other  `thenUgn` \ gen_pragmas ->
 211         returnUgn (RdrGenPragmas gen_pragmas)
 212 \end{code}
 213
 214 \begin{code}
 215 wlkGuidance guide
 216   = case guide of
 217       U_iunfold_always -> returnUgn UnfoldAlways
 218
 219       U_iunfold_if_args num_ty_args num_val_args con_arg_spec size ->
 220         let
 221             con_arg_info = take num_val_args (map cvt (_UNPK_ con_arg_spec))
 222             -- if there were 0 args, we want to throw away
 223             -- any dummy con_arg_spec stuff...
 224         in
 225         returnUgn (UnfoldIfGoodArgs num_ty_args num_val_args
 226                     con_arg_info size)
 227         where
 228           cvt 'C' = True  -- want a constructor in this arg position
 229           cvt _   = False
 230 \end{code}
 231
 232 \begin{code}
 233 wlkCoreExpr :: U_coresyn -> UgnM ProtoNameUnfoldingCoreExpr
 234
 235 wlkCoreExpr core_expr
 236   = case core_expr of
 237       U_covar v ->
 238         wlkCoreId  v    `thenUgn` \ var ->
 239         returnUgn (UfVar var)
 240
 241       U_coliteral l ->
 242         wlkBasicLit l   `thenUgn` \ lit ->
 243         returnUgn (UfLit lit)
 244
 245       U_cocon c ts as ->
 246         wlkCoreId c             `thenUgn` \ (BoringUfId con) ->
 247         wlkList rdCoreType ts   `thenUgn` \ tys ->
 248         wlkList rdCoreAtom as   `thenUgn` \ vs  ->
 249         returnUgn (UfCon con tys vs)
 250
 251       U_coprim o ts as ->
 252         wlk_primop         o    `thenUgn` \ op  ->
 253         wlkList rdCoreType ts   `thenUgn` \ tys ->
 254         wlkList rdCoreAtom as   `thenUgn` \ vs  ->
 255         let
 256             fixed_vs = case op of { UfOtherOp pop -> fixup pop vs ; _ -> vs }
 257         in
 258         returnUgn (UfPrim op tys fixed_vs)
 259        where
 260
 261         -- Question: why did ccall once panic if you looked at the
 262         -- maygc flag?  Was this just laziness or is it not needed?
 263         -- In that case, modify the stuff that writes them to pragmas
 264         -- so that it never adds the _GC_ tag. ADR
 265
 266         wlk_primop op
 267           = case op of
 268               U_co_primop op_str ->
 269                 returnUgn (UfOtherOp (readUnfoldingPrimOp op_str))
 270
 271               U_co_ccall fun_str may_gc a_tys r_ty ->
 272                 wlkList rdCoreType a_tys `thenUgn` \ arg_tys ->
 273                 wlkCoreType        r_ty  `thenUgn` \ res_ty  ->
 274                 returnUgn (UfCCallOp fun_str False (is_T_or_F may_gc) arg_tys res_ty)
 275
 276               U_co_casm litlit may_gc a_tys r_ty ->
 277                 wlkBasicLit         litlit  `thenUgn` \ (MachLitLit casm_str _) ->
 278                 wlkList rdCoreType  a_tys   `thenUgn` \ arg_tys     ->
 279                 wlkCoreType         r_ty    `thenUgn` \ res_ty      ->
 280                 returnUgn (UfCCallOp casm_str True (is_T_or_F may_gc) arg_tys res_ty)
 281           where
 282             is_T_or_F 0 = False
 283             is_T_or_F _ = True
 284
 285         -- Now *this* is a hack: we can't distinguish Int# literals
 286         -- from Word# literals as they come in; this is only likely
 287         -- to bite on the args of certain PrimOps (shifts, etc); so
 288         -- we look for those and fix things up!!! (WDP 95/05)
 289
 290         fixup AndOp    [a1, a2] = [fixarg a1, fixarg a2]
 291         fixup OrOp     [a1, a2] = [fixarg a1, fixarg a2]
 292         fixup NotOp    [a1]     = [fixarg a1]
 293         fixup SllOp    [a1, a2] = [fixarg a1, a2]
 294         fixup SraOp    [a1, a2] = [fixarg a1, a2]
 295         fixup SrlOp    [a1, a2] = [fixarg a1, a2]
 296         fixup WordGtOp [a1, a2] = [fixarg a1, fixarg a2]
 297         fixup WordGeOp [a1, a2] = [fixarg a1, fixarg a2]
 298         fixup WordLtOp [a1, a2] = [fixarg a1, fixarg a2]
 299         fixup WordLeOp [a1, a2] = [fixarg a1, fixarg a2]
 300         fixup WordEqOp [a1, a2] = [fixarg a1, fixarg a2]
 301         fixup WordNeOp [a1, a2] = [fixarg a1, fixarg a2]
 302         fixup _        as       = as
 303
 304         fixarg (UfCoLitAtom (MachInt i _)) = UfCoLitAtom (MachInt i False{-unsigned-})
 305         fixarg arg                         = arg
 306
 307       U_colam vars expr ->
 308         wlkList rdCoreBinder vars   `thenUgn` \ bs   ->
 309         wlkCoreExpr          expr   `thenUgn` \ body ->
 310         returnUgn (foldr UfLam body bs)
 311
 312       U_coapp f as ->
 313         wlkCoreExpr        f    `thenUgn` \ fun  ->
 314         wlkList rdCoreAtom as   `thenUgn` \ args ->
 315         returnUgn (foldl UfApp fun args)
 316
 317       U_cocase s as ->
 318         wlkCoreExpr s       `thenUgn` \ scrut ->
 319         wlk_alts    as      `thenUgn` \ alts  ->
 320         returnUgn (UfCase scrut alts)
 321        where
 322         wlk_alts (U_coalg_alts as d)
 323           = wlkList rd_alg_alt as   `thenUgn` \ alts  ->
 324             wlk_deflt          d    `thenUgn` \ deflt ->
 325             returnUgn (UfCoAlgAlts alts deflt)
 326           where
 327             rd_alg_alt pt
 328               = rdU_coresyn pt  `thenUgn` \ (U_coalg_alt c bs exp) ->
 329
 330                 wlkCoreId            c   `thenUgn` \ (BoringUfId con) ->
 331                 wlkList rdCoreBinder bs  `thenUgn` \ params           ->
 332                 wlkCoreExpr          exp `thenUgn` \ rhs              ->
 333                 returnUgn (con, params, rhs)
 334
 335         wlk_alts (U_coprim_alts as d)
 336           = wlkList rd_prim_alt as  `thenUgn` \ alts  ->
 337             wlk_deflt           d   `thenUgn` \ deflt ->
 338             returnUgn (UfCoPrimAlts alts deflt)
 339           where
 340             rd_prim_alt pt
 341               = rdU_coresyn pt  `thenUgn` \ (U_coprim_alt l exp) ->
 342
 343                 wlkBasicLit l   `thenUgn` \ lit ->
 344                 wlkCoreExpr exp `thenUgn` \ rhs ->
 345                 returnUgn (lit, rhs)
 346
 347         wlk_deflt U_conodeflt = returnUgn UfCoNoDefault
 348         wlk_deflt (U_cobinddeflt v exp)
 349           = wlkCoreBinder v     `thenUgn` \ b   ->
 350             wlkCoreExpr   exp   `thenUgn` \ rhs ->
 351             returnUgn (UfCoBindDefault b rhs)
 352
 353       U_colet b expr ->
 354         wlk_bind    b    `thenUgn` \ bind ->
 355         wlkCoreExpr expr `thenUgn` \ body ->
 356         returnUgn (UfLet bind body)
 357        where
 358         wlk_bind (U_cononrec v expr)
 359           = wlkCoreBinder v     `thenUgn` \ b   ->
 360             wlkCoreExpr   expr  `thenUgn` \ rhs ->
 361             returnUgn (UfCoNonRec b rhs)
 362
 363         wlk_bind (U_corec prs)
 364           = wlkList rd_pair prs `thenUgn` \ pairs ->
 365             returnUgn (UfCoRec pairs)
 366           where
 367             rd_pair pt
 368               = rdU_coresyn pt  `thenUgn` \ (U_corec_pair v expr) ->
 369
 370                 wlkCoreBinder v    `thenUgn` \ b   ->
 371                 wlkCoreExpr   expr `thenUgn` \ rhs ->
 372                 returnUgn (b, rhs)
 373
 374       U_coscc c expr ->
 375         wlk_cc      c    `thenUgn` \ cc   ->
 376         wlkCoreExpr expr `thenUgn` \ body ->
 377         returnUgn (UfSCC cc body)
 378       where
 379         wlk_cc (U_co_preludedictscc dupd)
 380           = wlk_dupd dupd       `thenUgn` \ is_dupd ->
 381             returnUgn (UfPreludeDictsCC is_dupd)
 382
 383         wlk_cc (U_co_alldictscc m g dupd)
 384           = wlk_dupd dupd       `thenUgn` \ is_dupd ->
 385             returnUgn (UfAllDictsCC m g is_dupd)
 386
 387         wlk_cc (U_co_usercc n m g dupd cafd)
 388           = wlk_dupd dupd       `thenUgn` \ is_dupd ->
 389             wlk_cafd cafd       `thenUgn` \ is_cafd ->
 390             returnUgn (UfUserCC n m g is_dupd is_cafd)
 391
 392         wlk_cc (U_co_autocc id m g dupd cafd)
 393           = wlkCoreId id        `thenUgn` \ i       ->
 394             wlk_dupd  dupd      `thenUgn` \ is_dupd ->
 395             wlk_cafd  cafd      `thenUgn` \ is_cafd ->
 396             returnUgn (UfAutoCC i m g is_dupd is_cafd)
 397
 398         wlk_cc (U_co_dictcc id m g dupd cafd)
 399           = wlkCoreId id        `thenUgn` \ i       ->
 400             wlk_dupd  dupd      `thenUgn` \ is_dupd ->
 401             wlk_cafd  cafd      `thenUgn` \ is_cafd ->
 402             returnUgn (UfDictCC i m g is_dupd is_cafd)
 403
 404         ------
 405         wlk_cafd U_co_scc_noncaf  = returnUgn False
 406         wlk_cafd U_co_scc_caf     = returnUgn True
 407
 408         wlk_dupd U_co_scc_nondupd = returnUgn False
 409         wlk_dupd U_co_scc_dupd    = returnUgn True
 410 \end{code}
 411
 412 \begin{code}
 413 type ProtoUfBinder = (ProtoName, PolyType ProtoName)
 414
 415 rdCoreBinder :: ParseTree -> UgnM ProtoUfBinder
 416
 417 rdCoreBinder pt = rdU_coresyn pt `thenUgn` \ x -> wlkCoreBinder x
 418
 419 wlkCoreBinder :: U_coresyn -> UgnM ProtoUfBinder
 420
 421 wlkCoreBinder (U_cobinder b t)
 422   = wlkCoreType t   `thenUgn` \ ty ->
 423     returnUgn (b, ty)
 424
 425 rdCoreAtom pt
 426   = rdU_coresyn pt `thenUgn` \ atom ->
 427     case atom of
 428       U_colit l ->
 429         wlkBasicLit l   `thenUgn` \ lit ->
 430         returnUgn (UfCoLitAtom lit)
 431
 432       U_colocal var ->
 433         wlkCoreId var   `thenUgn` \ v ->
 434         returnUgn (UfCoVarAtom v)
 435 \end{code}
 436
 437 \begin{code}
 438 rdCoreType :: ParseTree -> UgnM ProtoNamePolyType
 439
 440 rdCoreType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkCoreType ttype
 441
 442 wlkCoreType :: U_ttype -> UgnM ProtoNamePolyType
 443
 444 wlkCoreType other
 445   = panic "ReadPragmas:wlkCoreType:ToDo"
 446 {- LATER:
 447 wlkCoreType (U_uniforall ts t)
 448   = wlkList rdU_???unkId ts    `thenUgn` \ tvs ->
 449     wlkMonoType       t     `thenUgn` \ ty  ->
 450     returnUgn (HsForAllTy tvs ty)
 451
 452 wlkCoreType other
 453   = wlkMonoType other   `thenUgn` \ ty ->
 454     returnUgn (UnoverloadedTy ty)
 455 -}
 456 \end{code}
 457
 458 \begin{code}
 459 rdMonoTypeMaybe pt
 460   = rdU_maybe pt `thenUgn` \ ty_maybe ->
 461     wlkMaybe rdMonoType ty_maybe
 462 \end{code}
 463
 464 \begin{code}
 465 wlkCoreId :: U_coresyn -> UgnM (UfId ProtoName)
 466
 467 wlkCoreId (U_co_id v)
 468   = returnUgn (BoringUfId (cvt_IdString v))
 469
 470 wlkCoreId (U_co_orig_id mod nm)
 471   = returnUgn (BoringUfId (Imp mod nm [mod]{-dubious, but doesn't matter-} nm))
 472
 473 wlkCoreId (U_co_sdselid clas super_clas)
 474   = returnUgn (SuperDictSelUfId clas super_clas)
 475
 476 wlkCoreId (U_co_classopid clas method)
 477   = returnUgn (ClassOpUfId clas method)
 478
 479 wlkCoreId (U_co_defmid clas method)
 480   = returnUgn (DefaultMethodUfId clas method)
 481
 482 wlkCoreId (U_co_dfunid clas t)
 483   = wlkCoreType t   `thenUgn` \ ty ->
 484     returnUgn (DictFunUfId clas ty)
 485
 486 wlkCoreId (U_co_constmid clas op t)
 487   = wlkCoreType t   `thenUgn` \ ty ->
 488     returnUgn (ConstMethodUfId clas op ty)
 489
 490 wlkCoreId (U_co_specid id tys)
 491   = wlkCoreId               id  `thenUgn` \ unspec    ->
 492     wlkList rdMonoTypeMaybe tys `thenUgn` \ ty_maybes ->
 493     returnUgn (SpecUfId unspec ty_maybes)
 494
 495 wlkCoreId (U_co_wrkrid un)
 496   = wlkCoreId un        `thenUgn` \ unwrkr ->
 497     returnUgn (WorkerUfId unwrkr)
 498
 499 ------------
 500 cvt_IdString :: FAST_STRING -> ProtoName
 501
 502 cvt_IdString s
 503   = if (_HEAD_ s /= '_') then
 504         boring
 505     else if (sub_s == SLIT("NIL_")) then
 506         Prel (WiredInVal nilDataCon)
 507     else if (sub_s == SLIT("TUP_")) then
 508         Prel (WiredInVal (mkTupleCon arity))
 509     else
 510         boring
 511   where
 512     boring = Unk s
 513     sub_s  = _SUBSTR_ s 1 4     -- chars 1--4 (0-origin)
 514     arity  = read (_UNPK_ (_SUBSTR_ s 5 999999))
 515                                 -- chars 5 onwards give the arity
 516 \end{code}
 517
 518 \begin{code}
 519 wlkBasicLit :: U_literal -> UgnM Literal
 520
 521 wlkBasicLit (U_norepr n d)
 522   = let
 523         num = ((read (_UNPK_ n)) :: Integer)
 524         den = ((read (_UNPK_ d)) :: Integer)
 525     in
 526     returnUgn (NoRepRational (num % den))
 527
 528 wlkBasicLit other
 529   = returnUgn (
 530     case other of
 531       U_intprim    s -> mkMachInt   (as_integer  s)
 532       U_doubleprim s -> MachDouble  (as_rational s)
 533       U_floatprim  s -> MachFloat   (as_rational s)
 534       U_charprim   s -> MachChar    (as_char     s)
 535       U_stringprim s -> MachStr     (as_string   s)
 536
 537       U_clitlit    s k -> MachLitLit (as_string  s) (guessPrimRep (_UNPK_ k))
 538
 539       U_norepi     s -> NoRepInteger (as_integer s)
 540       U_noreps     s -> NoRepStr     (as_string  s)
 541     )
 542   where
 543     as_char s     = _HEAD_ s
 544     as_integer s  = readInteger (_UNPK_ s)
 545     as_rational s = _readRational (_UNPK_ s) -- non-std
 546     as_string s   = s
 547 \end{code}