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

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Internal.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 GHC.Internal.Text.Read
--
-----------------------------------------------------------------------------

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

  , numberToInteger, numberToFixed, numberToRational, numberToRangedRational

  -- lexer
  , lex, expect
  , hsLex
  , lexChar

  , readBinP
  , readIntP
  , readOctP
  , readDecP
  , readHexP

  , isSymbolChar
  )
 where

import GHC.Internal.Text.ParserCombinators.ReadP

import GHC.Internal.Base
import GHC.Internal.Char
import GHC.Internal.Num( Num(..), Integer )
import GHC.Internal.Show( Show(..) )
import GHC.Internal.Unicode
  ( GeneralCategory(..), generalCategory, isSpace, isAlpha, isAlphaNum )
import GHC.Internal.Real( Rational, (%), fromIntegral, Integral,
                 toInteger, (^), quot, even )
import GHC.Internal.List
import GHC.Internal.Enum( maxBound )
import GHC.Internal.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 :: forall (m :: * -> *). MonadPlus m => Bool -> m ()
guard Bool
True      =  () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
guard Bool
False     =  m ()
forall a. m a
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 base-4.6.0.0
  | EOF
 deriving ( Lexeme -> Lexeme -> Bool
(Lexeme -> Lexeme -> Bool)
-> (Lexeme -> Lexeme -> Bool) -> Eq Lexeme
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Lexeme -> Lexeme -> Bool
== :: Lexeme -> Lexeme -> Bool
$c/= :: Lexeme -> Lexeme -> Bool
/= :: Lexeme -> Lexeme -> Bool
Eq   -- ^ @since base-2.01
          , Int -> Lexeme -> ShowS
[Lexeme] -> ShowS
Lexeme -> String
(Int -> Lexeme -> ShowS)
-> (Lexeme -> String) -> ([Lexeme] -> ShowS) -> Show Lexeme
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Lexeme -> ShowS
showsPrec :: Int -> Lexeme -> ShowS
$cshow :: Lexeme -> String
show :: Lexeme -> String
$cshowList :: [Lexeme] -> ShowS
showList :: [Lexeme] -> ShowS
Show -- ^ @since base-2.01
          )

-- | @since base-4.6.0.0
data Number = MkNumber Int              -- Base
                       Digits           -- Integral part
            | MkDecimal Digits          -- Integral part
                        (Maybe Digits)  -- Fractional part
                        (Maybe Integer) -- Exponent
 deriving ( Number -> Number -> Bool
(Number -> Number -> Bool)
-> (Number -> Number -> Bool) -> Eq Number
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Number -> Number -> Bool
== :: Number -> Number -> Bool
$c/= :: Number -> Number -> Bool
/= :: Number -> Number -> Bool
Eq   -- ^ @since base-4.6.0.0
          , Int -> Number -> ShowS
[Number] -> ShowS
Number -> String
(Int -> Number -> ShowS)
-> (Number -> String) -> ([Number] -> ShowS) -> Show Number
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Number -> ShowS
showsPrec :: Int -> Number -> ShowS
$cshow :: Number -> String
show :: Number -> String
$cshowList :: [Number] -> ShowS
showList :: [Number] -> ShowS
Show -- ^ @since base-4.6.0.0
          )

-- | @since base-4.5.1.0
numberToInteger :: Number -> Maybe Integer
numberToInteger :: Number -> Maybe Integer
numberToInteger (MkNumber Int
base 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 Digits
iPart Maybe Digits
Nothing Maybe Integer
Nothing) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Digits -> Integer
forall a. Num a => a -> Digits -> a
val Integer
10 Digits
iPart)
numberToInteger Number
_ = Maybe Integer
forall a. Maybe a
Nothing

-- | @since base-4.7.0.0
numberToFixed :: Integer -> Number -> Maybe (Integer, Integer)
numberToFixed :: Integer -> Number -> Maybe (Integer, Integer)
numberToFixed Integer
_ (MkNumber Int
base 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, Integer
0)
numberToFixed Integer
_ (MkDecimal Digits
iPart Maybe Digits
Nothing Maybe Integer
Nothing) = (Integer, Integer) -> Maybe (Integer, Integer)
forall a. a -> Maybe a
Just (Integer -> Digits -> Integer
forall a. Num a => a -> Digits -> a
val Integer
10 Digits
iPart, Integer
0)
numberToFixed Integer
p (MkDecimal Digits
iPart (Just Digits
fPart) Maybe Integer
Nothing)
    = let i :: Integer
i = Integer -> Digits -> Integer
forall a. Num a => a -> Digits -> a
val Integer
10 Digits
iPart
          f :: Integer
f = Integer -> Digits -> Integer
forall a. Num a => a -> Digits -> a
val Integer
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 Int
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 :: forall a. Integer -> [a] -> [a]
integerTake Integer
n [a]
_ | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 = []
          integerTake Integer
_ []        =  []
          integerTake Integer
n (a
x:[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
-Integer
1) [a]
xs
      in (Integer, Integer) -> Maybe (Integer, Integer)
forall a. a -> Maybe a
Just (Integer
i, Integer
f)
numberToFixed Integer
_ Number
_ = 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 floatRange 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 base-4.5.1.0
numberToRangedRational :: (Int, Int) -> Number
                       -> Maybe Rational -- Nothing = Inf
numberToRangedRational :: (Int, Int) -> Number -> Maybe Rational
numberToRangedRational (Int
neg, Int
pos) n :: Number
n@(MkDecimal Digits
iPart Maybe Digits
mFPart (Just Integer
exp))
    -- Calculate amount to increase/decrease the exponent, based on (non
    -- leading zero) places in the iPart, or leading zeros in the fPart.
    -- If iPart and fPart are all zeros, return Nothing.
    = let mFirstDigit :: Maybe Int
mFirstDigit = case (Int -> Bool) -> Digits -> Digits
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Int
0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==) Digits
iPart of
                        iPart' :: Digits
iPart'@(Int
_ : Digits
_) -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Digits -> Int
forall a. [a] -> Int
length Digits
iPart')
                        [] -> case Maybe Digits
mFPart of
                              Maybe Digits
Nothing -> Maybe Int
forall a. Maybe a
Nothing
                              Just Digits
fPart ->
                                  case (Int -> Bool) -> Digits -> (Digits, Digits)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Int
0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==) Digits
fPart of
                                  (Digits
_, []) -> Maybe Int
forall a. Maybe a
Nothing
                                  (Digits
zeroes, Digits
_) ->
                                      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
         Maybe Int
Nothing -> Rational -> Maybe Rational
forall a. a -> Maybe a
Just Rational
0
         Just Int
firstDigit ->
             -- compare exp to bounds as Integer to avoid over/underflow
             let firstDigit' :: Integer
firstDigit' = Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
firstDigit Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
exp
             in if Integer
firstDigit' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)
                then Maybe Rational
forall a. Maybe a
Nothing
                else if Integer
firstDigit' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
neg Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3)
                then Rational -> Maybe Rational
forall a. a -> Maybe a
Just Rational
0
                else Rational -> Maybe Rational
forall a. a -> Maybe a
Just (Number -> Rational
numberToRational Number
n)
numberToRangedRational (Int, Int)
_ Number
n = Rational -> Maybe Rational
forall a. a -> Maybe a
Just (Number -> Rational
numberToRational Number
n)

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

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

hsLex :: ReadP String
-- ^ Haskell lexer: returns the lexed string, rather than the lexeme
hsLex :: ReadP String
hsLex = do ReadP ()
skipSpaces
           (s,_) <- ReadP Lexeme -> ReadP (String, Lexeme)
forall a. ReadP a -> ReadP (String, a)
gather ReadP Lexeme
lexToken
           return 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 s <- ReadP String
look
            guard (null s)
            return EOF

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

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

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

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

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

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

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

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

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

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


lexCharE :: ReadP (Char, Bool)  -- "escaped or not"?
lexCharE :: ReadP (Char, Bool)
lexCharE =
  do c1 <- ReadP Char
get
     if c1 == '\\'
       then do c2 <- lexEsc; return (c2, True)
       else return (c1, 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 c <- ReadP Char
get
       case c of
         Char
'a'  -> Char -> ReadP Char
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\a'
         Char
'b'  -> Char -> ReadP Char
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\b'
         Char
'f'  -> Char -> ReadP Char
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\f'
         Char
'n'  -> Char -> ReadP Char
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\n'
         Char
'r'  -> Char -> ReadP Char
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\r'
         Char
't'  -> Char -> ReadP Char
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\t'
         Char
'v'  -> Char -> ReadP Char
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\v'
         Char
'\\' -> Char -> ReadP Char
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\\'
         Char
'\"' -> Char -> ReadP Char
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\"'
         Char
'\'' -> Char -> ReadP Char
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\''
         Char
_    -> ReadP Char
forall a. ReadP a
pfail

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

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

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

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


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

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

  lexStrItem :: ReadP (Char, Bool)
lexStrItem = (ReadP ()
lexEmpty ReadP () -> ReadP (Char, Bool) -> ReadP (Char, Bool)
forall a b. ReadP a -> ReadP b -> ReadP b
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 -> ReadP Char
char Char
'\\'
       c <- get
       case c of
         Char
'&'           -> () -> ReadP ()
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         Char
_ | Char -> Bool
isSpace Char
c -> do ReadP ()
skipSpaces; _ <- Char -> ReadP Char
char Char
'\\'; return ()
         Char
_             -> 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 -> ReadP Char
char 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 :: ReadP Int
lexBaseChar = do
  c <- ReadP Char
get
  case c of
    Char
'o' -> Int -> ReadP Int
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
8
    Char
'O' -> Int -> ReadP Int
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
8
    Char
'x' -> Int -> ReadP Int
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
16
    Char
'X' -> Int -> ReadP Int
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
16
    Char
_   -> ReadP Int
forall a. ReadP a
pfail

lexDecNumber :: ReadP Lexeme
lexDecNumber :: ReadP Lexeme
lexDecNumber =
  do xs    <- Int -> ReadP Digits
lexDigits Int
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 :: ReadP (Maybe Digits)
lexFrac = do _ <- Char -> ReadP Char
char Char
'.'
             fraction <- lexDigits 10
             return (Just fraction)

lexExp :: ReadP (Maybe Integer)
lexExp :: ReadP (Maybe Integer)
lexExp = do _ <- Char -> ReadP Char
char Char
'e' ReadP Char -> ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a -> ReadP a
+++ Char -> ReadP Char
char Char
'E'
            exp <- signedExp +++ lexInteger 10
            return (Just exp)
 where
   signedExp :: ReadP Integer
signedExp
     = do c <- Char -> ReadP Char
char Char
'-' ReadP Char -> ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a -> ReadP a
+++ Char -> ReadP Char
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 :: Int -> ReadP Digits
lexDigits Int
base =
  do s  <- ReadP String
look
     xs <- scan s id
     guard (not (null xs))
     return xs
 where
  scan :: String -> (Digits -> b) -> ReadP b
scan (Char
c:String
cs) Digits -> b
f = case Int -> Char -> Maybe Int
forall a. (Eq a, Num a) => a -> Char -> Maybe Int
valDig Int
base Char
c of
                    Just Int
n  -> do _ <- ReadP Char
get; scan cs (f.(n:))
                    Maybe Int
Nothing -> b -> ReadP b
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return (Digits -> b
f [])
  scan []     Digits -> b
f = b -> ReadP b
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return (Digits -> b
f [])

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

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

valDig a
8 Char
c
  | Char
'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
<= Char
'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 Char
'0')
  | Bool
otherwise            = Maybe Int
forall a. Maybe a
Nothing

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

valDig a
16 Char
c
  | Char
'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
<= Char
'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 Char
'0')
  | Char
'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
<= Char
'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 Char
'a' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10)
  | Char
'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
<= Char
'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 Char
'A' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10)
  | Bool
otherwise            = Maybe Int
forall a. Maybe a
Nothing

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

valDecDig :: Char -> Maybe Int
valDecDig :: Char -> Maybe Int
valDecDig Char
c
  | Char
'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
<= Char
'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 Char
'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 :: forall a. Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadP a
readIntP a
base Char -> Bool
isDigit Char -> Int
valDigit =
  do s <- (Char -> Bool) -> ReadP String
munch1 Char -> Bool
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' :: forall a. (Eq a, Num a) => a -> ReadP a
readIntP' 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  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 Char
c = Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
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 #-}

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