Parser combinators, JSON Parser

src/Language/Json.hs

@@ -0,0 +1,210 @@
+{-# 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
+