{-# 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 :: Bool -> m ()
guard True      =  () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
guard False     =  m ()
forall (m :: * -> *) a. MonadPlus m => m a
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   -- ^ @since 2.01
          , Show -- ^ @since 2.01
          )

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

-- | @since 4.5.1.0
numberToInteger :: Number -> Maybe Integer
numberToInteger :: Number -> Maybe Integer
numberToInteger (MkNumber base :: Int
base iPart :: Digits
iPart) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Digits -> Integer
forall a. Num a => a -> Digits -> a
val (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
base) Digits
iPart)
numberToInteger (MkDecimal iPart :: Digits
iPart Nothing Nothing) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Digits -> Integer
forall a. Num a => a -> Digits -> a
val 10 Digits
iPart)
numberToInteger _ = Maybe Integer
forall a. Maybe a
Nothing

-- | @since 4.7.0.0
numberToFixed :: Integer -> Number -> Maybe (Integer, Integer)
numberToFixed :: Integer -> Number -> Maybe (Integer, Integer)
numberToFixed _ (MkNumber base :: Int
base iPart :: Digits
iPart) = (Integer, Integer) -> Maybe (Integer, Integer)
forall a. a -> Maybe a
Just (Integer -> Digits -> Integer
forall a. Num a => a -> Digits -> a
val (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
base) Digits
iPart, 0)
numberToFixed _ (MkDecimal iPart :: Digits
iPart Nothing Nothing) = (Integer, Integer) -> Maybe (Integer, Integer)
forall a. a -> Maybe a
Just (Integer -> Digits -> Integer
forall a. Num a => a -> Digits -> a
val 10 Digits
iPart, 0)
numberToFixed p :: Integer
p (MkDecimal iPart :: Digits
iPart (Just fPart :: Digits
fPart) Nothing)
    = let i :: Integer
i = Integer -> Digits -> Integer
forall a. Num a => a -> Digits -> a
val 10 Digits
iPart
          f :: Integer
f = Integer -> Digits -> Integer
forall a. Num a => a -> Digits -> a
val 10 (Integer -> Digits -> Digits
forall a. Integer -> [a] -> [a]
integerTake Integer
p (Digits
fPart Digits -> Digits -> Digits
forall a. [a] -> [a] -> [a]
++ Int -> Digits
forall a. a -> [a]
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 :: Integer -> [a] -> [a]
integerTake n :: Integer
n _ | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 = []
          integerTake _ []        =  []
          integerTake n :: Integer
n (x :: a
x:xs :: [a]
xs)    =  a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Integer -> [a] -> [a]
forall a. Integer -> [a] -> [a]
integerTake (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-1) [a]
xs
      in (Integer, Integer) -> Maybe (Integer, Integer)
forall a. a -> Maybe a
Just (Integer
i, Integer
f)
numberToFixed _ _ = Maybe (Integer, Integer)
forall a. Maybe a
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 :: (Int, Int) -> Number -> Maybe Rational
numberToRangedRational (neg :: Int
neg, pos :: Int
pos) n :: Number
n@(MkDecimal iPart :: Digits
iPart mFPart :: Maybe Digits
mFPart (Just exp :: Integer
exp))
    -- if exp is out of integer bounds,
    -- then the number is definitely out of range
    | Integer
exp Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
forall a. Bounded a => a
maxBound :: Int) Bool -> Bool -> Bool
||
      Integer
exp Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
forall a. Bounded a => a
minBound :: Int)
    = Maybe Rational
forall a. Maybe a
Nothing
    | Bool
otherwise
    = let mFirstDigit :: Maybe Int
mFirstDigit = case (Int -> Bool) -> Digits -> Digits
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==) Digits
iPart of
                        iPart' :: Digits
iPart'@(_ : _) -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Digits -> Int
forall a. [a] -> Int
length Digits
iPart')
                        [] -> case Maybe Digits
mFPart of
                              Nothing -> Maybe Int
forall a. Maybe a
Nothing
                              Just fPart :: Digits
fPart ->
                                  case (Int -> Bool) -> Digits -> (Digits, Digits)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==) Digits
fPart of
                                  (_, []) -> Maybe Int
forall a. Maybe a
Nothing
                                  (zeroes :: Digits
zeroes, _) ->
                                      Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Int
forall a. Num a => a -> a
negate (Digits -> Int
forall a. [a] -> Int
length Digits
zeroes))
      in case Maybe Int
mFirstDigit of
         Nothing -> Rational -> Maybe Rational
forall a. a -> Maybe a
Just 0
         Just firstDigit :: Int
firstDigit ->
             let firstDigit' :: Int
firstDigit' = Int
firstDigit Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
exp
             in if Int
firstDigit' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 3)
                then Maybe Rational
forall a. Maybe a
Nothing
                else if Int
firstDigit' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< (Int
neg Int -> Int -> Int
forall a. Num a => a -> a -> a
- 3)
                then Rational -> Maybe Rational
forall a. a -> Maybe a
Just 0
                else Rational -> Maybe Rational
forall a. a -> Maybe a
Just (Number -> Rational
numberToRational Number
n)
numberToRangedRational _ n :: Number
n = Rational -> Maybe Rational
forall a. a -> Maybe a
Just (Number -> Rational
numberToRational Number
n)

-- | @since 4.6.0.0
numberToRational :: Number -> Rational
numberToRational :: Number -> Rational
numberToRational (MkNumber base :: Int
base iPart :: Digits
iPart) = Integer -> Digits -> Integer
forall a. Num a => a -> Digits -> a
val (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
base) Digits
iPart Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% 1
numberToRational (MkDecimal iPart :: Digits
iPart mFPart :: Maybe Digits
mFPart mExp :: Maybe Integer
mExp)
 = let i :: Integer
i = Integer -> Digits -> Integer
forall a. Num a => a -> Digits -> a
val 10 Digits
iPart
   in case (Maybe Digits
mFPart, Maybe Integer
mExp) of
      (Nothing, Nothing)     -> Integer
i Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% 1
      (Nothing, Just exp :: Integer
exp)
       | Integer
exp Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= 0            -> (Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (10 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
exp)) Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% 1
       | Bool
otherwise           -> Integer
i Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% (10 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (- Integer
exp))
      (Just fPart :: Digits
fPart, Nothing)  -> Integer -> Integer -> Digits -> Rational
fracExp 0   Integer
i Digits
fPart
      (Just fPart :: Digits
fPart, Just exp :: Integer
exp) -> Integer -> Integer -> Digits -> Rational
fracExp Integer
exp Integer
i Digits
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 :: ReadP Lexeme
lex = ReadP ()
skipSpaces ReadP () -> ReadP Lexeme -> ReadP Lexeme
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP Lexeme
lexToken

-- | @since 4.7.0.0
expect :: Lexeme -> ReadP ()
expect :: Lexeme -> ReadP ()
expect lexeme :: Lexeme
lexeme = do { ReadP ()
skipSpaces
                   ; Lexeme
thing <- ReadP Lexeme
lexToken
                   ; if Lexeme
thing Lexeme -> Lexeme -> Bool
forall a. Eq a => a -> a -> Bool
== Lexeme
lexeme then () -> ReadP ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else ReadP ()
forall a. ReadP a
pfail }

hsLex :: ReadP String
-- ^ Haskell lexer: returns the lexed string, rather than the lexeme
hsLex :: ReadP String
hsLex = do ReadP ()
skipSpaces
           (s :: String
s,_) <- ReadP Lexeme -> ReadP (String, Lexeme)
forall a. ReadP a -> ReadP (String, a)
gather ReadP Lexeme
lexToken
           String -> ReadP String
forall (m :: * -> *) a. Monad m => a -> m a
return String
s

lexToken :: ReadP Lexeme
lexToken :: ReadP Lexeme
lexToken = ReadP Lexeme
lexEOF     ReadP Lexeme -> ReadP Lexeme -> ReadP Lexeme
forall a. ReadP a -> ReadP a -> ReadP a
+++
           ReadP Lexeme
lexLitChar ReadP Lexeme -> ReadP Lexeme -> ReadP Lexeme
forall a. ReadP a -> ReadP a -> ReadP a
+++
           ReadP Lexeme
lexString  ReadP Lexeme -> ReadP Lexeme -> ReadP Lexeme
forall a. ReadP a -> ReadP a -> ReadP a
+++
           ReadP Lexeme
lexPunc    ReadP Lexeme -> ReadP Lexeme -> ReadP Lexeme
forall a. ReadP a -> ReadP a -> ReadP a
+++
           ReadP Lexeme
lexSymbol  ReadP Lexeme -> ReadP Lexeme -> ReadP Lexeme
forall a. ReadP a -> ReadP a -> ReadP a
+++
           ReadP Lexeme
lexId      ReadP Lexeme -> ReadP Lexeme -> ReadP Lexeme
forall a. ReadP a -> ReadP a -> ReadP a
+++
           ReadP Lexeme
lexNumber


-- ----------------------------------------------------------------------
-- End of file
lexEOF :: ReadP Lexeme
lexEOF :: ReadP Lexeme
lexEOF = do String
s <- ReadP String
look
            Bool -> ReadP ()
forall (m :: * -> *). MonadPlus m => Bool -> m ()
guard (String -> Bool
forall a. [a] -> Bool
null String
s)
            Lexeme -> ReadP Lexeme
forall (m :: * -> *) a. Monad m => a -> m a
return Lexeme
EOF

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

lexPunc :: ReadP Lexeme
lexPunc :: ReadP Lexeme
lexPunc =
  do Char
c <- (Char -> Bool) -> ReadP Char
satisfy Char -> Bool
isPuncChar
     Lexeme -> ReadP Lexeme
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Lexeme
Punc [Char
c])

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

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

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

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

lexId :: ReadP Lexeme
lexId :: ReadP Lexeme
lexId = do Char
c <- (Char -> Bool) -> ReadP Char
satisfy Char -> Bool
isIdsChar
           String
s <- (Char -> Bool) -> ReadP String
munch Char -> Bool
isIdfChar
           Lexeme -> ReadP Lexeme
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Lexeme
Ident (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
s))
  where
          -- Identifiers can start with a '_'
    isIdsChar :: Char -> Bool
isIdsChar c :: Char
c = Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_'
    isIdfChar :: Char -> Bool
isIdfChar c :: Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
`elem` "_'"

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

lexLitChar :: ReadP Lexeme
lexLitChar :: ReadP Lexeme
lexLitChar =
  do Char
_ <- Char -> ReadP Char
char '\''
     (c :: Char
c,esc :: Bool
esc) <- ReadP (Char, Bool)
lexCharE
     Bool -> ReadP ()
forall (m :: * -> *). MonadPlus m => Bool -> m ()
guard (Bool
esc Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\'')   -- Eliminate '' possibility
     Char
_ <- Char -> ReadP Char
char '\''
     Lexeme -> ReadP Lexeme
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Lexeme
Char Char
c)

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


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

  lexEscChar :: ReadP Char
lexEscChar =
    do Char
c <- ReadP Char
get
       case Char
c of
         'a'  -> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\a'
         'b'  -> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\b'
         'f'  -> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\f'
         'n'  -> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\n'
         'r'  -> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\r'
         't'  -> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\t'
         'v'  -> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\v'
         '\\' -> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\\'
         '\"' -> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\"'
         '\'' -> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\''
         _    -> ReadP Char
forall a. ReadP a
pfail

  lexNumeric :: ReadP Char
lexNumeric =
    do Int
base <- ReadP Int
lexBaseChar ReadP Int -> ReadP Int -> ReadP Int
forall a. ReadP a -> ReadP a -> ReadP a
<++ Int -> ReadP Int
forall (m :: * -> *) a. Monad m => a -> m a
return 10
       Integer
n    <- Int -> ReadP Integer
lexInteger Int
base
       Bool -> ReadP ()
forall (m :: * -> *). MonadPlus m => Bool -> m ()
guard (Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Char -> Int
ord Char
forall a. Bounded a => a
maxBound))
       Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Char
chr (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n))

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

  lexAscii :: ReadP Char
lexAscii =
    do [ReadP Char] -> ReadP Char
forall a. [ReadP a] -> ReadP a
choice
         [ (String -> ReadP String
string "SOH" ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\SOH') ReadP Char -> ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a -> ReadP a
<++
           (String -> ReadP String
string "SO"  ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\SO')
                -- \SO and \SOH need maximal-munch treatment
                -- See the Haskell report Sect 2.6

         , String -> ReadP String
string "NUL" ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\NUL'
         , String -> ReadP String
string "STX" ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\STX'
         , String -> ReadP String
string "ETX" ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\ETX'
         , String -> ReadP String
string "EOT" ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\EOT'
         , String -> ReadP String
string "ENQ" ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\ENQ'
         , String -> ReadP String
string "ACK" ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\ACK'
         , String -> ReadP String
string "BEL" ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\BEL'
         , String -> ReadP String
string "BS"  ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\BS'
         , String -> ReadP String
string "HT"  ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\HT'
         , String -> ReadP String
string "LF"  ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\LF'
         , String -> ReadP String
string "VT"  ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\VT'
         , String -> ReadP String
string "FF"  ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\FF'
         , String -> ReadP String
string "CR"  ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\CR'
         , String -> ReadP String
string "SI"  ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\SI'
         , String -> ReadP String
string "DLE" ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\DLE'
         , String -> ReadP String
string "DC1" ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\DC1'
         , String -> ReadP String
string "DC2" ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\DC2'
         , String -> ReadP String
string "DC3" ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\DC3'
         , String -> ReadP String
string "DC4" ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\DC4'
         , String -> ReadP String
string "NAK" ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\NAK'
         , String -> ReadP String
string "SYN" ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\SYN'
         , String -> ReadP String
string "ETB" ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\ETB'
         , String -> ReadP String
string "CAN" ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\CAN'
         , String -> ReadP String
string "EM"  ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\EM'
         , String -> ReadP String
string "SUB" ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\SUB'
         , String -> ReadP String
string "ESC" ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\ESC'
         , String -> ReadP String
string "FS"  ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\FS'
         , String -> ReadP String
string "GS"  ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\GS'
         , String -> ReadP String
string "RS"  ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\RS'
         , String -> ReadP String
string "US"  ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\US'
         , String -> ReadP String
string "SP"  ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\SP'
         , String -> ReadP String
string "DEL" ReadP String -> ReadP Char -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ReadP Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\DEL'
         ]


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

lexString :: ReadP Lexeme
lexString :: ReadP Lexeme
lexString =
  do Char
_ <- Char -> ReadP Char
char '"'
     ShowS -> ReadP Lexeme
body ShowS
forall a. a -> a
id
 where
  body :: ShowS -> ReadP Lexeme
body f :: ShowS
f =
    do (c :: Char
c,esc :: Bool
esc) <- ReadP (Char, Bool)
lexStrItem
       if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '"' Bool -> Bool -> Bool
|| Bool
esc
         then ShowS -> ReadP Lexeme
body (ShowS
fShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:))
         else let s :: String
s = ShowS
f "" in
              Lexeme -> ReadP Lexeme
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Lexeme
String String
s)

  lexStrItem :: ReadP (Char, Bool)
lexStrItem = (ReadP ()
lexEmpty ReadP () -> ReadP (Char, Bool) -> ReadP (Char, Bool)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP (Char, Bool)
lexStrItem)
               ReadP (Char, Bool) -> ReadP (Char, Bool) -> ReadP (Char, Bool)
forall a. ReadP a -> ReadP a -> ReadP a
+++ ReadP (Char, Bool)
lexCharE

  lexEmpty :: ReadP ()
lexEmpty =
    do Char
_ <- Char -> ReadP Char
char '\\'
       Char
c <- ReadP Char
get
       case Char
c of
         '&'           -> do () -> ReadP ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         _ | Char -> Bool
isSpace Char
c -> do ReadP ()
skipSpaces; Char
_ <- Char -> ReadP Char
char '\\'; () -> ReadP ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         _             -> do ReadP ()
forall a. ReadP a
pfail

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

type Base   = Int
type Digits = [Int]

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

lexHexOct :: ReadP Lexeme
lexHexOct :: ReadP Lexeme
lexHexOct
  = do  Char
_ <- Char -> ReadP Char
char '0'
        Int
base <- ReadP Int
lexBaseChar
        Digits
digits <- Int -> ReadP Digits
lexDigits Int
base
        Lexeme -> ReadP Lexeme
forall (m :: * -> *) a. Monad m => a -> m a
return (Number -> Lexeme
Number (Int -> Digits -> Number
MkNumber Int
base Digits
digits))

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

lexDecNumber :: ReadP Lexeme
lexDecNumber :: ReadP Lexeme
lexDecNumber =
  do Digits
xs    <- Int -> ReadP Digits
lexDigits 10
     Maybe Digits
mFrac <- ReadP (Maybe Digits)
lexFrac ReadP (Maybe Digits)
-> ReadP (Maybe Digits) -> ReadP (Maybe Digits)
forall a. ReadP a -> ReadP a -> ReadP a
<++ Maybe Digits -> ReadP (Maybe Digits)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Digits
forall a. Maybe a
Nothing
     Maybe Integer
mExp  <- ReadP (Maybe Integer)
lexExp  ReadP (Maybe Integer)
-> ReadP (Maybe Integer) -> ReadP (Maybe Integer)
forall a. ReadP a -> ReadP a -> ReadP a
<++ Maybe Integer -> ReadP (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing
     Lexeme -> ReadP Lexeme
forall (m :: * -> *) a. Monad m => a -> m a
return (Number -> Lexeme
Number (Digits -> Maybe Digits -> Maybe Integer -> Number
MkDecimal Digits
xs Maybe Digits
mFrac Maybe Integer
mExp))

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

lexExp :: ReadP (Maybe Integer)
lexExp :: ReadP (Maybe Integer)
lexExp = do Char
_ <- Char -> ReadP Char
char 'e' ReadP Char -> ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a -> ReadP a
+++ Char -> ReadP Char
char 'E'
            Integer
exp <- ReadP Integer
signedExp ReadP Integer -> ReadP Integer -> ReadP Integer
forall a. ReadP a -> ReadP a -> ReadP a
+++ Int -> ReadP Integer
lexInteger 10
            Maybe Integer -> ReadP (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
exp)
 where
   signedExp :: ReadP Integer
signedExp
     = do Char
c <- Char -> ReadP Char
char '-' ReadP Char -> ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a -> ReadP a
+++ Char -> ReadP Char
char '+'
          Integer
n <- Int -> ReadP Integer
lexInteger 10
          Integer -> ReadP Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-' then -Integer
n else Integer
n)

lexDigits :: Int -> ReadP Digits
-- Lex a non-empty sequence of digits in specified base
lexDigits :: Int -> ReadP Digits
lexDigits base :: Int
base =
  do String
s  <- ReadP String
look
     Digits
xs <- String -> (Digits -> Digits) -> ReadP Digits
forall a. String -> (Digits -> a) -> ReadP a
scan String
s Digits -> Digits
forall a. a -> a
id
     Bool -> ReadP ()
forall (m :: * -> *). MonadPlus m => Bool -> m ()
guard (Bool -> Bool
not (Digits -> Bool
forall a. [a] -> Bool
null Digits
xs))
     Digits -> ReadP Digits
forall (m :: * -> *) a. Monad m => a -> m a
return Digits
xs
 where
  scan :: String -> (Digits -> a) -> ReadP a
scan (c :: Char
c:cs :: String
cs) f :: Digits -> a
f = case Int -> Char -> Maybe Int
forall a. (Eq a, Num a) => a -> Char -> Maybe Int
valDig Int
base Char
c of
                    Just n :: Int
n  -> do Char
_ <- ReadP Char
get; String -> (Digits -> a) -> ReadP a
scan String
cs (Digits -> a
f(Digits -> a) -> (Digits -> Digits) -> Digits -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int
nInt -> Digits -> Digits
forall a. a -> [a] -> [a]
:))
                    Nothing -> do a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return (Digits -> a
f [])
  scan []     f :: Digits -> a
f = do a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return (Digits -> a
f [])

lexInteger :: Base -> ReadP Integer
lexInteger :: Int -> ReadP Integer
lexInteger base :: Int
base =
  do Digits
xs <- Int -> ReadP Digits
lexDigits Int
base
     Integer -> ReadP Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Digits -> Integer
forall a. Num a => a -> Digits -> a
val (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
base) Digits
xs)

val :: Num a => a -> Digits -> a
val :: a -> Digits -> a
val = a -> Digits -> a
forall a d. (Num a, Integral d) => a -> [d] -> a
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 :: a -> [d] -> a
valSimple base :: a
base = a -> [d] -> a
forall a. Integral a => a -> [a] -> a
go 0
  where
    go :: a -> [a] -> a
go r :: a
r [] = a
r
    go r :: a
r (d :: a
d : ds :: [a]
ds) = a
r' a -> a -> a
forall a b. a -> b -> b
`seq` a -> [a] -> a
go a
r' [a]
ds
      where
        r' :: a
r' = a
r a -> a -> a
forall a. Num a => a -> a -> a
* a
base a -> a -> a
forall a. Num a => a -> a -> a
+ a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
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 :: Integer -> Digits -> Integer
valInteger b0 :: Integer
b0 ds0 :: Digits
ds0 = Integer -> Int -> [Integer] -> Integer
forall t a. (Integral t, Integral a) => t -> a -> [t] -> t
go Integer
b0 (Digits -> Int
forall a. [a] -> Int
length Digits
ds0) ([Integer] -> Integer) -> [Integer] -> Integer
forall a b. (a -> b) -> a -> b
$ (Int -> Integer) -> Digits -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Digits
ds0
  where
    go :: t -> a -> [t] -> t
go _ _ []  = 0
    go _ _ [d :: t
d] = t
d
    go b :: t
b l :: a
l ds :: [t]
ds
        | a
l a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> 40 = t
b' t -> t -> t
forall a b. a -> b -> b
`seq` t -> a -> [t] -> t
go t
b' a
l' (t -> [t] -> [t]
forall a. Num a => a -> [a] -> [a]
combine t
b [t]
ds')
        | Bool
otherwise = t -> [t] -> t
forall a d. (Num a, Integral d) => a -> [d] -> a
valSimple t
b [t]
ds
      where
        -- ensure that we have an even number of digits
        -- before we call combine:
        ds' :: [t]
ds' = if a -> Bool
forall a. Integral a => a -> Bool
even a
l then [t]
ds else 0 t -> [t] -> [t]
forall a. a -> [a] -> [a]
: [t]
ds
        b' :: t
b' = t
b t -> t -> t
forall a. Num a => a -> a -> a
* t
b
        l' :: a
l' = (a
l a -> a -> a
forall a. Num a => a -> a -> a
+ 1) a -> a -> a
forall a. Integral a => a -> a -> a
`quot` 2
    combine :: a -> [a] -> [a]
combine b :: a
b (d1 :: a
d1 : d2 :: a
d2 : ds :: [a]
ds) = a
d a -> [a] -> [a]
forall a b. a -> b -> b
`seq` (a
d a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a -> [a] -> [a]
combine a
b [a]
ds)
      where
        d :: a
d = a
d1 a -> a -> a
forall a. Num a => a -> a -> a
* a
b a -> a -> a
forall a. Num a => a -> a -> a
+ a
d2
    combine _ []  = []
    combine _ [_] = String -> [a]
forall a. String -> a
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 :: Integer -> Integer -> Digits -> Rational
fracExp exp :: Integer
exp mant :: Integer
mant []
  | Integer
exp Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 0     = Integer
mant Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% (10 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (-Integer
exp))
  | Bool
otherwise   = Integer -> Rational
forall a. Num a => Integer -> a
fromInteger (Integer
mant Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* 10 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
exp)
fracExp exp :: Integer
exp mant :: Integer
mant (d :: Int
d:ds :: Digits
ds) = Integer
exp' Integer -> Rational -> Rational
forall a b. a -> b -> b
`seq` Integer
mant' Integer -> Rational -> Rational
forall a b. a -> b -> b
`seq` Integer -> Integer -> Digits -> Rational
fracExp Integer
exp' Integer
mant' Digits
ds
  where
    exp' :: Integer
exp'  = Integer
exp Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- 1
    mant' :: Integer
mant' = Integer
mant Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* 10 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
d

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

valDig 10 c :: Char
c = Char -> Maybe Int
valDecDig Char
c

valDig 16 c :: Char
c
  | '0' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '9' = Int -> Maybe Int
forall a. a -> Maybe a
Just (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord '0')
  | 'a' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= 'f' = Int -> Maybe Int
forall a. a -> Maybe a
Just (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord 'a' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 10)
  | 'A' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= 'F' = Int -> Maybe Int
forall a. a -> Maybe a
Just (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord 'A' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 10)
  | Bool
otherwise            = Maybe Int
forall a. Maybe a
Nothing

valDig _ _ = String -> Maybe Int
forall a. String -> a
errorWithoutStackTrace "valDig: Bad base"

valDecDig :: Char -> Maybe Int
valDecDig :: Char -> Maybe Int
valDecDig c :: Char
c
  | '0' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '9' = Int -> Maybe Int
forall a. a -> Maybe a
Just (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord '0')
  | Bool
otherwise            = Maybe Int
forall a. Maybe a
Nothing

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

readIntP :: Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadP a
readIntP :: a -> (Char -> Bool) -> (Char -> Int) -> ReadP a
readIntP base :: a
base isDigit :: Char -> Bool
isDigit valDigit :: Char -> Int
valDigit =
  do String
s <- (Char -> Bool) -> ReadP String
munch1 Char -> Bool
isDigit
     a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Digits -> a
forall a. Num a => a -> Digits -> a
val a
base ((Char -> Int) -> String -> Digits
forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
valDigit String
s))
{-# SPECIALISE readIntP
        :: Integer -> (Char -> Bool) -> (Char -> Int) -> ReadP Integer #-}

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

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