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