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