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
  13 import UgenAll          -- all Yacc parser gumpff...
  14 import PrefixSyn        -- and various syntaxen.
  15 import HsSyn
  16 import HsPragmas        ( noDataPragmas, noClassPragmas, noInstancePragmas )
  17 import RdrHsSyn
  18 import PrefixToHs
  19
  20 import ErrUtils         ( addErrLoc, ghcExit )
  21 import FiniteMap        ( elemFM, FiniteMap )
  22 import Name             ( RdrName(..), isRdrLexConOrSpecial, preludeQual )
  23 import PprStyle         ( PprStyle(..) )
  24 import PrelMods         ( pRELUDE )
  25 import Pretty
  26 import SrcLoc           ( SrcLoc )
  27 import Util             ( nOfThem, pprError, panic )
  28 \end{code}
  29
  30 %************************************************************************
  31 %*                                                                      *
  32 \subsection[ReadPrefix-help]{Help Functions}
  33 %*                                                                      *
  34 %************************************************************************
  35
  36 \begin{code}
  37 wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a]
  38
  39 wlkList wlk_it U_lnil = returnUgn []
  40
  41 wlkList wlk_it (U_lcons hd tl)
  42   = wlk_it  hd          `thenUgn` \ hd_it ->
  43     wlkList wlk_it tl   `thenUgn` \ tl_it ->
  44     returnUgn (hd_it : tl_it)
  45 \end{code}
  46
  47 \begin{code}
  48 wlkMaybe :: (U_VOID_STAR -> UgnM a) -> U_maybe -> UgnM (Maybe a)
  49
  50 wlkMaybe wlk_it U_nothing  = returnUgn Nothing
  51 wlkMaybe wlk_it (U_just x)
  52   = wlk_it  x           `thenUgn` \ it ->
  53     returnUgn (Just it)
  54 \end{code}
  55
  56 \begin{code}
  57 rdQid   :: ParseTree -> UgnM RdrName
  58 rdQid pt = rdU_qid pt `thenUgn` \ qid -> wlkQid qid
  59
  60 wlkQid  :: U_qid -> UgnM RdrName
  61 wlkQid (U_noqual name)
  62   = returnUgn (Unqual name)
  63 wlkQid (U_aqual  mod name)
  64   = returnUgn (Qual mod name)
  65 wlkQid (U_gid n name)
  66   = returnUgn (preludeQual name)
  67
  68 cvFlag :: U_long -> Bool
  69 cvFlag 0 = False
  70 cvFlag 1 = True
  71 \end{code}
  72
  73 %************************************************************************
  74 %*                                                                      *
  75 \subsection[rdModule]{@rdModule@: reads in a Haskell module}
  76 %*                                                                      *
  77 %************************************************************************
  78
  79 \begin{code}
  80 rdModule :: IO (Module,             -- this module's name
  81                 RdrNameHsModule)    -- the main goods
  82
  83 rdModule
  84   = _ccall_ hspmain `thenPrimIO` \ pt -> -- call the Yacc parser!
  85     let
  86         srcfile  = _packCString ``input_filename'' -- What A Great Hack! (TM)
  87     in
  88     initUgn               $
  89     rdU_tree pt `thenUgn` \ (U_hmodule modname himplist hexplist hfixlist
  90                                        hmodlist srciface_version srcline) ->
  91
  92     setSrcFileUgn srcfile $
  93     setSrcModUgn  modname $
  94     mkSrcLocUgn srcline   $                         \ src_loc   ->
  95
  96     wlkMaybe rdEntities          hexplist `thenUgn` \ exports   ->
  97     wlkList  rdImport            himplist `thenUgn` \ imports   ->
  98     wlkList  rdFixOp             hfixlist `thenUgn` \ fixities  ->
  99     wlkBinding                   hmodlist `thenUgn` \ binding   ->
 100
 101     case sepDeclsForTopBinds binding of
 102     (tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) ->
 103
 104       returnUgn (modname,
 105                  HsModule modname
 106                           (case srciface_version of { 0 -> Nothing; n -> Just n })
 107                           exports
 108                           imports
 109                           fixities
 110                           tydecls
 111                           tysigs
 112                           classdecls
 113                           instdecls
 114                           instsigs
 115                           defaultdecls
 116                           (cvSepdBinds srcfile cvValSig binds)
 117                           [{-no interface sigs yet-}]
 118                           src_loc
 119                 )
 120 \end{code}
 121
 122 %************************************************************************
 123 %*                                                                      *
 124 \subsection[wlkExprOrPat]{@wlkExpr@ and @wlkPat@}
 125 %*                                                                      *
 126 %************************************************************************
 127
 128 \begin{code}
 129 rdExpr :: ParseTree -> UgnM RdrNameHsExpr
 130 rdPat  :: ParseTree -> UgnM RdrNamePat
 131
 132 rdExpr pt = rdU_tree pt `thenUgn` \ tree -> wlkExpr tree
 133 rdPat  pt = rdU_tree pt `thenUgn` \ tree -> wlkPat  tree
 134
 135 wlkExpr :: U_tree -> UgnM RdrNameHsExpr
 136 wlkPat  :: U_tree -> UgnM RdrNamePat
 137
 138 wlkExpr expr
 139   = case expr of
 140       U_par pexpr -> -- parenthesised expr
 141         wlkExpr pexpr   `thenUgn` \ expr ->
 142         returnUgn (HsPar expr)
 143
 144       U_lsection lsexp lop -> -- left section
 145         wlkExpr lsexp   `thenUgn` \ expr ->
 146         wlkQid  lop     `thenUgn` \ op   ->
 147         returnUgn (SectionL expr (HsVar op))
 148
 149       U_rsection rop rsexp -> -- right section
 150         wlkQid  rop     `thenUgn` \ op   ->
 151         wlkExpr rsexp   `thenUgn` \ expr ->
 152         returnUgn (SectionR (HsVar op) expr)
 153
 154       U_ccall fun flavor ccargs -> -- ccall/casm
 155         wlkList rdExpr ccargs   `thenUgn` \ args ->
 156         let
 157             tag = _HEAD_ flavor
 158         in
 159         returnUgn (CCall fun args
 160                     (tag == 'p' || tag == 'P') -- may invoke GC
 161                     (tag == 'N' || tag == 'P') -- really a "casm"
 162                     (panic "CCall:result_ty"))
 163
 164       U_scc label sccexp -> -- scc (set-cost-centre) expression
 165         wlkExpr   sccexp        `thenUgn` \ expr  ->
 166         returnUgn (HsSCC label expr)
 167
 168       U_lambda lampats lamexpr srcline -> -- lambda expression
 169         mkSrcLocUgn   srcline           $ \ src_loc ->
 170         wlkList rdPat lampats   `thenUgn` \ pats ->
 171         wlkExpr       lamexpr   `thenUgn` \ body ->
 172         returnUgn (
 173             HsLam (foldr PatMatch
 174                          (GRHSMatch (GRHSsAndBindsIn
 175                                       [OtherwiseGRHS body src_loc]
 176                                       EmptyBinds))
 177                          pats)
 178         )
 179
 180       U_casee caseexpr casebody srcline ->      -- case expression
 181         mkSrcLocUgn srcline              $ \ src_loc ->
 182         wlkExpr         caseexpr `thenUgn` \ expr ->
 183         wlkList rdMatch casebody `thenUgn` \ mats ->
 184         getSrcFileUgn            `thenUgn` \ sf ->
 185         let
 186             matches = cvMatches sf True mats
 187         in
 188         returnUgn (HsCase expr matches src_loc)
 189
 190       U_ife ifpred ifthen ifelse srcline ->     -- if expression
 191         mkSrcLocUgn srcline             $ \ src_loc ->
 192         wlkExpr ifpred          `thenUgn` \ e1 ->
 193         wlkExpr ifthen          `thenUgn` \ e2 ->
 194         wlkExpr ifelse          `thenUgn` \ e3 ->
 195         returnUgn (HsIf e1 e2 e3 src_loc)
 196
 197       U_let letvdefs letvexpr ->                -- let expression
 198         wlkBinding letvdefs     `thenUgn` \ binding ->
 199         wlkExpr    letvexpr     `thenUgn` \ expr    ->
 200         getSrcFileUgn           `thenUgn` \ sf      ->
 201         let
 202             binds = cvBinds sf cvValSig binding
 203         in
 204         returnUgn (HsLet binds expr)
 205
 206       U_doe gdo srcline ->                      -- do expression
 207         mkSrcLocUgn srcline             $ \ src_loc ->
 208         wlkList rd_stmt gdo     `thenUgn` \ stmts ->
 209         returnUgn (HsDo stmts src_loc)
 210         where
 211         rd_stmt pt
 212           = rdU_tree pt `thenUgn` \ bind ->
 213             case bind of
 214               U_doexp exp srcline ->
 215                 mkSrcLocUgn srcline             $ \ src_loc ->
 216                 wlkExpr exp             `thenUgn` \ expr ->
 217                 returnUgn (ExprStmt expr src_loc)
 218
 219               U_dobind pat exp srcline ->
 220                 mkSrcLocUgn srcline             $ \ src_loc ->
 221                 wlkPat  pat             `thenUgn` \ patt ->
 222                 wlkExpr exp             `thenUgn` \ expr ->
 223                 returnUgn (BindStmt patt expr src_loc)
 224
 225               U_seqlet seqlet ->
 226                 wlkBinding seqlet       `thenUgn` \ bs ->
 227                 getSrcFileUgn           `thenUgn` \ sf ->
 228                 let
 229                     binds = cvBinds sf cvValSig bs
 230                 in
 231                 returnUgn (LetStmt binds)
 232
 233       U_comprh cexp cquals -> -- list comprehension
 234         wlkExpr cexp            `thenUgn` \ expr  ->
 235         wlkList rd_qual cquals  `thenUgn` \ quals ->
 236         returnUgn (ListComp expr quals)
 237         where
 238           rd_qual pt
 239             = rdU_tree pt       `thenUgn` \ qual ->
 240               wlk_qual qual
 241
 242           wlk_qual qual
 243             = case qual of
 244                 U_guard exp ->
 245                   wlkExpr exp   `thenUgn` \ expr ->
 246                   returnUgn (FilterQual expr)
 247
 248                 U_qual qpat qexp ->
 249                   wlkPat  qpat  `thenUgn` \ pat  ->
 250                   wlkExpr qexp  `thenUgn` \ expr ->
 251                   returnUgn (GeneratorQual pat expr)
 252
 253                 U_seqlet seqlet ->
 254                   wlkBinding seqlet     `thenUgn` \ bs ->
 255                   getSrcFileUgn         `thenUgn` \ sf ->
 256                   let
 257                       binds = cvBinds sf cvValSig bs
 258                   in
 259                   returnUgn (LetQual binds)
 260
 261       U_eenum efrom estep eto -> -- arithmetic sequence
 262         wlkExpr efrom           `thenUgn` \ e1  ->
 263         wlkMaybe rdExpr estep   `thenUgn` \ es2 ->
 264         wlkMaybe rdExpr eto     `thenUgn` \ es3 ->
 265         returnUgn (cv_arith_seq e1 es2 es3)
 266         where
 267            cv_arith_seq e1 Nothing   Nothing   = ArithSeqIn (From       e1)
 268            cv_arith_seq e1 Nothing   (Just e3) = ArithSeqIn (FromTo     e1 e3)
 269            cv_arith_seq e1 (Just e2) Nothing   = ArithSeqIn (FromThen   e1 e2)
 270            cv_arith_seq e1 (Just e2) (Just e3) = ArithSeqIn (FromThenTo e1 e2 e3)
 271
 272       U_restr restre restrt ->  -- expression with type signature
 273         wlkExpr     restre      `thenUgn` \ expr ->
 274         wlkPolyType restrt      `thenUgn` \ ty   ->
 275         returnUgn (ExprWithTySig expr ty)
 276
 277       --------------------------------------------------------------
 278       -- now the prefix items that can either be an expression or
 279       -- pattern, except we know they are *expressions* here
 280       -- (this code could be commoned up with the pattern version;
 281       -- but it probably isn't worth it)
 282       --------------------------------------------------------------
 283       U_lit lit ->
 284         wlkLiteral lit  `thenUgn` \ lit ->
 285         returnUgn (HsLit lit)
 286
 287       U_ident n ->                      -- simple identifier
 288         wlkQid n        `thenUgn` \ var ->
 289         returnUgn (HsVar var)
 290
 291       U_ap fun arg ->                   -- application
 292         wlkExpr fun     `thenUgn` \ expr1 ->
 293         wlkExpr arg     `thenUgn` \ expr2 ->
 294         returnUgn (HsApp expr1 expr2)
 295
 296       U_infixap fun arg1 arg2 ->        -- infix application
 297         wlkQid  fun     `thenUgn` \ op    ->
 298         wlkExpr arg1    `thenUgn` \ expr1 ->
 299         wlkExpr arg2    `thenUgn` \ expr2 ->
 300         returnUgn (OpApp expr1 (HsVar op) expr2)
 301
 302       U_negate nexp ->                  -- prefix negation
 303         wlkExpr nexp    `thenUgn` \ expr ->
 304         -- this is a hack
 305         let
 306             rdr = preludeQual SLIT("negate")
 307         in
 308         returnUgn (NegApp expr (HsVar rdr))
 309
 310       U_llist llist -> -- explicit list
 311         wlkList rdExpr llist `thenUgn` \ exprs ->
 312         returnUgn (ExplicitList exprs)
 313
 314       U_tuple tuplelist -> -- explicit tuple
 315         wlkList rdExpr tuplelist `thenUgn` \ exprs ->
 316         returnUgn (ExplicitTuple exprs)
 317
 318       U_record con rbinds -> -- record construction
 319         wlkQid  con             `thenUgn` \ rcon     ->
 320         wlkList rdRbind rbinds  `thenUgn` \ recbinds ->
 321         returnUgn (RecordCon (HsVar rcon) recbinds)
 322
 323       U_rupdate updexp updbinds -> -- record update
 324         wlkExpr updexp           `thenUgn` \ aexp ->
 325         wlkList rdRbind updbinds `thenUgn` \ recbinds ->
 326         returnUgn (RecordUpd aexp recbinds)
 327
 328 #ifdef DEBUG
 329       U_hmodule _ _ _ _ _ _ _ -> error "U_hmodule"
 330       U_as _ _                -> error "U_as"
 331       U_lazyp _               -> error "U_lazyp"
 332       U_wildp                 -> error "U_wildp"
 333       U_qual _ _              -> error "U_qual"
 334       U_guard _               -> error "U_guard"
 335       U_seqlet _              -> error "U_seqlet"
 336       U_dobind _ _ _          -> error "U_dobind"
 337       U_doexp _ _             -> error "U_doexp"
 338       U_rbind _ _             -> error "U_rbind"
 339       U_fixop _ _ _           -> error "U_fixop"
 340 #endif
 341
 342 rdRbind pt
 343   = rdU_tree pt         `thenUgn` \ (U_rbind var exp) ->
 344     wlkQid   var        `thenUgn` \ rvar ->
 345     wlkMaybe rdExpr exp `thenUgn` \ expr_maybe ->
 346     returnUgn (
 347       case expr_maybe of
 348         Nothing -> (rvar, HsVar rvar, True{-pun-})
 349         Just re -> (rvar, re,         False)
 350     )
 351 \end{code}
 352
 353 Patterns: just bear in mind that lists of patterns are represented as
 354 a series of ``applications''.
 355 \begin{code}
 356 wlkPat pat
 357   = case pat of
 358       U_par ppat ->                     -- parenthesised pattern
 359         wlkPat ppat     `thenUgn` \ pat ->
 360         -- tidy things up a little:
 361         returnUgn (
 362         case pat of
 363           VarPatIn _ -> pat
 364           WildPatIn  -> pat
 365           other      -> ParPatIn pat
 366         )
 367
 368       U_as avar as_pat ->               -- "as" pattern
 369         wlkQid avar     `thenUgn` \ var ->
 370         wlkPat as_pat   `thenUgn` \ pat ->
 371         returnUgn (AsPatIn var pat)
 372
 373       U_lazyp lazyp ->                  -- irrefutable ("twiddle") pattern
 374         wlkPat lazyp    `thenUgn` \ pat ->
 375         returnUgn (LazyPatIn pat)
 376
 377       U_wildp -> returnUgn WildPatIn    -- wildcard pattern
 378
 379       U_lit lit ->                      -- literal pattern
 380         wlkLiteral lit  `thenUgn` \ lit ->
 381         returnUgn (LitPatIn lit)
 382
 383       U_ident nn ->                     -- simple identifier
 384         wlkQid nn       `thenUgn` \ n ->
 385         returnUgn (
 386           if isRdrLexConOrSpecial n
 387           then ConPatIn n []
 388           else VarPatIn n
 389         )
 390
 391       U_ap l r ->       -- "application": there's a list of patterns lurking here!
 392         wlkPat r                `thenUgn` \ rpat         ->
 393         collect_pats l [rpat]   `thenUgn` \ (lpat,lpats) ->
 394         (case lpat of
 395             VarPatIn x        -> returnUgn (x,  lpats)
 396             ConPatIn x []     -> returnUgn (x,  lpats)
 397             ConOpPatIn x op y -> returnUgn (op, x:y:lpats)
 398             _ -> getSrcLocUgn   `thenUgn` \ loc ->
 399                  let
 400                      err = addErrLoc loc "Illegal pattern `application'"
 401                                      (\sty -> ppInterleave ppSP (map (ppr sty) (lpat:lpats)))
 402                      msg = ppShow 100 (err PprForUser)
 403                  in
 404                  ioToUgnM  (hPutStr stderr msg) `thenUgn` \ _ ->
 405                  ioToUgnM  (ghcExit 1)          `thenUgn` \ _ ->
 406                  returnUgn (error "ReadPrefix")
 407
 408         )                       `thenUgn` \ (n, arg_pats) ->
 409         returnUgn (ConPatIn n arg_pats)
 410         where
 411           collect_pats pat acc
 412             = case pat of
 413                 U_ap l r ->
 414                   wlkPat r      `thenUgn` \ rpat  ->
 415                   collect_pats l (rpat:acc)
 416                 other ->
 417                   wlkPat other  `thenUgn` \ pat ->
 418                   returnUgn (pat,acc)
 419
 420       U_infixap fun arg1 arg2 ->        -- infix pattern
 421         wlkQid fun      `thenUgn` \ op   ->
 422         wlkPat arg1     `thenUgn` \ pat1 ->
 423         wlkPat arg2     `thenUgn` \ pat2 ->
 424         returnUgn (ConOpPatIn pat1 op pat2)
 425
 426       U_negate npat ->                  -- negated pattern
 427         wlkPat npat     `thenUgn` \ pat ->
 428         returnUgn (NegPatIn pat)
 429
 430       U_llist llist ->                  -- explicit list
 431         wlkList rdPat llist     `thenUgn` \ pats ->
 432         returnUgn (ListPatIn pats)
 433
 434       U_tuple tuplelist ->              -- explicit tuple
 435         wlkList rdPat tuplelist `thenUgn` \ pats ->
 436         returnUgn (TuplePatIn pats)
 437
 438       U_record con rpats ->             -- record destruction
 439         wlkQid  con             `thenUgn` \ rcon     ->
 440         wlkList rdRpat rpats    `thenUgn` \ recpats ->
 441         returnUgn (RecPatIn rcon recpats)
 442         where
 443           rdRpat pt
 444             = rdU_tree pt        `thenUgn` \ (U_rbind var pat) ->
 445               wlkQid   var       `thenUgn` \ rvar ->
 446               wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
 447               returnUgn (
 448                 case pat_maybe of
 449                   Nothing -> (rvar, VarPatIn rvar, True{-pun-})
 450                   Just rp -> (rvar, rp,            False)
 451               )
 452 \end{code}
 453
 454 \begin{code}
 455 wlkLiteral :: U_literal -> UgnM HsLit
 456
 457 wlkLiteral ulit
 458   = returnUgn (
 459     case ulit of
 460       U_integer    s -> HsInt        (as_integer  s)
 461       U_floatr     s -> HsFrac       (as_rational s)
 462       U_intprim    s -> HsIntPrim    (as_integer  s)
 463       U_doubleprim s -> HsDoublePrim (as_rational s)
 464       U_floatprim  s -> HsFloatPrim  (as_rational s)
 465       U_charr      s -> HsChar       (as_char     s)
 466       U_charprim   s -> HsCharPrim   (as_char     s)
 467       U_string     s -> HsString     (as_string   s)
 468       U_stringprim s -> HsStringPrim (as_string   s)
 469       U_clitlit    s -> HsLitLit     (as_string   s)
 470     )
 471   where
 472     as_char s     = _HEAD_ s
 473     as_integer s  = readInteger (_UNPK_ s)
 474     as_rational s = _readRational (_UNPK_ s) -- non-std
 475     as_string s   = s
 476 \end{code}
 477
 478 %************************************************************************
 479 %*                                                                      *
 480 \subsection{wlkBinding}
 481 %*                                                                      *
 482 %************************************************************************
 483
 484 \begin{code}
 485 wlkBinding :: U_binding -> UgnM RdrBinding
 486
 487 wlkBinding binding
 488   = case binding of
 489         -- null binding
 490       U_nullbind ->
 491         returnUgn RdrNullBind
 492
 493         -- "and" binding (just glue, really)
 494       U_abind a b ->
 495         wlkBinding a    `thenUgn` \ binding1 ->
 496         wlkBinding b    `thenUgn` \ binding2 ->
 497         returnUgn (RdrAndBindings binding1 binding2)
 498
 499         -- "data" declaration
 500       U_tbind tctxt ttype tcons tderivs srcline ->
 501         mkSrcLocUgn        srcline          $ \ src_loc     ->
 502         wlkContext         tctxt    `thenUgn` \ ctxt        ->
 503         wlkTyConAndTyVars  ttype    `thenUgn` \ (tycon, tyvars) ->
 504         wlkList rdConDecl  tcons    `thenUgn` \ cons        ->
 505         wlkDerivings       tderivs  `thenUgn` \ derivings   ->
 506         returnUgn (RdrTyDecl (TyData ctxt tycon tyvars cons derivings noDataPragmas src_loc))
 507
 508         -- "newtype" declaration
 509       U_ntbind ntctxt nttype ntcon ntderivs srcline ->
 510         mkSrcLocUgn        srcline          $ \ src_loc     ->
 511         wlkContext         ntctxt   `thenUgn` \ ctxt        ->
 512         wlkTyConAndTyVars  nttype   `thenUgn` \ (tycon, tyvars) ->
 513         wlkList rdConDecl  ntcon    `thenUgn` \ con         ->
 514         wlkDerivings       ntderivs `thenUgn` \ derivings   ->
 515         returnUgn (RdrTyDecl (TyNew ctxt tycon tyvars con derivings noDataPragmas src_loc))
 516
 517         -- "type" declaration
 518       U_nbind nbindid nbindas srcline ->
 519         mkSrcLocUgn       srcline         $ \ src_loc       ->
 520         wlkTyConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
 521         wlkMonoType       nbindas `thenUgn` \ expansion     ->
 522         returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc))
 523
 524         -- function binding
 525       U_fbind fbindl srcline ->
 526         mkSrcLocUgn     srcline         $ \ src_loc ->
 527         wlkList rdMatch fbindl  `thenUgn` \ matches ->
 528         returnUgn (RdrFunctionBinding srcline matches)
 529
 530         -- pattern binding
 531       U_pbind pbindl srcline ->
 532         mkSrcLocUgn     srcline         $ \ src_loc ->
 533         wlkList rdMatch pbindl  `thenUgn` \ matches ->
 534         returnUgn (RdrPatternBinding srcline matches)
 535
 536         -- "class" declaration
 537       U_cbind cbindc cbindid cbindw srcline ->
 538         mkSrcLocUgn      srcline        $ \ src_loc       ->
 539         wlkContext       cbindc  `thenUgn` \ ctxt         ->
 540         wlkClassAssertTy cbindid `thenUgn` \ (clas, tyvar)->
 541         wlkBinding       cbindw  `thenUgn` \ binding      ->
 542         getSrcFileUgn            `thenUgn` \ sf           ->
 543         let
 544             (class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding
 545
 546             final_sigs    = concat (map cvClassOpSig class_sigs)
 547             final_methods = cvMonoBinds sf class_methods
 548         in
 549         returnUgn (RdrClassDecl
 550           (ClassDecl ctxt clas tyvar final_sigs final_methods noClassPragmas src_loc))
 551
 552         -- "instance" declaration
 553       U_ibind ibindc iclas ibindi ibindw srcline ->
 554         mkSrcLocUgn     srcline         $ \ src_loc ->
 555         wlkContext      ibindc  `thenUgn` \ ctxt    ->
 556         wlkQid          iclas   `thenUgn` \ clas    ->
 557         wlkMonoType     ibindi  `thenUgn` \ inst_ty ->
 558         wlkBinding      ibindw  `thenUgn` \ binding ->
 559         getSrcModUgn            `thenUgn` \ modname ->
 560         getSrcFileUgn           `thenUgn` \ sf      ->
 561         let
 562             (ss, bs)  = sepDeclsIntoSigsAndBinds binding
 563             binds     = cvMonoBinds sf bs
 564             uprags    = concat (map cvInstDeclSig ss)
 565             ctxt_inst_ty = HsPreForAllTy ctxt inst_ty
 566         in
 567         returnUgn (RdrInstDecl
 568           (InstDecl clas ctxt_inst_ty binds True modname 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 ->
 794                             returnUgn (Banged   (HsPreForAllTy [] ty))
 795 wlkBangType uty           = wlkMonoType uty `thenUgn` \ ty ->
 796                             returnUgn (Unbanged (HsPreForAllTy [] ty))
 797 \end{code}
 798
 799 %************************************************************************
 800 %*                                                                      *
 801 \subsection{Read a ``match''}
 802 %*                                                                      *
 803 %************************************************************************
 804
 805 \begin{code}
 806 rdMatch :: ParseTree -> UgnM RdrMatch
 807
 808 rdMatch pt
 809   = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind gsrcfun srcline) ->
 810     mkSrcLocUgn srcline                 $ \ src_loc      ->
 811     wlkPat      gpat            `thenUgn` \ pat     ->
 812     wlkBinding  gbind           `thenUgn` \ binding ->
 813     wlkQid      gsrcfun         `thenUgn` \ srcfun  ->
 814     let
 815         wlk_guards (U_pnoguards exp)
 816           = wlkExpr exp `thenUgn` \ expr ->
 817             returnUgn (RdrMatch_NoGuard srcline srcfun pat expr binding)
 818
 819         wlk_guards (U_pguards gs)
 820           = wlkList rd_gd_expr gs   `thenUgn` \ gd_exps ->
 821             returnUgn (RdrMatch_Guards  srcline srcfun pat gd_exps binding)
 822     in
 823     wlk_guards gdexprs
 824   where
 825     rd_gd_expr pt
 826       = rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) ->
 827         wlkExpr      g  `thenUgn` \ guard ->
 828         wlkExpr      e  `thenUgn` \ expr  ->
 829         returnUgn (guard, expr)
 830 \end{code}
 831
 832 %************************************************************************
 833 %*                                                                      *
 834 \subsection[rdFixOp]{Read in a fixity declaration}
 835 %*                                                                      *
 836 %************************************************************************
 837
 838 \begin{code}
 839 rdFixOp :: ParseTree -> UgnM RdrNameFixityDecl
 840 rdFixOp pt
 841   = rdU_tree pt `thenUgn` \ fix ->
 842     case fix of
 843       U_fixop op (-1) prec -> wlkQid op `thenUgn` \ op ->
 844                                        returnUgn (InfixL op prec)
 845       U_fixop op   0  prec -> wlkQid op `thenUgn` \ op ->
 846                                        returnUgn (InfixN op prec)
 847       U_fixop op   1  prec -> wlkQid op `thenUgn` \ op ->
 848                                        returnUgn (InfixR op prec)
 849       _ -> error "ReadPrefix:rdFixOp"
 850 \end{code}
 851
 852 %************************************************************************
 853 %*                                                                      *
 854 \subsection[rdImport]{Read an import decl}
 855 %*                                                                      *
 856 %************************************************************************
 857
 858 \begin{code}
 859 rdImport :: ParseTree
 860          -> UgnM RdrNameImportDecl
 861
 862 rdImport pt
 863   = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec srcline) ->
 864     mkSrcLocUgn srcline                         $ \ src_loc      ->
 865     wlkMaybe rdU_stringId ias           `thenUgn` \ maybe_as    ->
 866     wlkMaybe rd_spec ispec              `thenUgn` \ maybe_spec  ->
 867     returnUgn (ImportDecl imod (cvFlag iqual) maybe_as maybe_spec src_loc)
 868   where
 869     rd_spec pt = rdU_either pt          `thenUgn` \ spec ->
 870       case spec of
 871         U_left pt  -> rdEntities pt     `thenUgn` \ ents ->
 872                       returnUgn (False, ents)
 873         U_right pt -> rdEntities pt     `thenUgn` \ ents ->
 874                       returnUgn (True, ents)
 875 \end{code}
 876
 877 \begin{code}
 878 rdEntities pt
 879   = rdU_list pt             `thenUgn` \ list ->
 880     wlkList rdEntity list
 881
 882 rdEntity :: ParseTree -> UgnM (IE RdrName)
 883
 884 rdEntity pt
 885   = rdU_entidt pt `thenUgn` \ entity ->
 886     case entity of
 887       U_entid evar ->           -- just a value
 888         wlkQid  evar            `thenUgn` \ var ->
 889         returnUgn (IEVar var)
 890
 891       U_enttype x ->            -- abstract type constructor/class
 892         wlkQid  x               `thenUgn` \ thing ->
 893         returnUgn (IEThingAbs thing)
 894
 895       U_enttypeall x ->         -- non-abstract type constructor/class
 896         wlkQid  x               `thenUgn` \ thing ->
 897         returnUgn (IEThingAll thing)
 898
 899       U_enttypenamed x ns ->    -- non-abstract type constructor/class
 900                                 -- with specified constrs/methods
 901         wlkQid  x               `thenUgn` \ thing ->
 902         wlkList rdQid ns        `thenUgn` \ names ->
 903         returnUgn (IEThingWith thing names)
 904
 905       U_entmod mod ->           -- everything provided unqualified by a module
 906         returnUgn (IEModuleContents mod)
 907 \end{code}
 908