jsonlogic-0.1.0.0: src/JsonLogic/Json.hs
-- |
-- 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 (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 JsonNull = "null"
show (JsonBool True) = "true"
show (JsonBool False) = "false"
show (JsonNumber d) = show d
show (JsonString s) = show s
show (JsonArray js) = show js
show (JsonObject o) = "{" ++ intercalate "," (map (\(k, v) -> show k ++ ":" ++ show v) $ M.toList o) ++ "}"
-- Using a custom parser to read the Json according to specification.
instance Read Json where
readPrec = parens 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 = prettyShow' 0
where
-- Pretty show with the number of spaces included
prettyShow' :: Int -> Json -> String
prettyShow' nrSpaces (JsonArray js) =
"[\n"
++ commaSeparate (map (\j -> tab nrSpaces ++ prettyShow' (nrSpaces + 2) j) js)
++ closingBracket nrSpaces ']'
prettyShow' nrSpaces (JsonObject o) =
"{\n"
++ commaSeparate (map (\(k, v) -> tab nrSpaces ++ show k ++ ": " ++ prettyShow' (nrSpaces + 2) v) $ M.toList o)
++ closingBracket nrSpaces '}'
prettyShow' _ json = show json
-- Helper functions for clarity
commaSeparate :: [String] -> String
commaSeparate = intercalate ",\n"
closingBracket :: Int -> Char -> String
closingBracket depth c = "\n" ++ replicate depth ' ' ++ [c]
tab :: Int -> String
tab depth = replicate (depth + 2) ' '
-- | 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 JsonNull = ""
stringify (JsonBool True) = "true"
stringify (JsonBool False) = "false"
stringify (JsonNumber d) = show d
stringify (JsonString s) = s
stringify (JsonArray js) = intercalate "," $ map stringify js
stringify (JsonObject _) = "[object Object]"
-- | Truthy test for Json
-- See https://developer.mozilla.org/en-US/docs/Glossary/Truthy for more information.
isTruthy :: Json -> Bool
isTruthy JsonNull = False
isTruthy (JsonBool b) = b
isTruthy (JsonNumber 0.0) = False
isTruthy (JsonNumber _) = True
isTruthy (JsonString "") = False
isTruthy (JsonString _) = True
isTruthy (JsonArray []) = False
isTruthy (JsonArray _) = True
isTruthy (JsonObject _) = True
-- | The opposite of `isTruthy`
isFalsy :: Json -> Bool
isFalsy = not . 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 (JsonNumber n) = n
-- The string "Infinity" is parsed as actual infinity
parseFloat (JsonString "Infinity") = 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 s) = fromMaybe notANumber $ readMaybe $ dropAfterSecondPoint $ takeWhile isValid $ dropWhile isSpace s
where
-- Numbers, decimal point, +/- for sign and e/E for exponent are valid characters.
isValid x
| x `elem` valids = True
| otherwise = False
valids = ['0' .. '9'] ++ ['.', 'e', 'E', '+', '-']
-- Break on the first decimal point, then the second, and glue the first parts together to drop evertyhing after the second point.
dropAfterSecondPoint t = case break (== '.') t of
(l, '.' : r) -> case break (== '.') r of (l', _) -> l ++ "." ++ l'
(l, _) -> l
-- For an array always take the first element.
parseFloat (JsonArray (a : _)) = parseFloat a
-- Everything else is NaN
parseFloat _ = notANumber
-- Gives a Infinity
infinity :: Double
infinity = 1 / 0
-- Gives a NaN
notANumber :: Double
notANumber = 0 / 0
-- Parsing
-- See https://www.json.org/json-en.html
-- Read an object, a map with strings as keys.
readObject :: ReadPrec JsonObject
readObject = do
'{' <- get
items <-
( do
readWhitespace
return []
)
+++ ( do
h <- readKvp
t <- many $ do
',' <- get
readKvp
return $ h : t
)
'}' <- get
return $ M.fromList items
where
readKvp = do
readWhitespace
key <- readString
readWhitespace
':' <- get
value <- readValue
return (key, value)
-- Read an array, can contain multiple comma separated values.
readArray :: ReadPrec [Json]
readArray = do
'[' <- get
items <-
( do
readWhitespace
return []
)
+++ ( do
h <- readValue
t <- many $ do
',' <- get
readValue
return $ h : t
)
']' <- get
return items
-- Read a value, wrapper around many of the other parsers.
readValue :: ReadPrec Json
readValue = do
readWhitespace
value <-
(JsonString <$> readString)
+++ (JsonNumber <$> readNumber)
+++ (JsonObject <$> readObject)
+++ (JsonArray <$> readArray)
+++ ( do
"true" <- many get
return $ JsonBool True
)
+++ ( do
"false" <- many get
return $ JsonBool False
)
+++ ( do
"null" <- many get
return JsonNull
)
readWhitespace
return value
-- Reads a string with escaping.
readString :: ReadPrec String
readString = do
'\"' <- get
xs <-
many $
( do
char <- get
case char of
'\\' -> pfail
'\"' -> pfail
plain -> return plain
)
+++ ( do
'\\' <- get
char <- get
case char of
'\"' -> return '\"'
'\\' -> return '\\'
'/' -> return '/'
'b' -> return '\b'
'f' -> return '\f'
'n' -> return '\n'
'r' -> return '\r'
't' -> return '\t'
'u' -> do
a <- readHex
b <- readHex
c <- readHex
d <- readHex
return $ toEnum $ foldl (\l r -> l * 16 + r) 0 [a, b, c, d]
_ -> pfail
)
'\"' <- get
return xs
where
readHex = readMap $ zip (['0' .. '9'] ++ ['A' .. 'F'] ++ ['a' .. 'f']) ([0 .. 9] ++ [10 .. 15] ++ [10 .. 15])
-- Reads a number, including the sign and exponent as a double.
readNumber :: ReadPrec Double
readNumber = do
-- An optional negative sign
sign <-
return id
+++ ( do
'-' <- get
return negate
)
-- Numbers before the optional decimal.
beforeDecimal <-
( -- Can be just 0
do
'0' <- get
return 0
)
+++ (
-- Or can be non zero, without starting with a 0
do
nonZeroDigit <- getNonZeroDigit
digits <- many getDigit
return $ foldl (\l r -> l * 10 + r) nonZeroDigit digits
)
-- Numbers after the optional decimal
afterDecimal <-
return id
+++ ( do
-- After decimal single or more digits
'.' <- get
digits <- some getDigit
-- Added 0 to the front of the digits to make it below 1
return $ (+) $ foldr1 (\l r -> l + r / 10) (0 : digits)
)
-- Or zero if no decimal
-- The number exponent
expo <-
-- Can be 1 if no exponent.
return id +++ do
-- Otherwise may start with e or E
( do
'e' <- get
return ()
)
+++ ( do
'E' <- get
return ()
)
-- Then may have a sign, defaulting to positive
expBase <-
return (*)
+++ ( do
'-' <- get
return $ flip (/)
)
+++ ( do
'+' <- get
return (*)
)
-- Then some digits determining the size.
expDigits <-
( do
digits <- some getDigit
return $ foldl1 (\l r -> l * 10 + r) digits
)
return $ expBase $ 10 ** expDigits
-- Then combine everything.
return $ sign $ expo $ afterDecimal beforeDecimal
where
getDigit = readMap $ zip ['0' .. '9'] [0 .. 9]
getNonZeroDigit = readMap $ zip ['1' .. '9'] [1 .. 9]
-- Reads whitespace and throws it away.
readWhitespace :: ReadPrec ()
readWhitespace = () <$ many (readMap $ zip " \t\n\r" (repeat ()))
-- Use a lookup table to parse characters.
readMap :: [(Char, a)] -> ReadPrec a
readMap xs = do
x <- get
maybe pfail return (lookup x xs)