ghc/compiler/reader/ReadPrefix2.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1995
   3 %
   4 \section[ReadPrefix2]{Read parse tree built by Yacc parser}
   5
   6 Comments?
   7
   8 \begin{code}
   9 #include "HsVersions.h"
  10
  11 module ReadPrefix2 (
  12         rdModule,
  13
  14         -- used over in ReadPragmas2...
  15         wlkList, rdConDecl, wlkMonoType
  16     )  where
  17
  18 IMPORT_Trace            -- ToDo: rm (debugging)
  19 import Pretty
  20
  21 import UgenAll
  22
  23 import AbsSyn
  24 import HsCore           -- ****** NEED TO SEE CONSTRUCTORS ******
  25 import HsPragmas        -- ****** NEED TO SEE CONSTRUCTORS ******
  26 import FiniteMap
  27 import IdInfo           ( UnfoldingGuidance(..) )
  28 import MainMonad
  29 import Maybes           ( Maybe(..) )
  30 import PrefixToHs
  31 import PrefixSyn
  32 import ProtoName
  33 import Outputable
  34 import ReadPragmas2
  35 import Util
  36 \end{code}
  37
  38 %************************************************************************
  39 %*                                                                      *
  40 \subsection[ReadPrefix-help]{Help Functions}
  41 %*                                                                      *
  42 %************************************************************************
  43
  44 \begin{code}
  45 wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a]
  46
  47 wlkList wlk_it U_lnil = returnUgn []
  48
  49 wlkList wlk_it (U_lcons hd tl)
  50   = wlk_it  hd          `thenUgn` \ hd_it ->
  51     wlkList wlk_it tl   `thenUgn` \ tl_it ->
  52     returnUgn (hd_it : tl_it)
  53 \end{code}
  54
  55 %************************************************************************
  56 %*                                                                      *
  57 \subsection[rdModule]{@rdModule@: reads in a Haskell module}
  58 %*                                                                      *
  59 %************************************************************************
  60
  61 \begin{code}
  62 rdModule :: MainIO
  63             (FAST_STRING,                       -- this module's name
  64              (FAST_STRING -> Bool,      -- a function to chk if <x> is in the export list
  65               FAST_STRING -> Bool),     -- a function to chk if <M> is among the M..
  66                                         -- ("dotdot") modules in the export list.
  67              ProtoNameModule)           -- the main goods
  68
  69 rdModule
  70   = _ccall_ hspmain `thenMn` \ pt -> -- call the Yacc parser!
  71     let
  72         srcfile  = _packCString ``input_filename'' -- What A Great Hack! (TM)
  73     in
  74     initUgn srcfile (
  75
  76     rdU_tree pt `thenUgn` \ (U_hmodule name himplist hexplist hmodlist srcline) ->
  77     rdFixities  `thenUgn` \ fixities ->
  78     wlkBinding                  hmodlist `thenUgn` \ binding    ->
  79     wlkList rdImportedInterface himplist `thenUgn` \ imports    ->
  80     wlkList rdEntity            hexplist `thenUgn` \ export_list->
  81     mkSrcLocUgn srcline                  `thenUgn` \ src_loc    ->
  82
  83     case sepDeclsForTopBinds binding      of {
  84       (tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) ->
  85       -- ToDo: bad for laziness??
  86
  87     returnUgn (
  88      name,
  89      mk_export_list_chker export_list,
  90      Module name
  91             export_list
  92             imports
  93             fixities
  94             tydecls
  95             tysigs
  96             classdecls
  97             (cvInstDecls True name name instdecls) -- True indicates not imported
  98             instsigs
  99             defaultdecls
 100             (cvSepdBinds srcfile cvValSig binds)
 101             [{-no sigs-}]
 102             src_loc
 103     ) } )
 104   where
 105     mk_export_list_chker exp_list
 106       = case (getIEStrings exp_list) of { (entity_info, dotdot_modules) ->
 107         ( \ n -> n `elemFM` entity_info,
 108           \ n -> n `elemFM` dotdot_modules )
 109         }
 110 \end{code}
 111
 112 Convert fixities table:
 113 \begin{code}
 114 rdFixities :: UgnM [ProtoNameFixityDecl]
 115
 116 rdFixities
 117   = ioToUgnM (_ccall_ nfixes)   `thenUgn` \ num_fixities@(I# _) ->
 118     let
 119         rd i acc
 120           | i >= num_fixities
 121           = returnUgn acc
 122
 123           | otherwise
 124           = ioToUgnM (_ccall_ fixtype i) `thenUgn` \ fix_ty@(A# _) ->
 125             if fix_ty == ``NULL'' then
 126                 rd (i+1) acc
 127             else
 128                 ioToUgnM (_ccall_ fixop      i) `thenUgn` \ fix_op@(A# _) ->
 129                 ioToUgnM (_ccall_ precedence i) `thenUgn` \ precedence@(I# _) ->
 130                 let
 131                     op = Unk (_packCString fix_op)
 132
 133                     associativity
 134                       = _UNPK_ (_packCString fix_ty)
 135
 136                     new_fix
 137                       = case associativity of
 138                           "infix"  -> InfixN op precedence
 139                           "infixl" -> InfixL op precedence
 140                           "infixr" -> InfixR op precedence
 141                 in
 142                 rd (i+1) (new_fix : acc)
 143     in
 144     rd 0 []
 145 \end{code}
 146
 147 %************************************************************************
 148 %*                                                                      *
 149 \subsection[wlkExprOrPat]{@wlkExpr@ and @wlkPat@}
 150 %*                                                                      *
 151 %************************************************************************
 152
 153 \begin{code}
 154 rdExpr :: ParseTree -> UgnM ProtoNameExpr
 155 rdPat  :: ParseTree -> UgnM ProtoNamePat
 156
 157 rdExpr pt = rdU_tree pt `thenUgn` \ tree -> wlkExpr tree
 158 rdPat  pt = rdU_tree pt `thenUgn` \ tree -> wlkPat  tree
 159
 160 wlkExpr :: U_tree -> UgnM ProtoNameExpr
 161 wlkPat  :: U_tree -> UgnM ProtoNamePat
 162
 163 wlkExpr expr
 164   = case expr of
 165       U_par expr -> -- parenthesised expr
 166         wlkExpr expr
 167
 168       U_lsection lsexp op ->    -- left section
 169         wlkExpr lsexp   `thenUgn` \ expr ->
 170         returnUgn (SectionL expr (Var op))
 171
 172       U_rsection op rsexp -> -- right section
 173         wlkExpr rsexp   `thenUgn` \ expr ->
 174         returnUgn (SectionR (Var 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 (SCC label expr)
 189
 190       U_lambda lampats lamexpr srcline -> -- lambda expression
 191         wlkList rdPat lampats   `thenUgn` \ pats ->
 192         wlkExpr       lamexpr   `thenUgn` \ body ->
 193         mkSrcLocUgn   srcline   `thenUgn` \ src_loc ->
 194         returnUgn (
 195             Lam (foldr PatMatch
 196                        (GRHSMatch (GRHSsAndBindsIn
 197                                     [OtherwiseGRHS body src_loc]
 198                                     EmptyBinds))
 199                        pats)
 200         )
 201
 202       U_casee caseexpr casebody -> -- case expression
 203         wlkExpr        caseexpr  `thenUgn` \ expr ->
 204         wlkList rdMatch casebody `thenUgn` \ mats ->
 205         getSrcFileUgn            `thenUgn` \ sf ->
 206         let
 207             matches = cvMatches sf True mats
 208         in
 209         returnUgn (Case expr matches)
 210
 211       U_ife ifpred ifthen ifelse -> -- if expression
 212         wlkExpr ifpred  `thenUgn` \ e1 ->
 213         wlkExpr ifthen  `thenUgn` \ e2 ->
 214         wlkExpr ifelse  `thenUgn` \ e3 ->
 215         returnUgn (If e1 e2 e3)
 216
 217       U_let letvdeflist letvexpr -> -- let expression
 218         wlkBinding letvdeflist  `thenUgn` \ binding ->
 219         wlkExpr    letvexpr     `thenUgn` \ expr    ->
 220         getSrcFileUgn           `thenUgn` \ sf      ->
 221         let
 222             binds = cvBinds sf cvValSig binding
 223         in
 224         returnUgn (Let binds expr)
 225
 226       U_comprh cexp cquals -> -- list comprehension
 227         wlkExpr cexp            `thenUgn` \ expr  ->
 228         wlkList rd_qual cquals  `thenUgn` \ quals ->
 229         returnUgn (ListComp expr quals)
 230         where
 231           rd_qual pt
 232             = rdU_tree pt       `thenUgn` \ qual ->
 233               wlk_qual qual
 234
 235           wlk_qual qual
 236             = case qual of
 237                 U_par expr -> wlk_qual expr -- overkill? (ToDo?)
 238
 239                 U_qual qpat qexp ->
 240                   wlkPat  qpat  `thenUgn` \ pat  ->
 241                   wlkExpr qexp  `thenUgn` \ expr ->
 242                   returnUgn (GeneratorQual pat expr)
 243
 244                 U_guard gexp ->
 245                   wlkExpr gexp  `thenUgn` \ expr ->
 246                   returnUgn (FilterQual expr)
 247
 248       U_eenum efrom estep eto -> -- arithmetic sequence
 249         wlkExpr efrom           `thenUgn` \ e1  ->
 250         wlkList rdExpr estep    `thenUgn` \ es2 ->
 251         wlkList rdExpr eto      `thenUgn` \ es3 ->
 252         returnUgn (cv_arith_seq e1 es2 es3)
 253         where -- ToDo: use Maybe type
 254            cv_arith_seq e1 []   []   = ArithSeqIn (From       e1)
 255            cv_arith_seq e1 []   [e3] = ArithSeqIn (FromTo     e1 e3)
 256            cv_arith_seq e1 [e2] []   = ArithSeqIn (FromThen   e1 e2)
 257            cv_arith_seq e1 [e2] [e3] = ArithSeqIn (FromThenTo e1 e2 e3)
 258
 259       U_restr restre restrt -> -- expression with type signature
 260         wlkExpr     restre      `thenUgn` \ expr ->
 261         wlkPolyType restrt      `thenUgn` \ ty   ->
 262         returnUgn (ExprWithTySig expr ty)
 263
 264       U_negate nexp -> -- negated expression
 265         wlkExpr nexp            `thenUgn` \ expr ->
 266         returnUgn (App (Var (Unk SLIT("negate"))) expr)
 267
 268       -- ToDo: DPH stuff
 269
 270       --------------------------------------------------------------
 271       -- now the prefix items that can either be an expression or
 272       -- pattern, except we know they are *expressions* here
 273       -- (this code could be commoned up with the pattern version;
 274       -- but it probably isn't worth it)
 275       --------------------------------------------------------------
 276       U_lit lit ->
 277         wlkLiteral lit  `thenUgn` \ lit ->
 278         returnUgn (Lit lit)
 279
 280       U_ident n -> -- simple identifier
 281         returnUgn (Var n)
 282
 283       U_ap fun arg -> -- application
 284         wlkExpr fun     `thenUgn` \ expr1 ->
 285         wlkExpr arg     `thenUgn` \ expr2 ->
 286         returnUgn (App expr1 expr2)
 287
 288       U_tinfixop (op, arg1, arg2) ->
 289         wlkExpr arg1    `thenUgn` \ expr1 ->
 290         wlkExpr arg2    `thenUgn` \ expr2 ->
 291         returnUgn (OpApp expr1 (Var op) expr2)
 292
 293       U_llist llist -> -- explicit list
 294         wlkList rdExpr llist `thenUgn` \ exprs ->
 295         returnUgn (ExplicitList exprs)
 296
 297       U_tuple tuplelist -> -- explicit tuple
 298         wlkList rdExpr tuplelist `thenUgn` \ exprs ->
 299         returnUgn (ExplicitTuple exprs)
 300
 301 #ifdef DEBUG
 302       U_hmodule _ _ _ _ _ -> error "U_hmodule"
 303       U_as _ _ -> error "U_as"
 304       U_lazyp _ -> error "U_lazyp"
 305       U_plusp _ _ -> error "U_plusp"
 306       U_wildp -> error "U_wildp"
 307       U_qual _ _ -> error "U_qual"
 308       U_guard _ -> error "U_guard"
 309       U_def _ -> error "U_def"
 310 #endif
 311
 312 -- ToDo: DPH stuff
 313 \end{code}
 314
 315 Patterns: just bear in mind that lists of patterns are represented as
 316 a series of ``applications''.
 317 \begin{code}
 318 wlkPat pat
 319   = case pat of
 320       U_par pat ->  -- parenthesised pattern
 321         wlkPat pat
 322
 323       U_as var as_pat -> -- "as" pattern
 324         wlkPat as_pat   `thenUgn` \ pat ->
 325         returnUgn (AsPatIn var pat)
 326
 327       U_lazyp lazyp -> -- irrefutable ("twiddle") pattern
 328         wlkPat lazyp    `thenUgn` \ pat ->
 329         returnUgn (LazyPatIn pat)
 330
 331       U_plusp plusn plusk -> -- n+k pattern
 332         wlkPat     plusn    `thenUgn` \ pat ->
 333         wlkLiteral plusk    `thenUgn` \ lit ->
 334         let
 335             n = case pat of
 336                   VarPatIn n -> n
 337                   WildPatIn  -> error "ERROR: wlkPat: GHC can't handle _+k patterns\n"
 338         in
 339         returnUgn (NPlusKPatIn n lit)
 340
 341       U_wildp -> returnUgn WildPatIn -- wildcard pattern
 342
 343       --------------------------------------------------------------
 344       -- now the prefix items that can either be an expression or
 345       -- pattern, except we know they are *patterns* here.
 346       --------------------------------------------------------------
 347       U_negate nexp ->  -- negated pattern: negatee must be a literal
 348         wlkPat nexp     `thenUgn` \ lit_pat ->
 349         case lit_pat of
 350           LitPatIn lit -> returnUgn (LitPatIn (negLiteral lit))
 351           _            -> panic "wlkPat: bad negated pattern!"
 352
 353       U_lit lit ->
 354         wlkLiteral lit  `thenUgn` \ lit ->
 355         returnUgn (LitPatIn lit)
 356
 357       U_ident n -> -- simple identifier
 358         returnUgn (
 359           if isConopPN n
 360           then ConPatIn n []
 361           else VarPatIn n
 362         )
 363
 364       U_ap l r -> -- "application": there's a list of patterns lurking here!
 365         wlk_curried_pats l `thenUgn` \ (lpat:lpats) ->
 366         wlkPat           r `thenUgn` \ rpat         ->
 367         let
 368             (n, llpats)
 369               = case lpat of
 370                   VarPatIn x        -> (x, [])
 371                   ConPatIn x []     -> (x, [])
 372                   ConOpPatIn x op y -> (op, [x, y])
 373                   _ -> -- sorry about the weedy msg; the parser missed this one
 374                        error (ppShow 100 (ppCat [ppStr "ERROR: an illegal `application' of a pattern to another one:", ppInterleave ppSP (map (ppr PprForUser) bad_app)]))
 375
 376             arg_pats = llpats ++ lpats ++ [rpat]
 377             bad_app  = (lpat:lpats) ++ [rpat]
 378         in
 379         returnUgn (ConPatIn n arg_pats)
 380         where
 381           wlk_curried_pats pat
 382             = case pat of
 383                 U_ap l r ->
 384                   wlk_curried_pats l    `thenUgn` \ lpats ->
 385                   wlkPat           r    `thenUgn` \ rpat  ->
 386                   returnUgn (lpats ++ [rpat])
 387                 other ->
 388                   wlkPat other          `thenUgn` \ pat ->
 389                   returnUgn [pat]
 390
 391       U_tinfixop (op, arg1, arg2) ->
 392         wlkPat arg1     `thenUgn` \ pat1 ->
 393         wlkPat arg2     `thenUgn` \ pat2 ->
 394         returnUgn (ConOpPatIn pat1 op pat2)
 395
 396       U_llist llist -> -- explicit list
 397         wlkList rdPat llist `thenUgn` \ pats ->
 398         returnUgn (ListPatIn pats)
 399
 400       U_tuple tuplelist -> -- explicit tuple
 401         wlkList rdPat tuplelist `thenUgn` \ pats ->
 402         returnUgn (TuplePatIn pats)
 403
 404       -- ToDo: DPH
 405 \end{code}
 406
 407 OLD, MISPLACED NOTE: The extra DPH syntax above is defined such that
 408 to the left of a \tr{<<-} or \tr{<<=} there has to be a processor (no
 409 expressions).  Therefore in the pattern matching below we are taking
 410 this into consideration to create the @DrawGen@ whose fields are the
 411 \tr{K} patterns, pat and the exp right of the generator.
 412
 413 \begin{code}
 414 wlkLiteral :: U_literal -> UgnM Literal
 415
 416 wlkLiteral ulit
 417   = returnUgn (
 418     case ulit of
 419       U_integer    s   -> IntLit        (as_integer  s)
 420       U_floatr     s   -> FracLit       (as_rational s)
 421       U_intprim    s   -> IntPrimLit    (as_integer  s)
 422       U_doubleprim s   -> DoublePrimLit (as_rational s)
 423       U_floatprim  s   -> FloatPrimLit  (as_rational s)
 424       U_charr      s   -> CharLit       (as_char     s)
 425       U_charprim   s   -> CharPrimLit   (as_char     s)
 426       U_string     s   -> StringLit     (as_string   s)
 427       U_stringprim s   -> StringPrimLit (as_string   s)
 428       U_clitlit    s _ -> LitLitLitIn   (as_string   s)
 429     )
 430   where
 431     as_char s     = _HEAD_ s
 432     as_integer s  = readInteger (_UNPK_ s)
 433     as_rational s = _readRational (_UNPK_ s) -- non-std
 434     as_string s   = s
 435 \end{code}
 436
 437 %************************************************************************
 438 %*                                                                      *
 439 \subsection{wlkBinding}
 440 %*                                                                      *
 441 %************************************************************************
 442
 443 \begin{code}
 444 wlkBinding :: U_binding -> UgnM RdrBinding
 445
 446 wlkBinding binding
 447   = case binding of
 448       U_nullbind -> -- null binding
 449         returnUgn RdrNullBind
 450
 451       U_abind a b -> -- "and" binding (just glue, really)
 452         wlkBinding a    `thenUgn` \ binding1 ->
 453         wlkBinding b    `thenUgn` \ binding2 ->
 454         returnUgn (RdrAndBindings binding1 binding2)
 455
 456       U_tbind tbindc tbindid tbindl tbindd srcline tpragma -> -- "data" declaration
 457         wlkContext         tbindc  `thenUgn` \ ctxt         ->
 458         wlkList rdU_unkId  tbindd  `thenUgn` \ derivings    ->
 459         wlkTyConAndTyVars  tbindid `thenUgn` \ (tycon, tyvars) ->
 460         wlkList rdConDecl  tbindl  `thenUgn` \ cons         ->
 461         wlkDataPragma      tpragma `thenUgn` \ pragma       ->
 462         mkSrcLocUgn        srcline `thenUgn` \ src_loc      ->
 463         returnUgn (RdrTyData (TyData ctxt tycon tyvars cons derivings pragma src_loc))
 464
 465       U_nbind nbindid nbindas srcline npragma -> -- "type" declaration
 466         wlkTyConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
 467         wlkMonoType       nbindas `thenUgn` \ expansion     ->
 468         wlkTypePragma     npragma `thenUgn` \ pragma        ->
 469         mkSrcLocUgn       srcline `thenUgn` \ src_loc       ->
 470         returnUgn (RdrTySynonym (TySynonym tycon tyvars expansion pragma src_loc))
 471
 472       U_fbind fbindl srcline -> -- function binding
 473         wlkList rdMatch fbindl  `thenUgn` \ matches ->
 474         mkSrcLocUgn     srcline `thenUgn` \ src_loc ->
 475         returnUgn (RdrFunctionBinding srcline matches)
 476
 477       U_pbind pbindl srcline ->  -- pattern binding
 478         wlkList rdMatch pbindl  `thenUgn` \ matches ->
 479         mkSrcLocUgn     srcline `thenUgn` \ src_loc ->
 480         returnUgn (RdrPatternBinding srcline matches)
 481
 482       U_cbind cbindc cbindid cbindw srcline cpragma -> -- "class" declaration
 483         wlkContext       cbindc  `thenUgn` \ ctxt         ->
 484         wlkClassAssertTy cbindid `thenUgn` \ (clas, tyvar) ->
 485         wlkBinding       cbindw  `thenUgn` \ binding      ->
 486         wlkClassPragma   cpragma `thenUgn` \ pragma       ->
 487         mkSrcLocUgn      srcline `thenUgn` \ src_loc      ->
 488         getSrcFileUgn            `thenUgn` \ sf           ->
 489         let
 490             (class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding
 491
 492             final_sigs    = concat (map cvClassOpSig class_sigs)
 493             final_methods = cvMonoBinds sf class_methods
 494         in
 495         returnUgn (RdrClassDecl
 496           (ClassDecl ctxt clas tyvar final_sigs final_methods pragma src_loc))
 497
 498       U_ibind ibindc clas ibindi ibindw srcline ipragma -> -- "instance" declaration
 499         wlkContext      ibindc  `thenUgn` \ ctxt    ->
 500         wlkMonoType     ibindi  `thenUgn` \ inst_ty ->
 501         wlkBinding      ibindw  `thenUgn` \ binding ->
 502         wlkInstPragma   ipragma `thenUgn` \ (modname_maybe, pragma) ->
 503         mkSrcLocUgn     srcline `thenUgn` \ src_loc ->
 504         getSrcFileUgn           `thenUgn` \ sf      ->
 505         let
 506             (ss, bs) = sepDeclsIntoSigsAndBinds binding
 507             binds    = cvMonoBinds sf bs
 508             uprags   = concat (map cvInstDeclSig ss)
 509         in
 510         returnUgn (
 511         case modname_maybe of {
 512           Nothing ->
 513             RdrInstDecl (\ orig_mod infor_mod here ->
 514                   InstDecl ctxt clas inst_ty binds here orig_mod infor_mod uprags pragma src_loc);
 515           Just orig_mod ->
 516             RdrInstDecl (\ _ infor_mod here ->
 517                   InstDecl ctxt clas inst_ty binds here orig_mod infor_mod uprags pragma src_loc)
 518         })
 519
 520       U_dbind dbindts srcline -> -- "default" declaration
 521         wlkList rdMonoType dbindts  `thenUgn` \ tys ->
 522         mkSrcLocUgn        srcline  `thenUgn` \ src_loc ->
 523         returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc))
 524
 525       U_mbind mod mbindimp mbindren srcline ->
 526         -- "import" declaration in an interface
 527         wlkList rdEntity   mbindimp     `thenUgn` \ entities  ->
 528         wlkList rdRenaming mbindren     `thenUgn` \ renamings ->
 529         mkSrcLocUgn        srcline      `thenUgn` \ src_loc   ->
 530         returnUgn (RdrIfaceImportDecl (IfaceImportDecl mod entities renamings src_loc))
 531
 532       a_sig_we_hope ->
 533         -- signature(-like) things, including user pragmas
 534         wlk_sig_thing a_sig_we_hope
 535 \end{code}
 536
 537 ToDo: really needed as separate?
 538 \begin{code}
 539 wlk_sig_thing (U_sbind sbindids sbindid srcline spragma)  -- type signature
 540   = wlkList rdU_unkId   sbindids `thenUgn` \ vars    ->
 541     wlkPolyType         sbindid  `thenUgn` \ poly_ty ->
 542     wlkTySigPragmas     spragma  `thenUgn` \ pragma  ->
 543     mkSrcLocUgn         srcline  `thenUgn` \ src_loc ->
 544     returnUgn (RdrTySig vars poly_ty pragma src_loc)
 545
 546 wlk_sig_thing (U_vspec_uprag var vspec_tys srcline) -- value specialisation user-pragma
 547   = wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids ->
 548     mkSrcLocUgn          srcline   `thenUgn` \ src_loc ->
 549     returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc
 550                              | (ty, using_id) <- tys_and_ids ])
 551   where
 552     rd_ty_and_id :: ParseTree -> UgnM (ProtoNamePolyType, Maybe ProtoName)
 553     rd_ty_and_id pt
 554       = rdU_binding pt                  `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
 555         wlkPolyType vspec_ty            `thenUgn` \ ty      ->
 556         wlkList rdU_unkId vspec_id      `thenUgn` \ id_list ->
 557         returnUgn(ty, case id_list of { []  -> Nothing; [x] -> Just x })
 558
 559 wlk_sig_thing (U_ispec_uprag clas ispec_ty srcline)-- instance specialisation user-pragma
 560   = wlkMonoType     ispec_ty    `thenUgn` \ ty      ->
 561     mkSrcLocUgn     srcline     `thenUgn` \ src_loc ->
 562     returnUgn (RdrSpecInstSig (InstSpecSig clas ty src_loc))
 563
 564 wlk_sig_thing (U_inline_uprag var inline_howto srcline) -- value inlining user-pragma
 565   = wlkList rdU_stringId inline_howto `thenUgn` \ howto  ->
 566     mkSrcLocUgn          srcline      `thenUgn` \ src_loc ->
 567     let
 568         guidance -- ToDo: use Maybe type
 569           = (case howto of {
 570               []  -> id;
 571               [x] -> trace "ignoring unfold howto" }) UnfoldAlways
 572     in
 573     returnUgn (RdrInlineValSig (InlineSig var guidance src_loc))
 574
 575 wlk_sig_thing (U_deforest_uprag var srcline) -- "deforest me" user-pragma
 576   = mkSrcLocUgn srcline      `thenUgn` \ src_loc ->
 577     returnUgn (RdrDeforestSig (DeforestSig var src_loc))
 578
 579 wlk_sig_thing (U_magicuf_uprag var str srcline) -- "magic" unfolding user-pragma
 580   = mkSrcLocUgn srcline      `thenUgn` \ src_loc ->
 581     returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
 582
 583 wlk_sig_thing (U_abstract_uprag tycon srcline) -- abstract-type-synonym user-pragma
 584   = mkSrcLocUgn srcline      `thenUgn` \ src_loc ->
 585     returnUgn (RdrAbstractTypeSig (AbstractTypeSig tycon src_loc))
 586
 587 wlk_sig_thing (U_dspec_uprag tycon dspec_tys srcline)
 588   = mkSrcLocUgn srcline          `thenUgn` \ src_loc ->
 589     wlkList rdMonoType dspec_tys `thenUgn` \ tys ->
 590     let
 591         spec_ty = MonoTyCon tycon tys
 592     in
 593     returnUgn (RdrSpecDataSig (SpecDataSig tycon spec_ty src_loc))
 594 \end{code}
 595
 596 %************************************************************************
 597 %*                                                                      *
 598 \subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
 599 %*                                                                      *
 600 %************************************************************************
 601
 602 \begin{code}
 603 rdPolyType :: ParseTree -> UgnM ProtoNamePolyType
 604 rdMonoType :: ParseTree -> UgnM ProtoNameMonoType
 605
 606 rdPolyType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkPolyType ttype
 607 rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
 608
 609 wlkPolyType :: U_ttype -> UgnM ProtoNamePolyType
 610 wlkMonoType :: U_ttype -> UgnM ProtoNameMonoType
 611
 612 wlkPolyType ttype
 613   = case ttype of
 614       U_context tcontextl tcontextt -> -- context
 615         wlkContext  tcontextl   `thenUgn` \ ctxt ->
 616         wlkMonoType tcontextt   `thenUgn` \ ty   ->
 617         returnUgn (OverloadedTy ctxt ty)
 618
 619       U_uniforall utvs uty -> -- forall type (pragmas)
 620         wlkList rdU_unkId utvs  `thenUgn` \ tvs ->
 621         wlkMonoType       uty   `thenUgn` \ ty  ->
 622         returnUgn (ForAllTy tvs ty)
 623
 624       other -> -- something else
 625         wlkMonoType other   `thenUgn` \ ty ->
 626         returnUgn (UnoverloadedTy ty)
 627
 628 wlkMonoType ttype
 629   = case ttype of
 630       U_tname tycon typel -> -- tycon
 631         wlkList rdMonoType typel `thenUgn` \ tys ->
 632         returnUgn (MonoTyCon tycon tys)
 633
 634       U_tllist tlist -> -- list type
 635         wlkMonoType tlist       `thenUgn` \ ty ->
 636         returnUgn (ListMonoTy ty)
 637
 638       U_ttuple ttuple ->
 639         wlkList rdPolyType ttuple `thenUgn` \ tys ->
 640         returnUgn (TupleMonoTy tys)
 641
 642       U_tfun tfun targ ->
 643         wlkMonoType tfun        `thenUgn` \ ty1 ->
 644         wlkMonoType targ        `thenUgn` \ ty2 ->
 645         returnUgn (FunMonoTy ty1 ty2)
 646
 647       U_namedtvar tyvar -> -- type variable
 648         returnUgn (MonoTyVar tyvar)
 649
 650       U_unidict clas t -> -- UniDict (pragmas)
 651         wlkMonoType t   `thenUgn` \ ty   ->
 652         returnUgn (MonoDict clas ty)
 653
 654       U_unityvartemplate tv_tmpl -> -- pragmas only
 655         returnUgn (MonoTyVarTemplate tv_tmpl)
 656
 657 #ifdef DPH
 658 wlkMonoType ('v' : xs)
 659   = wlkMonoType xs          `thenUgn` \ (ty, xs1) ->
 660     returnUgn (RdrExplicitPodTy ty, xs1)
 661     BEND
 662
 663 wlkMonoType ('u' : xs)
 664   = wlkList rdMonoType xs `thenUgn` \ (tys, xs1) ->
 665     wlkMonoType xs1     `thenUgn` \ (ty,  xs2)  ->
 666     returnUgn (RdrExplicitProcessorTy tys ty, xs2)
 667     BEND BEND
 668 #endif {- Data Parallel Haskell -}
 669
 670 --wlkMonoType oops = panic ("wlkMonoType:"++oops)
 671 \end{code}
 672
 673 \begin{code}
 674 wlkTyConAndTyVars :: U_ttype -> UgnM (ProtoName, [ProtoName])
 675 wlkContext        :: U_list  -> UgnM ProtoNameContext
 676 wlkClassAssertTy  :: U_ttype -> UgnM (ProtoName, ProtoName)
 677
 678 wlkTyConAndTyVars ttype
 679   = wlkMonoType ttype   `thenUgn` \ (MonoTyCon tycon ty_args) ->
 680     let
 681         args = [ a | (MonoTyVar a) <- ty_args ]
 682     in
 683     returnUgn (tycon, args)
 684
 685 wlkContext list
 686   = wlkList rdMonoType list `thenUgn` \ tys ->
 687     returnUgn (map mk_class_assertion tys)
 688
 689 wlkClassAssertTy xs
 690   = wlkMonoType xs   `thenUgn` \ mono_ty ->
 691     returnUgn (mk_class_assertion mono_ty)
 692
 693 mk_class_assertion :: ProtoNameMonoType -> (ProtoName, ProtoName)
 694
 695 mk_class_assertion (MonoTyCon name [(MonoTyVar tyname)]) = (name, tyname)
 696 mk_class_assertion other
 697   = error ("ERROR: malformed type context: "++ppShow 80 (ppr PprForUser other)++"\n")
 698     -- regrettably, the parser does let some junk past
 699     -- e.g., f :: Num {-nothing-} => a -> ...
 700 \end{code}
 701
 702 \begin{code}
 703 rdConDecl :: ParseTree -> UgnM ProtoNameConDecl
 704
 705 rdConDecl pt
 706   = rdU_atype pt    `thenUgn` \ (U_atc con atctypel srcline) ->
 707
 708     mkSrcLocUgn srcline         `thenUgn` \ src_loc ->
 709     wlkList rdMonoType atctypel `thenUgn` \ tys     ->
 710     returnUgn (ConDecl con tys src_loc)
 711 \end{code}
 712
 713 %************************************************************************
 714 %*                                                                      *
 715 \subsection{Read a ``match''}
 716 %*                                                                      *
 717 %************************************************************************
 718
 719 \begin{code}
 720 rdMatch :: ParseTree -> UgnM RdrMatch
 721
 722 rdMatch pt
 723   = rdU_pbinding pt     `thenUgn` \ (U_pgrhs gpat gdexprs gbind srcfun srcline) ->
 724
 725     mkSrcLocUgn         srcline `thenUgn` \ src_loc ->
 726     wlkPat              gpat    `thenUgn` \ pat     ->
 727     wlkList rd_guarded  gdexprs `thenUgn` \ grhss   ->
 728     wlkBinding          gbind   `thenUgn` \ binding ->
 729
 730     returnUgn (RdrMatch srcline srcfun pat grhss binding)
 731   where
 732     rd_guarded pt
 733       = rdU_list pt         `thenUgn` \ list ->
 734         wlkList rdExpr list `thenUgn` \ [g,e] ->
 735         returnUgn (g, e)
 736 \end{code}
 737
 738 %************************************************************************
 739 %*                                                                      *
 740 \subsection[wlkFixity]{Read in a fixity declaration}
 741 %*                                                                      *
 742 %************************************************************************
 743
 744 \begin{code}
 745 {-
 746 wlkFixity :: ParseTree -> UgnM ProtoNameFixityDecl
 747
 748 wlkFixity pt
 749   = wlkId          xs   `thenUgn` \ (op,             xs1) ->
 750     wlkIdString xs1     `thenUgn` \ (associativity, xs2) ->
 751     wlkIdString xs2     `thenUgn` \ (prec_str,       xs3) ->
 752     let
 753         precedence = read prec_str
 754     in
 755     case associativity of {
 756       "infix"  -> returnUgn (InfixN op precedence, xs3);
 757       "infixl" -> returnUgn (InfixL op precedence, xs3);
 758       "infixr" -> returnUgn (InfixR op precedence, xs3)
 759     } BEND BEND BEND
 760 -}
 761 \end{code}
 762
 763 %************************************************************************
 764 %*                                                                      *
 765 \subsection[rdImportedInterface]{Read an imported interface}
 766 %*                                                                      *
 767 %************************************************************************
 768
 769 \begin{code}
 770 rdImportedInterface :: ParseTree
 771                     -> UgnM ProtoNameImportedInterface
 772
 773 rdImportedInterface pt
 774   = grab_pieces pt  `thenUgn`
 775         \ (expose_or_hide,
 776            modname,
 777            bindexp,
 778            bindren,
 779            binddef,
 780            bindfile,
 781            srcline) ->
 782
 783     mkSrcLocUgn         srcline `thenUgn` \ src_loc   ->
 784     wlkList rdEntity    bindexp `thenUgn` \ imports   ->
 785     wlkList rdRenaming  bindren `thenUgn` \ renamings ->
 786
 787     setSrcFileUgn bindfile ( -- OK, we're now looking inside the .hi file...
 788         wlkBinding binddef
 789     )                           `thenUgn` \ iface_bs  ->
 790
 791     case (sepDeclsForInterface iface_bs) of {
 792                 (tydecls,classdecls,instdecls,sigs,iimpdecls) ->
 793     let
 794         cv_iface
 795           = MkInterface modname
 796                 iimpdecls
 797                 [{-fixity decls-}]  -- can't get fixity decls in here yet (ToDo)
 798                 tydecls
 799                 classdecls
 800                 (cvInstDecls False SLIT(""){-probably superceded by modname < pragmas-}
 801                                    modname instdecls)
 802                             -- False indicates imported
 803                 (concat (map cvValSig sigs))
 804                 src_loc -- OLD: (mkSrcLoc importing_srcfile srcline)
 805     in
 806     returnUgn (
 807      if null imports then
 808         ImportAll cv_iface renamings
 809      else
 810         expose_or_hide cv_iface imports renamings
 811     )}
 812   where
 813     grab_pieces pt
 814       = rdU_binding pt `thenUgn` \ binding ->
 815         returnUgn (
 816         case binding of
 817           U_import a b c d e f -> (ImportSome,    a, b, c, d, e, f)
 818           U_hiding a b c d e f -> (ImportButHide, a, b, c, d, e, f)
 819         )
 820 \end{code}
 821
 822 \begin{code}
 823 rdRenaming :: ParseTree -> UgnM Renaming
 824
 825 rdRenaming pt
 826   = rdU_list             pt     `thenUgn` \ list ->
 827     wlkList rdU_stringId list   `thenUgn` \ [id1, id2] ->
 828     returnUgn (MkRenaming id1 id2)
 829 \end{code}
 830
 831 \begin{code}
 832 rdEntity :: ParseTree -> UgnM IE
 833
 834 rdEntity pt
 835   = rdU_entidt pt   `thenUgn` \ entity ->
 836     case entity of
 837       U_entid var -> -- just a value
 838         returnUgn (IEVar var)
 839
 840       U_enttype thing -> -- abstract type constructor/class
 841         returnUgn (IEThingAbs thing)
 842
 843       U_enttypeall thing -> -- non-abstract type constructor/class
 844         returnUgn (IEThingAll thing)
 845
 846       U_enttypecons tycon ctentcons -> -- type con w/ data cons listed
 847         wlkList rdU_stringId   ctentcons   `thenUgn` \ cons  ->
 848         returnUgn (IEConWithCons tycon cons)
 849
 850       U_entclass clas centops -> -- class with ops listed
 851         wlkList rdU_stringId   centops  `thenUgn` \ ops ->
 852         returnUgn (IEClsWithOps clas ops)
 853
 854       U_entmod mod -> -- everything provided by a module
 855         returnUgn (IEModuleContents mod)
 856 \end{code}