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