ghc/compiler/reader/ReadPrefix.lhs

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