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