Text/Read/Lex.hs

    {-# LANGUAGE Trustworthy #-}
    {-# LANGUAGE NoImplicitPrelude #-}

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Text.Read.Lex
    -- Copyright   :  (c) The University of Glasgow 2002
    -- License     :  BSD-style (see the file libraries/base/LICENSE)
    --
    -- Maintainer  :  libraries@haskell.org
    -- Stability   :  provisional
    -- Portability :  non-portable (uses Text.ParserCombinators.ReadP)
    --
    -- The cut-down Haskell lexer, used by Text.Read
    --
    -----------------------------------------------------------------------------

    module Text.Read.Lex
      -- lexing types
      ( Lexeme(..), Number

      , numberToInteger, numberToFixed, numberToRational, numberToRangedRational

      -- lexer
      , lex, expect
      , hsLex
      , lexChar

      , readIntP
      , readOctP
      , readDecP
      , readHexP

      , isSymbolChar
      )
     where

    import Text.ParserCombinators.ReadP

    import GHC.Base
    import GHC.Char
    import GHC.Num( Num(..), Integer )
    import GHC.Show( Show(..) )
    import GHC.Unicode
      ( GeneralCategory(..), generalCategory, isSpace, isAlpha, isAlphaNum )
    import GHC.Real( Rational, (%), fromIntegral, Integral,
                     toInteger, (^), quot, even )
    import GHC.List
    import GHC.Enum( minBound, maxBound )
    import Data.Maybe

    -- local copy to break import-cycle
    -- | @'guard' b@ is @'return' ()@ if @b@ is 'True',
    -- and 'mzero' if @b@ is 'False'.
    guard           :: (MonadPlus m) => Bool -> m ()
    guard True      =  return ()
    guard False     =  mzero

    -- -----------------------------------------------------------------------------
    -- Lexing types

    -- ^ Haskell lexemes.
    data Lexeme
      = Char   Char         -- ^ Character literal
      | String String       -- ^ String literal, with escapes interpreted
      | Punc   String       -- ^ Punctuation or reserved symbol, e.g. @(@, @::@
      | Ident  String       -- ^ Haskell identifier, e.g. @foo@, @Baz@
      | Symbol String       -- ^ Haskell symbol, e.g. @>>@, @:%@
      | Number Number       -- ^ @since 4.6.0.0
      | EOF
     deriving (Eq, Show)

    -- | @since 4.7.0.0
    data Number = MkNumber Int              -- Base
                           Digits           -- Integral part
                | MkDecimal Digits          -- Integral part
                            (Maybe Digits)  -- Fractional part
                            (Maybe Integer) -- Exponent
     deriving (Eq, Show)

    -- | @since 4.5.1.0
    numberToInteger :: Number -> Maybe Integer
    numberToInteger (MkNumber base iPart) = Just (val (fromIntegral base) iPart)
    numberToInteger (MkDecimal iPart Nothing Nothing) = Just (val 10 iPart)
    numberToInteger _ = Nothing

    -- | @since 4.7.0.0
    numberToFixed :: Integer -> Number -> Maybe (Integer, Integer)
    numberToFixed _ (MkNumber base iPart) = Just (val (fromIntegral base) iPart, 0)
    numberToFixed _ (MkDecimal iPart Nothing Nothing) = Just (val 10 iPart, 0)
    numberToFixed p (MkDecimal iPart (Just fPart) Nothing)
        = let i = val 10 iPart
              f = val 10 (integerTake p (fPart ++ repeat 0))
              -- Sigh, we really want genericTake, but that's above us in
              -- the hierarchy, so we define our own version here (actually
              -- specialised to Integer)
              integerTake             :: Integer -> [a] -> [a]
              integerTake n _ | n <= 0 = []
              integerTake _ []        =  []
              integerTake n (x:xs)    =  x : integerTake (n-1) xs
          in Just (i, f)
    numberToFixed _ _ = Nothing

    -- This takes a floatRange, and if the Rational would be outside of
    -- the floatRange then it may return Nothing. Not that it will not
    -- /necessarily/ return Nothing, but it is good enough to fix the
    -- space problems in #5688
    -- Ways this is conservative:
    -- * the floatRange is in base 2, but we pretend it is in base 10
    -- * we pad the floateRange a bit, just in case it is very small
    --   and we would otherwise hit an edge case
    -- * We only worry about numbers that have an exponent. If they don't
    --   have an exponent then the Rational won't be much larger than the
    --   Number, so there is no problem
    -- | @since 4.5.1.0
    numberToRangedRational :: (Int, Int) -> Number
                           -> Maybe Rational -- Nothing = Inf
    numberToRangedRational (neg, pos) n@(MkDecimal iPart mFPart (Just exp))
        -- if exp is out of integer bounds,
        -- then the number is definitely out of range
        | exp > fromIntegral (maxBound :: Int) ||
          exp < fromIntegral (minBound :: Int)
        = Nothing
        | otherwise
        = let mFirstDigit = case dropWhile (0 ==) iPart of
                            iPart'@(_ : _) -> Just (length iPart')
                            [] -> case mFPart of
                                  Nothing -> Nothing
                                  Just fPart ->
                                      case span (0 ==) fPart of
                                      (_, []) -> Nothing
                                      (zeroes, _) ->
                                          Just (negate (length zeroes))
          in case mFirstDigit of
             Nothing -> Just 0
             Just firstDigit ->
                 let firstDigit' = firstDigit + fromInteger exp
                 in if firstDigit' > (pos + 3)
                    then Nothing
                    else if firstDigit' < (neg - 3)
                    then Just 0
                    else Just (numberToRational n)
    numberToRangedRational _ n = Just (numberToRational n)

    -- | @since 4.6.0.0
    numberToRational :: Number -> Rational
    numberToRational (MkNumber base iPart) = val (fromIntegral base) iPart % 1
    numberToRational (MkDecimal iPart mFPart mExp)
     = let i = val 10 iPart
       in case (mFPart, mExp) of
          (Nothing, Nothing)     -> i % 1
          (Nothing, Just exp)
           | exp >= 0            -> (i * (10 ^ exp)) % 1
           | otherwise           -> i % (10 ^ (- exp))
          (Just fPart, Nothing)  -> fracExp 0   i fPart
          (Just fPart, Just exp) -> fracExp exp i fPart
          -- fracExp is a bit more efficient in calculating the Rational.
          -- Instead of calculating the fractional part alone, then
          -- adding the integral part and finally multiplying with
          -- 10 ^ exp if an exponent was given, do it all at once.

    -- -----------------------------------------------------------------------------
    -- Lexing

    lex :: ReadP Lexeme
    lex = skipSpaces >> lexToken

    -- | @since 4.7.0.0
    expect :: Lexeme -> ReadP ()
    expect lexeme = do { skipSpaces
                       ; thing <- lexToken
                       ; if thing == lexeme then return () else pfail }

    hsLex :: ReadP String
    -- ^ Haskell lexer: returns the lexed string, rather than the lexeme
    hsLex = do skipSpaces
               (s,_) <- gather lexToken
               return s

    lexToken :: ReadP Lexeme
    lexToken = lexEOF     +++
               lexLitChar +++
               lexString  +++
               lexPunc    +++
               lexSymbol  +++
               lexId      +++
               lexNumber

    -- ----------------------------------------------------------------------
    -- End of file
    lexEOF :: ReadP Lexeme
    lexEOF = do s <- look
                guard (null s)
                return EOF

    -- ---------------------------------------------------------------------------
    -- Single character lexemes

    lexPunc :: ReadP Lexeme
    lexPunc =
      do c <- satisfy isPuncChar
         return (Punc [c])

    -- | The @special@ character class as defined in the Haskell Report.
    isPuncChar :: Char -> Bool
    isPuncChar c = c `elem` ",;()[]{}`"

    -- ----------------------------------------------------------------------
    -- Symbols

    lexSymbol :: ReadP Lexeme
    lexSymbol =
      do s <- munch1 isSymbolChar
         if s `elem` reserved_ops then
            return (Punc s)         -- Reserved-ops count as punctuation
          else
            return (Symbol s)
      where
        reserved_ops   = ["..", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>"]

    isSymbolChar :: Char -> Bool
    isSymbolChar c = not (isPuncChar c) && case generalCategory c of
        MathSymbol              -> True
        CurrencySymbol          -> True
        ModifierSymbol          -> True
        OtherSymbol             -> True
        DashPunctuation         -> True
        OtherPunctuation        -> not (c `elem` "'\"")
        ConnectorPunctuation    -> c /= '_'
        _                       -> False
    -- ----------------------------------------------------------------------
    -- identifiers

    lexId :: ReadP Lexeme
    lexId = do c <- satisfy isIdsChar
               s <- munch isIdfChar
               return (Ident (c:s))
      where
              -- Identifiers can start with a '_'
        isIdsChar c = isAlpha c || c == '_'
        isIdfChar c = isAlphaNum c || c `elem` "_'"

    -- ---------------------------------------------------------------------------
    -- Lexing character literals

    lexLitChar :: ReadP Lexeme
    lexLitChar =
      do _ <- char '\''
         (c,esc) <- lexCharE
         guard (esc || c /= '\'')   -- Eliminate '' possibility
         _ <- char '\''
         return (Char c)

    lexChar :: ReadP Char
    lexChar = do { (c,_) <- lexCharE; consumeEmpties; return c }
        where
        -- Consumes the string "\&" repeatedly and greedily (will only produce one match)
        consumeEmpties :: ReadP ()
        consumeEmpties = do
            rest <- look
            case rest of
                ('\\':'&':_) -> string "\\&" >> consumeEmpties
                _ -> return ()

    lexCharE :: ReadP (Char, Bool)  -- "escaped or not"?
    lexCharE =
      do c1 <- get
         if c1 == '\\'
           then do c2 <- lexEsc; return (c2, True)
           else do return (c1, False)
     where
      lexEsc =
        lexEscChar
          +++ lexNumeric
            +++ lexCntrlChar
              +++ lexAscii

      lexEscChar =
        do c <- get
           case c of
             'a'  -> return '\a'
             'b'  -> return '\b'
             'f'  -> return '\f'
             'n'  -> return '\n'
             'r'  -> return '\r'
             't'  -> return '\t'
             'v'  -> return '\v'
             '\\' -> return '\\'
             '\"' -> return '\"'
             '\'' -> return '\''
             _    -> pfail

      lexNumeric =
        do base <- lexBaseChar <++ return 10
           n    <- lexInteger base
           guard (n <= toInteger (ord maxBound))
           return (chr (fromInteger n))

      lexCntrlChar =
        do _ <- char '^'
           c <- get
           case c of
             '@'  -> return '\^@'
             'A'  -> return '\^A'
             'B'  -> return '\^B'
             'C'  -> return '\^C'
             'D'  -> return '\^D'
             'E'  -> return '\^E'
             'F'  -> return '\^F'
             'G'  -> return '\^G'
             'H'  -> return '\^H'
             'I'  -> return '\^I'
             'J'  -> return '\^J'
             'K'  -> return '\^K'
             'L'  -> return '\^L'
             'M'  -> return '\^M'
             'N'  -> return '\^N'
             'O'  -> return '\^O'
             'P'  -> return '\^P'
             'Q'  -> return '\^Q'
             'R'  -> return '\^R'
             'S'  -> return '\^S'
             'T'  -> return '\^T'
             'U'  -> return '\^U'
             'V'  -> return '\^V'
             'W'  -> return '\^W'
             'X'  -> return '\^X'
             'Y'  -> return '\^Y'
             'Z'  -> return '\^Z'
             '['  -> return '\^['
             '\\' -> return '\^\'
             ']'  -> return '\^]'
             '^'  -> return '\^^'
             '_'  -> return '\^_'
             _    -> pfail

      lexAscii =
        do choice
             [ (string "SOH" >> return '\SOH') <++
               (string "SO"  >> return '\SO')
                    -- \SO and \SOH need maximal-munch treatment
                    -- See the Haskell report Sect 2.6

             , string "NUL" >> return '\NUL'
             , string "STX" >> return '\STX'
             , string "ETX" >> return '\ETX'
             , string "EOT" >> return '\EOT'
             , string "ENQ" >> return '\ENQ'
             , string "ACK" >> return '\ACK'
             , string "BEL" >> return '\BEL'
             , string "BS"  >> return '\BS'
             , string "HT"  >> return '\HT'
             , string "LF"  >> return '\LF'
             , string "VT"  >> return '\VT'
             , string "FF"  >> return '\FF'
             , string "CR"  >> return '\CR'
             , string "SI"  >> return '\SI'
             , string "DLE" >> return '\DLE'
             , string "DC1" >> return '\DC1'
             , string "DC2" >> return '\DC2'
             , string "DC3" >> return '\DC3'
             , string "DC4" >> return '\DC4'
             , string "NAK" >> return '\NAK'
             , string "SYN" >> return '\SYN'
             , string "ETB" >> return '\ETB'
             , string "CAN" >> return '\CAN'
             , string "EM"  >> return '\EM'
             , string "SUB" >> return '\SUB'
             , string "ESC" >> return '\ESC'
             , string "FS"  >> return '\FS'
             , string "GS"  >> return '\GS'
             , string "RS"  >> return '\RS'
             , string "US"  >> return '\US'
             , string "SP"  >> return '\SP'
             , string "DEL" >> return '\DEL'
             ]

    -- ---------------------------------------------------------------------------
    -- string literal

    lexString :: ReadP Lexeme
    lexString =
      do _ <- char '"'
         body id
     where
      body f =
        do (c,esc) <- lexStrItem
           if c /= '"' || esc
             then body (f.(c:))
             else let s = f "" in
                  return (String s)

      lexStrItem = (lexEmpty >> lexStrItem)
                   +++ lexCharE

      lexEmpty =
        do _ <- char '\\'
           c <- get
           case c of
             '&'           -> do return ()
             _ | isSpace c -> do skipSpaces; _ <- char '\\'; return ()
             _             -> do pfail

    -- ---------------------------------------------------------------------------
    --  Lexing numbers

    type Base   = Int
    type Digits = [Int]

    lexNumber :: ReadP Lexeme
    lexNumber
      = lexHexOct  <++      -- First try for hex or octal 0x, 0o etc
                            -- If that fails, try for a decimal number
        lexDecNumber        -- Start with ordinary digits

    lexHexOct :: ReadP Lexeme
    lexHexOct
      = do  _ <- char '0'
            base <- lexBaseChar
            digits <- lexDigits base
            return (Number (MkNumber base digits))

    lexBaseChar :: ReadP Int
    -- Lex a single character indicating the base; fail if not there
    lexBaseChar = do { c <- get;
                       case c of
                            'o' -> return 8
                            'O' -> return 8
                            'x' -> return 16
                            'X' -> return 16
                            _   -> pfail }

    lexDecNumber :: ReadP Lexeme
    lexDecNumber =
      do xs    <- lexDigits 10
         mFrac <- lexFrac <++ return Nothing
         mExp  <- lexExp  <++ return Nothing
         return (Number (MkDecimal xs mFrac mExp))

    lexFrac :: ReadP (Maybe Digits)
    -- Read the fractional part; fail if it doesn't
    -- start ".d" where d is a digit
    lexFrac = do _ <- char '.'
                 fraction <- lexDigits 10
                 return (Just fraction)

    lexExp :: ReadP (Maybe Integer)
    lexExp = do _ <- char 'e' +++ char 'E'
                exp <- signedExp +++ lexInteger 10
                return (Just exp)
     where
       signedExp
         = do c <- char '-' +++ char '+'
              n <- lexInteger 10
              return (if c == '-' then -n else n)

    lexDigits :: Int -> ReadP Digits
    -- Lex a non-empty sequence of digits in specified base
    lexDigits base =
      do s  <- look
         xs <- scan s id
         guard (not (null xs))
         return xs
     where
      scan (c:cs) f = case valDig base c of
                        Just n  -> do _ <- get; scan cs (f.(n:))
                        Nothing -> do return (f [])
      scan []     f = do return (f [])

    lexInteger :: Base -> ReadP Integer
    lexInteger base =
      do xs <- lexDigits base
         return (val (fromIntegral base) xs)

    val :: Num a => a -> Digits -> a
    val = valSimple
    {-# RULES
    "val/Integer" val = valInteger
      #-}
    {-# INLINE [1] val #-}

    -- The following algorithm is only linear for types whose Num operations
    -- are in constant time.
    valSimple :: (Num a, Integral d) => a -> [d] -> a
    valSimple base = go 0
      where
        go r [] = r
        go r (d : ds) = r' `seq` go r' ds
          where
            r' = r * base + fromIntegral d
    {-# INLINE valSimple #-}

    -- A sub-quadratic algorithm for Integer. Pairs of adjacent radix b
    -- digits are combined into a single radix b^2 digit. This process is
    -- repeated until we are left with a single digit. This algorithm
    -- performs well only on large inputs, so we use the simple algorithm
    -- for smaller inputs.
    valInteger :: Integer -> Digits -> Integer
    valInteger b0 ds0 = go b0 (length ds0) $ map fromIntegral ds0
      where
        go _ _ []  = 0
        go _ _ [d] = d
        go b l ds
            | l > 40 = b' `seq` go b' l' (combine b ds')
            | otherwise = valSimple b ds
          where
            -- ensure that we have an even number of digits
            -- before we call combine:
            ds' = if even l then ds else 0 : ds
            b' = b * b
            l' = (l + 1) `quot` 2
        combine b (d1 : d2 : ds) = d `seq` (d : combine b ds)
          where
            d = d1 * b + d2
        combine _ []  = []
        combine _ [_] = errorWithoutStackTrace "this should not happen"

    -- Calculate a Rational from the exponent [of 10 to multiply with],
    -- the integral part of the mantissa and the digits of the fractional
    -- part. Leaving the calculation of the power of 10 until the end,
    -- when we know the effective exponent, saves multiplications.
    -- More importantly, this way we need at most one gcd instead of three.
    --
    -- frac was never used with anything but Integer and base 10, so
    -- those are hardcoded now (trivial to change if necessary).
    fracExp :: Integer -> Integer -> Digits -> Rational
    fracExp exp mant []
      | exp < 0     = mant % (10 ^ (-exp))
      | otherwise   = fromInteger (mant * 10 ^ exp)
    fracExp exp mant (d:ds) = exp' `seq` mant' `seq` fracExp exp' mant' ds
      where
        exp'  = exp - 1
        mant' = mant * 10 + fromIntegral d

    valDig :: (Eq a, Num a) => a -> Char -> Maybe Int
    valDig 8 c
      | '0' <= c && c <= '7' = Just (ord c - ord '0')
      | otherwise            = Nothing

    valDig 10 c = valDecDig c

    valDig 16 c
      | '0' <= c && c <= '9' = Just (ord c - ord '0')
      | 'a' <= c && c <= 'f' = Just (ord c - ord 'a' + 10)
      | 'A' <= c && c <= 'F' = Just (ord c - ord 'A' + 10)
      | otherwise            = Nothing

    valDig _ _ = errorWithoutStackTrace "valDig: Bad base"

    valDecDig :: Char -> Maybe Int
    valDecDig c
      | '0' <= c && c <= '9' = Just (ord c - ord '0')
      | otherwise            = Nothing

    -- ----------------------------------------------------------------------
    -- other numeric lexing functions

    readIntP :: Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadP a
    readIntP base isDigit valDigit =
      do s <- munch1 isDigit
         return (val base (map valDigit s))
    {-# SPECIALISE readIntP
            :: Integer -> (Char -> Bool) -> (Char -> Int) -> ReadP Integer #-}

    readIntP' :: (Eq a, Num a) => a -> ReadP a
    readIntP' base = readIntP base isDigit valDigit
     where
      isDigit  c = maybe False (const True) (valDig base c)
      valDigit c = maybe 0     id           (valDig base c)
    {-# SPECIALISE readIntP' :: Integer -> ReadP Integer #-}

    readOctP, readDecP, readHexP :: (Eq a, Num a) => ReadP a
    readOctP = readIntP' 8
    readDecP = readIntP' 10
    readHexP = readIntP' 16
    {-# SPECIALISE readOctP :: ReadP Integer #-}
    {-# SPECIALISE readDecP :: ReadP Integer #-}
    {-# SPECIALISE readHexP :: ReadP Integer #-}