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