ghc/compiler/reader/ReadPrefix.lhs

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