(original) (raw)

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

module Text.Read.Lex

( Lexeme(..), Number

, numberToInteger, numberToFixed, numberToRational, numberToRangedRational

, 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

guard :: (MonadPlus m) => Bool -> m () guard True = return () guard False = mzero

data Lexeme = Char Char
| String String
| Punc String
| Ident String
| Symbol String
| Number Number
| EOF deriving ( Eq
, Show )

data Number = MkNumber Int
Digits
| MkDecimal Digits
(Maybe Digits)
(Maybe Integer) deriving ( Eq
, Show )

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

numberToFixed :: Integer -> Number -> Maybe (Integer, Integer) numberToFixed _ (MkNumber base iPart) = Just (val (fromIntegral base) iPart, 0) numberToFixed _ (MkDecimal iPart Nothing Nothing) = Just (val 10 iPart, 0) numberToFixed p (MkDecimal iPart (Just fPart) Nothing) = let i = val 10 iPart f = val 10 (integerTake p (fPart ++ repeat 0))

      integerTake             :: Integer -> [[a](#local-6989586621679079425)] -> [[a](#local-6989586621679079425)]
      [integerTake](#local-6989586621679079424) [n](#local-6989586621679079426) _ | [n](#local-6989586621679079426) <= 0 = []
      integerTake _ []        =  []
      integerTake [n](#local-6989586621679079427) ([x](#local-6989586621679079428):[xs](#local-6989586621679079429))    =  [x](#local-6989586621679079428) : [integerTake](#local-6989586621679079424) ([n](#local-6989586621679079427)-1) [xs](#local-6989586621679079429)
  in [Just](GHC.Maybe.html#Just) ([i](#local-6989586621679079422), [f](#local-6989586621679079423))

numberToFixed _ _ = Nothing

numberToRangedRational :: (Int, Int) -> Number -> Maybe Rational numberToRangedRational (neg, pos) n@(MkDecimal iPart mFPart (Just exp))

| [exp](#local-6989586621679079435) > [fromIntegral](GHC.Real.html#fromIntegral) ([maxBound](GHC.Enum.html#maxBound) :: Int) ||
  [exp](#local-6989586621679079435) < [fromIntegral](GHC.Real.html#fromIntegral) ([minBound](GHC.Enum.html#minBound) :: Int)
= [Nothing](GHC.Maybe.html#Nothing)
| [otherwise](GHC.Base.html#otherwise)
= let [mFirstDigit](#local-6989586621679079436) = case [dropWhile](GHC.List.html#dropWhile) (0 ==) [iPart](#local-6989586621679079433) of
                    [iPart'](#local-6989586621679079437)@(_ : _) -> [Just](GHC.Maybe.html#Just) ([length](GHC.List.html#length) [iPart'](#local-6989586621679079437))
                    [] -> case [mFPart](#local-6989586621679079434) of
                          [Nothing](GHC.Maybe.html#Nothing) -> [Nothing](GHC.Maybe.html#Nothing)
                          [Just](GHC.Maybe.html#Just) [fPart](#local-6989586621679079438) ->
                              case [span](GHC.List.html#span) (0 ==) [fPart](#local-6989586621679079438) of
                              (_, []) -> [Nothing](GHC.Maybe.html#Nothing)
                              ([zeroes](#local-6989586621679079439), _) ->
                                  [Just](GHC.Maybe.html#Just) ([negate](GHC.Num.html#negate) ([length](GHC.List.html#length) [zeroes](#local-6989586621679079439)))
  in case [mFirstDigit](#local-6989586621679079436) of
     [Nothing](GHC.Maybe.html#Nothing) -> [Just](GHC.Maybe.html#Just) 0
     [Just](GHC.Maybe.html#Just) [firstDigit](#local-6989586621679079440) ->
         let [firstDigit'](#local-6989586621679079441) = [firstDigit](#local-6989586621679079440) [+](GHC.Num.html#%2B) [fromInteger](GHC.Num.html#fromInteger) [exp](#local-6989586621679079435)
         in if [firstDigit'](#local-6989586621679079441) > ([pos](#local-6989586621679079431) [+](GHC.Num.html#%2B) 3)
            then [Nothing](GHC.Maybe.html#Nothing)
            else if [firstDigit'](#local-6989586621679079441) < ([neg](#local-6989586621679079430) - 3)
            then [Just](GHC.Maybe.html#Just) 0
            else [Just](GHC.Maybe.html#Just) ([numberToRational](Text.Read.Lex.html#numberToRational) [n](#local-6989586621679079432))

numberToRangedRational _ n = Just (numberToRational n)

numberToRational :: Number -> Rational numberToRational (MkNumber base iPart) = val (fromIntegral base) iPart % 1 numberToRational (MkDecimal iPart mFPart mExp) = let i = val 10 iPart in case (mFPart, mExp) of (Nothing, Nothing) -> i % 1 (Nothing, Just exp) | exp >= 0 -> (i * (10 ^ exp)) % 1 | otherwise -> i % (10 ^ (- exp)) (Just fPart, Nothing) -> fracExp 0 i fPart (Just fPart, Just exp) -> fracExp exp i fPart

lex :: ReadP Lexeme lex = skipSpaces >> lexToken

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

hsLex :: ReadP String

hsLex = do skipSpaces (s,_) <- gather lexToken return s

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

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

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

isPuncChar :: Char -> Bool isPuncChar c = c [elem](GHC.List.html#elem) ",;()[]{}`"

lexSymbol :: ReadP Lexeme lexSymbol = do s <- munch1 isSymbolChar if s [elem](GHC.List.html#elem) reserved_ops then return (Punc s)
else return (Symbol s) where reserved_ops = ["..", "::", "=", "\", "|", "<-", "->", "@", "~", "=>"]

isSymbolChar :: Char -> Bool isSymbolChar c = not (isPuncChar c) && case generalCategory c of MathSymbol -> True CurrencySymbol -> True ModifierSymbol -> True OtherSymbol -> True DashPunctuation -> True OtherPunctuation -> not (c [elem](GHC.List.html#elem) "'"") ConnectorPunctuation -> c /= '_' _ -> False

lexId :: ReadP Lexeme lexId = do c <- satisfy isIdsChar s <- munch isIdfChar return (Ident (c:s)) where

[isIdsChar](#local-6989586621679079462) [c](#local-6989586621679079464) = [isAlpha](GHC.Unicode.html#isAlpha) [c](#local-6989586621679079464) || [c](#local-6989586621679079464) == '_'
[isIdfChar](#local-6989586621679079463) [c](#local-6989586621679079465) = [isAlphaNum](GHC.Unicode.html#isAlphaNum) [c](#local-6989586621679079465) || [c](#local-6989586621679079465) `[elem](GHC.List.html#elem)` "_'"

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

lexChar :: ReadP Char lexChar = do { (c,_) <- lexCharE; consumeEmpties; return c } where

consumeEmpties :: [ReadP](Text.ParserCombinators.ReadP.html#ReadP) ()
[consumeEmpties](#local-6989586621679079470) = do
    [rest](#local-6989586621679079471) <- [look](Text.ParserCombinators.ReadP.html#look)
    case [rest](#local-6989586621679079471) of
        ('\\':'&':_) -> [string](Text.ParserCombinators.ReadP.html#string) "\\&" [>>](GHC.Base.html#%3E%3E) [consumeEmpties](#local-6989586621679079470)
        _ -> [return](GHC.Base.html#return) ()

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

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

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

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

lexAscii = do choice [ (string "SOH" >> return '\SOH') <++ (string "SO" >> return '\SO')

     , [string](Text.ParserCombinators.ReadP.html#string) "NUL" [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\NUL'
     , [string](Text.ParserCombinators.ReadP.html#string) "STX" [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\STX'
     , [string](Text.ParserCombinators.ReadP.html#string) "ETX" [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\ETX'
     , [string](Text.ParserCombinators.ReadP.html#string) "EOT" [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\EOT'
     , [string](Text.ParserCombinators.ReadP.html#string) "ENQ" [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\ENQ'
     , [string](Text.ParserCombinators.ReadP.html#string) "ACK" [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\ACK'
     , [string](Text.ParserCombinators.ReadP.html#string) "BEL" [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\BEL'
     , [string](Text.ParserCombinators.ReadP.html#string) "BS"  [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\BS'
     , [string](Text.ParserCombinators.ReadP.html#string) "HT"  [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\HT'
     , [string](Text.ParserCombinators.ReadP.html#string) "LF"  [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\LF'
     , [string](Text.ParserCombinators.ReadP.html#string) "VT"  [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\VT'
     , [string](Text.ParserCombinators.ReadP.html#string) "FF"  [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\FF'
     , [string](Text.ParserCombinators.ReadP.html#string) "CR"  [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\CR'
     , [string](Text.ParserCombinators.ReadP.html#string) "SI"  [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\SI'
     , [string](Text.ParserCombinators.ReadP.html#string) "DLE" [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\DLE'
     , [string](Text.ParserCombinators.ReadP.html#string) "DC1" [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\DC1'
     , [string](Text.ParserCombinators.ReadP.html#string) "DC2" [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\DC2'
     , [string](Text.ParserCombinators.ReadP.html#string) "DC3" [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\DC3'
     , [string](Text.ParserCombinators.ReadP.html#string) "DC4" [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\DC4'
     , [string](Text.ParserCombinators.ReadP.html#string) "NAK" [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\NAK'
     , [string](Text.ParserCombinators.ReadP.html#string) "SYN" [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\SYN'
     , [string](Text.ParserCombinators.ReadP.html#string) "ETB" [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\ETB'
     , [string](Text.ParserCombinators.ReadP.html#string) "CAN" [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\CAN'
     , [string](Text.ParserCombinators.ReadP.html#string) "EM"  [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\EM'
     , [string](Text.ParserCombinators.ReadP.html#string) "SUB" [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\SUB'
     , [string](Text.ParserCombinators.ReadP.html#string) "ESC" [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\ESC'
     , [string](Text.ParserCombinators.ReadP.html#string) "FS"  [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\FS'
     , [string](Text.ParserCombinators.ReadP.html#string) "GS"  [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\GS'
     , [string](Text.ParserCombinators.ReadP.html#string) "RS"  [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\RS'
     , [string](Text.ParserCombinators.ReadP.html#string) "US"  [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\US'
     , [string](Text.ParserCombinators.ReadP.html#string) "SP"  [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\SP'
     , [string](Text.ParserCombinators.ReadP.html#string) "DEL" [>>](GHC.Base.html#%3E%3E) [return](GHC.Base.html#return) '\DEL'
     ]

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

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

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

type Base = Int type Digits = [Int]

lexNumber :: ReadP Lexeme lexNumber = lexHexOct <++

[lexDecNumber](Text.Read.Lex.html#lexDecNumber)        

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

lexBaseChar :: ReadP Int

lexBaseChar = do { c <- get; case c of 'o' -> return 8 'O' -> return 8 'x' -> return 16 'X' -> return 16 _ -> pfail }

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

lexFrac :: ReadP (Maybe Digits)

lexFrac = do _ <- char '.' fraction <- lexDigits 10 return (Just fraction)

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

lexDigits :: Int -> ReadP Digits

lexDigits base = do s <- look xs <- scan s id guard (not (null xs)) return xs where scan (c:cs) f = case valDig base c of Just n -> do _ <- get; scan cs (f.(n:)) Nothing -> do return (f []) scan [] f = do return (f [])

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

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

valSimple :: (Num a, Integral d) => a -> [d] -> a valSimple base = go 0 where go r [] = r go r (d : ds) = r' seq go r' ds where r' = r * base + fromIntegral d {-# INLINE valSimple #-}

valInteger :: Integer -> Digits -> Integer valInteger b0 ds0 = go b0 (length ds0) $ map fromIntegral ds0 where go _ _ [] = 0 go _ _ [d] = d go b l ds | l > 40 = b' seq go b' l' (combine b ds') | otherwise = valSimple b ds where

    [ds'](#local-6989586621679079529) = if [even](GHC.Real.html#even) [l](#local-6989586621679079527) then [ds](#local-6989586621679079528) else 0 : [ds](#local-6989586621679079528)
    [b'](#local-6989586621679079530) = [b](#local-6989586621679079526) [*](GHC.Num.html#%2A) [b](#local-6989586621679079526)
    [l'](#local-6989586621679079531) = ([l](#local-6989586621679079527) [+](GHC.Num.html#%2B) 1) `[quot](GHC.Real.html#quot)` 2
[combine](#local-6989586621679079524) [b](#local-6989586621679079532) ([d1](#local-6989586621679079533) : [d2](#local-6989586621679079534) : [ds](#local-6989586621679079535)) = [d](#local-6989586621679079536) `seq` ([d](#local-6989586621679079536) : [combine](#local-6989586621679079524) [b](#local-6989586621679079532) [ds](#local-6989586621679079535))
  where
    [d](#local-6989586621679079536) = [d1](#local-6989586621679079533) [*](GHC.Num.html#%2A) [b](#local-6989586621679079532) [+](GHC.Num.html#%2B) [d2](#local-6989586621679079534)
combine _ []  = []
combine _ [_] = [errorWithoutStackTrace](GHC.Err.html#errorWithoutStackTrace) "this should not happen"

fracExp :: Integer -> Integer -> Digits -> Rational fracExp exp mant [] | exp < 0 = mant % (10 ^ (-exp)) | otherwise = fromInteger (mant * 10 ^ exp) fracExp exp mant (d:ds) = exp' seq mant' seq fracExp exp' mant' ds where exp' = exp - 1 mant' = mant * 10 + fromIntegral d

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

valDig 10 c = valDecDig c

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

valDig _ _ = errorWithoutStackTrace "valDig: Bad base"

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

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

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

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