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