ghc/compiler/reader/ReadPrefix.lhs

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