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, 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 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 (rvar, expr_maybe)
 356 \end{code}
 357
 358 Patterns: just bear in mind that lists of patterns are represented as
 359 a series of ``applications''.
 360 \begin{code}
 361 wlkPat pat
 362   = case pat of
 363       U_par pat ->                      -- parenthesised pattern
 364         wlkPat pat
 365
 366       U_as avar as_pat ->               -- "as" pattern
 367         wlkQid avar     `thenUgn` \ var ->
 368         wlkPat as_pat   `thenUgn` \ pat ->
 369         returnUgn (AsPatIn var pat)
 370
 371       U_lazyp lazyp ->                  -- irrefutable ("twiddle") pattern
 372         wlkPat lazyp    `thenUgn` \ pat ->
 373         returnUgn (LazyPatIn pat)
 374
 375       U_wildp -> returnUgn WildPatIn    -- wildcard pattern
 376
 377       --------------------------------------------------------------
 378       -- now the prefix items that can either be an expression or
 379       -- pattern, except we know they are *patterns* here.
 380       --------------------------------------------------------------
 381       U_negate nexp _ _ ->              -- negated pattern: must be a literal
 382         wlkPat nexp     `thenUgn` \ lit_pat ->
 383         case lit_pat of
 384           LitPatIn lit -> returnUgn (LitPatIn (negLiteral lit))
 385           _            -> panic "wlkPat: bad negated pattern!"
 386
 387       U_lit lit ->                      -- literal pattern
 388         wlkLiteral lit  `thenUgn` \ lit ->
 389         returnUgn (LitPatIn lit)
 390
 391       U_ident nn ->                     -- simple identifier
 392         wlkQid nn       `thenUgn` \ n ->
 393         returnUgn (
 394           if isConopPN n
 395           then ConPatIn n []
 396           else VarPatIn n
 397         )
 398
 399       U_ap l r ->       -- "application": there's a list of patterns lurking here!
 400         wlkPat r                `thenUgn` \ rpat         ->
 401         collect_pats l [rpat]   `thenUgn` \ (lpat,lpats) ->
 402         let
 403             (n, arg_pats)
 404               = case lpat of
 405                   VarPatIn x        -> (x,  lpats)
 406                   ConPatIn x []     -> (x,  lpats)
 407                   ConOpPatIn x op y -> (op, x:y:lpats)
 408                   _ -> -- sorry about the weedy msg; the parser missed this one
 409                        error (ppShow 100 (ppCat [
 410                            ppStr "ERROR: an illegal `application' of a pattern to another one:",
 411                            ppInterleave ppSP (map (ppr PprForUser) (lpat:lpats))]))
 412         in
 413         returnUgn (ConPatIn n arg_pats)
 414         where
 415           collect_pats pat acc
 416             = case pat of
 417                 U_ap l r ->
 418                   wlkPat r      `thenUgn` \ rpat  ->
 419                   collect_pats l (rpat:acc)
 420                 other ->
 421                   wlkPat other  `thenUgn` \ pat ->
 422                   returnUgn (pat,acc)
 423
 424       U_infixap fun arg1 arg2 ->
 425         wlkQid fun      `thenUgn` \ op   ->
 426         wlkPat arg1     `thenUgn` \ pat1 ->
 427         wlkPat arg2     `thenUgn` \ pat2 ->
 428         returnUgn (ConOpPatIn pat1 op pat2)
 429
 430       U_llist llist ->                  -- explicit list
 431         wlkList rdPat llist     `thenUgn` \ pats ->
 432         returnUgn (ListPatIn pats)
 433
 434       U_tuple tuplelist ->              -- explicit tuple
 435         wlkList rdPat tuplelist `thenUgn` \ pats ->
 436         returnUgn (TuplePatIn pats)
 437
 438       U_record con rpats ->             -- record destruction
 439         wlkQid  con             `thenUgn` \ rcon     ->
 440         wlkList rdRpat rpats    `thenUgn` \ recpats ->
 441         returnUgn (RecPatIn rcon recpats)
 442         where
 443           rdRpat pt
 444             = rdU_tree pt        `thenUgn` \ (U_rbind var pat) ->
 445               wlkQid   var       `thenUgn` \ rvar ->
 446               wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
 447               returnUgn (rvar, pat_maybe)
 448 \end{code}
 449
 450 \begin{code}
 451 wlkLiteral :: U_literal -> UgnM HsLit
 452
 453 wlkLiteral ulit
 454   = returnUgn (
 455     case ulit of
 456       U_integer    s   -> HsInt        (as_integer  s)
 457       U_floatr     s   -> HsFrac       (as_rational s)
 458       U_intprim    s   -> HsIntPrim    (as_integer  s)
 459       U_doubleprim s   -> HsDoublePrim (as_rational s)
 460       U_floatprim  s   -> HsFloatPrim  (as_rational s)
 461       U_charr      s   -> HsChar       (as_char     s)
 462       U_charprim   s   -> HsCharPrim   (as_char     s)
 463       U_string     s   -> HsString     (as_string   s)
 464       U_stringprim s   -> HsStringPrim (as_string   s)
 465       U_clitlit    s _ -> HsLitLit     (as_string   s)
 466     )
 467   where
 468     as_char s     = _HEAD_ s
 469     as_integer s  = readInteger (_UNPK_ s)
 470     as_rational s = _readRational (_UNPK_ s) -- non-std
 471     as_string s   = s
 472 \end{code}
 473
 474 %************************************************************************
 475 %*                                                                      *
 476 \subsection{wlkBinding}
 477 %*                                                                      *
 478 %************************************************************************
 479
 480 \begin{code}
 481 wlkBinding :: U_binding -> UgnM RdrBinding
 482
 483 wlkBinding binding
 484   = case binding of
 485       U_nullbind -> -- null binding
 486         returnUgn RdrNullBind
 487
 488       U_abind a b -> -- "and" binding (just glue, really)
 489         wlkBinding a    `thenUgn` \ binding1 ->
 490         wlkBinding b    `thenUgn` \ binding2 ->
 491         returnUgn (RdrAndBindings binding1 binding2)
 492
 493       U_tbind tctxt ttype tcons tderivs srcline tpragma -> -- "data" declaration
 494         wlkContext         tctxt    `thenUgn` \ ctxt        ->
 495         wlkTyConAndTyVars  ttype    `thenUgn` \ (tycon, tyvars) ->
 496         wlkList rdConDecl  tcons    `thenUgn` \ cons        ->
 497         wlkDerivings       tderivs  `thenUgn` \ derivings   ->
 498         wlkDataPragma      tpragma  `thenUgn` \ pragmas     ->
 499         mkSrcLocUgn        srcline  `thenUgn` \ src_loc     ->
 500         returnUgn (RdrTyDecl (TyData ctxt tycon tyvars cons derivings pragmas src_loc))
 501
 502       U_ntbind ntctxt nttype ntcon ntderivs srcline ntpragma -> -- "newtype" declaration
 503         wlkContext         ntctxt   `thenUgn` \ ctxt        ->
 504         wlkTyConAndTyVars  nttype   `thenUgn` \ (tycon, tyvars) ->
 505         wlkList rdConDecl  ntcon    `thenUgn` \ con         ->
 506         wlkDerivings       ntderivs `thenUgn` \ derivings   ->
 507         wlkDataPragma      ntpragma `thenUgn` \ pragma      ->
 508         mkSrcLocUgn        srcline  `thenUgn` \ src_loc     ->
 509         returnUgn (RdrTyDecl (TyNew ctxt tycon tyvars con derivings pragma src_loc))
 510
 511       U_nbind nbindid nbindas srcline -> -- "type" declaration
 512         wlkTyConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
 513         wlkMonoType       nbindas `thenUgn` \ expansion     ->
 514         mkSrcLocUgn       srcline `thenUgn` \ src_loc       ->
 515         returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc))
 516
 517       U_fbind fbindl srcline -> -- function binding
 518         wlkList rdMatch fbindl  `thenUgn` \ matches ->
 519         mkSrcLocUgn     srcline `thenUgn` \ src_loc ->
 520         returnUgn (RdrFunctionBinding srcline matches)
 521
 522       U_pbind pbindl srcline ->  -- pattern binding
 523         wlkList rdMatch pbindl  `thenUgn` \ matches ->
 524         mkSrcLocUgn     srcline `thenUgn` \ src_loc ->
 525         returnUgn (RdrPatternBinding srcline matches)
 526
 527       U_cbind cbindc cbindid cbindw srcline cpragma ->          -- "class" declaration
 528         wlkContext       cbindc  `thenUgn` \ ctxt         ->
 529         wlkClassAssertTy cbindid `thenUgn` \ (clas, tyvar)->
 530         wlkBinding       cbindw  `thenUgn` \ binding      ->
 531         wlkClassPragma   cpragma `thenUgn` \ pragma       ->
 532         mkSrcLocUgn      srcline `thenUgn` \ src_loc      ->
 533         getSrcFileUgn            `thenUgn` \ sf           ->
 534         let
 535             (class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding
 536
 537             final_sigs    = concat (map cvClassOpSig class_sigs)
 538             final_methods = cvMonoBinds sf class_methods
 539         in
 540         returnUgn (RdrClassDecl
 541           (ClassDecl ctxt clas tyvar final_sigs final_methods pragma src_loc))
 542
 543       U_ibind from_source orig_mod                              -- "instance" declaration
 544               ibindc iclas ibindi ibindw srcline ipragma ->
 545         wlkContext      ibindc  `thenUgn` \ ctxt    ->
 546         wlkQid          iclas   `thenUgn` \ clas    ->
 547         wlkMonoType     ibindi  `thenUgn` \ inst_ty ->
 548         wlkBinding      ibindw  `thenUgn` \ binding ->
 549         wlkInstPragma   ipragma `thenUgn` \ pragma  ->
 550         mkSrcLocUgn     srcline `thenUgn` \ src_loc ->
 551         getSrcFileUgn           `thenUgn` \ sf      ->
 552         let
 553             from_here = case from_source of { 0 -> False; 1 -> True }
 554             (ss, bs)  = sepDeclsIntoSigsAndBinds binding
 555             binds     = cvMonoBinds sf bs
 556             uprags    = concat (map cvInstDeclSig ss)
 557             ctxt_inst_ty = HsPreForAllTy ctxt inst_ty
 558         in
 559         returnUgn (RdrInstDecl
 560           (InstDecl clas ctxt_inst_ty binds from_here orig_mod uprags pragma src_loc))
 561
 562       U_dbind dbindts srcline -> -- "default" declaration
 563         wlkList rdMonoType dbindts  `thenUgn` \ tys ->
 564         mkSrcLocUgn        srcline  `thenUgn` \ src_loc ->
 565         returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc))
 566
 567       U_mbind mod mbindimp srcline ->
 568         -- "import" declaration in an interface
 569         wlkList rdEntity   mbindimp     `thenUgn` \ entities  ->
 570         mkSrcLocUgn        srcline      `thenUgn` \ src_loc   ->
 571         returnUgn (RdrIfaceImportDecl (IfaceImportDecl mod entities src_loc))
 572
 573       U_mfbind fixes ->
 574         -- "infix" declarations in an interface
 575         wlkList rdFixOp fixes           `thenUgn` \ fixities  ->
 576         returnUgn (RdrIfaceFixities fixities)
 577
 578       a_sig_we_hope ->
 579         -- signature(-like) things, including user pragmas
 580         wlk_sig_thing a_sig_we_hope
 581 \end{code}
 582
 583 \begin{code}
 584 wlkDerivings :: U_maybe -> UgnM (Maybe [ProtoName])
 585
 586 wlkDerivings (U_nothing) = returnUgn Nothing
 587 wlkDerivings (U_just pt)
 588   = rdU_list pt          `thenUgn` \ ds     ->
 589     wlkList rdQid ds     `thenUgn` \ derivs ->
 590     returnUgn (Just derivs)
 591 \end{code}
 592
 593 \begin{code}
 594 wlk_sig_thing (U_sbind sbindids sbindid srcline spragma)  -- type signature
 595   = wlkList rdQid       sbindids `thenUgn` \ vars    ->
 596     wlkPolyType         sbindid  `thenUgn` \ poly_ty ->
 597     wlkTySigPragmas     spragma  `thenUgn` \ pragma  ->
 598     mkSrcLocUgn         srcline  `thenUgn` \ src_loc ->
 599     returnUgn (RdrTySig vars poly_ty pragma src_loc)
 600
 601 wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline) -- value specialisation user-pragma
 602   = wlkQid  uvar                    `thenUgn` \ var ->
 603     wlkList rd_ty_and_id vspec_tys  `thenUgn` \ tys_and_ids ->
 604     mkSrcLocUgn          srcline    `thenUgn` \ src_loc ->
 605     returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc
 606                              | (ty, using_id) <- tys_and_ids ])
 607   where
 608     rd_ty_and_id :: ParseTree -> UgnM (ProtoNamePolyType, Maybe ProtoName)
 609     rd_ty_and_id pt
 610       = rdU_binding pt          `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
 611         wlkPolyType vspec_ty    `thenUgn` \ ty       ->
 612         wlkMaybe rdQid vspec_id `thenUgn` \ id_maybe ->
 613         returnUgn(ty, id_maybe)
 614
 615 wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)-- instance specialisation user-pragma
 616   = wlkQid      iclas           `thenUgn` \ clas    ->
 617     wlkMonoType ispec_ty        `thenUgn` \ ty      ->
 618     mkSrcLocUgn srcline         `thenUgn` \ src_loc ->
 619     returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc))
 620
 621 wlk_sig_thing (U_inline_uprag ivar srcline) -- value inlining user-pragma
 622   = wlkQid      ivar            `thenUgn` \ var     ->
 623     mkSrcLocUgn srcline         `thenUgn` \ src_loc ->
 624     returnUgn (RdrInlineValSig (InlineSig var src_loc))
 625
 626 wlk_sig_thing (U_deforest_uprag ivar srcline) -- "deforest me" user-pragma
 627   = wlkQid      ivar            `thenUgn` \ var     ->
 628     mkSrcLocUgn srcline         `thenUgn` \ src_loc ->
 629     returnUgn (RdrDeforestSig (DeforestSig var src_loc))
 630
 631 wlk_sig_thing (U_magicuf_uprag ivar str srcline) -- "magic" unfolding user-pragma
 632   = wlkQid      ivar            `thenUgn` \ var     ->
 633     mkSrcLocUgn srcline         `thenUgn` \ src_loc ->
 634     returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
 635
 636 wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline)
 637   = wlkQid      itycon           `thenUgn` \ tycon   ->
 638     mkSrcLocUgn srcline          `thenUgn` \ src_loc ->
 639     wlkList rdMonoType dspec_tys `thenUgn` \ tys     ->
 640     let
 641         spec_ty = MonoTyApp tycon tys
 642     in
 643     returnUgn (RdrSpecDataSig (SpecDataSig tycon spec_ty src_loc))
 644 \end{code}
 645
 646 %************************************************************************
 647 %*                                                                      *
 648 \subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
 649 %*                                                                      *
 650 %************************************************************************
 651
 652 \begin{code}
 653 rdPolyType :: ParseTree -> UgnM ProtoNamePolyType
 654 rdMonoType :: ParseTree -> UgnM ProtoNameMonoType
 655
 656 rdPolyType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkPolyType ttype
 657 rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
 658
 659 wlkPolyType :: U_ttype -> UgnM ProtoNamePolyType
 660 wlkMonoType :: U_ttype -> UgnM ProtoNameMonoType
 661
 662 wlkPolyType ttype
 663   = case ttype of
 664 {-LATER:
 665       U_uniforall utvs uty -> -- forall type (pragmas)
 666         wlkList rdU_unkId utvs  `thenUgn` \ tvs ->
 667         wlkMonoType       uty   `thenUgn` \ ty  ->
 668         returnUgn (HsForAllTy tvs ty)
 669 -}
 670
 671       U_context tcontextl tcontextt -> -- context
 672         wlkContext  tcontextl   `thenUgn` \ ctxt ->
 673         wlkMonoType tcontextt   `thenUgn` \ ty   ->
 674         returnUgn (HsPreForAllTy ctxt ty)
 675
 676       other -> -- something else
 677         wlkMonoType other   `thenUgn` \ ty ->
 678         returnUgn (HsPreForAllTy [{-no context-}] ty)
 679
 680 wlkMonoType ttype
 681   = case ttype of
 682       U_namedtvar tyvar -> -- type variable
 683         returnUgn (MonoTyVar tyvar)
 684
 685       U_tname tcon -> -- type constructor
 686         wlkQid tcon     `thenUgn` \ tycon ->
 687         returnUgn (MonoTyApp tycon [])
 688
 689       U_tapp t1 t2 ->
 690         wlkMonoType t2          `thenUgn` \ ty2 ->
 691         collect t1 [ty2]        `thenUgn` \ (tycon, tys) ->
 692         returnUgn (MonoTyApp tycon tys)
 693        where
 694         collect t acc
 695           = case t of
 696               U_tapp t1 t2 -> wlkMonoType t2    `thenUgn` \ ty2 ->
 697                               collect t1 (ty2:acc)
 698               U_tname tcon -> wlkQid tcon       `thenUgn` \ tycon  ->
 699                               returnUgn (tycon, acc)
 700               U_namedtvar tv -> returnUgn (tv, acc)
 701               U_tllist _ -> panic "tlist"
 702               U_ttuple _ -> panic "ttuple"
 703               U_tfun _ _ -> panic "tfun"
 704               U_tbang _ -> panic "tbang"
 705               U_context _ _ -> panic "context"
 706               _ -> panic "something else"
 707
 708       U_tllist tlist -> -- list type
 709         wlkMonoType tlist       `thenUgn` \ ty ->
 710         returnUgn (MonoListTy ty)
 711
 712       U_ttuple ttuple ->
 713         wlkList rdMonoType ttuple `thenUgn` \ tys ->
 714         returnUgn (MonoTupleTy tys)
 715
 716       U_tfun tfun targ ->
 717         wlkMonoType tfun        `thenUgn` \ ty1 ->
 718         wlkMonoType targ        `thenUgn` \ ty2 ->
 719         returnUgn (MonoFunTy ty1 ty2)
 720
 721       U_unidict uclas t -> -- DictTy (pragmas)
 722         wlkQid uclas    `thenUgn` \ clas ->
 723         wlkMonoType t   `thenUgn` \ ty   ->
 724         returnUgn (MonoDictTy clas ty)
 725 \end{code}
 726
 727 \begin{code}
 728 wlkTyConAndTyVars :: U_ttype -> UgnM (ProtoName, [ProtoName])
 729 wlkContext        :: U_list  -> UgnM ProtoNameContext
 730 wlkClassAssertTy  :: U_ttype -> UgnM (ProtoName, ProtoName)
 731
 732 wlkTyConAndTyVars ttype
 733   = wlkMonoType ttype   `thenUgn` \ (MonoTyApp tycon ty_args) ->
 734     let
 735         args = [ a | (MonoTyVar a) <- ty_args ]
 736     in
 737     returnUgn (tycon, args)
 738
 739 wlkContext list
 740   = wlkList rdMonoType list `thenUgn` \ tys ->
 741     returnUgn (map mk_class_assertion tys)
 742
 743 wlkClassAssertTy xs
 744   = wlkMonoType xs   `thenUgn` \ mono_ty ->
 745     returnUgn (mk_class_assertion mono_ty)
 746
 747 mk_class_assertion :: ProtoNameMonoType -> (ProtoName, ProtoName)
 748
 749 mk_class_assertion (MonoTyApp name [(MonoTyVar tyname)]) = (name, tyname)
 750 mk_class_assertion other
 751   = error ("ERROR: malformed type context: "++ppShow 80 (ppr PprForUser other)++"\n")
 752     -- regrettably, the parser does let some junk past
 753     -- e.g., f :: Num {-nothing-} => a -> ...
 754 \end{code}
 755
 756 \begin{code}
 757 rdConDecl :: ParseTree -> UgnM ProtoNameConDecl
 758 rdConDecl pt
 759   = rdU_constr pt    `thenUgn` \ blah ->
 760     wlkConDecl blah
 761
 762 wlkConDecl :: U_constr -> UgnM ProtoNameConDecl
 763
 764 wlkConDecl (U_constrpre ccon ctys srcline)
 765   = mkSrcLocUgn srcline         `thenUgn` \ src_loc ->
 766     wlkQid      ccon            `thenUgn` \ con     ->
 767     wlkList     rdBangType ctys `thenUgn` \ tys     ->
 768     returnUgn (ConDecl con tys src_loc)
 769
 770 wlkConDecl (U_constrinf cty1 cop cty2 srcline)
 771   = mkSrcLocUgn srcline         `thenUgn` \ src_loc ->
 772     wlkBangType cty1            `thenUgn` \ ty1     ->
 773     wlkQid      cop             `thenUgn` \ op      ->
 774     wlkBangType cty2            `thenUgn` \ ty2     ->
 775     returnUgn (ConOpDecl ty1 op ty2 src_loc)
 776
 777 wlkConDecl (U_constrnew ccon cty srcline)
 778   = mkSrcLocUgn srcline         `thenUgn` \ src_loc ->
 779     wlkQid      ccon            `thenUgn` \ con     ->
 780     wlkMonoType cty             `thenUgn` \ ty      ->
 781     returnUgn (NewConDecl con ty src_loc)
 782
 783 wlkConDecl (U_constrrec ccon cfields srcline)
 784   = mkSrcLocUgn srcline         `thenUgn` \ src_loc      ->
 785     wlkQid      ccon            `thenUgn` \ con          ->
 786     wlkList rd_field cfields    `thenUgn` \ fields_lists ->
 787     returnUgn (RecConDecl con (concat fields_lists) src_loc)
 788   where
 789     rd_field :: ParseTree -> UgnM [(ProtoName, BangType ProtoName)]
 790     rd_field pt
 791       = rdU_constr pt           `thenUgn` \ (U_field fvars fty) ->
 792         wlkList rdQid   fvars   `thenUgn` \ vars ->
 793         wlkBangType fty         `thenUgn` \ ty ->
 794         returnUgn [ (var, ty) | var <- vars ]
 795
 796 -----------------
 797 rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty
 798
 799 wlkBangType :: U_ttype -> UgnM (BangType ProtoName)
 800
 801 wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty -> returnUgn (Banged   ty)
 802 wlkBangType uty           = wlkMonoType uty `thenUgn` \ ty -> returnUgn (Unbanged ty)
 803
 804 \end{code}
 805
 806 %************************************************************************
 807 %*                                                                      *
 808 \subsection{Read a ``match''}
 809 %*                                                                      *
 810 %************************************************************************
 811
 812 \begin{code}
 813 rdMatch :: ParseTree -> UgnM RdrMatch
 814
 815 rdMatch pt
 816   = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind gsrcfun srcline) ->
 817
 818     wlkPat              gpat    `thenUgn` \ pat     ->
 819     wlkBinding          gbind   `thenUgn` \ binding ->
 820     wlkQid              gsrcfun `thenUgn` \ srcfun  ->
 821     let
 822         wlk_guards (U_pnoguards exp)
 823           = wlkExpr exp `thenUgn` \ expr ->
 824             returnUgn (RdrMatch_NoGuard srcline srcfun pat expr binding)
 825
 826         wlk_guards (U_pguards gs)
 827           = wlkList rd_gd_expr gs   `thenUgn` \ gd_exps ->
 828             returnUgn (RdrMatch_Guards  srcline srcfun pat gd_exps binding)
 829     in
 830     wlk_guards gdexprs
 831   where
 832     rd_gd_expr pt
 833       = rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) ->
 834         wlkExpr      g  `thenUgn` \ guard ->
 835         wlkExpr      e  `thenUgn` \ expr  ->
 836         returnUgn (guard, expr)
 837 \end{code}
 838
 839 %************************************************************************
 840 %*                                                                      *
 841 \subsection[rdFixOp]{Read in a fixity declaration}
 842 %*                                                                      *
 843 %************************************************************************
 844
 845 \begin{code}
 846 rdFixOp :: ParseTree -> UgnM ProtoNameFixityDecl
 847 rdFixOp pt
 848   = rdU_tree pt `thenUgn` \ fix ->
 849     case fix of
 850       U_fixop op (-1) prec -> returnUgn (InfixL op prec)
 851       U_fixop op   0  prec -> returnUgn (InfixN op prec)
 852       U_fixop op   1  prec -> returnUgn (InfixR op prec)
 853       _ -> error "ReadPrefix:rdFixOp"
 854 \end{code}
 855
 856 %************************************************************************
 857 %*                                                                      *
 858 \subsection[rdImportedInterface]{Read an imported interface}
 859 %*                                                                      *
 860 %************************************************************************
 861
 862 \begin{code}
 863 rdImportedInterface :: ParseTree
 864                     -> UgnM ProtoNameImportedInterface
 865
 866 rdImportedInterface pt
 867   = rdU_binding pt
 868         `thenUgn` \ (U_import ifname iffile binddef imod iqual ias ispec srcline) ->
 869
 870     mkSrcLocUgn srcline                 `thenUgn` \ src_loc     ->
 871     wlkMaybe rdU_stringId ias           `thenUgn` \ maybe_as    ->
 872     wlkMaybe rd_spec ispec              `thenUgn` \ maybe_spec  ->
 873
 874     setSrcFileUgn iffile ( -- looking inside the .hi file...
 875         wlkBinding binddef
 876     )                           `thenUgn` \ iface_bs  ->
 877
 878     case (sepDeclsForInterface iface_bs) of {
 879         (tydecls,classdecls,instdecls,sigs,iimpdecls,ifixities) ->
 880     let
 881         cv_sigs  = concat (map cvValSig sigs)
 882
 883         cv_iface = Interface ifname iimpdecls ifixities
 884                         tydecls classdecls instdecls cv_sigs
 885                         src_loc
 886
 887         cv_qual = case iqual of {0 -> False; 1 -> True}
 888     in
 889     returnUgn (ImportMod cv_iface cv_qual maybe_as maybe_spec)
 890     }
 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 \end{code}
 899
 900 \begin{code}
 901 rdEntities pt
 902   = rdU_list pt             `thenUgn` \ list ->
 903     wlkList rdEntity list
 904
 905 rdEntity :: ParseTree -> UgnM (IE ProtoName)
 906
 907 rdEntity pt
 908   = rdU_entidt pt `thenUgn` \ entity ->
 909     case entity of
 910       U_entid evar ->           -- just a value
 911         wlkQid  evar            `thenUgn` \ var ->
 912         returnUgn (IEVar var)
 913
 914       U_enttype x ->            -- abstract type constructor/class
 915         wlkQid  x               `thenUgn` \ thing ->
 916         returnUgn (IEThingAbs thing)
 917
 918       U_enttypeall x ->         -- non-abstract type constructor/class
 919         wlkQid  x               `thenUgn` \ thing ->
 920         returnUgn (IEThingAll thing)
 921
 922       U_enttypenamed x ns ->    -- non-abstract type constructor/class
 923                                 -- with specified constrs/methods
 924         wlkQid  x               `thenUgn` \ thing ->
 925         wlkList rdQid ns        `thenUgn` \ names ->
 926         returnUgn (IEThingAll thing)
 927         -- returnUgn (IEThingWith thing names)
 928
 929       U_entmod mod -> -- everything provided by a module
 930         returnUgn (IEModuleContents mod)
 931 \end{code}
 932