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