-- |

-- Module      : JsonLogic.Json

-- Description : JsonLogic Json object with utility functions and read/show instances

-- Copyright   : (c) Marien Matser, Gerard van Schie, Jelle Teeuwissen, 2022

-- License     : MIT

-- Maintainer  : jelleteeuwissen@hotmail.nl

-- Stability   : experimental

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,
    (+++),
  )

-- | Json is a collection of possible Json values.

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)

-- | A Json object is a map of string-Json pairs.

type JsonObject = M.Map String Json

-- | A rule can be any kind of Json value, but objects and arrays will be evaluated.

type Rule = Json

-- | Data can be any kind of Json value.

type Data = Json

-- An instance to show Json in clear format for users.

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
"}"

-- Using a custom parser to read the Json according to specification.

instance Read Json where
  readPrec :: ReadPrec Json
readPrec = ReadPrec Json -> ReadPrec Json
forall a. ReadPrec a -> ReadPrec a
parens ReadPrec Json
readValue

-- | A pretty formatted show for the Json, with identation and depth

-- Use putStr so the newline characters will be interpreted in console

--

-- >>> putStr $ prettyShow JsonNull

-- null

--

-- >>> putStr $ prettyShow $ JsonNumber 3.0

-- 3.0

--

-- >>> prettyShow (JsonArray [JsonNumber 1, JsonNumber 2])

-- "[\n  1.0,\n  2.0\n]"

--

-- >>> putStr $ prettyShow (JsonArray [JsonNumber 1, JsonBool True])

-- [

--   1.0,

--   true

-- ]

prettyShow :: Json -> String
prettyShow :: Json -> String
prettyShow = Int -> Json -> String
prettyShow' Int
0
  where
    -- Pretty show with the number of spaces included

    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
    -- Helper functions for clarity

    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
' '

-- | Convert Json to string, used in string operations

-- See https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Object/toString for more information.

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]"

-- | Truthy test for Json

-- See https://developer.mozilla.org/en-US/docs/Glossary/Truthy for more information.

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

-- | The opposite of `isTruthy`

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

-- | Convert Json to a numeric value, including NaN

-- Same as the Parsefloat function in JS

-- Parsefloat source: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/parseFloat

-- NaN source: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/NaN

parseFloat :: Json -> Double
-- Numbers stay just numbers

parseFloat :: Json -> Double
parseFloat (JsonNumber Double
n) = Double
n
-- The string "Infinity" is parsed as actual infinity

parseFloat (JsonString String
"Infinity") = Double
infinity
-- First drop all whitespace, then take all "valid" characters. Drop everything after the second point and then try to parse it to a double.

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
    -- Numbers, decimal point, +/- for sign and e/E for exponent are valid characters.

    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
'-']
    -- Break on the first decimal point, then the second, and glue the first parts together to drop evertyhing after the second point.

    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
-- For an array always take the first element.

parseFloat (JsonArray (Json
a : [Json]
_)) = Json -> Double
parseFloat Json
a
-- Everything else is NaN

parseFloat Json
_ = Double
notANumber

-- Gives a Infinity

infinity :: Double
infinity :: Double
infinity = Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0

-- Gives a NaN

notANumber :: Double
notANumber :: Double
notANumber = Double
0 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0

-- Parsing

-- See https://www.json.org/json-en.html


-- Read an object, a map with strings as keys.

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)

-- Read an array, can contain multiple comma separated values.

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

-- Read a value, wrapper around many of the other parsers.

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

-- Reads a string with escaping.

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])

-- Reads a number, including the sign and exponent as a double.

readNumber :: ReadPrec Double
readNumber :: ReadPrec Double
readNumber = do
  -- An optional negative sign

  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
          )
  -- Numbers before the optional decimal.

  Double
beforeDecimal <-
    ( -- Can be just 0

      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
+++ (
            -- Or can be non zero, without starting with a 0

            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
          )
  -- Numbers after the optional decimal

  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
              -- After decimal single or more digits

              Char
'.' <- ReadPrec Char
get
              [Double]
digits <- ReadPrec Double -> ReadPrec [Double]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ReadPrec Double
getDigit
              -- Added 0 to the front of the digits to make it below 1

              (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)
          )
  -- Or zero if no decimal

  -- The number exponent

  Double -> Double
expo <-
    -- Can be 1 if no exponent.

    (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
      -- Otherwise may start with e or E

      ( 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 ()
            )
      -- Then may have a sign, defaulting to positive

      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
(*)
              )
      -- Then some digits determining the size.

      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
  -- Then combine everything.

  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]

-- Reads whitespace and throws it away.

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 ()))

-- Use a lookup table to parse characters.

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)