ghc/compiler/reader/Lex.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[Lexical analysis]{Lexical analysis}
   5
   6 --------------------------------------------------------
   7 [Jan 98]
   8 There's a known bug in here:
   9
  10         If an interface file ends prematurely, Lex tries to
  11         do headFS of an empty FastString.
  12
  13 An example that provokes the error is
  14
  15         f _:_ _forall_ [a] <<<END OF FILE>>>
  16 --------------------------------------------------------
  17
  18 \begin{code}
  19 {-# OPTIONS -#include "ctypes.h" #-}
  20
  21 module Lex (
  22
  23         ifaceParseErr,
  24
  25         -- Monad for parser
  26         IfaceToken(..), lexIface, IfM, thenIf, returnIf, getSrcLocIf,
  27         checkVersion,
  28         happyError,
  29         StringBuffer
  30
  31     ) where
  32
  33 #include "HsVersions.h"
  34
  35 import Char             ( ord, isSpace )
  36 import List             ( isSuffixOf )
  37
  38 import IdInfo           ( InlinePragInfo(..) )
  39 import Name             ( isLowerISO, isUpperISO )
  40 import Module           ( IfaceFlavour, hiFile, hiBootFile )
  41 import PrelMods         ( mkTupNameStr, mkUbxTupNameStr )
  42 import CmdLineOpts      ( opt_IgnoreIfacePragmas, opt_HiVersion, opt_NoHiCheck )
  43 import Demand           ( Demand(..) {- instance Read -} )
  44 import UniqFM           ( UniqFM, listToUFM, lookupUFM)
  45 import BasicTypes       ( NewOrData(..) )
  46 import SrcLoc           ( SrcLoc, incSrcLine, srcLocFile )
  47
  48 import Maybes           ( MaybeErr(..) )
  49 import ErrUtils         ( Message )
  50 import Outputable
  51
  52 import FastString
  53 import StringBuffer
  54 import GlaExts
  55 import ST               ( runST )
  56
  57 #if __GLASGOW_HASKELL__ >= 303
  58 import Bits
  59 import Word
  60 #endif
  61
  62 import Addr
  63 import PrelRead                 ( readRational__ ) -- Glasgow non-std
  64 \end{code}
  65
  66 %************************************************************************
  67 %*                                                                      *
  68 \subsection{Data types}
  69 %*                                                                      *
  70 %************************************************************************
  71
  72 The token data type, fairly un-interesting except from one
  73 constructor, @ITidinfo@, which is used to lazily lex id info (arity,
  74 strictness, unfolding etc).
  75
  76 The Idea/Observation here is that the renamer needs to scan through
  77 all of an interface file before it can continue. But only a fraction
  78 of the information contained in the file turns out to be useful, so
  79 delaying as much as possible of the scanning and parsing of an
  80 interface file Makes Sense (Heap profiles of the compiler
  81 show a reduction in heap usage by at least a factor of two,
  82 post-renamer).
  83
  84 Hence, the interface file lexer spots when value declarations are
  85 being scanned and return the @ITidinfo@ and @ITtype@ constructors
  86 for the type and any other id info for that binding (unfolding, strictness
  87 etc). These constructors are applied to the result of lexing these sub-chunks.
  88
  89 The lexing of the type and id info is all done lazily, of course, so
  90 the scanning (and subsequent parsing) will be done *only* on the ids the
  91 renamer finds out that it is interested in. The rest will just be junked.
  92 Laziness, you know it makes sense :-)
  93
  94 \begin{code}
  95 data IfaceToken
  96   = ITcase                      -- Haskell keywords
  97   | ITclass
  98   | ITdata
  99   | ITdefault
 100   | ITderiving
 101   | ITdo
 102   | ITelse
 103   | ITif
 104   | ITimport
 105   | ITin
 106   | ITinfix
 107   | ITinfixl
 108   | ITinfixr
 109   | ITinstance
 110   | ITlet
 111   | ITmodule
 112   | ITnewtype
 113   | ITof
 114   | ITthen
 115   | ITtype
 116   | ITwhere
 117   | ITas
 118   | ITqualified
 119   | IThiding
 120
 121   | ITinterface                 -- GHC-extension keywords
 122   | ITexport
 123   | ITinstimport
 124   | ITforall
 125   | ITletrec
 126   | ITcoerce
 127   | ITinline
 128   | ITccall (Bool,Bool,Bool)    -- (is_dyn, is_casm, may_gc)
 129   | ITdefaultbranch
 130   | ITbottom
 131   | ITinteger_lit
 132   | ITfloat_lit
 133   | ITrational_lit
 134   | ITaddr_lit
 135   | ITlit_lit
 136   | ITstring_lit
 137   | ITtypeapp
 138   | ITarity
 139   | ITspecialise
 140   | ITnocaf
 141   | ITunfold InlinePragInfo
 142   | ITstrict ([Demand], Bool)
 143   | ITscc
 144   | ITsccAllCafs
 145
 146   | ITdotdot                    -- reserved symbols
 147   | ITdcolon
 148   | ITequal
 149   | ITlam
 150   | ITvbar
 151   | ITlarrow
 152   | ITrarrow
 153   | ITat
 154   | ITtilde
 155   | ITdarrow
 156   | ITminus
 157   | ITbang
 158
 159   | ITbiglam                    -- GHC-extension symbols
 160
 161   | ITocurly                    -- special symbols
 162   | ITccurly
 163   | ITobrack
 164   | ITcbrack
 165   | IToparen
 166   | ITcparen
 167   | IToubxparen
 168   | ITcubxparen
 169   | ITsemi
 170   | ITcomma
 171
 172   | ITvarid   FAST_STRING       -- identifiers
 173   | ITconid   FAST_STRING
 174   | ITvarsym  FAST_STRING
 175   | ITconsym  FAST_STRING
 176   | ITqvarid  (FAST_STRING,FAST_STRING,IfaceFlavour)
 177   | ITqconid  (FAST_STRING,FAST_STRING,IfaceFlavour)
 178   | ITqvarsym (FAST_STRING,FAST_STRING,IfaceFlavour)
 179   | ITqconsym (FAST_STRING,FAST_STRING,IfaceFlavour)
 180
 181   | ITpragma StringBuffer
 182
 183   | ITchar Char
 184   | ITstring FAST_STRING
 185   | ITinteger Integer
 186   | ITrational Rational
 187
 188   | ITunknown String            -- Used when the lexer can't make sense of it
 189   | ITeof                       -- end of file token
 190   deriving Text -- debugging
 191 \end{code}
 192
 193 %************************************************************************
 194 %*                                                                      *
 195 \subsection{The lexical analyser}
 196 %*                                                                      *
 197 %************************************************************************
 198
 199 \begin{code}
 200 lexIface :: (IfaceToken -> IfM a) -> IfM a
 201 lexIface cont buf =
 202  _scc_ "Lexer"
 203 -- if bufferExhausted buf then
 204 --  []
 205 -- else
 206 --  trace ("Lexer: '"++[C# (currentChar# buf)]++"'") $
 207   case currentChar# buf of
 208       -- whitespace and comments, ignore.
 209     ' '#  -> lexIface cont (stepOn buf)
 210     '\t'# -> lexIface cont (stepOn buf)
 211     '\n'# -> \ loc -> lexIface cont (stepOn buf) (incSrcLine loc)
 212
 213 -- Numbers and comments
 214     '-'#  ->
 215       case lookAhead# buf 1# of
 216 --        '-'# -> lex_comment cont (stepOnBy# buf 2#)
 217         c    ->
 218           if is_digit c
 219           then lex_num cont (negate) (ord# c -# ord# '0'#) (incLexeme (incLexeme buf))
 220           else lex_sym cont buf
 221
 222     '{'# ->                             -- look for "{-##" special iface pragma
 223         case lookAhead# buf 1# of
 224            '-'# -> case lookAhead# buf 2# of
 225                     '#'# -> case lookAhead# buf 3# of
 226                                 '#'# ->
 227                                    let (lexeme, buf')
 228                                           = doDiscard False (stepOnBy# buf 4#) in
 229                                    cont (ITpragma lexeme) buf'
 230                                 _ ->  lex_nested_comment (lexIface cont) buf
 231                     _    -> cont ITocurly (stepOn buf)
 232                             -- lex_nested_comment (lexIface cont) buf
 233            _ -> cont ITocurly (stepOn buf)
 234
 235     -- special symbols ----------------------------------------------------
 236     '('# ->
 237          case prefixMatch (stepOn buf) "..)" of
 238            Just buf' ->  cont ITdotdot (stepOverLexeme buf')
 239            Nothing ->
 240             case lookAhead# buf 1# of
 241               '#'# -> cont IToubxparen (stepOnBy# buf 2#)
 242               _    -> cont IToparen (stepOn buf)
 243     ')'# -> cont ITcparen (stepOn buf)
 244     '}'# -> cont ITccurly (stepOn buf)
 245     '#'# -> case lookAhead# buf 1# of
 246                 ')'# -> cont ITcubxparen (stepOnBy# buf 2#)
 247                 _    -> lex_sym cont (incLexeme buf)
 248     '['# -> cont ITobrack (stepOn buf)
 249     ']'# -> cont ITcbrack (stepOn buf)
 250     ','# -> cont ITcomma  (stepOn buf)
 251     ';'# -> cont ITsemi   (stepOn buf)
 252
 253     -- strings/characters -------------------------------------------------
 254     '\"'#{-"-} -> case untilEndOfString# (stepOn buf) of
 255               buf' ->
 256                   -- the string literal does *not* include the dquotes
 257                 case lexemeToFastString buf' of
 258                  v -> cont (ITstring v) (stepOn (stepOverLexeme buf'))
 259
 260     '\''# -> --
 261              -- untilEndOfChar# extends the current lexeme until
 262              -- it hits a non-escaped single quote. The lexeme of the
 263              -- StringBuffer returned does *not* include the closing quote,
 264              -- hence we augment the lexeme and make sure to add the
 265              -- starting quote, before `read'ing the string.
 266              --
 267              case untilEndOfChar# (stepOn buf) of
 268                buf' -> case reads ('\'':lexemeToString (incLexeme buf')) of
 269                         [  (ch, rest)] -> cont (ITchar ch) (stepOverLexeme (incLexeme buf'))
 270
 271     -- strictness pragma and __scc treated specially.
 272     '_'# ->
 273          case lookAhead# buf 1# of
 274            '_'# -> case lookAhead# buf 2# of
 275                     'S'# ->
 276                         lex_demand cont (stepOnUntil (not . isSpace)
 277                                         (stepOnBy# buf 3#)) -- past __S
 278                     's'# ->
 279                         case prefixMatch (stepOnBy# buf 3#) "cc" of
 280                                Just buf' -> lex_scc cont (stepOverLexeme buf')
 281                                Nothing   -> lex_id cont buf
 282                     _ -> lex_id cont buf
 283            _    -> lex_id cont buf
 284
 285 -- ``thingy'' form for casm
 286     '`'# ->
 287             case lookAhead# buf 1# of
 288               '`'# -> lex_cstring cont (stepOnBy# buf 2#) -- remove the `s and go.
 289               _    -> lex_sym cont (incLexeme buf)         -- add ` to lexeme and assume
 290                                                      -- scanning an id of some sort.
 291
 292     '\NUL'# ->
 293             if bufferExhausted (stepOn buf) then
 294                cont ITeof buf
 295             else
 296                trace "lexIface: misplaced NUL?" $
 297                cont (ITunknown "\NUL") (stepOn buf)
 298
 299     c | is_digit  c -> lex_num cont (id) (ord# c -# ord# '0'#) (incLexeme buf)
 300       | is_symbol c -> lex_sym cont buf
 301       | is_upper  c -> lex_con cont buf
 302       | is_ident  c -> lex_id  cont buf
 303
 304 --  where
 305 lex_comment cont buf =
 306 --   _trace ("comment: "++[C# (currentChar# buf)]) $
 307    case untilChar# buf '\n'# of {buf' -> lexIface cont (stepOverLexeme buf')}
 308
 309 -------------------------------------------------------------------------------
 310
 311 lex_nested_comment cont buf =
 312   case currentChar# buf of
 313         '-'# -> case lookAhead# buf 1# of
 314                  '}'# -> cont (stepOnBy# buf 2#)
 315                  _    -> lex_nested_comment cont (stepOn buf)
 316
 317         '{'# -> case lookAhead# buf 1# of
 318                  '-'# -> lex_nested_comment
 319                                 (lex_nested_comment cont)
 320                                 (stepOnBy# buf 2#)
 321                  _    -> lex_nested_comment cont (stepOn buf)
 322
 323         _   -> lex_nested_comment cont (stepOn buf)
 324
 325 -------------------------------------------------------------------------------
 326
 327 lex_demand cont buf =
 328  case read_em [] buf of { (ls,buf') ->
 329  case currentChar# buf' of
 330    'B'# -> cont (ITstrict (ls, True )) (stepOverLexeme (stepOn buf'))
 331    _    -> cont (ITstrict (ls, False)) (stepOverLexeme buf')
 332  }
 333  where
 334    -- code snatched from Demand.lhs
 335   read_em acc buf =
 336    case currentChar# buf of
 337     'L'# -> read_em (WwLazy False : acc) (stepOn buf)
 338     'A'# -> read_em (WwLazy True  : acc) (stepOn buf)
 339     'S'# -> read_em (WwStrict     : acc) (stepOn buf)
 340     'P'# -> read_em (WwPrim       : acc) (stepOn buf)
 341     'E'# -> read_em (WwEnum       : acc) (stepOn buf)
 342     ')'# -> (reverse acc, stepOn buf)
 343     'U'# -> do_unpack DataType True  acc (stepOnBy# buf 2#)
 344     'u'# -> do_unpack DataType False acc (stepOnBy# buf 2#)
 345     'N'# -> do_unpack NewType True  acc (stepOnBy# buf 2#)
 346     'n'# -> do_unpack NewType False acc (stepOnBy# buf 2#)
 347     _    -> (reverse acc, buf)
 348
 349   do_unpack new_or_data wrapper_unpacks acc buf
 350    = case read_em [] buf of
 351       (stuff, rest) -> read_em (WwUnpack new_or_data wrapper_unpacks stuff : acc) rest
 352
 353 ------------------
 354 lex_scc cont buf =
 355  case currentChar# buf of
 356   'C'# -> cont ITsccAllCafs  (stepOverLexeme (stepOn buf))
 357   other -> cont ITscc buf
 358
 359 -----------
 360 lex_num :: (IfaceToken -> IfM a) -> (Int -> Int) -> Int# -> IfM a
 361 lex_num cont minus acc# buf =
 362  --trace ("lex_num: "++[C# (currentChar# buf)]) $
 363  case scanNumLit (I# acc#) buf of
 364      (acc',buf') ->
 365        case currentChar# buf' of
 366          '.'# ->
 367              -- this case is not optimised at all, as the
 368              -- presence of floating point numbers in interface
 369              -- files is not that common. (ToDo)
 370             case expandWhile# is_digit (incLexeme buf') of
 371               buf2 -> -- points to first non digit char
 372                 let l = case currentChar# buf2 of
 373                           'e'# -> let buf3 = incLexeme buf2 in
 374                               case currentChar# buf3 of
 375                                 '-'# -> expandWhile# is_digit (incLexeme buf3)
 376                                 _    -> expandWhile# is_digit buf3
 377                           _ -> buf2
 378                 in let v = readRational__ (lexemeToString l) in
 379                    cont (ITrational v) (stepOverLexeme l)
 380
 381          _ -> cont (ITinteger (fromInt (minus acc'))) (stepOverLexeme buf')
 382
 383 -----------
 384 lex_cstring cont buf =
 385  case expandUntilMatch buf "\'\'" of
 386    buf' -> cont (ITstring (lexemeToFastString (setCurrentPos# buf' (negateInt# 2#))))
 387            (stepOverLexeme buf')
 388
 389 ------------------------------------------------------------------------------
 390 -- Character Classes
 391
 392 is_ident, is_symbol, is_any, is_upper, is_digit :: Char# -> Bool
 393
 394 {-# INLINE is_ctype #-}
 395 #if __GLASGOW_HASKELL__ >= 303
 396 is_ctype :: Word8 -> Char# -> Bool
 397 is_ctype mask = \c ->
 398    (indexWord8OffAddr (``char_types'' :: Addr) (ord (C# c)) .&. mask) /= 0
 399 #else
 400 is_ctype :: Int -> Char# -> Bool
 401 is_ctype (I# mask) = \c ->
 402     let (A# ctype) = ``char_types'' :: Addr
 403         flag_word  = int2Word# (ord# (indexCharOffAddr# ctype (ord# c)))
 404     in
 405         (flag_word `and#` (int2Word# mask)) `neWord#` (int2Word# 0#)
 406 #endif
 407
 408 is_ident  = is_ctype 1
 409 is_symbol = is_ctype 2
 410 is_any    = is_ctype 4
 411 is_space  = is_ctype 8
 412 is_upper  = is_ctype 16
 413 is_digit  = is_ctype 32
 414
 415 -----------------------------------------------------------------------------
 416 -- identifiers, symbols etc.
 417
 418 lex_id cont buf =
 419  case expandWhile# is_ident buf of { buf1 ->
 420  case expandWhile# (eqChar# '#'#) buf1 of { buf' -> -- only if GHC extns on
 421  let new_buf = stepOverLexeme buf'
 422      lexeme  = lexemeToFastString buf'
 423  in
 424  case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
 425         Just kwd_token -> --trace ("hkeywd: "++_UNPK_(lexeme)) $
 426                           cont kwd_token new_buf;
 427         Nothing        ->
 428  case lookupUFM ifaceKeywordsFM lexeme of {
 429         Just kwd_token -> --trace ("ifacekeywd: "++_UNPK_(lexeme)) $
 430                           cont kwd_token new_buf;
 431         Nothing        -> --trace ("id: "++_UNPK_(lexeme)) $
 432                           cont (mk_var_token lexeme) new_buf
 433  }}}}
 434
 435 lex_sym cont buf =
 436  case expandWhile# is_symbol buf of
 437    buf'
 438      | is_comment lexeme -> lex_comment cont new_buf
 439      | otherwise         ->
 440            case lookupUFM haskellKeySymsFM lexeme of {
 441                 Just kwd_token -> --trace ("keysym: "++unpackFS lexeme) $
 442                                   cont kwd_token new_buf ;
 443                 Nothing        -> --trace ("sym: "++unpackFS lexeme) $
 444                                   cont (mk_var_token lexeme) new_buf
 445            }
 446         where lexeme = lexemeToFastString buf'
 447               new_buf = stepOverLexeme buf'
 448
 449               is_comment fs
 450                 | len < 2   = False
 451                 | otherwise = trundle 0
 452                   where
 453                    len = lengthFS fs
 454
 455                    trundle n | n == len  = True
 456                              | otherwise = indexFS fs n == '-' && trundle (n+1)
 457
 458 lex_con cont buf =
 459  case expandWhile# is_ident buf of        { buf1 ->
 460  case expandWhile# (eqChar# '#'#) buf1 of { buf' ->
 461  case currentChar# buf' of
 462      '.'# -> munch hiFile
 463      '!'# -> munch hiBootFile
 464      _    -> just_a_conid
 465
 466    where
 467     just_a_conid = --trace ("con: "++unpackFS lexeme) $
 468                    cont (ITconid lexeme) new_buf
 469     lexeme = lexemeToFastString buf'
 470     new_buf = stepOverLexeme buf'
 471     munch hif = lex_qid cont lexeme hif (stepOn new_buf) just_a_conid
 472  }}
 473
 474 lex_qid cont mod hif buf just_a_conid =
 475  case currentChar# buf of
 476   '['# ->       -- Special case for []
 477     case lookAhead# buf 1# of
 478      ']'# -> cont (ITqconid  (mod,SLIT("[]"),hif)) (stepOnBy# buf 2#)
 479      _    -> just_a_conid
 480
 481   '('# ->  -- Special case for (,,,)
 482            -- This *is* necessary to deal with e.g. "instance C PrelBase.(,,)"
 483     case lookAhead# buf 1# of
 484      '#'# -> case lookAhead# buf 2# of
 485                 ','# -> lex_ubx_tuple cont mod hif (stepOnBy# buf 3#)
 486                                 just_a_conid
 487                 _    -> just_a_conid
 488      ')'# -> cont (ITqconid (mod,SLIT("()"),hif)) (stepOnBy# buf 2#)
 489      ','# -> lex_tuple cont mod hif (stepOnBy# buf 2#) just_a_conid
 490      _    -> just_a_conid
 491
 492   '-'# -> case lookAhead# buf 1# of
 493             '>'# -> cont (ITqconid (mod,SLIT("->"),hif)) (stepOnBy# buf 2#)
 494             _    -> lex_id3 cont mod hif buf just_a_conid
 495   _    -> lex_id3 cont mod hif buf just_a_conid
 496
 497 lex_id3 cont mod hif buf just_a_conid
 498   | is_symbol c =
 499      case expandWhile# is_symbol buf of { buf' ->
 500      let
 501       lexeme  = lexemeToFastString buf'
 502       new_buf = stepOverLexeme buf'
 503      in
 504      case lookupUFM haskellKeySymsFM lexeme of {
 505         Just kwd_token -> just_a_conid; -- avoid M.:: etc.
 506         Nothing        -> cont (mk_qvar_token mod hif lexeme) new_buf
 507      }}
 508
 509   | otherwise   =
 510      case expandWhile# is_ident buf of { buf1 ->
 511      if emptyLexeme buf1
 512             then just_a_conid
 513             else
 514      case expandWhile# (eqChar# '#'#) buf1 of { buf' -> -- only if GHC extns on
 515      let
 516       lexeme  = lexemeToFastString buf'
 517       new_buf = stepOverLexeme buf'
 518      in
 519      case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
 520             Just kwd_token -> just_a_conid; -- avoid M.where etc.
 521             Nothing        ->
 522      case lookupUFM ifaceKeywordsFM lexeme of { -- only for iface files
 523             Just kwd_token -> just_a_conid;
 524             Nothing        -> cont (mk_qvar_token mod hif lexeme) new_buf
 525      }}}}
 526   where c = currentChar# buf
 527
 528 mk_var_token pk_str
 529   | is_upper f          = ITconid pk_str
 530         -- _[A-Z] is treated as a constructor in interface files.
 531   | f `eqChar#` '_'# && not (_NULL_ tl)
 532         && (case _HEAD_ tl of { C# g -> is_upper g }) = ITconid pk_str
 533   | is_ident f          = ITvarid pk_str
 534   | f `eqChar#` ':'#    = ITconsym pk_str
 535   | otherwise           = ITvarsym pk_str
 536   where
 537       (C# f) = _HEAD_ pk_str
 538       tl     = _TAIL_ pk_str
 539
 540 mk_qvar_token m hif token =
 541  case mk_var_token token of
 542    ITconid n  -> ITqconid  (m,n,hif)
 543    ITvarid n  -> ITqvarid  (m,n,hif)
 544    ITconsym n -> ITqconsym (m,n,hif)
 545    ITvarsym n -> ITqvarsym (m,n,hif)
 546    _          -> ITunknown (show token)
 547 \end{code}
 548
 549 ----------------------------------------------------------------------------
 550 Horrible stuff for dealing with M.(,,,)
 551
 552 \begin{code}
 553 lex_tuple cont mod hif buf back_off =
 554   go 2 buf
 555   where
 556    go n buf =
 557     case currentChar# buf of
 558       ','# -> go (n+1) (stepOn buf)
 559       ')'# -> cont (ITqconid (mod, snd (mkTupNameStr n),hif)) (stepOn buf)
 560       _    -> back_off
 561
 562 lex_ubx_tuple cont mod hif buf back_off =
 563   go 2 buf
 564   where
 565    go n buf =
 566     case currentChar# buf of
 567       ','# -> go (n+1) (stepOn buf)
 568       '#'# -> case lookAhead# buf 1# of
 569                 ')'# -> cont (ITqconid (mod, snd (mkUbxTupNameStr n), hif))
 570                                  (stepOnBy# buf 2#)
 571                 _    -> back_off
 572       _    -> back_off
 573 \end{code}
 574
 575 -----------------------------------------------------------------------------
 576 Keyword Lists
 577
 578 \begin{code}
 579 ifaceKeywordsFM :: UniqFM IfaceToken
 580 ifaceKeywordsFM = listToUFM $
 581       map (\ (x,y) -> (_PK_ x,y))
 582      [  ("__interface",         ITinterface),
 583         ("__export",            ITexport),
 584         ("__instimport",        ITinstimport),
 585         ("__forall",            ITforall),
 586         ("__letrec",            ITletrec),
 587         ("__coerce",            ITcoerce),
 588         ("__inline",            ITinline),
 589         ("__DEFAULT",           ITdefaultbranch),
 590         ("__bot",               ITbottom),
 591         ("__integer",           ITinteger_lit),
 592         ("__float",             ITfloat_lit),
 593         ("__rational",          ITrational_lit),
 594         ("__addr",              ITaddr_lit),
 595         ("__litlit",            ITlit_lit),
 596         ("__string",            ITstring_lit),
 597         ("__a",                 ITtypeapp),
 598         ("__A",                 ITarity),
 599         ("__P",                 ITspecialise),
 600         ("__C",                 ITnocaf),
 601         ("__u",                 ITunfold NoInlinePragInfo),
 602         ("__U",                 ITunfold IWantToBeINLINEd),
 603         ("__UU",                ITunfold IMustBeINLINEd),
 604         ("__Unot",              ITunfold IMustNotBeINLINEd),
 605         ("__Ux",                ITunfold IAmALoopBreaker),
 606
 607         ("__ccall",             ITccall (False, False, False)),
 608         ("__ccall_GC",          ITccall (False, False, True)),
 609         ("__dyn_ccall",         ITccall (True,  False, False)),
 610         ("__dyn_ccall_GC",      ITccall (True,  False, True)),
 611         ("__casm",              ITccall (False, True,  False)),
 612         ("__dyn_casm",          ITccall (True,  True,  False)),
 613         ("__casm_GC",           ITccall (False, True,  True)),
 614         ("__dyn_casm_GC",       ITccall (True,  True,  True)),
 615
 616         ("/\\",                 ITbiglam)
 617        ]
 618
 619 haskellKeywordsFM = listToUFM $
 620       map (\ (x,y) -> (_PK_ x,y))
 621        [( "case",       ITcase ),
 622         ( "class",      ITclass ),
 623         ( "data",       ITdata ),
 624         ( "default",    ITdefault ),
 625         ( "deriving",   ITderiving ),
 626         ( "do",         ITdo ),
 627         ( "else",       ITelse ),
 628         ( "if",         ITif ),
 629         ( "import",     ITimport ),
 630         ( "in",         ITin ),
 631         ( "infix",      ITinfix ),
 632         ( "infixl",     ITinfixl ),
 633         ( "infixr",     ITinfixr ),
 634         ( "instance",   ITinstance ),
 635         ( "let",        ITlet ),
 636         ( "module",     ITmodule ),
 637         ( "newtype",    ITnewtype ),
 638         ( "of",         ITof ),
 639         ( "then",       ITthen ),
 640         ( "type",       ITtype ),
 641         ( "where",      ITwhere )
 642
 643 --      These three aren't Haskell keywords at all
 644 --      and 'as' is often used as a variable name
 645 --      ( "as",         ITas ),
 646 --      ( "qualified",  ITqualified ),
 647 --      ( "hiding",     IThiding )
 648
 649      ]
 650
 651 haskellKeySymsFM = listToUFM $
 652         map (\ (x,y) -> (_PK_ x,y))
 653       [ ("..",                  ITdotdot)
 654        ,("::",                  ITdcolon)
 655        ,("=",                   ITequal)
 656        ,("\\",                  ITlam)
 657        ,("|",                   ITvbar)
 658        ,("<-",                  ITlarrow)
 659        ,("->",                  ITrarrow)
 660        ,("@",                   ITat)
 661        ,("~",                   ITtilde)
 662        ,("=>",                  ITdarrow)
 663        ,("-",                   ITminus)
 664        ,("!",                   ITbang)
 665        ]
 666 \end{code}
 667
 668 -----------------------------------------------------------------------------
 669 doDiscard rips along really fast, looking for a '#-}',
 670 indicating the end of the pragma we're skipping
 671
 672 \begin{code}
 673 doDiscard inStr buf =
 674  case currentChar# buf of
 675    '#'# | not inStr ->
 676        case lookAhead# buf 1# of { '#'# ->
 677        case lookAhead# buf 2# of { '-'# ->
 678        case lookAhead# buf 3# of { '}'# ->
 679            (lexemeToBuffer buf, stepOverLexeme (setCurrentPos# buf 4#));
 680         _    -> doDiscard inStr (incLexeme buf) };
 681         _    -> doDiscard inStr (incLexeme buf) };
 682         _    -> doDiscard inStr (incLexeme buf) }
 683    '"'# ->
 684        let
 685         odd_slashes buf flg i# =
 686           case lookAhead# buf i# of
 687            '\\'# -> odd_slashes buf (not flg) (i# -# 1#)
 688            _     -> flg
 689        in
 690        case lookAhead# buf (negateInt# 1#) of --backwards, actually
 691          '\\'# -> -- escaping something..
 692            if odd_slashes buf True (negateInt# 2#) then
 693                -- odd number of slashes, " is escaped.
 694               doDiscard inStr (incLexeme buf)
 695            else
 696                -- even number of slashes, \ is escaped.
 697               doDiscard (not inStr) (incLexeme buf)
 698          _ -> case inStr of -- forced to avoid build-up
 699                True  -> doDiscard False (incLexeme buf)
 700                False -> doDiscard True  (incLexeme buf)
 701    _ -> doDiscard inStr (incLexeme buf)
 702
 703 \end{code}
 704
 705 -----------------------------------------------------------------------------
 706
 707 \begin{code}
 708 type IfM a = StringBuffer       -- Input string
 709           -> SrcLoc
 710           -> MaybeErr a {-error-}Message
 711
 712 returnIf   :: a -> IfM a
 713 returnIf a s l = Succeeded a
 714
 715 thenIf     :: IfM a -> (a -> IfM b) -> IfM b
 716 m `thenIf` k = \s l ->
 717         case m s l of
 718                 Succeeded a -> k a s l
 719                 Failed err  -> Failed err
 720
 721 getSrcLocIf :: IfM SrcLoc
 722 getSrcLocIf s l = Succeeded l
 723
 724 happyError :: IfM a
 725 happyError s l = Failed (ifaceParseErr s l)
 726
 727
 728 {-
 729  Note that if the name of the file we're processing ends
 730  with `hi-boot', we accept it on faith as having the right
 731  version. This is done so that .hi-boot files that comes
 732  with hsc don't have to be updated before every release,
 733  *and* it allows us to share .hi-boot files with versions
 734  of hsc that don't have .hi version checking (e.g., ghc-2.10's)
 735
 736  If the version number is 0, the checking is also turned off.
 737  (needed to deal with GHC.hi only!)
 738
 739  Once we can assume we're compiling with a version of ghc that
 740  supports interface file checking, we can drop the special
 741  pleading
 742 -}
 743 checkVersion :: Maybe Integer -> IfM ()
 744 checkVersion mb@(Just v) s l
 745  | (v==0) || (v == fromInt opt_HiVersion) || opt_NoHiCheck = Succeeded ()
 746  | otherwise = Failed (ifaceVersionErr mb l ([]::[IfaceToken]){-Todo-})
 747 checkVersion mb@Nothing  s l
 748  | "hi-boot" `isSuffixOf` (_UNPK_ (srcLocFile l)) = Succeeded ()
 749  | otherwise = Failed (ifaceVersionErr mb l ([]::[IfaceToken]){-Todo-})
 750
 751 -----------------------------------------------------------------
 752
 753 ifaceParseErr :: StringBuffer -> SrcLoc -> Message
 754 ifaceParseErr s l
 755   = hsep [ppr l, ptext SLIT("Interface-file parse error;"),
 756           ptext SLIT("current input ="), text first_bit]
 757   where
 758     first_bit = lexemeToString (stepOnBy# s 100#)
 759
 760 ifaceVersionErr hi_vers l toks
 761   = hsep [ppr l, ptext SLIT("Interface file version error;"),
 762           ptext SLIT("Expected"), int opt_HiVersion,
 763           ptext SLIT("found "), pp_version]
 764     where
 765      pp_version =
 766       case hi_vers of
 767         Nothing -> ptext SLIT("pre ghc-3.02 version")
 768         Just v  -> ptext SLIT("version") <+> integer v
 769
 770 \end{code}