hon/src/Language/Json.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}
module Language.Json (Value(..), null, true, false, boolean, buildInteger, number, document) where
import Data.Text (Text)
import Data.Array.IArray (Array)
import Numeric.Natural (Natural)
import Data.Map.Strict (Map)
import Language.Json.Parser (Parser)
import qualified Language.Json.Parser as Parser

import Prelude hiding (exponent, null)
import Control.Applicative ((<|>), Alternative (many), some)
import qualified Data.Char as Char
import qualified Data.List as List
import Data.Functor (($>))
import Data.Ratio ((%))
import qualified Data.Maybe as Maybe
import qualified Data.Text as Text
import qualified Data.Text.Internal.Read as Text
import qualified Debug.Trace as Debug
import qualified Data.Array.IArray as Array
import qualified Data.Map.Strict as Map


data Value
  = Null
  | String Text
  | Boolean Bool
  | Number Rational
  | Array (Array Natural Value)
  | Object (Map Text Value)
  deriving Show

null :: Parser Value
null = do
  Parser.exact "null"
  pure Null

true :: Parser Bool
true = do
  Parser.exact "true"
  pure True

false :: Parser Bool
false = do
  Parser.exact "false"
  pure False

boolean :: Parser Bool
boolean = true <|> false

digit :: Parser Int
digit = Char.digitToInt <$> Parser.oneOf (Parser.char <$> ['0'..'9'])

onenine :: Parser Int
onenine = Char.digitToInt <$> Parser.oneOf (Parser.char <$> ['1'..'9'])

multiDigitNumber :: Parser Natural
multiDigitNumber = do
  firstDigit <- onenine
  rest <- many digit
  let allDigits = firstDigit : rest
  pure $! buildInteger allDigits

buildInteger :: [Int] -> Natural
buildInteger = List.foldl (\ acc x -> acc * 10 + fromIntegral x) 0

fraction :: Parser (Maybe Natural)
fraction = Parser.optional (buildInteger <$> (Parser.char '.' *> some digit))

data Sign
  = Positive
  | Negative

applySign :: Integral a => Sign -> a -> a
applySign = \case
  Positive -> id
  Negative -> negate

sign :: Parser Sign
sign = Parser.oneOf
  [ Parser.char '+' $> Positive
  , Parser.char '-' $> Negative
  , pure Positive
  ]

exponent :: Parser (Maybe Integer)
exponent = Parser.optional $ do
  _ <- Parser.oneOf (Parser.char <$> ['e', 'E'])
  applySign <$> sign <*> (fromIntegral <$> multiDigitNumber)

number :: Parser Rational
number = do
  factor <- sign
  integerPart <- multiDigitNumber <|> fromIntegral <$> digit
  decimalPart <- fraction
  power <- exponent

  let concatRational = case decimalPart of
        Nothing -> fromIntegral integerPart
        Just part -> let
         decimalPartLength = length . show $ part
         in fromIntegral (integerPart * 10 ^ decimalPartLength + part) % 10 ^ decimalPartLength

  pure $ concatRational * fromIntegral @Integer (applySign factor (10 ^ Maybe.fromMaybe 0 power))

-- >>> import Language.Json.Parser
-- >>> runParser number "1"
-- Just ("",Number (1 % 1))
-- >>> runParser number "1.5"
-- Just ("",Number (3 % 5))
-- >>> runParser number "1.5e1"
-- Just ("",Number (6 % 1))

string :: Parser Text
string = do
  _ <- Parser.exact "\""
  str <- many stringChar
  _ <- Parser.exact "\""

  pure $ Text.pack str

stringChar :: Parser Char
stringChar = Parser.oneOf
  [ Parser.char '\\' *> Parser.oneOf
    [ Parser.char '"'
    , Parser.char '\\'
    , Parser.char '/'
    , Parser.char 'b' $> '\b'
    , Parser.char 'f' $> '\f'
    , Parser.char 'n' $> '\b'
    , Parser.char 'r' $> '\r'
    , Parser.char 't' $> '\t'
    , Parser.char 'u' *> hexChar
    ]
  , Parser.satisfies isAllowedCodepoint
  ]

-- >>> import Language.Json.Parser
-- >>> runParser string "\"\\u000A\""
-- Just ("",String "\n")

buildBase16 :: String -> Int
buildBase16 = List.foldl' (\ acc x -> acc * 16 + Text.hexDigitToInt x) 0

hexChar :: Parser Char
hexChar = do
  digits <- 4 `Parser.times` Parser.satisfies Char.isHexDigit
  let base16 = buildBase16 $ Debug.traceShowId digits
  pure . toEnum $ Debug.traceShowId base16

isAllowedCodepoint :: Char -> Bool
isAllowedCodepoint = \case
  '"' -> False
  '\\' -> False
  x -> not . Char.isControl $ x

-- >>> fromEnum 'A'
-- 65
-- >>> toEnum 10 :: Char
-- '\n'

value :: Parser Value
value = Parser.oneOf
  [ null
  , Array <$> array
  , Object <$> object
  , Number <$> number
  , String <$> string
  , Boolean <$> boolean
  ]

document :: Parser Value
document = whitespace *> value <* whitespace <* Parser.eof

keyvalue :: Parser (Text, Value)
keyvalue = do
  name <- string

  whitespace
  _ <- Parser.char ':'
  whitespace

  val <- value
  pure (name, val)

object :: Parser (Map Text Value)
object = do
  _ <- Parser.char '{'
  whitespace

  members <- (keyvalue <* whitespace) `Parser.sepBy` (Parser.char ',' <* whitespace)

  _ <- Parser.char '}'
  pure $ Map.fromList members

whitespace :: Parser ()
whitespace = many (Parser.satisfies Char.isSpace) $> ()

array :: Parser (Array Natural Value)
array = do
  _ <- Parser.char '['

  whitespace
  elements <- (value <* whitespace) `Parser.sepBy` (Parser.char ',' <* whitespace)

  _ <- Parser.char ']'
  pure $ Array.listArray (0, fromIntegral $ length elements - 1) elements