module JsonLogic.Json (Json (..), JsonObject, Rule, Data, prettyShow, stringify, isTruthy, isFalsy, parseFloat) where
import Control.Applicative
import Data.Char (isSpace)
import Data.List (intercalate)
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Text.Read
( Read (readPrec),
ReadPrec,
get,
parens,
pfail,
readMaybe,
(+++),
)
data Json
= JsonNull
| JsonBool Bool
| JsonNumber Double
| JsonString String
| JsonArray [Json]
| JsonObject JsonObject
deriving (Json -> Json -> Bool
(Json -> Json -> Bool) -> (Json -> Json -> Bool) -> Eq Json
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Json -> Json -> Bool
$c/= :: Json -> Json -> Bool
== :: Json -> Json -> Bool
$c== :: Json -> Json -> Bool
Eq)
type JsonObject = M.Map String Json
type Rule = Json
type Data = Json
instance Show Json where
show :: Json -> String
show Json
JsonNull = String
"null"
show (JsonBool Bool
True) = String
"true"
show (JsonBool Bool
False) = String
"false"
show (JsonNumber Double
d) = Double -> String
forall a. Show a => a -> String
show Double
d
show (JsonString String
s) = ShowS
forall a. Show a => a -> String
show String
s
show (JsonArray [Json]
js) = [Json] -> String
forall a. Show a => a -> String
show [Json]
js
show (JsonObject JsonObject
o) = String
"{" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," (((String, Json) -> String) -> [(String, Json)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
k, Json
v) -> ShowS
forall a. Show a => a -> String
show String
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Json -> String
forall a. Show a => a -> String
show Json
v) ([(String, Json)] -> [String]) -> [(String, Json)] -> [String]
forall a b. (a -> b) -> a -> b
$ JsonObject -> [(String, Json)]
forall k a. Map k a -> [(k, a)]
M.toList JsonObject
o) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}"
instance Read Json where
readPrec :: ReadPrec Json
readPrec = ReadPrec Json -> ReadPrec Json
forall a. ReadPrec a -> ReadPrec a
parens ReadPrec Json
readValue
prettyShow :: Json -> String
prettyShow :: Json -> String
prettyShow = Int -> Json -> String
prettyShow' Int
0
where
prettyShow' :: Int -> Json -> String
prettyShow' :: Int -> Json -> String
prettyShow' Int
nrSpaces (JsonArray [Json]
js) =
String
"[\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
commaSeparate ((Json -> String) -> [Json] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\Json
j -> Int -> String
tab Int
nrSpaces String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Json -> String
prettyShow' (Int
nrSpaces Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Json
j) [Json]
js)
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
closingBracket Int
nrSpaces Char
']'
prettyShow' Int
nrSpaces (JsonObject JsonObject
o) =
String
"{\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
commaSeparate (((String, Json) -> String) -> [(String, Json)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
k, Json
v) -> Int -> String
tab Int
nrSpaces String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Json -> String
prettyShow' (Int
nrSpaces Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Json
v) ([(String, Json)] -> [String]) -> [(String, Json)] -> [String]
forall a b. (a -> b) -> a -> b
$ JsonObject -> [(String, Json)]
forall k a. Map k a -> [(k, a)]
M.toList JsonObject
o)
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
closingBracket Int
nrSpaces Char
'}'
prettyShow' Int
_ Json
json = Json -> String
forall a. Show a => a -> String
show Json
json
commaSeparate :: [String] -> String
commaSeparate :: [String] -> String
commaSeparate = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
",\n"
closingBracket :: Int -> Char -> String
closingBracket :: Int -> Char -> String
closingBracket Int
depth Char
c = String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
depth Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
c]
tab :: Int -> String
tab :: Int -> String
tab Int
depth = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Char
' '
stringify :: Json -> String
stringify :: Json -> String
stringify Json
JsonNull = String
""
stringify (JsonBool Bool
True) = String
"true"
stringify (JsonBool Bool
False) = String
"false"
stringify (JsonNumber Double
d) = Double -> String
forall a. Show a => a -> String
show Double
d
stringify (JsonString String
s) = String
s
stringify (JsonArray [Json]
js) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Json -> String) -> [Json] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Json -> String
stringify [Json]
js
stringify (JsonObject JsonObject
_) = String
"[object Object]"
isTruthy :: Json -> Bool
isTruthy :: Json -> Bool
isTruthy Json
JsonNull = Bool
False
isTruthy (JsonBool Bool
b) = Bool
b
isTruthy (JsonNumber Double
0.0) = Bool
False
isTruthy (JsonNumber Double
_) = Bool
True
isTruthy (JsonString String
"") = Bool
False
isTruthy (JsonString String
_) = Bool
True
isTruthy (JsonArray []) = Bool
False
isTruthy (JsonArray [Json]
_) = Bool
True
isTruthy (JsonObject JsonObject
_) = Bool
True
isFalsy :: Json -> Bool
isFalsy :: Json -> Bool
isFalsy = Bool -> Bool
not (Bool -> Bool) -> (Json -> Bool) -> Json -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Json -> Bool
isTruthy
parseFloat :: Json -> Double
parseFloat :: Json -> Double
parseFloat (JsonNumber Double
n) = Double
n
parseFloat (JsonString String
"Infinity") = Double
infinity
parseFloat (JsonString String
s) = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
notANumber (Maybe Double -> Double) -> Maybe Double -> Double
forall a b. (a -> b) -> a -> b
$ String -> Maybe Double
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Double) -> String -> Maybe Double
forall a b. (a -> b) -> a -> b
$ ShowS
dropAfterSecondPoint ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isValid ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
s
where
isValid :: Char -> Bool
isValid Char
x
| Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
valids = Bool
True
| Bool
otherwise = Bool
False
valids :: String
valids = [Char
'0' .. Char
'9'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'.', Char
'e', Char
'E', Char
'+', Char
'-']
dropAfterSecondPoint :: ShowS
dropAfterSecondPoint String
t = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') String
t of
(String
l, Char
'.' : String
r) -> case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') String
r of (String
l', String
_) -> String
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
l'
(String
l, String
_) -> String
l
parseFloat (JsonArray (Json
a : [Json]
_)) = Json -> Double
parseFloat Json
a
parseFloat Json
_ = Double
notANumber
infinity :: Double
infinity :: Double
infinity = Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0
notANumber :: Double
notANumber :: Double
notANumber = Double
0 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0
readObject :: ReadPrec JsonObject
readObject :: ReadPrec JsonObject
readObject = do
Char
'{' <- ReadPrec Char
get
[(String, Json)]
items <-
( do
ReadPrec ()
readWhitespace
[(String, Json)] -> ReadPrec [(String, Json)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
)
ReadPrec [(String, Json)]
-> ReadPrec [(String, Json)] -> ReadPrec [(String, Json)]
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
+++ ( do
(String, Json)
h <- ReadPrec (String, Json)
readKvp
[(String, Json)]
t <- ReadPrec (String, Json) -> ReadPrec [(String, Json)]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ReadPrec (String, Json) -> ReadPrec [(String, Json)])
-> ReadPrec (String, Json) -> ReadPrec [(String, Json)]
forall a b. (a -> b) -> a -> b
$ do
Char
',' <- ReadPrec Char
get
ReadPrec (String, Json)
readKvp
[(String, Json)] -> ReadPrec [(String, Json)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, Json)] -> ReadPrec [(String, Json)])
-> [(String, Json)] -> ReadPrec [(String, Json)]
forall a b. (a -> b) -> a -> b
$ (String, Json)
h (String, Json) -> [(String, Json)] -> [(String, Json)]
forall a. a -> [a] -> [a]
: [(String, Json)]
t
)
Char
'}' <- ReadPrec Char
get
JsonObject -> ReadPrec JsonObject
forall (m :: * -> *) a. Monad m => a -> m a
return (JsonObject -> ReadPrec JsonObject)
-> JsonObject -> ReadPrec JsonObject
forall a b. (a -> b) -> a -> b
$ [(String, Json)] -> JsonObject
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(String, Json)]
items
where
readKvp :: ReadPrec (String, Json)
readKvp = do
ReadPrec ()
readWhitespace
String
key <- ReadPrec String
readString
ReadPrec ()
readWhitespace
Char
':' <- ReadPrec Char
get
Json
value <- ReadPrec Json
readValue
(String, Json) -> ReadPrec (String, Json)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
key, Json
value)
readArray :: ReadPrec [Json]
readArray :: ReadPrec [Json]
readArray = do
Char
'[' <- ReadPrec Char
get
[Json]
items <-
( do
ReadPrec ()
readWhitespace
[Json] -> ReadPrec [Json]
forall (m :: * -> *) a. Monad m => a -> m a
return []
)
ReadPrec [Json] -> ReadPrec [Json] -> ReadPrec [Json]
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
+++ ( do
Json
h <- ReadPrec Json
readValue
[Json]
t <- ReadPrec Json -> ReadPrec [Json]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ReadPrec Json -> ReadPrec [Json])
-> ReadPrec Json -> ReadPrec [Json]
forall a b. (a -> b) -> a -> b
$ do
Char
',' <- ReadPrec Char
get
ReadPrec Json
readValue
[Json] -> ReadPrec [Json]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Json] -> ReadPrec [Json]) -> [Json] -> ReadPrec [Json]
forall a b. (a -> b) -> a -> b
$ Json
h Json -> [Json] -> [Json]
forall a. a -> [a] -> [a]
: [Json]
t
)
Char
']' <- ReadPrec Char
get
[Json] -> ReadPrec [Json]
forall (m :: * -> *) a. Monad m => a -> m a
return [Json]
items
readValue :: ReadPrec Json
readValue :: ReadPrec Json
readValue = do
ReadPrec ()
readWhitespace
Json
value <-
(String -> Json
JsonString (String -> Json) -> ReadPrec String -> ReadPrec Json
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadPrec String
readString)
ReadPrec Json -> ReadPrec Json -> ReadPrec Json
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
+++ (Double -> Json
JsonNumber (Double -> Json) -> ReadPrec Double -> ReadPrec Json
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadPrec Double
readNumber)
ReadPrec Json -> ReadPrec Json -> ReadPrec Json
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
+++ (JsonObject -> Json
JsonObject (JsonObject -> Json) -> ReadPrec JsonObject -> ReadPrec Json
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadPrec JsonObject
readObject)
ReadPrec Json -> ReadPrec Json -> ReadPrec Json
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
+++ ([Json] -> Json
JsonArray ([Json] -> Json) -> ReadPrec [Json] -> ReadPrec Json
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadPrec [Json]
readArray)
ReadPrec Json -> ReadPrec Json -> ReadPrec Json
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
+++ ( do
String
"true" <- ReadPrec Char -> ReadPrec String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ReadPrec Char
get
Json -> ReadPrec Json
forall (m :: * -> *) a. Monad m => a -> m a
return (Json -> ReadPrec Json) -> Json -> ReadPrec Json
forall a b. (a -> b) -> a -> b
$ Bool -> Json
JsonBool Bool
True
)
ReadPrec Json -> ReadPrec Json -> ReadPrec Json
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
+++ ( do
String
"false" <- ReadPrec Char -> ReadPrec String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ReadPrec Char
get
Json -> ReadPrec Json
forall (m :: * -> *) a. Monad m => a -> m a
return (Json -> ReadPrec Json) -> Json -> ReadPrec Json
forall a b. (a -> b) -> a -> b
$ Bool -> Json
JsonBool Bool
False
)
ReadPrec Json -> ReadPrec Json -> ReadPrec Json
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
+++ ( do
String
"null" <- ReadPrec Char -> ReadPrec String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ReadPrec Char
get
Json -> ReadPrec Json
forall (m :: * -> *) a. Monad m => a -> m a
return Json
JsonNull
)
ReadPrec ()
readWhitespace
Json -> ReadPrec Json
forall (m :: * -> *) a. Monad m => a -> m a
return Json
value
readString :: ReadPrec String
readString :: ReadPrec String
readString = do
Char
'\"' <- ReadPrec Char
get
String
xs <-
ReadPrec Char -> ReadPrec String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ReadPrec Char -> ReadPrec String)
-> ReadPrec Char -> ReadPrec String
forall a b. (a -> b) -> a -> b
$
( do
Char
char <- ReadPrec Char
get
case Char
char of
Char
'\\' -> ReadPrec Char
forall a. ReadPrec a
pfail
Char
'\"' -> ReadPrec Char
forall a. ReadPrec a
pfail
Char
plain -> Char -> ReadPrec Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
plain
)
ReadPrec Char -> ReadPrec Char -> ReadPrec Char
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
+++ ( do
Char
'\\' <- ReadPrec Char
get
Char
char <- ReadPrec Char
get
case Char
char of
Char
'\"' -> Char -> ReadPrec Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\"'
Char
'\\' -> Char -> ReadPrec Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\\'
Char
'/' -> Char -> ReadPrec Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'/'
Char
'b' -> Char -> ReadPrec Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\b'
Char
'f' -> Char -> ReadPrec Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\f'
Char
'n' -> Char -> ReadPrec Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\n'
Char
'r' -> Char -> ReadPrec Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\r'
Char
't' -> Char -> ReadPrec Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\t'
Char
'u' -> do
Int
a <- ReadPrec Int
readHex
Int
b <- ReadPrec Int
readHex
Int
c <- ReadPrec Int
readHex
Int
d <- ReadPrec Int
readHex
Char -> ReadPrec Char
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> ReadPrec Char) -> Char -> ReadPrec Char
forall a b. (a -> b) -> a -> b
$ Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Int) -> Int -> [Int] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Int
l Int
r -> Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
r) Int
0 [Int
a, Int
b, Int
c, Int
d]
Char
_ -> ReadPrec Char
forall a. ReadPrec a
pfail
)
Char
'\"' <- ReadPrec Char
get
String -> ReadPrec String
forall (m :: * -> *) a. Monad m => a -> m a
return String
xs
where
readHex :: ReadPrec Int
readHex = [(Char, Int)] -> ReadPrec Int
forall a. [(Char, a)] -> ReadPrec a
readMap ([(Char, Int)] -> ReadPrec Int) -> [(Char, Int)] -> ReadPrec Int
forall a b. (a -> b) -> a -> b
$ String -> [Int] -> [(Char, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Char
'0' .. Char
'9'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'A' .. Char
'F'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'a' .. Char
'f']) ([Int
0 .. Int
9] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
10 .. Int
15] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
10 .. Int
15])
readNumber :: ReadPrec Double
readNumber :: ReadPrec Double
readNumber = do
Double -> Double
sign <-
(Double -> Double) -> ReadPrec (Double -> Double)
forall (m :: * -> *) a. Monad m => a -> m a
return Double -> Double
forall a. a -> a
id
ReadPrec (Double -> Double)
-> ReadPrec (Double -> Double) -> ReadPrec (Double -> Double)
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
+++ ( do
Char
'-' <- ReadPrec Char
get
(Double -> Double) -> ReadPrec (Double -> Double)
forall (m :: * -> *) a. Monad m => a -> m a
return Double -> Double
forall a. Num a => a -> a
negate
)
Double
beforeDecimal <-
(
do
Char
'0' <- ReadPrec Char
get
Double -> ReadPrec Double
forall (m :: * -> *) a. Monad m => a -> m a
return Double
0
)
ReadPrec Double -> ReadPrec Double -> ReadPrec Double
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
+++ (
do
Double
nonZeroDigit <- ReadPrec Double
getNonZeroDigit
[Double]
digits <- ReadPrec Double -> ReadPrec [Double]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ReadPrec Double
getDigit
Double -> ReadPrec Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> ReadPrec Double) -> Double -> ReadPrec Double
forall a b. (a -> b) -> a -> b
$ (Double -> Double -> Double) -> Double -> [Double] -> Double
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Double
l Double
r -> Double
l Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
10 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
r) Double
nonZeroDigit [Double]
digits
)
Double -> Double
afterDecimal <-
(Double -> Double) -> ReadPrec (Double -> Double)
forall (m :: * -> *) a. Monad m => a -> m a
return Double -> Double
forall a. a -> a
id
ReadPrec (Double -> Double)
-> ReadPrec (Double -> Double) -> ReadPrec (Double -> Double)
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
+++ ( do
Char
'.' <- ReadPrec Char
get
[Double]
digits <- ReadPrec Double -> ReadPrec [Double]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ReadPrec Double
getDigit
(Double -> Double) -> ReadPrec (Double -> Double)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Double -> Double) -> ReadPrec (Double -> Double))
-> (Double -> Double) -> ReadPrec (Double -> Double)
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) (Double -> Double -> Double) -> Double -> Double -> Double
forall a b. (a -> b) -> a -> b
$ (Double -> Double -> Double) -> [Double] -> Double
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Double
l Double
r -> Double
l Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
r Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
10) (Double
0 Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: [Double]
digits)
)
Double -> Double
expo <-
(Double -> Double) -> ReadPrec (Double -> Double)
forall (m :: * -> *) a. Monad m => a -> m a
return Double -> Double
forall a. a -> a
id ReadPrec (Double -> Double)
-> ReadPrec (Double -> Double) -> ReadPrec (Double -> Double)
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
+++ do
( do
Char
'e' <- ReadPrec Char
get
() -> ReadPrec ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
)
ReadPrec () -> ReadPrec () -> ReadPrec ()
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
+++ ( do
Char
'E' <- ReadPrec Char
get
() -> ReadPrec ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
)
Double -> Double -> Double
expBase <-
(Double -> Double -> Double)
-> ReadPrec (Double -> Double -> Double)
forall (m :: * -> *) a. Monad m => a -> m a
return Double -> Double -> Double
forall a. Num a => a -> a -> a
(*)
ReadPrec (Double -> Double -> Double)
-> ReadPrec (Double -> Double -> Double)
-> ReadPrec (Double -> Double -> Double)
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
+++ ( do
Char
'-' <- ReadPrec Char
get
(Double -> Double -> Double)
-> ReadPrec (Double -> Double -> Double)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Double -> Double -> Double)
-> ReadPrec (Double -> Double -> Double))
-> (Double -> Double -> Double)
-> ReadPrec (Double -> Double -> Double)
forall a b. (a -> b) -> a -> b
$ (Double -> Double -> Double) -> Double -> Double -> Double
forall a b c. (a -> b -> c) -> b -> a -> c
flip Double -> Double -> Double
forall a. Fractional a => a -> a -> a
(/)
)
ReadPrec (Double -> Double -> Double)
-> ReadPrec (Double -> Double -> Double)
-> ReadPrec (Double -> Double -> Double)
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
+++ ( do
Char
'+' <- ReadPrec Char
get
(Double -> Double -> Double)
-> ReadPrec (Double -> Double -> Double)
forall (m :: * -> *) a. Monad m => a -> m a
return Double -> Double -> Double
forall a. Num a => a -> a -> a
(*)
)
Double
expDigits <-
( do
[Double]
digits <- ReadPrec Double -> ReadPrec [Double]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ReadPrec Double
getDigit
Double -> ReadPrec Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> ReadPrec Double) -> Double -> ReadPrec Double
forall a b. (a -> b) -> a -> b
$ (Double -> Double -> Double) -> [Double] -> Double
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\Double
l Double
r -> Double
l Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
10 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
r) [Double]
digits
)
(Double -> Double) -> ReadPrec (Double -> Double)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Double -> Double) -> ReadPrec (Double -> Double))
-> (Double -> Double) -> ReadPrec (Double -> Double)
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
expBase (Double -> Double -> Double) -> Double -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double
10 Double -> Double -> Double
forall a. Floating a => a -> a -> a
** Double
expDigits
Double -> ReadPrec Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> ReadPrec Double) -> Double -> ReadPrec Double
forall a b. (a -> b) -> a -> b
$ Double -> Double
sign (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double -> Double
expo (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double -> Double
afterDecimal Double
beforeDecimal
where
getDigit :: ReadPrec Double
getDigit = [(Char, Double)] -> ReadPrec Double
forall a. [(Char, a)] -> ReadPrec a
readMap ([(Char, Double)] -> ReadPrec Double)
-> [(Char, Double)] -> ReadPrec Double
forall a b. (a -> b) -> a -> b
$ String -> [Double] -> [(Char, Double)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Char
'0' .. Char
'9'] [Double
0 .. Double
9]
getNonZeroDigit :: ReadPrec Double
getNonZeroDigit = [(Char, Double)] -> ReadPrec Double
forall a. [(Char, a)] -> ReadPrec a
readMap ([(Char, Double)] -> ReadPrec Double)
-> [(Char, Double)] -> ReadPrec Double
forall a b. (a -> b) -> a -> b
$ String -> [Double] -> [(Char, Double)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Char
'1' .. Char
'9'] [Double
1 .. Double
9]
readWhitespace :: ReadPrec ()
readWhitespace :: ReadPrec ()
readWhitespace = () () -> ReadPrec [()] -> ReadPrec ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ReadPrec () -> ReadPrec [()]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ([(Char, ())] -> ReadPrec ()
forall a. [(Char, a)] -> ReadPrec a
readMap ([(Char, ())] -> ReadPrec ()) -> [(Char, ())] -> ReadPrec ()
forall a b. (a -> b) -> a -> b
$ String -> [()] -> [(Char, ())]
forall a b. [a] -> [b] -> [(a, b)]
zip String
" \t\n\r" (() -> [()]
forall a. a -> [a]
repeat ()))
readMap :: [(Char, a)] -> ReadPrec a
readMap :: [(Char, a)] -> ReadPrec a
readMap [(Char, a)]
xs = do
Char
x <- ReadPrec Char
get
ReadPrec a -> (a -> ReadPrec a) -> Maybe a -> ReadPrec a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ReadPrec a
forall a. ReadPrec a
pfail a -> ReadPrec a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> [(Char, a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Char
x [(Char, a)]
xs)