ghc/compiler/reader/ReadPrefix.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1996
   3 %
   4 \section{Read parse tree built by Yacc parser}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module ReadPrefix ( rdModule )  where
  10
  11 IMP_Ubiq()
  12 IMPORT_1_3(IO(hPutStr, stderr))
  13 #if __GLASGOW_HASKELL__ == 201
  14 import GHCio(stThen)
  15 #elif __GLASGOW_HASKELL__ >= 202
  16 import GlaExts
  17 import IOBase
  18 import PrelRead
  19 #endif
  20
  21 import UgenAll          -- all Yacc parser gumpff...
  22 import PrefixSyn        -- and various syntaxen.
  23 import HsSyn
  24 import HsTypes          ( HsTyVar(..) )
  25 import HsPragmas        ( noDataPragmas, noClassPragmas, noInstancePragmas, noGenPragmas )
  26 import RdrHsSyn
  27 import BasicTypes       ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..) )
  28 import PrefixToHs
  29
  30 import CmdLineOpts      ( opt_PprUserLength, opt_NoImplicitPrelude )
  31 import ErrUtils         ( addErrLoc, ghcExit )
  32 import FiniteMap        ( elemFM, FiniteMap )
  33 import Name             ( OccName(..), SYN_IE(Module) )
  34 import Lex              ( isLexConId )
  35 import Outputable       ( Outputable(..), PprStyle(..) )
  36 import PrelMods         ( pRELUDE )
  37 import Pretty
  38 import SrcLoc           ( mkGeneratedSrcLoc, noSrcLoc, SrcLoc )
  39 import Util             ( nOfThem, pprError, panic )
  40 \end{code}
  41
  42 %************************************************************************
  43 %*                                                                      *
  44 \subsection[ReadPrefix-help]{Help Functions}
  45 %*                                                                      *
  46 %************************************************************************
  47
  48 \begin{code}
  49 wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a]
  50
  51 wlkList wlk_it U_lnil = returnUgn []
  52
  53 wlkList wlk_it (U_lcons hd tl)
  54   = wlk_it  hd          `thenUgn` \ hd_it ->
  55     wlkList wlk_it tl   `thenUgn` \ tl_it ->
  56     returnUgn (hd_it : tl_it)
  57 \end{code}
  58
  59 \begin{code}
  60 wlkMaybe :: (U_VOID_STAR -> UgnM a) -> U_maybe -> UgnM (Maybe a)
  61
  62 wlkMaybe wlk_it U_nothing  = returnUgn Nothing
  63 wlkMaybe wlk_it (U_just x)
  64   = wlk_it  x           `thenUgn` \ it ->
  65     returnUgn (Just it)
  66 \end{code}
  67
  68 \begin{code}
  69 wlkTvId   = wlkQid TvOcc
  70 wlkTCId   = wlkQid TCOcc
  71 wlkVarId  = wlkQid VarOcc
  72 wlkDataId = wlkQid VarOcc
  73 wlkEntId = wlkQid (\occ -> if isLexConId occ
  74                            then TCOcc occ
  75                            else VarOcc occ)
  76
  77 wlkQid  :: (FAST_STRING -> OccName) -> U_qid -> UgnM RdrName
  78
  79 -- There are three kinds of qid:
  80 --      qualified name (aqual)          A.x
  81 --      unqualified name (noqual)       x
  82 --      special name (gid)              [], (), ->, (,,,)
  83 -- The special names always mean "Prelude.whatever"; that's why
  84 -- they are distinct.  So if you write "()", it's just as if  you
  85 -- had written "Prelude.()".
  86 -- NB: The (qualified) prelude is always in scope, so the renamer will find it.
  87
  88 -- EXCEPT: when we're compiling with -fno-implicit-prelude, in which
  89 -- case we need to unqualify these things. -- SDM.
  90
  91 wlkQid mk_occ_name (U_noqual name)
  92   = returnUgn (Unqual (mk_occ_name name))
  93 wlkQid mk_occ_name (U_aqual  mod name)
  94   = returnUgn (Qual mod (mk_occ_name name) HiFile)
  95 wlkQid mk_occ_name (U_gid n name)
  96   | opt_NoImplicitPrelude
  97         = returnUgn (Unqual (mk_occ_name name))
  98   | otherwise
  99         = returnUgn (Qual pRELUDE (mk_occ_name name) HiFile)
 100
 101 rdTCId  pt = rdU_qid pt `thenUgn` \ qid -> wlkTCId qid
 102 rdVarId pt = rdU_qid pt `thenUgn` \ qid -> wlkVarId qid
 103
 104 cvFlag :: U_long -> Bool
 105 cvFlag 0 = False
 106 cvFlag 1 = True
 107 \end{code}
 108
 109 %************************************************************************
 110 %*                                                                      *
 111 \subsection[rdModule]{@rdModule@: reads in a Haskell module}
 112 %*                                                                      *
 113 %************************************************************************
 114
 115 \begin{code}
 116 #if __GLASGOW_HASKELL__ == 201
 117 # define PACK_STR packCString
 118 #elif __GLASGOW_HASKELL__ >= 202
 119 # define PACK_STR mkFastCharString
 120 #else
 121 # define PACK_STR mkFastCharString
 122 #endif
 123
 124 rdModule :: IO (Module,             -- this module's name
 125                 RdrNameHsModule)    -- the main goods
 126
 127 rdModule
 128   = _ccall_ hspmain `CCALL_THEN` \ pt -> -- call the Yacc parser!
 129     let
 130         srcfile  = PACK_STR ``input_filename'' -- What A Great Hack! (TM)
 131     in
 132     initUgn               $
 133     rdU_tree pt `thenUgn` \ (U_hmodule modname himplist hexplist hfixlist
 134                                        hmodlist srciface_version srcline) ->
 135
 136     setSrcFileUgn srcfile $
 137     setSrcModUgn  modname $
 138     mkSrcLocUgn srcline   $                \ src_loc    ->
 139
 140     wlkMaybe rdEntities hexplist `thenUgn` \ exports    ->
 141     wlkList  rdImport   himplist `thenUgn` \ imports    ->
 142     wlkList  rdFixOp    hfixlist `thenUgn` \ fixities   ->
 143     wlkBinding          hmodlist `thenUgn` \ binding    ->
 144
 145     let
 146         val_decl    = ValD (cvBinds srcfile cvValSig binding)
 147         other_decls = cvOtherDecls binding
 148     in
 149     returnUgn (modname,
 150                HsModule modname
 151                           (case srciface_version of { 0 -> Nothing; n -> Just n })
 152                           exports
 153                           imports
 154                           fixities
 155                           (val_decl: other_decls)
 156                           src_loc
 157                 )
 158 \end{code}
 159
 160 %************************************************************************
 161 %*                                                                      *
 162 \subsection[wlkExprOrPat]{@wlkExpr@ and @wlkPat@}
 163 %*                                                                      *
 164 %************************************************************************
 165
 166 \begin{code}
 167 rdExpr :: ParseTree -> UgnM RdrNameHsExpr
 168 rdPat  :: ParseTree -> UgnM RdrNamePat
 169
 170 rdExpr pt = rdU_tree pt `thenUgn` \ tree -> wlkExpr tree
 171 rdPat  pt = rdU_tree pt `thenUgn` \ tree -> wlkPat  tree
 172
 173 wlkExpr :: U_tree -> UgnM RdrNameHsExpr
 174 wlkPat  :: U_tree -> UgnM RdrNamePat
 175
 176 wlkExpr expr
 177   = case expr of
 178       U_par pexpr -> -- parenthesised expr
 179         wlkExpr pexpr   `thenUgn` \ expr ->
 180         returnUgn (HsPar expr)
 181
 182       U_lsection lsexp lop -> -- left section
 183         wlkExpr lsexp   `thenUgn` \ expr ->
 184         wlkVarId  lop   `thenUgn` \ op   ->
 185         returnUgn (SectionL expr (HsVar op))
 186
 187       U_rsection rop rsexp -> -- right section
 188         wlkVarId  rop   `thenUgn` \ op   ->
 189         wlkExpr rsexp   `thenUgn` \ expr ->
 190         returnUgn (SectionR (HsVar op) expr)
 191
 192       U_ccall fun flavor ccargs -> -- ccall/casm
 193         wlkList rdExpr ccargs   `thenUgn` \ args ->
 194         let
 195             tag = _HEAD_ flavor
 196         in
 197         returnUgn (CCall fun args
 198                     (tag == 'p' || tag == 'P') -- may invoke GC
 199                     (tag == 'N' || tag == 'P') -- really a "casm"
 200                     (panic "CCall:result_ty"))
 201
 202       U_scc label sccexp -> -- scc (set-cost-centre) expression
 203         wlkExpr   sccexp        `thenUgn` \ expr  ->
 204         returnUgn (HsSCC label expr)
 205
 206       U_lambda lampats lamexpr srcline -> -- lambda expression
 207         mkSrcLocUgn   srcline           $ \ src_loc ->
 208         wlkList rdPat lampats   `thenUgn` \ pats ->
 209         wlkExpr       lamexpr   `thenUgn` \ body ->
 210         returnUgn (
 211             HsLam (foldr PatMatch
 212                          (GRHSMatch (GRHSsAndBindsIn
 213                                       [OtherwiseGRHS body src_loc]
 214                                       EmptyBinds))
 215                          pats)
 216         )
 217
 218       U_casee caseexpr casebody srcline ->      -- case expression
 219         mkSrcLocUgn srcline              $ \ src_loc ->
 220         wlkExpr         caseexpr `thenUgn` \ expr ->
 221         wlkList rdMatch casebody `thenUgn` \ mats ->
 222         getSrcFileUgn            `thenUgn` \ sf ->
 223         let
 224             matches = cvMatches sf True mats
 225         in
 226         returnUgn (HsCase expr matches src_loc)
 227
 228       U_ife ifpred ifthen ifelse srcline ->     -- if expression
 229         mkSrcLocUgn srcline             $ \ src_loc ->
 230         wlkExpr ifpred          `thenUgn` \ e1 ->
 231         wlkExpr ifthen          `thenUgn` \ e2 ->
 232         wlkExpr ifelse          `thenUgn` \ e3 ->
 233         returnUgn (HsIf e1 e2 e3 src_loc)
 234
 235       U_let letvdefs letvexpr ->                -- let expression
 236         wlkBinding letvdefs     `thenUgn` \ binding ->
 237         wlkExpr    letvexpr     `thenUgn` \ expr    ->
 238         getSrcFileUgn           `thenUgn` \ sf      ->
 239         let
 240             binds = cvBinds sf cvValSig binding
 241         in
 242         returnUgn (HsLet binds expr)
 243
 244       U_doe gdo srcline ->                      -- do expression
 245         mkSrcLocUgn srcline             $ \ src_loc ->
 246         wlkList rd_stmt gdo     `thenUgn` \ stmts ->
 247         returnUgn (HsDo DoStmt stmts src_loc)
 248         where
 249         rd_stmt pt
 250           = rdU_tree pt `thenUgn` \ bind ->
 251             case bind of
 252               U_doexp exp srcline ->
 253                 mkSrcLocUgn srcline             $ \ src_loc ->
 254                 wlkExpr exp             `thenUgn` \ expr ->
 255                 returnUgn (ExprStmt expr src_loc)
 256
 257               U_dobind pat exp srcline ->
 258                 mkSrcLocUgn srcline             $ \ src_loc ->
 259                 wlkPat  pat             `thenUgn` \ patt ->
 260                 wlkExpr exp             `thenUgn` \ expr ->
 261                 returnUgn (BindStmt patt expr src_loc)
 262
 263               U_seqlet seqlet ->
 264                 wlkBinding seqlet       `thenUgn` \ bs ->
 265                 getSrcFileUgn           `thenUgn` \ sf ->
 266                 let
 267                     binds = cvBinds sf cvValSig bs
 268                 in
 269                 returnUgn (LetStmt binds)
 270
 271       U_comprh cexp cquals -> -- list comprehension
 272         wlkExpr cexp            `thenUgn` \ expr  ->
 273         wlkQuals cquals         `thenUgn` \ quals ->
 274         getSrcLocUgn            `thenUgn` \ loc ->
 275         returnUgn (HsDo ListComp (quals ++ [ReturnStmt expr]) loc)
 276
 277       U_eenum efrom estep eto -> -- arithmetic sequence
 278         wlkExpr efrom           `thenUgn` \ e1  ->
 279         wlkMaybe rdExpr estep   `thenUgn` \ es2 ->
 280         wlkMaybe rdExpr eto     `thenUgn` \ es3 ->
 281         returnUgn (cv_arith_seq e1 es2 es3)
 282         where
 283            cv_arith_seq e1 Nothing   Nothing   = ArithSeqIn (From       e1)
 284            cv_arith_seq e1 Nothing   (Just e3) = ArithSeqIn (FromTo     e1 e3)
 285            cv_arith_seq e1 (Just e2) Nothing   = ArithSeqIn (FromThen   e1 e2)
 286            cv_arith_seq e1 (Just e2) (Just e3) = ArithSeqIn (FromThenTo e1 e2 e3)
 287
 288       U_restr restre restrt ->  -- expression with type signature
 289         wlkExpr     restre      `thenUgn` \ expr ->
 290         wlkHsType restrt        `thenUgn` \ ty   ->
 291         returnUgn (ExprWithTySig expr ty)
 292
 293       --------------------------------------------------------------
 294       -- now the prefix items that can either be an expression or
 295       -- pattern, except we know they are *expressions* here
 296       -- (this code could be commoned up with the pattern version;
 297       -- but it probably isn't worth it)
 298       --------------------------------------------------------------
 299       U_lit lit ->
 300         wlkLiteral lit  `thenUgn` \ lit ->
 301         returnUgn (HsLit lit)
 302
 303       U_ident n ->                      -- simple identifier
 304         wlkVarId n      `thenUgn` \ var ->
 305         returnUgn (HsVar var)
 306
 307       U_ap fun arg ->                   -- application
 308         wlkExpr fun     `thenUgn` \ expr1 ->
 309         wlkExpr arg     `thenUgn` \ expr2 ->
 310         returnUgn (HsApp expr1 expr2)
 311
 312       U_infixap fun arg1 arg2 ->        -- infix application
 313         wlkVarId  fun   `thenUgn` \ op    ->
 314         wlkExpr arg1    `thenUgn` \ expr1 ->
 315         wlkExpr arg2    `thenUgn` \ expr2 ->
 316         returnUgn (mkOpApp expr1 op expr2)
 317
 318       U_negate nexp ->                  -- prefix negation
 319         wlkExpr nexp    `thenUgn` \ expr ->
 320         returnUgn (NegApp expr (HsVar dummyRdrVarName))
 321
 322       U_llist llist -> -- explicit list
 323         wlkList rdExpr llist `thenUgn` \ exprs ->
 324         returnUgn (ExplicitList exprs)
 325
 326       U_tuple tuplelist -> -- explicit tuple
 327         wlkList rdExpr tuplelist `thenUgn` \ exprs ->
 328         returnUgn (ExplicitTuple exprs)
 329
 330       U_record con rbinds -> -- record construction
 331         wlkDataId  con          `thenUgn` \ rcon     ->
 332         wlkList rdRbind rbinds  `thenUgn` \ recbinds ->
 333         returnUgn (RecordCon rcon recbinds)
 334
 335       U_rupdate updexp updbinds -> -- record update
 336         wlkExpr updexp           `thenUgn` \ aexp ->
 337         wlkList rdRbind updbinds `thenUgn` \ recbinds ->
 338         returnUgn (RecordUpd aexp recbinds)
 339
 340 #ifdef DEBUG
 341       U_hmodule _ _ _ _ _ _ _ -> error "U_hmodule"
 342       U_as _ _                -> error "U_as"
 343       U_lazyp _               -> error "U_lazyp"
 344       U_wildp                 -> error "U_wildp"
 345       U_qual _ _              -> error "U_qual"
 346       U_guard _               -> error "U_guard"
 347       U_seqlet _              -> error "U_seqlet"
 348       U_dobind _ _ _          -> error "U_dobind"
 349       U_doexp _ _             -> error "U_doexp"
 350       U_rbind _ _             -> error "U_rbind"
 351       U_fixop _ _ _           -> error "U_fixop"
 352 #endif
 353
 354 rdRbind pt
 355   = rdU_tree pt         `thenUgn` \ (U_rbind var exp) ->
 356     wlkVarId   var      `thenUgn` \ rvar ->
 357     wlkMaybe rdExpr exp `thenUgn` \ expr_maybe ->
 358     returnUgn (
 359       case expr_maybe of
 360         Nothing -> (rvar, HsVar rvar, True{-pun-})
 361         Just re -> (rvar, re,         False)
 362     )
 363
 364 wlkQuals cquals
 365   = wlkList rd_qual cquals
 366   where
 367           rd_qual pt
 368             = rdU_tree pt       `thenUgn` \ qual ->
 369               wlk_qual qual
 370
 371           wlk_qual qual
 372             = case qual of
 373                 U_guard exp ->
 374                   wlkExpr exp   `thenUgn` \ expr ->
 375                   getSrcLocUgn  `thenUgn` \ loc ->
 376                   returnUgn (GuardStmt expr loc)
 377
 378                 U_qual qpat qexp ->
 379                   wlkPat  qpat  `thenUgn` \ pat  ->
 380                   wlkExpr qexp  `thenUgn` \ expr ->
 381                   getSrcLocUgn  `thenUgn` \ loc ->
 382                   returnUgn (BindStmt pat expr loc)
 383
 384                 U_seqlet seqlet ->
 385                   wlkBinding seqlet     `thenUgn` \ bs ->
 386                   getSrcFileUgn         `thenUgn` \ sf ->
 387                   let
 388                       binds = cvBinds sf cvValSig bs
 389                   in
 390                   returnUgn (LetStmt binds)
 391                 U_let letvdefs letvexpr ->
 392                     wlkBinding letvdefs `thenUgn` \ binding ->
 393                     wlkExpr    letvexpr `thenUgn` \ expr    ->
 394                     getSrcLocUgn        `thenUgn` \ loc ->
 395                     getSrcFileUgn       `thenUgn` \ sf      ->
 396                     let
 397                      binds = cvBinds sf cvValSig binding
 398                     in
 399                     returnUgn (GuardStmt (HsLet binds expr) loc)
 400 \end{code}
 401
 402 Patterns: just bear in mind that lists of patterns are represented as
 403 a series of ``applications''.
 404 \begin{code}
 405 wlkPat pat
 406   = case pat of
 407       U_par ppat ->                     -- parenthesised pattern
 408         wlkPat ppat     `thenUgn` \ pat ->
 409         -- tidy things up a little:
 410         returnUgn (
 411         case pat of
 412           VarPatIn _ -> pat
 413           WildPatIn  -> pat
 414           other      -> ParPatIn pat
 415         )
 416
 417       U_as avar as_pat ->               -- "as" pattern
 418         wlkVarId avar   `thenUgn` \ var ->
 419         wlkPat as_pat   `thenUgn` \ pat ->
 420         returnUgn (AsPatIn var pat)
 421
 422       U_lazyp lazyp ->                  -- irrefutable ("twiddle") pattern
 423         wlkPat lazyp    `thenUgn` \ pat ->
 424         returnUgn (LazyPatIn pat)
 425
 426       U_plusp avar lit ->
 427         wlkVarId avar   `thenUgn` \ var ->
 428         wlkLiteral lit  `thenUgn` \ lit ->
 429         returnUgn (NPlusKPatIn var lit)
 430
 431       U_wildp -> returnUgn WildPatIn    -- wildcard pattern
 432
 433       U_lit lit ->                      -- literal pattern
 434         wlkLiteral lit  `thenUgn` \ lit ->
 435         returnUgn (LitPatIn lit)
 436
 437       U_ident nn ->                     -- simple identifier
 438         wlkVarId nn     `thenUgn` \ n ->
 439         returnUgn (
 440           case rdrNameOcc n of
 441                 VarOcc occ | isLexConId occ -> ConPatIn n []
 442                 other                       -> VarPatIn n
 443         )
 444
 445       U_ap l r ->       -- "application": there's a list of patterns lurking here!
 446         wlkPat r                `thenUgn` \ rpat         ->
 447         collect_pats l [rpat]   `thenUgn` \ (lpat,lpats) ->
 448         (case lpat of
 449             VarPatIn x          -> returnUgn (x,  lpats)
 450             ConPatIn x []       -> returnUgn (x,  lpats)
 451             ConOpPatIn x op _ y -> returnUgn (op, x:y:lpats)
 452             _ -> getSrcLocUgn   `thenUgn` \ loc ->
 453                  let
 454                      err = addErrLoc loc "Illegal pattern `application'"
 455                                      (\sty -> hsep (map (ppr sty) (lpat:lpats)))
 456                      msg = show (err (PprForUser opt_PprUserLength))
 457                  in
 458 #if __GLASGOW_HASKELL__ == 201
 459                  ioToUgnM  (GHCbase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ ->
 460                  ioToUgnM  (GHCbase.ioToPrimIO (ghcExit 1))          `thenUgn` \ _ ->
 461 #elif __GLASGOW_HASKELL__ >= 202 && __GLASGOW_HASKELL__ < 209
 462                  ioToUgnM  (IOBase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ ->
 463                  ioToUgnM  (IOBase.ioToPrimIO (ghcExit 1))           `thenUgn` \ _ ->
 464 #else
 465                  ioToUgnM  (hPutStr stderr msg) `thenUgn` \ _ ->
 466                  ioToUgnM  (ghcExit 1)          `thenUgn` \ _ ->
 467 #endif
 468                  returnUgn (error "ReadPrefix")
 469
 470         )                       `thenUgn` \ (n, arg_pats) ->
 471         returnUgn (ConPatIn n arg_pats)
 472         where
 473           collect_pats pat acc
 474             = case pat of
 475                 U_ap l r ->
 476                   wlkPat r      `thenUgn` \ rpat  ->
 477                   collect_pats l (rpat:acc)
 478                 other ->
 479                   wlkPat other  `thenUgn` \ pat ->
 480                   returnUgn (pat,acc)
 481
 482       U_infixap fun arg1 arg2 ->        -- infix pattern
 483         wlkVarId fun    `thenUgn` \ op   ->
 484         wlkPat arg1     `thenUgn` \ pat1 ->
 485         wlkPat arg2     `thenUgn` \ pat2 ->
 486         returnUgn (ConOpPatIn pat1 op (error "ConOpPatIn:fixity") pat2)
 487
 488       U_negate npat ->                  -- negated pattern
 489         wlkPat npat     `thenUgn` \ pat ->
 490         returnUgn (NegPatIn pat)
 491
 492       U_llist llist ->                  -- explicit list
 493         wlkList rdPat llist     `thenUgn` \ pats ->
 494         returnUgn (ListPatIn pats)
 495
 496       U_tuple tuplelist ->              -- explicit tuple
 497         wlkList rdPat tuplelist `thenUgn` \ pats ->
 498         returnUgn (TuplePatIn pats)
 499
 500       U_record con rpats ->             -- record destruction
 501         wlkDataId  con          `thenUgn` \ rcon     ->
 502         wlkList rdRpat rpats    `thenUgn` \ recpats ->
 503         returnUgn (RecPatIn rcon recpats)
 504         where
 505           rdRpat pt
 506             = rdU_tree pt        `thenUgn` \ (U_rbind var pat) ->
 507               wlkVarId   var     `thenUgn` \ rvar ->
 508               wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
 509               returnUgn (
 510                 case pat_maybe of
 511                   Nothing -> (rvar, VarPatIn rvar, True{-pun-})
 512                   Just rp -> (rvar, rp,            False)
 513               )
 514 \end{code}
 515
 516 \begin{code}
 517 wlkLiteral :: U_literal -> UgnM HsLit
 518
 519 wlkLiteral ulit
 520   = returnUgn (
 521     case ulit of
 522       U_integer    s -> HsInt        (as_integer  s)
 523       U_floatr     s -> HsFrac       (as_rational s)
 524       U_intprim    s -> HsIntPrim    (as_integer  s)
 525       U_doubleprim s -> HsDoublePrim (as_rational s)
 526       U_floatprim  s -> HsFloatPrim  (as_rational s)
 527       U_charr      s -> HsChar       (as_char     s)
 528       U_charprim   s -> HsCharPrim   (as_char     s)
 529       U_string     s -> HsString     (as_string   s)
 530       U_stringprim s -> HsStringPrim (as_string   s)
 531       U_clitlit    s -> HsLitLit     (as_string   s)
 532     )
 533   where
 534     as_char s     = _HEAD_ s
 535     as_integer s  = readInteger (_UNPK_ s)
 536 #if __GLASGOW_HASKELL__ == 201
 537     as_rational s = GHCbase.readRational__ (_UNPK_ s) -- non-std
 538 #elif __GLASGOW_HASKELL__ == 202
 539     as_rational s = case readRational (_UNPK_ s) of { [(a,_)] -> a }
 540 #elif __GLASGOW_HASKELL__ >= 203
 541     as_rational s = readRational__ (_UNPK_ s) -- use non-std readRational__
 542                                               -- to handle rationals with leading '-'
 543 #else
 544     as_rational s = _readRational (_UNPK_ s) -- non-std
 545 #endif
 546     as_string s   = s
 547 \end{code}
 548
 549 %************************************************************************
 550 %*                                                                      *
 551 \subsection{wlkBinding}
 552 %*                                                                      *
 553 %************************************************************************
 554
 555 \begin{code}
 556 wlkBinding :: U_binding -> UgnM RdrBinding
 557
 558 wlkBinding binding
 559   = case binding of
 560         -- null binding
 561       U_nullbind ->
 562         returnUgn RdrNullBind
 563
 564         -- "and" binding (just glue, really)
 565       U_abind a b ->
 566         wlkBinding a    `thenUgn` \ binding1 ->
 567         wlkBinding b    `thenUgn` \ binding2 ->
 568         returnUgn (RdrAndBindings binding1 binding2)
 569
 570         -- "data" declaration
 571       U_tbind tctxt ttype tcons tderivs srcline ->
 572         mkSrcLocUgn        srcline          $ \ src_loc     ->
 573         wlkContext         tctxt    `thenUgn` \ ctxt        ->
 574         wlkTyConAndTyVars  ttype    `thenUgn` \ (tycon, tyvars) ->
 575         wlkList rdConDecl  tcons    `thenUgn` \ cons        ->
 576         wlkDerivings       tderivs  `thenUgn` \ derivings   ->
 577         returnUgn (RdrTyDecl (TyData DataType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
 578
 579         -- "newtype" declaration
 580       U_ntbind ntctxt nttype ntcon ntderivs srcline ->
 581         mkSrcLocUgn        srcline          $ \ src_loc     ->
 582         wlkContext         ntctxt   `thenUgn` \ ctxt        ->
 583         wlkTyConAndTyVars  nttype   `thenUgn` \ (tycon, tyvars) ->
 584         wlkList rdConDecl  ntcon    `thenUgn` \ cons        ->
 585         wlkDerivings       ntderivs `thenUgn` \ derivings   ->
 586         returnUgn (RdrTyDecl (TyData NewType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
 587
 588         -- "type" declaration
 589       U_nbind nbindid nbindas srcline ->
 590         mkSrcLocUgn       srcline         $ \ src_loc       ->
 591         wlkTyConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
 592         wlkMonoType       nbindas `thenUgn` \ expansion     ->
 593         returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc))
 594
 595         -- function binding
 596       U_fbind fbindl srcline ->
 597         mkSrcLocUgn     srcline         $ \ src_loc ->
 598         wlkList rdMatch fbindl  `thenUgn` \ matches ->
 599         returnUgn (RdrFunctionBinding srcline matches)
 600
 601         -- pattern binding
 602       U_pbind pbindl srcline ->
 603         mkSrcLocUgn     srcline         $ \ src_loc ->
 604         wlkList rdMatch pbindl  `thenUgn` \ matches ->
 605         returnUgn (RdrPatternBinding srcline matches)
 606
 607         -- "class" declaration
 608       U_cbind cbindc cbindid cbindw srcline ->
 609         mkSrcLocUgn      srcline        $ \ src_loc       ->
 610         wlkContext       cbindc  `thenUgn` \ ctxt         ->
 611         wlkClassAssertTy cbindid `thenUgn` \ (clas, tyvar)->
 612         wlkBinding       cbindw  `thenUgn` \ binding      ->
 613         getSrcFileUgn            `thenUgn` \ sf           ->
 614         let
 615             (final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding
 616         in
 617         returnUgn (RdrClassDecl
 618           (ClassDecl ctxt clas tyvar final_sigs final_methods noClassPragmas src_loc))
 619
 620         -- "instance" declaration
 621       U_ibind ibindc iclas ibindi ibindw srcline ->
 622         mkSrcLocUgn     srcline         $ \ src_loc ->
 623         wlkContext      ibindc  `thenUgn` \ ctxt    ->
 624         wlkTCId         iclas   `thenUgn` \ clas    ->
 625         wlkMonoType     ibindi  `thenUgn` \ at_ty ->
 626         wlkBinding      ibindw  `thenUgn` \ binding ->
 627         getSrcModUgn            `thenUgn` \ modname ->
 628         getSrcFileUgn           `thenUgn` \ sf      ->
 629         let
 630             (binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding
 631             inst_ty = HsPreForAllTy ctxt (MonoDictTy clas at_ty)
 632         in
 633         returnUgn (RdrInstDecl
 634           (InstDecl inst_ty binds uprags Nothing {- No dfun id -} src_loc))
 635
 636         -- "default" declaration
 637       U_dbind dbindts srcline ->
 638         mkSrcLocUgn        srcline      $ \ src_loc ->
 639         wlkList rdMonoType dbindts  `thenUgn` \ tys ->
 640         returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc))
 641
 642       a_sig_we_hope ->
 643         -- signature(-like) things, including user pragmas
 644         wlk_sig_thing a_sig_we_hope
 645 \end{code}
 646
 647 \begin{code}
 648 wlkDerivings :: U_maybe -> UgnM (Maybe [RdrName])
 649
 650 wlkDerivings (U_nothing) = returnUgn Nothing
 651 wlkDerivings (U_just pt)
 652   = rdU_list pt          `thenUgn` \ ds     ->
 653     wlkList rdTCId ds    `thenUgn` \ derivs ->
 654     returnUgn (Just derivs)
 655 \end{code}
 656
 657 \begin{code}
 658         -- type signature
 659 wlk_sig_thing (U_sbind sbindids sbindid srcline)
 660   = mkSrcLocUgn         srcline         $ \ src_loc ->
 661     wlkList rdVarId     sbindids `thenUgn` \ vars    ->
 662     wlkHsType           sbindid  `thenUgn` \ poly_ty ->
 663     returnUgn (RdrTySig vars poly_ty src_loc)
 664
 665         -- value specialisation user-pragma
 666 wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline)
 667   = mkSrcLocUgn srcline                     $ \ src_loc ->
 668     wlkVarId  uvar                  `thenUgn` \ var ->
 669     wlkList rd_ty_and_id vspec_tys  `thenUgn` \ tys_and_ids ->
 670     returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc
 671                              | (ty, using_id) <- tys_and_ids ])
 672   where
 673     rd_ty_and_id :: ParseTree -> UgnM (RdrNameHsType, Maybe RdrName)
 674     rd_ty_and_id pt
 675       = rdU_binding pt          `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
 676         wlkHsType vspec_ty      `thenUgn` \ ty       ->
 677         wlkMaybe rdVarId vspec_id       `thenUgn` \ id_maybe ->
 678         returnUgn(ty, id_maybe)
 679
 680         -- instance specialisation user-pragma
 681 wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)
 682   = mkSrcLocUgn srcline                 $ \ src_loc ->
 683     wlkTCId     iclas           `thenUgn` \ clas    ->
 684     wlkMonoType ispec_ty        `thenUgn` \ ty      ->
 685     returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc))
 686
 687         -- data specialisation user-pragma
 688 wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline)
 689   = mkSrcLocUgn srcline                  $ \ src_loc ->
 690     wlkTCId     itycon           `thenUgn` \ tycon   ->
 691     wlkList rdMonoType dspec_tys `thenUgn` \ tys     ->
 692     returnUgn (RdrSpecDataSig (SpecDataSig tycon (foldl MonoTyApp (MonoTyVar tycon) tys) src_loc))
 693
 694         -- value inlining user-pragma
 695 wlk_sig_thing (U_inline_uprag ivar srcline)
 696   = mkSrcLocUgn srcline                 $ \ src_loc ->
 697     wlkVarId    ivar            `thenUgn` \ var     ->
 698     returnUgn (RdrInlineValSig (InlineSig var src_loc))
 699
 700         -- "magic" unfolding user-pragma
 701 wlk_sig_thing (U_magicuf_uprag ivar str srcline)
 702   = mkSrcLocUgn srcline                 $ \ src_loc ->
 703     wlkVarId    ivar            `thenUgn` \ var     ->
 704     returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
 705 \end{code}
 706
 707 %************************************************************************
 708 %*                                                                      *
 709 \subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
 710 %*                                                                      *
 711 %************************************************************************
 712
 713 \begin{code}
 714 rdHsType :: ParseTree -> UgnM RdrNameHsType
 715 rdMonoType :: ParseTree -> UgnM RdrNameHsType
 716
 717 rdHsType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkHsType ttype
 718 rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
 719
 720 wlkHsType :: U_ttype -> UgnM RdrNameHsType
 721 wlkMonoType :: U_ttype -> UgnM RdrNameHsType
 722
 723 wlkHsType ttype
 724   = case ttype of
 725       U_context tcontextl tcontextt -> -- context
 726         wlkContext  tcontextl   `thenUgn` \ ctxt ->
 727         wlkMonoType tcontextt   `thenUgn` \ ty   ->
 728         returnUgn (HsPreForAllTy ctxt ty)
 729
 730       other -> -- something else
 731         wlkMonoType other   `thenUgn` \ ty ->
 732         returnUgn (HsPreForAllTy [{-no context-}] ty)
 733
 734 wlkMonoType ttype
 735   = case ttype of
 736                 -- Glasgow extension: nested polymorhism
 737       U_context tcontextl tcontextt -> -- context
 738         wlkContext  tcontextl   `thenUgn` \ ctxt ->
 739         wlkMonoType tcontextt   `thenUgn` \ ty   ->
 740         returnUgn (HsPreForAllTy ctxt ty)
 741
 742       U_namedtvar tv -> -- type variable
 743         wlkTvId tv      `thenUgn` \ tyvar ->
 744         returnUgn (MonoTyVar tyvar)
 745
 746       U_tname tcon -> -- type constructor
 747         wlkTCId tcon    `thenUgn` \ tycon ->
 748         returnUgn (MonoTyVar tycon)
 749
 750       U_tapp t1 t2 ->
 751         wlkMonoType t1          `thenUgn` \ ty1 ->
 752         wlkMonoType t2          `thenUgn` \ ty2 ->
 753         returnUgn (MonoTyApp ty1 ty2)
 754
 755       U_tllist tlist -> -- list type
 756         wlkMonoType tlist       `thenUgn` \ ty ->
 757         returnUgn (MonoListTy dummyRdrTcName ty)
 758
 759       U_ttuple ttuple ->
 760         wlkList rdMonoType ttuple `thenUgn` \ tys ->
 761         returnUgn (MonoTupleTy dummyRdrTcName tys)
 762
 763       U_tfun tfun targ ->
 764         wlkMonoType tfun        `thenUgn` \ ty1 ->
 765         wlkMonoType targ        `thenUgn` \ ty2 ->
 766         returnUgn (MonoFunTy ty1 ty2)
 767
 768 \end{code}
 769
 770 \begin{code}
 771 wlkTyConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
 772 wlkContext        :: U_list  -> UgnM RdrNameContext
 773 wlkClassAssertTy  :: U_ttype -> UgnM (RdrName, HsTyVar RdrName)
 774
 775 wlkTyConAndTyVars ttype
 776   = wlkMonoType ttype   `thenUgn` \ ty ->
 777     let
 778         split (MonoTyApp fun (MonoTyVar arg)) args = split fun (UserTyVar arg : args)
 779         split (MonoTyVar tycon)               args = (tycon,args)
 780     in
 781     returnUgn (split ty [])
 782
 783 wlkContext list
 784   = wlkList rdMonoType list `thenUgn` \ tys ->
 785     returnUgn (map mk_class_assertion tys)
 786
 787 wlkClassAssertTy xs
 788   = wlkMonoType xs   `thenUgn` \ mono_ty ->
 789     returnUgn (case mk_class_assertion mono_ty of
 790                   (clas, MonoTyVar tyvar) -> (clas, UserTyVar tyvar)
 791     )
 792
 793 mk_class_assertion :: RdrNameHsType -> (RdrName, RdrNameHsType)
 794
 795 mk_class_assertion (MonoTyApp (MonoTyVar name) ty@(MonoTyVar tyname)) = (name, ty)
 796 mk_class_assertion other
 797   = pprError "ERROR: malformed type context: " (ppr (PprForUser opt_PprUserLength) other)
 798     -- regrettably, the parser does let some junk past
 799     -- e.g., f :: Num {-nothing-} => a -> ...
 800 \end{code}
 801
 802 \begin{code}
 803 rdConDecl :: ParseTree -> UgnM RdrNameConDecl
 804 rdConDecl pt
 805   = rdU_constr pt    `thenUgn` \ blah ->
 806     wlkConDecl blah
 807
 808 wlkConDecl :: U_constr -> UgnM RdrNameConDecl
 809
 810 wlkConDecl (U_constrcxt ccxt ccdecl)
 811   = wlkContext ccxt             `thenUgn` \ theta ->
 812     wlkConDecl ccdecl           `thenUgn` \ (ConDecl con _ details loc) ->
 813     returnUgn (ConDecl con theta details loc)
 814
 815 wlkConDecl (U_constrpre ccon ctys srcline)
 816   = mkSrcLocUgn srcline                 $ \ src_loc ->
 817     wlkDataId   ccon            `thenUgn` \ con     ->
 818     wlkList     rdBangType ctys `thenUgn` \ tys     ->
 819     returnUgn (ConDecl con [] (VanillaCon tys) src_loc)
 820
 821 wlkConDecl (U_constrinf cty1 cop cty2 srcline)
 822   = mkSrcLocUgn srcline                 $ \ src_loc ->
 823     wlkBangType cty1            `thenUgn` \ ty1     ->
 824     wlkDataId   cop             `thenUgn` \ op      ->
 825     wlkBangType cty2            `thenUgn` \ ty2     ->
 826     returnUgn (ConDecl op [] (InfixCon ty1 ty2) src_loc)
 827
 828 wlkConDecl (U_constrnew ccon cty srcline)
 829   = mkSrcLocUgn srcline                 $ \ src_loc ->
 830     wlkDataId   ccon            `thenUgn` \ con     ->
 831     wlkMonoType cty             `thenUgn` \ ty      ->
 832     returnUgn (ConDecl con [] (NewCon ty) src_loc)
 833
 834 wlkConDecl (U_constrrec ccon cfields srcline)
 835   = mkSrcLocUgn srcline                 $ \ src_loc      ->
 836     wlkDataId   ccon            `thenUgn` \ con          ->
 837     wlkList rd_field cfields    `thenUgn` \ fields_lists ->
 838     returnUgn (ConDecl con [] (RecCon fields_lists) src_loc)
 839   where
 840     rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
 841     rd_field pt
 842       = rdU_constr pt           `thenUgn` \ (U_field fvars fty) ->
 843         wlkList rdVarId fvars   `thenUgn` \ vars ->
 844         wlkBangType fty         `thenUgn` \ ty ->
 845         returnUgn (vars, ty)
 846
 847 -----------------
 848 rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty
 849
 850 wlkBangType :: U_ttype -> UgnM (BangType RdrName)
 851
 852 wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty ->
 853                             returnUgn (Banged   ty)
 854 wlkBangType uty           = wlkMonoType uty `thenUgn` \ ty ->
 855                             returnUgn (Unbanged ty)
 856 \end{code}
 857
 858 %************************************************************************
 859 %*                                                                      *
 860 \subsection{Read a ``match''}
 861 %*                                                                      *
 862 %************************************************************************
 863
 864 \begin{code}
 865 rdMatch :: ParseTree -> UgnM RdrMatch
 866
 867 rdMatch pt
 868   = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind gsrcfun srcline) ->
 869     mkSrcLocUgn srcline                 $ \ src_loc      ->
 870     wlkPat      gpat            `thenUgn` \ pat     ->
 871     wlkBinding  gbind           `thenUgn` \ binding ->
 872     wlkVarId    gsrcfun         `thenUgn` \ srcfun  ->
 873     let
 874         wlk_guards (U_pnoguards exp)
 875           = wlkExpr exp `thenUgn` \ expr ->
 876             returnUgn (RdrMatch_NoGuard srcline srcfun pat expr binding)
 877
 878         wlk_guards (U_pguards gs)
 879           = wlkList rd_gd_expr gs   `thenUgn` \ gd_exps ->
 880             returnUgn (RdrMatch_Guards  srcline srcfun pat gd_exps binding)
 881     in
 882     wlk_guards gdexprs
 883   where
 884     rd_gd_expr pt
 885       = rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) ->
 886         wlkQuals     g  `thenUgn` \ guard ->
 887         wlkExpr      e  `thenUgn` \ expr  ->
 888         returnUgn (guard, expr)
 889 \end{code}
 890
 891 %************************************************************************
 892 %*                                                                      *
 893 \subsection[rdFixOp]{Read in a fixity declaration}
 894 %*                                                                      *
 895 %************************************************************************
 896
 897 \begin{code}
 898 rdFixOp :: ParseTree -> UgnM RdrNameFixityDecl
 899 rdFixOp pt
 900   = rdU_tree pt `thenUgn` \ fix ->
 901     case fix of
 902       U_fixop op dir_n prec -> wlkVarId op `thenUgn` \ op ->
 903                                        returnUgn (FixityDecl op (Fixity prec dir) noSrcLoc)
 904                                                 -- ToDo: add SrcLoc!
 905                             where
 906                               dir = case dir_n of
 907                                         (-1) -> InfixL
 908                                         0    -> InfixN
 909                                         1    -> InfixR
 910       _ -> error "ReadPrefix:rdFixOp"
 911 \end{code}
 912
 913 %************************************************************************
 914 %*                                                                      *
 915 \subsection[rdImport]{Read an import decl}
 916 %*                                                                      *
 917 %************************************************************************
 918
 919 \begin{code}
 920 rdImport :: ParseTree
 921          -> UgnM RdrNameImportDecl
 922
 923 rdImport pt
 924   = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec isrc srcline) ->
 925     mkSrcLocUgn srcline                         $ \ src_loc      ->
 926     wlkMaybe rdU_stringId ias           `thenUgn` \ maybe_as    ->
 927     wlkMaybe rd_spec ispec              `thenUgn` \ maybe_spec  ->
 928     returnUgn (ImportDecl imod (cvFlag iqual) (cvIfaceFlavour isrc) maybe_as maybe_spec src_loc)
 929   where
 930     rd_spec pt = rdU_either pt          `thenUgn` \ spec ->
 931       case spec of
 932         U_left pt  -> rdEntities pt     `thenUgn` \ ents ->
 933                       returnUgn (False, ents)
 934         U_right pt -> rdEntities pt     `thenUgn` \ ents ->
 935                       returnUgn (True, ents)
 936
 937 cvIfaceFlavour 0 = HiFile       -- No pragam
 938 cvIfaceFlavour 1 = HiBootFile   -- {-# SOURCE #-}
 939 \end{code}
 940
 941 \begin{code}
 942 rdEntities pt
 943   = rdU_list pt             `thenUgn` \ list ->
 944     wlkList rdEntity list
 945
 946 rdEntity :: ParseTree -> UgnM (IE RdrName)
 947
 948 rdEntity pt
 949   = rdU_entidt pt `thenUgn` \ entity ->
 950     case entity of
 951       U_entid evar ->           -- just a value
 952         wlkEntId        evar            `thenUgn` \ var ->
 953         returnUgn (IEVar var)
 954
 955       U_enttype x ->            -- abstract type constructor/class
 956         wlkTCId x               `thenUgn` \ thing ->
 957         returnUgn (IEThingAbs thing)
 958
 959       U_enttypeall x ->         -- non-abstract type constructor/class
 960         wlkTCId x               `thenUgn` \ thing ->
 961         returnUgn (IEThingAll thing)
 962
 963       U_enttypenamed x ns ->    -- non-abstract type constructor/class
 964                                 -- with specified constrs/methods
 965         wlkTCId x               `thenUgn` \ thing ->
 966         wlkList rdVarId ns      `thenUgn` \ names ->
 967         returnUgn (IEThingWith thing names)
 968
 969       U_entmod mod ->           -- everything provided unqualified by a module
 970         returnUgn (IEModuleContents mod)
 971 \end{code}
 972