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