{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude, StandaloneDeriving, ScopedTypeVariables #-}
{-# OPTIONS_HADDOCK hide #-}
module GHC.Read
( Read(..)
, ReadS
, lex
, lexLitChar
, readLitChar
, lexDigits
, lexP, expectP
, paren
, parens
, list
, choose
, readListDefault, readListPrecDefault
, readNumber
, readField
, readFieldHash
, readSymField
, readParen
)
where
#include "MachDeps.h"
import qualified Text.ParserCombinators.ReadP as P
import Text.ParserCombinators.ReadP
( ReadS
, readP_to_S
)
import qualified Text.Read.Lex as L
import Text.ParserCombinators.ReadPrec
import Data.Maybe
import GHC.Unicode
import GHC.Num
import GHC.Real
import GHC.Float
import GHC.Show
import GHC.Base
import GHC.Arr
import GHC.Word
readParen :: Bool -> ReadS a -> ReadS a
readParen b g = if b then mandatory else optional
where optional r = g r ++ mandatory r
mandatory r = do
("(",s) <- lex r
(x,t) <- optional s
(")",u) <- lex t
return (x,u)
class Read a where
{-# MINIMAL readsPrec | readPrec #-}
readsPrec :: Int
-> ReadS a
readList :: ReadS [a]
readPrec :: ReadPrec a
readListPrec :: ReadPrec [a]
readsPrec = readPrec_to_S readPrec
readList = readPrec_to_S (list readPrec) 0
readPrec = readS_to_Prec readsPrec
readListPrec = readS_to_Prec (\_ -> readList)
readListDefault :: Read a => ReadS [a]
readListDefault = readPrec_to_S readListPrec 0
readListPrecDefault :: Read a => ReadPrec [a]
readListPrecDefault = list readPrec
lex :: ReadS String
lex s = readP_to_S L.hsLex s
lexLitChar :: ReadS String
lexLitChar = readP_to_S (do { (s, _) <- P.gather L.lexChar ;
let s' = removeNulls s in
return s' })
where
removeNulls [] = []
removeNulls ('\\':'&':xs) = removeNulls xs
removeNulls (first:rest) = first : removeNulls rest
readLitChar :: ReadS Char
readLitChar = readP_to_S L.lexChar
lexDigits :: ReadS String
lexDigits = readP_to_S (P.munch1 isDigit)
lexP :: ReadPrec L.Lexeme
lexP = lift L.lex
expectP :: L.Lexeme -> ReadPrec ()
expectP lexeme = lift (L.expect lexeme)
expectCharP :: Char -> ReadPrec a -> ReadPrec a
expectCharP c a = do
q <- get
if q == c
then a
else pfail
{-# INLINE expectCharP #-}
skipSpacesThenP :: ReadPrec a -> ReadPrec a
skipSpacesThenP m =
do s <- look
skip s
where
skip (c:s) | isSpace c = get *> skip s
skip _ = m
paren :: ReadPrec a -> ReadPrec a
paren p = skipSpacesThenP (paren' p)
paren' :: ReadPrec a -> ReadPrec a
paren' p = expectCharP '(' $ reset p >>= \x ->
skipSpacesThenP (expectCharP ')' (pure x))
parens :: ReadPrec a -> ReadPrec a
parens p = optional
where
optional = skipSpacesThenP (p +++ mandatory)
mandatory = paren' optional
list :: ReadPrec a -> ReadPrec [a]
list readx =
parens
( do expectP (L.Punc "[")
(listRest False +++ listNext)
)
where
listRest started =
do L.Punc c <- lexP
case c of
"]" -> return []
"," | started -> listNext
_ -> pfail
listNext =
do x <- reset readx
xs <- listRest True
return (x:xs)
choose :: [(String, ReadPrec a)] -> ReadPrec a
choose sps = foldr ((+++) . try_one) pfail sps
where
try_one (s,p) = do { token <- lexP ;
case token of
L.Ident s' | s==s' -> p
L.Symbol s' | s==s' -> p
_other -> pfail }
readField :: String -> ReadPrec a -> ReadPrec a
readField fieldName readVal = do
expectP (L.Ident fieldName)
expectP (L.Punc "=")
readVal
{-# NOINLINE readField #-}
readFieldHash :: String -> ReadPrec a -> ReadPrec a
readFieldHash fieldName readVal = do
expectP (L.Ident fieldName)
expectP (L.Symbol "#")
expectP (L.Punc "=")
readVal
{-# NOINLINE readFieldHash #-}
readSymField :: String -> ReadPrec a -> ReadPrec a
readSymField fieldName readVal = do
expectP (L.Punc "(")
expectP (L.Symbol fieldName)
expectP (L.Punc ")")
expectP (L.Punc "=")
readVal
{-# NOINLINE readSymField #-}
deriving instance Read GeneralCategory
instance Read Char where
readPrec =
parens
( do L.Char c <- lexP
return c
)
readListPrec =
parens
( do L.String s <- lexP
return s
+++
readListPrecDefault
)
readList = readListDefault
instance Read Bool where
readPrec =
parens
( do L.Ident s <- lexP
case s of
"True" -> return True
"False" -> return False
_ -> pfail
)
readListPrec = readListPrecDefault
readList = readListDefault
instance Read Ordering where
readPrec =
parens
( do L.Ident s <- lexP
case s of
"LT" -> return LT
"EQ" -> return EQ
"GT" -> return GT
_ -> pfail
)
readListPrec = readListPrecDefault
readList = readListDefault
deriving instance Read a => Read (NonEmpty a)
instance Read a => Read (Maybe a) where
readPrec =
parens
(do expectP (L.Ident "Nothing")
return Nothing
+++
prec appPrec (
do expectP (L.Ident "Just")
x <- step readPrec
return (Just x))
)
readListPrec = readListPrecDefault
readList = readListDefault
instance Read a => Read [a] where
{-# SPECIALISE instance Read [String] #-}
{-# SPECIALISE instance Read [Char] #-}
{-# SPECIALISE instance Read [Int] #-}
readPrec = readListPrec
readListPrec = readListPrecDefault
readList = readListDefault
instance (Ix a, Read a, Read b) => Read (Array a b) where
readPrec = parens $ prec appPrec $
do expectP (L.Ident "array")
theBounds <- step readPrec
vals <- step readPrec
return (array theBounds vals)
readListPrec = readListPrecDefault
readList = readListDefault
instance Read L.Lexeme where
readPrec = lexP
readListPrec = readListPrecDefault
readList = readListDefault
readNumber :: Num a => (L.Lexeme -> ReadPrec a) -> ReadPrec a
readNumber convert =
parens
( do x <- lexP
case x of
L.Symbol "-" -> do y <- lexP
n <- convert y
return (negate n)
_ -> convert x
)
convertInt :: Num a => L.Lexeme -> ReadPrec a
convertInt (L.Number n)
| Just i <- L.numberToInteger n = return (fromInteger i)
convertInt _ = pfail
convertFrac :: forall a . RealFloat a => L.Lexeme -> ReadPrec a
convertFrac (L.Ident "NaN") = return (0 / 0)
convertFrac (L.Ident "Infinity") = return (1 / 0)
convertFrac (L.Number n) = let resRange = floatRange (undefined :: a)
in case L.numberToRangedRational resRange n of
Nothing -> return (1 / 0)
Just rat -> return $ fromRational rat
convertFrac _ = pfail
instance Read Int where
readPrec = readNumber convertInt
readListPrec = readListPrecDefault
readList = readListDefault
instance Read Word where
readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]
instance Read Word8 where
readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]
instance Read Word16 where
readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]
instance Read Word32 where
#if WORD_SIZE_IN_BITS < 33
readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]
#else
readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]
#endif
instance Read Word64 where
readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]
instance Read Integer where
readPrec = readNumber convertInt
readListPrec = readListPrecDefault
readList = readListDefault
instance Read Float where
readPrec = readNumber convertFrac
readListPrec = readListPrecDefault
readList = readListDefault
instance Read Double where
readPrec = readNumber convertFrac
readListPrec = readListPrecDefault
readList = readListDefault
instance (Integral a, Read a) => Read (Ratio a) where
readPrec =
parens
( prec ratioPrec
( do x <- step readPrec
expectP (L.Symbol "%")
y <- step readPrec
return (x % y)
)
)
readListPrec = readListPrecDefault
readList = readListDefault
instance Read () where
readPrec =
parens
( paren
( return ()
)
)
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b) => Read (a,b) where
readPrec = wrap_tup read_tup2
readListPrec = readListPrecDefault
readList = readListDefault
wrap_tup :: ReadPrec a -> ReadPrec a
wrap_tup p = parens (paren p)
read_comma :: ReadPrec ()
read_comma = expectP (L.Punc ",")
read_tup2 :: (Read a, Read b) => ReadPrec (a,b)
read_tup2 = do x <- readPrec
read_comma
y <- readPrec
return (x,y)
read_tup4 :: (Read a, Read b, Read c, Read d) => ReadPrec (a,b,c,d)
read_tup4 = do (a,b) <- read_tup2
read_comma
(c,d) <- read_tup2
return (a,b,c,d)
read_tup8 :: (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h)
=> ReadPrec (a,b,c,d,e,f,g,h)
read_tup8 = do (a,b,c,d) <- read_tup4
read_comma
(e,f,g,h) <- read_tup4
return (a,b,c,d,e,f,g,h)
instance (Read a, Read b, Read c) => Read (a, b, c) where
readPrec = wrap_tup (do { (a,b) <- read_tup2; read_comma
; c <- readPrec
; return (a,b,c) })
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where
readPrec = wrap_tup read_tup4
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b, Read c, Read d, Read e) => Read (a, b, c, d, e) where
readPrec = wrap_tup (do { (a,b,c,d) <- read_tup4; read_comma
; e <- readPrec
; return (a,b,c,d,e) })
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b, Read c, Read d, Read e, Read f)
=> Read (a, b, c, d, e, f) where
readPrec = wrap_tup (do { (a,b,c,d) <- read_tup4; read_comma
; (e,f) <- read_tup2
; return (a,b,c,d,e,f) })
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g)
=> Read (a, b, c, d, e, f, g) where
readPrec = wrap_tup (do { (a,b,c,d) <- read_tup4; read_comma
; (e,f) <- read_tup2; read_comma
; g <- readPrec
; return (a,b,c,d,e,f,g) })
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h)
=> Read (a, b, c, d, e, f, g, h) where
readPrec = wrap_tup read_tup8
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
Read i)
=> Read (a, b, c, d, e, f, g, h, i) where
readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
; i <- readPrec
; return (a,b,c,d,e,f,g,h,i) })
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
Read i, Read j)
=> Read (a, b, c, d, e, f, g, h, i, j) where
readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
; (i,j) <- read_tup2
; return (a,b,c,d,e,f,g,h,i,j) })
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
Read i, Read j, Read k)
=> Read (a, b, c, d, e, f, g, h, i, j, k) where
readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
; (i,j) <- read_tup2; read_comma
; k <- readPrec
; return (a,b,c,d,e,f,g,h,i,j,k) })
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
Read i, Read j, Read k, Read l)
=> Read (a, b, c, d, e, f, g, h, i, j, k, l) where
readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
; (i,j,k,l) <- read_tup4
; return (a,b,c,d,e,f,g,h,i,j,k,l) })
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
Read i, Read j, Read k, Read l, Read m)
=> Read (a, b, c, d, e, f, g, h, i, j, k, l, m) where
readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
; (i,j,k,l) <- read_tup4; read_comma
; m <- readPrec
; return (a,b,c,d,e,f,g,h,i,j,k,l,m) })
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
Read i, Read j, Read k, Read l, Read m, Read n)
=> Read (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where
readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
; (i,j,k,l) <- read_tup4; read_comma
; (m,n) <- read_tup2
; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n) })
readListPrec = readListPrecDefault
readList = readListDefault
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
Read i, Read j, Read k, Read l, Read m, Read n, Read o)
=> Read (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where
readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
; (i,j,k,l) <- read_tup4; read_comma
; (m,n) <- read_tup2; read_comma
; o <- readPrec
; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) })
readListPrec = readListPrecDefault
readList = readListDefault