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