ghc/compiler/reader/ReadPrefix.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[ReadPrefix]{Read prefix-form input}
   5
   6 This module contains a function, @rdModule@, which reads a Haskell
   7 module in `prefix form' emitted by the Lex/Yacc parser.
   8
   9 The prefix form string is converted into an algebraic data type
  10 defined in @PrefixSyn@.
  11
  12 Identifier names are converted into the @ProtoName@ data type.
  13
  14 @sf@ is used consistently to mean ``source file'' (name).
  15
  16 \begin{code}
  17 -- HBC does not have stack stubbing; you get a space leak w/
  18 -- default defns from HsVersions.h.
  19
  20 -- GHC may be overly slow to compile w/ the defaults...
  21
  22 #define BIND {--}
  23 #define _TO_ `thenLft` ( \ {--}
  24 #define BEND )
  25 #define RETN returnLft
  26 #define RETN_TYPE LiftM
  27
  28 #include "HsVersions.h"
  29 \end{code}
  30
  31 \begin{code}
  32 module ReadPrefix (
  33         rdModule,
  34
  35         rdList, rdId, rdIdString, rdString, rdConDecl, rdMonoType
  36     ) where
  37
  38 IMPORT_Trace            -- ToDo: rm (debugging)
  39 import Pretty
  40
  41 import AbsSyn
  42 import HsCore           -- ****** NEED TO SEE CONSTRUCTORS ******
  43 import HsPragmas        -- ****** NEED TO SEE CONSTRUCTORS ******
  44 import IdInfo           ( UnfoldingGuidance(..) )
  45 import LiftMonad
  46 import Maybes           ( Maybe(..) )
  47 import PrefixToHs
  48 import PrefixSyn
  49 import ProtoName
  50 import Outputable
  51 import ReadPragmas
  52 import SrcLoc           ( mkSrcLoc )
  53 import Util
  54 \end{code}
  55
  56 %************************************************************************
  57 %*                                                                      *
  58 \subsection[ReadPrefix-help]{Help Functions}
  59 %*                                                                      *
  60 %************************************************************************
  61
  62 \begin{code}
  63 rdList :: (String -> RETN_TYPE (a, String)) -> String -> RETN_TYPE ([a], String)
  64
  65 rdList rd_it ('N':xs) = RETN ([], xs)
  66 rdList rd_it ('L':xs)
  67   = BIND (rd_it xs)             _TO_ (hd_it, xs1) ->
  68     BIND (rdList rd_it xs1)     _TO_ (tl_it, xs2) ->
  69     RETN (hd_it : tl_it, xs2)
  70     BEND BEND
  71 rdList rd_it junk = panic ("ReadPrefix.rdList:"++junk)
  72
  73 rdString, rdIdString :: String -> RETN_TYPE (FAST_STRING, String)
  74 rdId :: String -> RETN_TYPE (ProtoName, String)
  75
  76 rdString ('#':xs) = BIND (split_at_tab xs) _TO_ (str, rest) ->
  77                     RETN (_PK_ (de_escape str), rest)
  78                     BEND
  79   where
  80     -- partain: tabs and backslashes are escaped
  81     de_escape []                = []
  82     de_escape ('\\':'\\':xs)    = '\\' : (de_escape xs)
  83     de_escape ('\\':'t':xs)     = '\t' : (de_escape xs)
  84     de_escape (x:xs)            = x    : (de_escape xs)
  85
  86 rdString xs = panic ("ReadPrefix.rdString:"++xs)
  87
  88 rdIdString ('#':xs) = BIND (split_at_tab xs) _TO_ (stuff,rest) -> -- no de-escaping...
  89                       RETN (_PK_ stuff, rest)
  90                       BEND
  91 rdIdString other    = panic ("rdIdString:"++other)
  92
  93  -- no need to de-escape it...
  94 rdId ('#':xs) = BIND (split_at_tab xs) _TO_ (str, rest) ->
  95                 RETN (Unk (_PK_ str), rest)
  96                 BEND
  97
  98 split_at_tab :: String -> RETN_TYPE (String, String) -- a la Lennart
  99 split_at_tab xs
 100   = split_me [] xs
 101   where
 102     split_me acc ('\t' : ys) = BIND (my_rev acc []) _TO_ reversed ->
 103                                RETN (reversed, ys)
 104                                BEND
 105     split_me acc (y    : ys) = split_me (y:acc) ys
 106
 107     my_rev ""     acc = RETN acc -- instead of reverse, so can see on heap-profiles
 108     my_rev (x:xs) acc = my_rev xs (x:acc)
 109 \end{code}
 110
 111 %************************************************************************
 112 %*                                                                      *
 113 \subsection[rdModule]{@rdModule@: reads in a Haskell module}
 114 %*                                                                      *
 115 %************************************************************************
 116
 117 \begin{code}
 118 rdModule :: String
 119          -> (FAST_STRING,               -- this module's name
 120              (FAST_STRING -> Bool,      -- a function to chk if <x> is in the export list
 121               FAST_STRING -> Bool),     -- a function to chk if <M> is among the M..
 122                                 -- ("dotdot") modules in the export list.
 123              ProtoNameModule)   -- the main goods
 124
 125 rdModule (next_char:xs)
 126   = case next_char of { 'M' ->
 127
 128     BIND (rdString                             xs)  _TO_ (srcline,  xs1) ->
 129     BIND (rdIdString                           xs1) _TO_ (name,   xs2) ->
 130     BIND (rdString                             xs2) _TO_ (srcfile,  xs3) ->
 131     BIND (rdBinding srcfile                    xs3) _TO_ (binding,  xs4) ->
 132     BIND (rdList rdFixity                      xs4) _TO_ (fixities, xs5) ->
 133     BIND (rdList (rdImportedInterface srcfile) xs5) _TO_ (imports,  xs6) ->
 134     BIND (rdList rdEntity                      xs6) _TO_ (export_list, _) ->
 135
 136     case sepDeclsForTopBinds binding      of {
 137       (tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) ->
 138
 139     (name,
 140      mk_export_list_chker export_list,
 141      Module name
 142             export_list
 143             imports
 144             fixities
 145             tydecls
 146             tysigs
 147             classdecls
 148             (cvInstDecls True name name instdecls) -- True indicates not imported
 149             instsigs
 150             defaultdecls
 151             (cvSepdBinds srcfile cvValSig binds)
 152             [{-no sigs-}]
 153             (mkSrcLoc srcfile srcline)
 154     )
 155     } BEND BEND BEND BEND BEND BEND BEND
 156     }
 157   where
 158     mk_export_list_chker exp_list
 159       = case (getIEStrings exp_list) of { (entity_info, dotdot_modules) ->
 160         ( \ n -> n `elemFM` just_the_strings,
 161           \ n -> n `elemFM` dotdot_modules )
 162         }
 163 \end{code}
 164
 165 %************************************************************************
 166 %*                                                                      *
 167 \subsection[rdExprOrPat]{@rdExpr@ and @rdPat@}
 168 %*                                                                      *
 169 %************************************************************************
 170
 171 \begin{code}
 172 rdExpr   :: SrcFile -> String -> RETN_TYPE (ProtoNameExpr, String)
 173 rdPat    :: SrcFile -> String -> RETN_TYPE (ProtoNamePat,  String)
 174
 175 rdExpr sf (next_char:xs)
 176   = case next_char of
 177      '(' -> -- left section
 178             BIND (rdExpr sf xs)    _TO_ (expr,xs1) ->
 179             BIND (rdId      xs1)   _TO_ (id,  xs2) ->
 180             RETN (SectionL expr (Var id), xs2)
 181             BEND BEND
 182
 183      ')' -> -- right section
 184             BIND (rdId      xs)    _TO_ (id,  xs1) ->
 185             BIND (rdExpr sf xs1)   _TO_ (expr,xs2) ->
 186             RETN (SectionR (Var id) expr, xs2)
 187             BEND BEND
 188
 189      'j' -> -- ccall/casm
 190             BIND (rdString           xs)  _TO_ (fun,     xs1) ->
 191             BIND (rdString           xs1) _TO_ (flavor,  xs2) ->
 192             BIND (rdList (rdExpr sf) xs2) _TO_ (args,    xs3) ->
 193             RETN (CCall fun args
 194                         (flavor == SLIT("p") || flavor == SLIT("P")) -- may invoke GC
 195                         (flavor == SLIT("N") || flavor == SLIT("P")) -- really a "casm"
 196                         (panic "CCall:result_ty"),
 197                   xs3)
 198             BEND BEND BEND
 199
 200      'k' -> -- scc (set-cost-centre) expression
 201             BIND (rdString      xs)     _TO_ (label, xs1) ->
 202             BIND (rdExpr sf     xs1)    _TO_ (expr,  xs2) ->
 203             RETN (SCC label expr, xs2)
 204             BEND BEND
 205
 206      'l' -> -- lambda expression
 207             BIND (rdString          xs)   _TO_ (srcline, xs1) ->
 208             BIND (rdList (rdPat sf) xs1)  _TO_ (pats,    xs2) ->
 209             BIND (rdExpr sf         xs2)  _TO_ (body,    xs3) ->
 210             let
 211                 src_loc = mkSrcLoc sf srcline
 212             in
 213             RETN (Lam (foldr PatMatch
 214                              (GRHSMatch (GRHSsAndBindsIn
 215                                           [OtherwiseGRHS body src_loc]
 216                                           EmptyBinds))
 217                              pats
 218                       ),
 219                  xs3)
 220             BEND BEND BEND
 221
 222      'c' -> -- case expression
 223             BIND (rdExpr sf           xs)  _TO_ (expr, xs1) ->
 224             BIND (rdList (rdMatch sf) xs1) _TO_ (mats, xs2) ->
 225             let
 226                 matches = cvMatches sf True mats
 227             in
 228             RETN (Case expr matches, xs2)
 229             BEND BEND
 230
 231      'b' -> -- if expression
 232             BIND (rdExpr sf xs)    _TO_ (e1, xs1) ->
 233             BIND (rdExpr sf xs1)   _TO_ (e2, xs2) ->
 234             BIND (rdExpr sf xs2)   _TO_ (e3, xs3) ->
 235             RETN (If e1 e2 e3, xs3)
 236             BEND BEND BEND
 237
 238      'E' -> -- let expression
 239             BIND (rdBinding sf xs)  _TO_ (binding,xs1) ->
 240             BIND (rdExpr sf    xs1) _TO_ (expr,   xs2) ->
 241             let
 242                 binds = cvBinds sf cvValSig binding
 243             in
 244             RETN (Let binds expr, xs2)
 245             BEND BEND
 246
 247      'Z' -> -- list comprehension
 248             BIND (rdExpr sf      xs)    _TO_ (expr,  xs1) ->
 249             BIND (rdList rd_qual xs1)   _TO_ (quals, xs2) ->
 250             RETN (ListComp expr quals, xs2)
 251             BEND BEND
 252             where
 253                rd_qual ('G':xs)
 254                  = BIND (rdPat  sf xs)  _TO_ (pat, xs1) ->
 255                    BIND (rdExpr sf xs1) _TO_ (expr,xs2) ->
 256                    RETN (GeneratorQual pat expr, xs2)
 257                    BEND BEND
 258
 259                rd_qual ('g':xs)
 260                  = BIND (rdExpr sf xs)  _TO_ (expr,xs1) ->
 261                    RETN (FilterQual expr, xs1)
 262                    BEND
 263
 264      '.' -> -- arithmetic sequence
 265             BIND (rdExpr sf             xs)     _TO_ (e1,  xs1) ->
 266             BIND (rdList (rdExpr sf)    xs1)    _TO_ (es2, xs2) ->
 267             BIND (rdList (rdExpr sf)    xs2)    _TO_ (es3, xs3) ->
 268             RETN (cv_arith_seq e1 es2 es3, xs3)
 269             BEND BEND BEND
 270             where
 271                cv_arith_seq e1 []   []   = ArithSeqIn (From       e1)
 272                cv_arith_seq e1 []   [e3] = ArithSeqIn (FromTo     e1 e3)
 273                cv_arith_seq e1 [e2] []   = ArithSeqIn (FromThen   e1 e2)
 274                cv_arith_seq e1 [e2] [e3] = ArithSeqIn (FromThenTo e1 e2 e3)
 275
 276      'R' -> -- expression with type signature
 277             BIND (rdExpr   sf xs)    _TO_ (expr,xs1) ->
 278             BIND (rdPolyType  xs1)   _TO_ (ty,  xs2) ->
 279             RETN (ExprWithTySig expr ty, xs2)
 280             BEND BEND
 281
 282      '-' -> -- negated expression
 283             BIND (rdExpr sf  xs)   _TO_ (expr,xs1) ->
 284             RETN (App (Var (Unk SLIT("negate"))) expr, xs1)
 285             BEND
 286 #ifdef DPH
 287      '5' -> -- parallel ZF expression
 288             BIND (rdExpr sf xs)         _TO_ (expr,      xs1) ->
 289             BIND (rdList (rd_par_qual sf) xs1) _TO_ (qual_list, xs2) ->
 290             let
 291                 quals = foldr1 AndParQuals qual_list
 292             in
 293             RETN (RdrParallelZF expr quals, xs2)
 294             BEND BEND
 295             where
 296               rdParQual sf inp
 297                 = case inp of
 298                 -- ToDo:DPH: I have kawunkled your RdrExplicitProcessor hack
 299                     '0':xs -> BIND (rdExPat sf xs)  _TO_ (RdrExplicitProcessor pats pat, xs1) ->
 300                               BIND (rdExpr  sf xs1) _TO_ (expr, xs2) ->
 301                               RETN (DrawnGenIn pats pat expr, xs2)
 302                               BEND BEND
 303
 304                     'w':xs -> BIND (rdExPat sf xs)  _TO_ (RdrExplicitProcessor exprs pat, xs1) ->
 305                               BIND (rdExpr  sf xs1) _TO_ (expr, xs2) ->
 306                               RETN (IndexGen exprs pat expr, xs2)
 307                               BEND BEND
 308
 309                     'I':xs -> BIND (rdExpr sf xs)       _TO_ (expr,xs1) ->
 310                               RETN (ParFilter expr, xs1)
 311                               BEND
 312
 313      '6' -> -- explicitPod expression
 314             BIND (rdList (rdExpr sf) xs)  _TO_ (exprs,xs1) ->
 315             RETN (RdrExplicitPod exprs,xs1)
 316             BEND
 317 #endif {- Data Parallel Haskell -}
 318
 319     --------------------------------------------------------------
 320     -- now the prefix items that can either be an expression or
 321     -- pattern, except we know they are *expressions* here
 322     -- (this code could be commoned up with the pattern version;
 323     -- but it probably isn't worth it)
 324     --------------------------------------------------------------
 325      'C' -> BIND (rdLiteral xs) _TO_ (lit, xs1) ->
 326             RETN (Lit lit, xs1)
 327             BEND
 328
 329      'i' -> -- simple identifier
 330             BIND (rdId xs) _TO_ (str,xs1) ->
 331             RETN (Var str, xs1)
 332             BEND
 333
 334      'a' -> -- application
 335             BIND (rdExpr sf xs)  _TO_ (expr1, xs1) ->
 336             BIND (rdExpr sf xs1) _TO_ (expr2, xs2) ->
 337             RETN (App expr1 expr2, xs2)
 338             BEND BEND
 339
 340      '@' -> -- operator application
 341             BIND (rdExpr sf xs)   _TO_ (expr1, xs1) ->
 342             BIND (rdId      xs1)  _TO_ (op,    xs2) ->
 343             BIND (rdExpr sf xs2)  _TO_ (expr2, xs3) ->
 344             RETN (OpApp expr1 (Var op) expr2, xs3)
 345             BEND BEND BEND
 346
 347      ':' -> -- explicit list
 348             BIND (rdList (rdExpr sf) xs) _TO_ (exprs, xs1) ->
 349             RETN (ExplicitList exprs, xs1)
 350             BEND
 351
 352      ',' -> -- explicit tuple
 353             BIND (rdList (rdExpr sf) xs) _TO_ (exprs, xs1) ->
 354             RETN (ExplicitTuple exprs, xs1)
 355             BEND
 356
 357 #ifdef DPH
 358      'O' -> -- explicitProcessor expression
 359             BIND (rdList (rdExpr sf) xs)  _TO_ (exprs,xs1) ->
 360             BIND (rdExpr sf xs1)            _TO_ (expr, xs2) ->
 361             RETN (ExplicitProcessor exprs expr, xs2)
 362             BEND BEND
 363 #endif {- Data Parallel Haskell -}
 364
 365      huh -> panic ("ReadPrefix.rdExpr:"++(next_char:xs))
 366 \end{code}
 367
 368 Patterns: just bear in mind that lists of patterns are represented as
 369 a series of ``applications''.
 370 \begin{code}
 371 rdPat sf (next_char:xs)
 372   = case next_char of
 373      's' -> -- "as" pattern
 374             BIND (rdId     xs)  _TO_ (id, xs1) ->
 375             BIND (rdPat sf xs1) _TO_ (pat,xs2) ->
 376             RETN (AsPatIn id pat, xs2)
 377             BEND BEND
 378
 379      '~' -> -- irrefutable ("twiddle") pattern
 380             BIND (rdPat sf xs)  _TO_ (pat,xs1) ->
 381             RETN (LazyPatIn pat, xs1)
 382             BEND
 383
 384      '+' -> -- n+k pattern
 385             BIND (rdPat     sf xs)  _TO_ (pat, xs1) ->
 386             BIND (rdLiteral    xs1) _TO_ (lit, xs2) ->
 387             let
 388                 n = case pat of
 389                       VarPatIn n -> n
 390                       WildPatIn  -> error "ERROR: rdPat: GHC can't handle _+k patterns yet"
 391             in
 392             RETN (NPlusKPatIn n lit, xs2)
 393             BEND BEND
 394
 395      '_' -> -- wildcard pattern
 396             RETN (WildPatIn, xs)
 397
 398     --------------------------------------------------------------
 399     -- now the prefix items that can either be an expression or
 400     -- pattern, except we know they are *patterns* here.
 401     --------------------------------------------------------------
 402      '-' -> BIND (rdPat sf xs)  _TO_ (lit_pat, xs1) ->
 403             case lit_pat of
 404               LitPatIn lit -> RETN (LitPatIn (negLiteral lit), xs1)
 405               _            -> panic "rdPat: bad negated pattern!"
 406             BEND
 407
 408      'C' -> BIND (rdLiteral xs) _TO_ (lit, xs1) ->
 409             RETN (LitPatIn lit, xs1)
 410             BEND
 411
 412      'i' -> -- simple identifier
 413             BIND (rdIdString xs) _TO_ (str, xs1) ->
 414             RETN (if isConop str then
 415                      ConPatIn (Unk str) []
 416                   else
 417                      VarPatIn (Unk str),
 418                   xs1)
 419             BEND
 420
 421      'a' -> -- "application": there's a list of patterns lurking here!
 422             BIND (rd_curried_pats    xs)  _TO_ (lpat:lpats, xs1) ->
 423             BIND (rdPat           sf xs1) _TO_ (rpat,       xs2) ->
 424             let
 425                 (n, llpats)
 426                   = case lpat of
 427                       VarPatIn x    -> (x, [])
 428                       ConPatIn x [] -> (x, [])
 429                       ConOpPatIn x op y -> (op, [x, y])
 430                       other -> -- sorry about the weedy msg; the parser missed this one
 431                         error (ppShow 100 (ppCat [ppStr "ERROR: an illegal `application' of a pattern to another one:", ppInterleave ppSP (map (ppr PprForUser) bad_app)]))
 432
 433                 arg_pats = llpats ++ lpats ++ [rpat]
 434                 bad_app  = (lpat:lpats) ++ [rpat]
 435             in
 436             RETN (ConPatIn n arg_pats, xs2)
 437             BEND BEND
 438             where
 439               rd_curried_pats ('a' : ys)
 440                 = BIND (rd_curried_pats ys)  _TO_ (lpats, ys1) ->
 441                   BIND (rdPat        sf ys1) _TO_ (rpat,  ys2) ->
 442                   RETN (lpats ++ [rpat], ys2)
 443                   BEND BEND
 444               rd_curried_pats ys
 445                 = BIND (rdPat sf ys) _TO_ (pat,  ys1) ->
 446                   RETN ([pat], ys1)
 447                   BEND
 448
 449      '@' -> -- operator application
 450             BIND (rdPat sf xs)   _TO_ (pat1, xs1) ->
 451             BIND (rdId     xs1)  _TO_ (op,   xs2) ->
 452             BIND (rdPat sf xs2)  _TO_ (pat2, xs3) ->
 453             RETN (ConOpPatIn pat1 op pat2, xs3)
 454             BEND BEND BEND
 455
 456      ':' -> -- explicit list
 457             BIND (rdList (rdPat sf) xs) _TO_ (pats, xs1) ->
 458             RETN (ListPatIn pats, xs1)
 459             BEND
 460
 461      ',' -> -- explicit tuple
 462             BIND (rdList (rdPat sf) xs) _TO_ (pats, xs1) ->
 463             RETN (TuplePatIn pats, xs1)
 464             BEND
 465
 466 #ifdef DPH
 467      'O' -> -- explicitProcessor pattern
 468             BIND (rdList (rdPat sf) xs) _TO_ (pats, xs1) ->
 469             BIND (rdPat sf xs1)         _TO_ (pat,  xs2) ->
 470             RETN (ProcessorPatIn pats pat, xs2)
 471             BEND BEND
 472 #endif {- Data Parallel Haskell -}
 473
 474      huh -> panic ("ReadPrefix.rdPat:"++(next_char:xs))
 475 \end{code}
 476
 477 OLD, MISPLACED NOTE: The extra DPH syntax above is defined such that
 478 to the left of a \tr{<<-} or \tr{<<=} there has to be a processor (no
 479 expressions).  Therefore in the pattern matching below we are taking
 480 this into consideration to create the @DrawGen@ whose fields are the
 481 \tr{K} patterns, pat and the exp right of the generator.
 482
 483 \begin{code}
 484 rdLiteral :: String -> RETN_TYPE (Literal, String)
 485
 486 rdLiteral (tag : xs)
 487   = BIND (rdString xs)  _TO_ (x, zs) ->
 488     let
 489         s = _UNPK_ x
 490
 491         as_char     = chr ((read s) :: Int)
 492             -- a char comes in as a number string
 493             -- representing its ASCII code
 494         as_integer  = readInteger s
 495 #if __GLASGOW_HASKELL__ <= 22
 496         as_rational = toRational ((read s)::Double)
 497 #else
 498 #ifdef __GLASGOW_HASKELL__
 499         as_rational = _readRational s -- non-std
 500 #else
 501         as_rational = ((read s)::Rational)
 502 #endif
 503 #endif
 504         as_double   = ((read s) :: Double)
 505     in
 506     case tag of {
 507      '4' -> RETN (IntLit as_integer,      zs);
 508      'F' -> RETN (FracLit as_rational,    zs);
 509      'H' -> RETN (IntPrimLit as_integer,  zs);
 510 #if __GLASGOW_HASKELL__ <= 22
 511      'J' -> RETN (DoublePrimLit as_double,zs);
 512      'K' -> RETN (FloatPrimLit as_double, zs);
 513 #else
 514      'J' -> RETN (DoublePrimLit as_rational,zs);
 515      'K' -> RETN (FloatPrimLit as_rational, zs);
 516 #endif
 517      'C' -> RETN (CharLit as_char,        zs);
 518      'P' -> RETN (CharPrimLit as_char,    zs);
 519      'S' -> RETN (StringLit x,            zs);
 520      'V' -> RETN (StringPrimLit x,        zs);
 521      'Y' -> RETN (LitLitLitIn x,          zs)
 522     } BEND
 523 \end{code}
 524
 525 %************************************************************************
 526 %*                                                                      *
 527 \subsection[rdBinding]{rdBinding}
 528 %*                                                                      *
 529 %************************************************************************
 530
 531 \begin{code}
 532 rdBinding :: SrcFile -> String -> RETN_TYPE (RdrBinding, String)
 533
 534 rdBinding sf (next_char:xs)
 535   = case next_char of
 536      'B' -> -- null binding
 537             RETN (RdrNullBind, xs)
 538
 539      'A' -> -- "and" binding (just glue, really)
 540             BIND (rdBinding sf xs)  _TO_ (binding1, xs1) ->
 541             BIND (rdBinding sf xs1) _TO_ (binding2, xs2) ->
 542             RETN (RdrAndBindings binding1 binding2, xs2)
 543             BEND BEND
 544
 545      't' -> -- "data" declaration
 546             BIND (rdString              xs)  _TO_ (srcline,         xs1) ->
 547             BIND (rdContext             xs1) _TO_ (ctxt,            xs2) ->
 548             BIND (rdList rdId           xs2) _TO_ (derivings,       xs3) ->
 549             BIND (rdTyConAndTyVars      xs3) _TO_ ((tycon, tyvars), xs4) ->
 550             BIND (rdList (rdConDecl sf) xs4) _TO_ (cons,            xs5) ->
 551             BIND (rdDataPragma          xs5) _TO_ (pragma,          xs6) ->
 552             let
 553                 src_loc = mkSrcLoc sf srcline
 554             in
 555             RETN (RdrTyData (TyData ctxt tycon tyvars cons derivings pragma src_loc),
 556                   xs6)
 557             BEND BEND BEND BEND BEND BEND
 558
 559      'n' -> -- "type" declaration
 560             BIND (rdString         xs)  _TO_ (srcline,         xs1) ->
 561             BIND (rdTyConAndTyVars xs1) _TO_ ((tycon, tyvars), xs2) ->
 562             BIND (rdMonoType       xs2) _TO_ (expansion,       xs3) ->
 563             BIND (rdTypePragma     xs3) _TO_ (pragma,          xs4) ->
 564             let
 565                 src_loc = mkSrcLoc sf srcline
 566             in
 567             RETN (RdrTySynonym (TySynonym tycon tyvars expansion pragma src_loc),
 568                   xs4)
 569             BEND BEND BEND BEND
 570
 571      'f' -> -- function binding
 572             BIND (rdString              xs) _TO_ (srcline, xs1) ->
 573             BIND (rdList (rdMatch sf) xs1)  _TO_ (matches, xs2) ->
 574             RETN (RdrFunctionBinding (read (_UNPK_ srcline)) matches, xs2)
 575             BEND BEND
 576
 577      'p' -> -- pattern binding
 578             BIND (rdString              xs)  _TO_ (srcline, xs1) ->
 579             BIND (rdList (rdMatch sf) xs1) _TO_ (matches, xs2) ->
 580             RETN (RdrPatternBinding (read (_UNPK_ srcline)) matches, xs2)
 581             BEND BEND
 582
 583      '$' -> -- "class" declaration
 584             BIND (rdString        xs)   _TO_ (srcline,       xs1) ->
 585             BIND (rdContext       xs1)  _TO_ (ctxt,          xs2) ->
 586             BIND (rdClassAssertTy xs2)  _TO_ ((clas, tyvar), xs3) ->
 587             BIND (rdBinding sf    xs3)  _TO_ (binding,       xs4) ->
 588             BIND (rdClassPragma   xs4)  _TO_ (pragma,        xs5) ->
 589             let
 590                 (class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding
 591
 592                 final_sigs    = concat (map cvClassOpSig class_sigs)
 593                 final_methods = cvMonoBinds sf class_methods
 594
 595                 src_loc = mkSrcLoc sf srcline
 596             in
 597             RETN (RdrClassDecl
 598                   (ClassDecl ctxt clas tyvar final_sigs final_methods pragma src_loc),
 599                   xs5)
 600             BEND BEND BEND BEND BEND
 601
 602      '%' -> -- "instance" declaration
 603             BIND (rdString     xs)      _TO_ (srcline,  xs1) ->
 604             BIND (rdContext    xs1)     _TO_ (ctxt,     xs2) ->
 605             BIND (rdId          xs2)    _TO_ (clas,     xs3) ->
 606             BIND (rdMonoType   xs3)     _TO_ (inst_ty,  xs4) ->
 607             BIND (rdBinding sf xs4)     _TO_ (binding,  xs5) ->
 608             BIND (rdInstPragma xs5)     _TO_ (modname_maybe, pragma, xs6) ->
 609             let
 610                 (ss, bs)   = sepDeclsIntoSigsAndBinds binding
 611                 binds      = cvMonoBinds sf bs
 612                 uprags     = concat (map cvInstDeclSig ss)
 613                 src_loc    = mkSrcLoc sf srcline
 614             in
 615             case modname_maybe of {
 616               Nothing ->
 617                 RETN (RdrInstDecl (\ orig_mod infor_mod here ->
 618                       InstDecl ctxt clas inst_ty binds here orig_mod infor_mod uprags pragma src_loc),
 619                       xs6);
 620               Just orig_mod ->
 621                 RETN (RdrInstDecl (\ _ infor_mod here ->
 622                       InstDecl ctxt clas inst_ty binds here orig_mod infor_mod uprags pragma src_loc),
 623                       xs6)
 624             }
 625             BEND BEND BEND BEND BEND BEND
 626
 627      'D' -> -- "default" declaration
 628             BIND (rdString          xs)   _TO_ (srcline,xs1) ->
 629             BIND (rdList rdMonoType xs1)  _TO_ (tys,    xs2) ->
 630
 631             RETN (RdrDefaultDecl (DefaultDecl tys (mkSrcLoc sf srcline)),
 632                   xs2)
 633             BEND BEND
 634
 635      '7' -> -- "import" declaration in an interface
 636             BIND (rdString          xs)  _TO_ (srcline,   xs1) ->
 637             BIND (rdIdString        xs1) _TO_ (mod,       xs2) ->
 638             BIND (rdList rdEntity   xs2) _TO_ (entities,  xs3) ->
 639             BIND (rdList rdRenaming xs3) _TO_ (renamings, xs4) ->
 640             let
 641                 src_loc = mkSrcLoc sf srcline
 642             in
 643             RETN (RdrIfaceImportDecl (IfaceImportDecl mod entities renamings src_loc),
 644                   xs4)
 645             BEND BEND BEND BEND
 646
 647      'S' -> -- signature(-like) things, including user pragmas
 648             rd_sig_thing sf xs
 649 \end{code}
 650
 651 \begin{code}
 652 rd_sig_thing sf (next_char:xs)
 653   = case next_char of
 654      't' -> -- type signature
 655             BIND (rdString       xs)  _TO_ (srcline, xs1) ->
 656             BIND (rdList rdId    xs1) _TO_ (vars,    xs2) ->
 657             BIND (rdPolyType     xs2) _TO_ (poly_ty, xs3) ->
 658             BIND (rdTySigPragmas xs3) _TO_ (pragma,  xs4) ->
 659             let
 660                 src_loc = mkSrcLoc sf srcline
 661             in
 662             RETN (RdrTySig vars poly_ty pragma src_loc, xs4)
 663             BEND BEND BEND BEND
 664
 665      's' -> -- value specialisation user-pragma
 666             BIND (rdString          xs)  _TO_ (srcline, xs1) ->
 667             BIND (rdId              xs1) _TO_ (var,     xs2) ->
 668             BIND (rdList rdPolyType xs2) _TO_ (tys,     xs3) ->
 669             let
 670                 src_loc = mkSrcLoc sf srcline
 671             in
 672             RETN (RdrSpecValSig [SpecSig var ty Nothing{-ToDo: using...s-} src_loc | ty <- tys], xs3)
 673             BEND BEND BEND
 674
 675      'S' -> -- instance specialisation user-pragma
 676             BIND (rdString          xs)  _TO_ (srcline, xs1) ->
 677             BIND (rdId              xs1) _TO_ (clas,    xs2) ->
 678             BIND (rdMonoType        xs2) _TO_ (ty,      xs3) ->
 679             let
 680                 src_loc = mkSrcLoc sf srcline
 681             in
 682             RETN (RdrSpecInstSig (InstSpecSig clas ty src_loc), xs3)
 683             BEND BEND BEND
 684
 685      'i' -> -- value inlining user-pragma
 686             BIND (rdString          xs)  _TO_ (srcline, xs1) ->
 687             BIND (rdId              xs1) _TO_ (var,     xs2) ->
 688             BIND (rdList rdIdString xs2) _TO_ (howto,   xs3) ->
 689             let
 690                 src_loc = mkSrcLoc sf srcline
 691
 692                 guidance
 693                   = (case howto of {
 694                       []  -> id;
 695                       [x] -> trace "ignoring unfold howto" }) UnfoldAlways
 696             in
 697             RETN (RdrInlineValSig (InlineSig var guidance src_loc), xs3)
 698             BEND BEND BEND
 699
 700      'd' -> -- value deforest user-pragma
 701             BIND (rdString       xs)  _TO_ (srcline, xs1) ->
 702             BIND (rdId           xs1) _TO_ (var, xs2) ->
 703             let
 704                 src_loc = mkSrcLoc sf srcline
 705             in
 706             RETN (RdrDeforestSig (DeforestSig var src_loc), xs2)
 707             BEND BEND
 708
 709      'u' -> -- value magic-unfolding user-pragma
 710             BIND (rdString       xs)  _TO_ (srcline, xs1) ->
 711             BIND (rdId           xs1) _TO_ (var,     xs2) ->
 712             BIND (rdIdString     xs2) _TO_ (str,     xs3) ->
 713             let
 714                 src_loc = mkSrcLoc sf srcline
 715             in
 716             RETN (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc), xs3)
 717             BEND BEND BEND
 718
 719      'a' -> -- abstract-type-synonym user-pragma
 720             BIND (rdString       xs)  _TO_ (srcline, xs1) ->
 721             BIND (rdId           xs1) _TO_ (tycon,   xs2) ->
 722             let
 723                 src_loc = mkSrcLoc sf srcline
 724             in
 725             RETN (RdrAbstractTypeSig (AbstractTypeSig tycon src_loc), xs2)
 726             BEND BEND
 727
 728      'd' -> -- data specialisation user-pragma
 729             BIND (rdString          xs)  _TO_ (srcline, xs1) ->
 730             BIND (rdId              xs1) _TO_ (tycon,   xs2) ->
 731             BIND (rdList rdMonoType xs2) _TO_ (tys,     xs3) ->
 732             let
 733                 src_loc = mkSrcLoc sf srcline
 734                 spec_ty = MonoTyCon tycon tys
 735             in
 736             RETN (RdrSpecDataSig (SpecDataSig tycon spec_ty src_loc), xs3)
 737             BEND BEND BEND
 738 \end{code}
 739
 740 %************************************************************************
 741 %*                                                                      *
 742 \subsection[rdTypes]{Reading in types in various forms (and data constructors)}
 743 %*                                                                      *
 744 %************************************************************************
 745
 746 \begin{code}
 747 rdPolyType :: String -> RETN_TYPE (ProtoNamePolyType, String)
 748 rdMonoType :: String -> RETN_TYPE (ProtoNameMonoType, String)
 749
 750 rdPolyType ('3' : xs)
 751   = BIND (rdContext      xs)    _TO_ (ctxt, xs1) ->
 752     BIND (rdMonoType xs1)       _TO_ (ty,   xs2) ->
 753     RETN (OverloadedTy ctxt ty, xs2)
 754     BEND BEND
 755
 756 rdPolyType ('2' : 'C' : xs)
 757   = BIND (rdList rdId xs)       _TO_ (tvs, xs1) ->
 758     BIND (rdMonoType  xs1)      _TO_ (ty,  xs2) ->
 759     RETN (ForAllTy tvs ty, xs2)
 760     BEND BEND
 761
 762 rdPolyType other
 763   = BIND (rdMonoType other)         _TO_ (ty, xs1) ->
 764     RETN (UnoverloadedTy ty, xs1)
 765     BEND
 766
 767 rdMonoType ('T' : xs)
 768   = BIND (rdId          xs)         _TO_ (tycon, xs1) ->
 769     BIND (rdList rdMonoType xs1)    _TO_ (tys,   xs2) ->
 770     RETN (MonoTyCon tycon tys, xs2)
 771     BEND BEND
 772
 773 rdMonoType (':' : xs)
 774   = BIND (rdMonoType xs)            _TO_ (ty, xs1) ->
 775     RETN (ListMonoTy ty, xs1)
 776     BEND
 777
 778 rdMonoType (',' : xs)
 779   = BIND (rdList rdPolyType xs)     _TO_ (tys, xs1) ->
 780     RETN (TupleMonoTy tys, xs1)
 781     BEND
 782
 783 rdMonoType ('>' : xs)
 784   = BIND (rdMonoType xs)        _TO_ (ty1, xs1) ->
 785     BIND (rdMonoType xs1)       _TO_ (ty2, xs2) ->
 786     RETN (FunMonoTy ty1 ty2, xs2)
 787     BEND BEND
 788
 789 rdMonoType ('y' : xs)
 790   = BIND (rdId xs)              _TO_ (tyvar, xs1) ->
 791     RETN (MonoTyVar tyvar, xs1)
 792     BEND
 793
 794 rdMonoType ('2' : 'A' : xs)
 795   = BIND (rdId       xs)        _TO_ (clas, xs1) ->
 796     BIND (rdMonoType xs1)       _TO_ (ty,   xs2) ->
 797     RETN (MonoDict clas ty, xs2)
 798     BEND BEND
 799
 800 rdMonoType ('2' : 'B' : xs)
 801   = BIND (rdId xs)              _TO_ (tv_tmpl, xs1) ->
 802     RETN (MonoTyVarTemplate tv_tmpl, xs1)
 803     BEND
 804
 805 #ifdef DPH
 806 rdMonoType ('v' : xs)
 807   = BIND (rdMonoType xs)            _TO_ (ty, xs1) ->
 808     RETN (RdrExplicitPodTy ty, xs1)
 809     BEND
 810
 811 rdMonoType ('u' : xs)
 812   = BIND (rdList rdMonoType xs) _TO_ (tys, xs1) ->
 813     BIND (rdMonoType xs1)       _TO_ (ty,  xs2)  ->
 814     RETN (RdrExplicitProcessorTy tys ty, xs2)
 815     BEND BEND
 816 #endif {- Data Parallel Haskell -}
 817
 818 rdMonoType oops = panic ("rdMonoType:"++oops)
 819 \end{code}
 820
 821 \begin{code}
 822 rdTyConAndTyVars :: String -> RETN_TYPE ((ProtoName, [ProtoName]), String)
 823 rdContext        :: String -> RETN_TYPE (ProtoNameContext, String)
 824 rdClassAssertTy  :: String -> RETN_TYPE ((ProtoName, ProtoName), String)
 825
 826 rdTyConAndTyVars xs
 827   = BIND (rdMonoType xs)   _TO_ (MonoTyCon tycon ty_args, xs1) ->
 828     let
 829         args = [ a | (MonoTyVar a) <- ty_args ]
 830     in
 831     RETN ((tycon, args), xs1)
 832     BEND
 833
 834 rdContext xs
 835   = BIND (rdList rdMonoType xs) _TO_ (tys, xs1) ->
 836     RETN (map mk_class_assertion tys, xs1)
 837     BEND
 838
 839 rdClassAssertTy xs
 840   = BIND (rdMonoType xs)   _TO_ (mono_ty, xs1) ->
 841     RETN (mk_class_assertion mono_ty, xs1)
 842     BEND
 843
 844 mk_class_assertion :: ProtoNameMonoType -> (ProtoName, ProtoName)
 845
 846 mk_class_assertion (MonoTyCon name [(MonoTyVar tyname)]) = (name, tyname)
 847 mk_class_assertion other
 848   = error ("ERROR: malformed type context: "++ppShow 80 (ppr PprForUser other)++"\n")
 849     -- regrettably, the parser does let some junk past
 850     -- e.g., f :: Num {-nothing-} => a -> ...
 851 \end{code}
 852
 853 \begin{code}
 854 rdConDecl :: SrcFile -> String -> RETN_TYPE (ProtoNameConDecl, String)
 855
 856 rdConDecl sf ('1':xs)
 857   = BIND (rdString          xs)  _TO_ (srcline,   xs1) ->
 858     BIND (rdId              xs1) _TO_ (id,        xs2) ->
 859     BIND (rdList rdMonoType xs2) _TO_ (tys,       xs3) ->
 860     RETN (ConDecl id tys (mkSrcLoc sf srcline), xs3)
 861     BEND BEND BEND
 862 \end{code}
 863
 864 %************************************************************************
 865 %*                                                                      *
 866 \subsection[rdMatch]{Read a ``match''}
 867 %*                                                                      *
 868 %************************************************************************
 869
 870 \begin{code}
 871 rdMatch :: SrcFile -> String -> RETN_TYPE (RdrMatch, String)
 872
 873 rdMatch sf ('W':xs)
 874   = BIND (rdString          xs)  _TO_ (srcline, xs1) ->
 875     BIND (rdIdString        xs1) _TO_ (srcfun,  xs2) ->
 876     BIND (rdPat sf          xs2) _TO_ (pat,     xs3) ->
 877     BIND (rdList rd_guarded xs3) _TO_ (grhss,   xs4) ->
 878     BIND (rdBinding sf      xs4) _TO_ (binding, xs5) ->
 879
 880     RETN (RdrMatch (read (_UNPK_ srcline)) srcfun pat grhss binding, xs5)
 881     BEND BEND BEND BEND BEND
 882   where
 883     rd_guarded xs
 884       = BIND (rdExpr sf xs)     _TO_ (g, xs1) ->
 885         BIND (rdExpr sf xs1)    _TO_ (e, xs2) ->
 886         RETN ((g, e), xs2)
 887         BEND BEND
 888 \end{code}
 889
 890 %************************************************************************
 891 %*                                                                      *
 892 \subsection[rdFixity]{Read in a fixity declaration}
 893 %*                                                                      *
 894 %************************************************************************
 895
 896 \begin{code}
 897 rdFixity :: String -> RETN_TYPE (ProtoNameFixityDecl, String)
 898 rdFixity xs
 899   = BIND (rdId     xs)  _TO_ (op,            xs1) ->
 900     BIND (rdString xs1) _TO_ (associativity, xs2) ->
 901     BIND (rdString xs2) _TO_ (prec_str,      xs3) ->
 902     let
 903         precedence = read (_UNPK_ prec_str)
 904     in
 905     case (_UNPK_ associativity) of {
 906       "infix"  -> RETN (InfixN op precedence, xs3);
 907       "infixl" -> RETN (InfixL op precedence, xs3);
 908       "infixr" -> RETN (InfixR op precedence, xs3)
 909     } BEND BEND BEND
 910 \end{code}
 911
 912 %************************************************************************
 913 %*                                                                      *
 914 \subsection[rdImportedInterface]{Read an imported interface}
 915 %*                                                                      *
 916 %************************************************************************
 917
 918 \begin{code}
 919 rdImportedInterface :: FAST_STRING -> String
 920                     -> RETN_TYPE (ProtoNameImportedInterface, String)
 921
 922 rdImportedInterface importing_srcfile (x:xs)
 923   = BIND (rdString          xs)  _TO_ (srcline,  xs1) ->
 924     BIND (rdString          xs1) _TO_ (srcfile,  xs2) ->
 925     BIND (rdIdString        xs2) _TO_ (modname,  xs3) ->
 926     BIND (rdList rdEntity   xs3) _TO_ (imports,  xs4) ->
 927     BIND (rdList rdRenaming xs4) _TO_ (renamings,xs5) ->
 928     BIND (rdBinding srcfile xs5) _TO_ (iface_bs, xs6) ->
 929
 930     case (sepDeclsForInterface iface_bs) of {
 931                 (tydecls,classdecls,instdecls,sigs,iimpdecls) ->
 932     let
 933         expose_or_hide = case x of { 'e' -> ImportSome; 'h' -> ImportButHide }
 934
 935         cv_iface
 936           = MkInterface modname
 937                 iimpdecls
 938                 [{-fixity decls-}]  -- can't get fixity decls in here yet (ToDo)
 939                 tydecls
 940                 classdecls
 941                 (cvInstDecls False SLIT(""){-probably superceded by modname < pragmas-}
 942                                    modname instdecls)
 943                             -- False indicates imported
 944                 (concat (map cvValSig sigs))
 945                 (mkSrcLoc importing_srcfile srcline)
 946     in
 947     RETN (
 948     (if null imports then
 949         ImportAll cv_iface renamings
 950      else
 951         expose_or_hide cv_iface imports renamings
 952     , xs6))
 953     } BEND BEND BEND BEND BEND BEND
 954 \end{code}
 955
 956 \begin{code}
 957 rdRenaming :: String -> RETN_TYPE (Renaming, String)
 958
 959 rdRenaming xs
 960   = BIND (rdIdString xs)    _TO_ (id1, xs1) ->
 961     BIND (rdIdString xs1)   _TO_ (id2, xs2) ->
 962     RETN (MkRenaming id1 id2, xs2)
 963     BEND BEND
 964 \end{code}
 965
 966 \begin{code}
 967 rdEntity :: String -> RETN_TYPE (IE, String)
 968
 969 rdEntity inp
 970   = case inp of
 971       'x':xs -> BIND (rdIdString xs)    _TO_ (var, xs1) ->
 972                 RETN (IEVar var, xs1)
 973                 BEND
 974
 975       'X':xs -> BIND (rdIdString xs)    _TO_ (thing, xs1) ->
 976                 RETN (IEThingAbs thing, xs1)
 977                 BEND
 978
 979       'z':xs -> BIND (rdIdString xs)    _TO_ (thing, xs1) ->
 980                 RETN (IEThingAll thing, xs1)
 981                 BEND
 982
 983       '8':xs -> BIND (rdIdString        xs)  _TO_ (tycon, xs1) ->
 984                 BIND (rdList rdString   xs1) _TO_ (cons,  xs2) ->
 985                 RETN (IEConWithCons tycon cons, xs2)
 986                 BEND BEND
 987
 988       '9':xs -> BIND (rdIdString        xs)  _TO_ (c,   xs1) ->
 989                 BIND (rdList rdString   xs1) _TO_ (ops, xs2) ->
 990                 RETN (IEClsWithOps c ops, xs2)
 991                 BEND BEND
 992
 993       'm':xs -> BIND (rdIdString xs)    _TO_ (m, xs1) ->
 994                 RETN (IEModuleContents m, xs1)
 995                 BEND
 996 \end{code}