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