ghc/compiler/reader/ReadPrefix.lhs

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