diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for jordan + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2021 Anthony Super + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/jordan.cabal b/jordan.cabal new file mode 100644 --- /dev/null +++ b/jordan.cabal @@ -0,0 +1,88 @@ +cabal-version: 2.4 +name: jordan +version: 0.1.0.0 +synopsis: JSON with Structure + +-- A longer description of the package. +description: + Jordan provides an abstract interface for converting to or from JSON. + This interface can be used to construct various parsers and serilaizers. + Because everything is kept abstract and inspectable, documentation can be + automatically generated as well. + . + Jordan's built-in parsers and serializers include variants that do not construct + intermediate datatypes, which can avoid some collision-based denial of service + attacks that have effected other libraries. They should also be more efficient + due to the need to avoid early conversion of types, although I have not measured + this. + . + Jordan is somewhat experimental but well-tested. + +homepage: + +-- A URL where users can report bugs. +-- bug-reports: +license: MIT +license-file: LICENSE +author: Anthony Super +maintainer: anthony@noided.media + +-- A copyright notice. +-- copyright: +category: Codec +extra-source-files: CHANGELOG.md + +common build-deps + build-depends: + attoparsec >= 0.14.1 && <0.15 + , bytestring >= 0.10.8.1 && <0.12 + , containers >= 0.6.2 && <0.7 + , scientific >= 0.3.7 && <0.4 + , text >= 1.2.3.0 && <1.3 + , megaparsec >= 9.1.0 && <9.2 + , contravariant >= 1.5.5 && <1.6 + , parser-combinators >= 1.3.0 && < 1.4 + +library + import: build-deps + exposed-modules: + Jordan.FromJSON.Class + , Jordan.FromJSON.Megaparsec + , Jordan.FromJSON.Attoparsec + , Jordan.FromJSON.ParseInternal + , Jordan.ToJSON.Class + , Jordan.ToJSON.Text + , Jordan.ToJSON.Builder + , Jordan.Generic.Options + , Jordan + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base ^>=4.14.1.0 + hs-source-dirs: lib + default-language: Haskell2010 + +test-suite jordan-test + import: build-deps + build-depends: + hspec + , hspec-megaparsec + , jordan + , raw-strings-qq + , QuickCheck + , quickcheck-text + other-modules: + Jordan.FromJSON.MegaparsecSpec + , Jordan.FromJSON.AttoparsecSpec + , Jordan.SpecDefs + , Jordan.ToJSON.TextSpec + , Jordan.ToJSON.BuilderSpec + , Jordan.RoundTripSpec + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: JordanSpec.hs + build-depends: base ^>=4.14.1.0 diff --git a/lib/Jordan.hs b/lib/Jordan.hs new file mode 100644 --- /dev/null +++ b/lib/Jordan.hs @@ -0,0 +1,40 @@ +-- | Base module! +-- +-- Has all functionality for parsing and serializing JSON. +module Jordan + ( -- * JSON Parsing + -- ** Concretely + parseViaMegaparsec + , parseViaAttoparsec + , runParserViaAttoparsec + , runParserViaMegaparsec + , attoparsecParser + , megaparsecParser + -- ** Abstractly + , FromJSON (..) + , JSONParser (..) + , JSONObjectParser (..) + , JSONTupleParser (..) + -- *** Generically + , gFromJSON + , FromJSONOptions (..) + -- * JSON Serialization + -- ** Concretely + , toJSONAsBuilder + , toJSONViaBuilder + , toJSONText + -- ** Abstractly + , ToJSON (..) + , JSONSerializer (..) + , JSONObjectSerializer (..) + -- *** Generically + , gToJSON + , ToJSONOptions (..) + ) where + +import Jordan.FromJSON.Attoparsec +import Jordan.FromJSON.Class +import Jordan.FromJSON.Megaparsec +import Jordan.ToJSON.Builder (toJSONAsBuilder, toJSONViaBuilder) +import Jordan.ToJSON.Class +import Jordan.ToJSON.Text (toJSONText) diff --git a/lib/Jordan/FromJSON/Attoparsec.hs b/lib/Jordan/FromJSON/Attoparsec.hs new file mode 100644 --- /dev/null +++ b/lib/Jordan/FromJSON/Attoparsec.hs @@ -0,0 +1,307 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +-- | Implementation of FromJSON parsers via Attoparsec. +-- +-- This module does not construct intermediate data structures like maps or key-value lists, +-- and instead uses permutation parsers in order to parse your data structure directly. +module Jordan.FromJSON.Attoparsec + ( convertParserToAttoparsecParser + , runParserViaAttoparsec + , parseViaAttoparsec + , attoparsecParser + ) where + +import Control.Applicative (Alternative(..)) +import Data.Attoparsec.ByteString (()) +import qualified Data.Attoparsec.ByteString as AP +import qualified Data.Attoparsec.ByteString.Char8 as CH +import Data.ByteString (ByteString) +import Data.Char (chr, digitToInt, isControl, isHexDigit, ord) +import Data.Functor (void, ($>)) +import Data.Monoid (Alt(..)) +import Data.Scientific (Scientific) +import qualified Data.Text as Text +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Jordan.FromJSON.Class +import Jordan.FromJSON.ParseInternal +import Numeric (showHex) +import qualified Text.Megaparsec as Text + +newtype ObjectParser a + = ObjectParser + { runObjectParser :: Permutation AP.Parser a } + deriving (Functor, Applicative) + +newtype ArrayParser a + = ArrayParser + { runArrayParser :: AP.Parser a } + deriving (Functor) + +instance Applicative ArrayParser where + pure = ArrayParser . pure + f <*> a = ArrayParser $ do + f' <- runArrayParser f + comma + a' <- runArrayParser a + pure $ f' a' + +skipSpace :: AP.Parser () +skipSpace = AP.skipWhile isSpace + where + isSpace = \case + 32 -> True + 10 -> True + 13 -> True + 9 -> True + _ -> False + +lexeme :: AP.Parser a -> AP.Parser a +lexeme a = a <* skipSpace + +label :: String -> AP.Parser a -> AP.Parser a +label l p = p l + +parseAnyField :: AP.Parser () +parseAnyField = label "junk field" $ void $ do + lexeme parseJSONText + labelSep + lexeme anyDatum + +junkFieldAtEnd :: AP.Parser () +junkFieldAtEnd = void $ do + comma + parseAnyField `AP.sepBy` comma + +comma :: AP.Parser () +comma = label "comma character" $ void $ lexeme (AP.string ",") + +quotation :: AP.Parser () +quotation = label "quotation mark" $ void $ AP.word8 34 + +parseJSONText :: AP.Parser Text.Text +parseJSONText = label "JSON text" $ do + quotation + innerText + +innerText :: AP.Parser Text.Text +innerText = do + chunk <- AP.takeWhile $ \char -> char /= 92 && char /= 34 + l <- AP.peekWord8 + case l of + Nothing -> fail "string without end" + Just 34 -> do + AP.anyWord8 + pure $ decodeUtf8 chunk + Just 92 -> do + AP.anyWord8 + r <- label "escape value" parseEscape + rest <- innerText + pure $ decodeUtf8 chunk <> r <> rest + Just _ -> fail "IMPOSSIBLE" + +parseEscape :: AP.Parser Text.Text +parseEscape + = quote + <|> backslash + <|> solidus + <|> backspace + <|> formfeed + <|> linefeed + <|> carriage + <|> tab + <|> escaped + where + backslash = AP.string "\\" $> "\\" + quote = AP.string "\"" $> "\"" + solidus = AP.string "/" $> "/" + backspace = AP.string "b" $> "\b" + formfeed = AP.string "f" $> "\f" + linefeed = AP.string "n" $> "\n" + carriage = AP.string "r" $> "\r" + tab = AP.string "t" $> "\t" + escaped = do + AP.string "u" + a <- parseHexDigit + b <- parseHexDigit + c <- parseHexDigit + d <- parseHexDigit + let s = (((a * 16) + b) * 16 + c) * 16 + d + pure $ Text.pack [chr s] + +parseHexDigit :: AP.Parser Int +parseHexDigit = label "hex digit" (digitToInt <$> CH.satisfy isHexDigit) + +parseCharInText :: Char -> AP.Parser () +parseCharInText a = parseLit a <|> escaped a + where + parseLit :: Char -> AP.Parser () + parseLit = \case + '\\' -> void $ AP.string "\\\\" + '"' -> void $ AP.string "\\\"" + '/' -> void $ AP.string "/" <|> AP.string "\\/" + '\b' -> void $ AP.string "\\b" + '\f' -> void $ AP.string "\\f" + '\n' -> void $ AP.string "\\n" + '\r' -> void $ AP.string "\\r" + '\t' -> void $ AP.string "\\t" + a -> if isControl a then empty else void $ AP.string $ encodeUtf8 $ Text.singleton a + escaped :: Char -> AP.Parser () + escaped a = void $ AP.string $ encodeUtf8 $ Text.pack $ withEscaped $ (showHex $ ord a) [] + withEscaped :: String -> String + withEscaped a@[_] = "\\u000" <> a + withEscaped a@[_,_] = "\\u00" <> a + withEscaped a@[_,_,_] = "\\u0" <> a + withEscaped r = "\\u" <> r + +objectKey :: Text.Text -> AP.Parser () +objectKey k = lexeme $ do + quotation + Text.foldr (\c a -> parseCharInText c *> a) (pure ()) k + quotation + pure () + +startObject :: AP.Parser () +startObject + = label "object starting brace ('{')" + $ lexeme + $ void + $ AP.word8 123 + +endObject :: AP.Parser () +endObject + = label "object ending brace ('}')" + $ lexeme + $ void + $ AP.word8 125 + +inObjectBraces :: AP.Parser a -> AP.Parser a +inObjectBraces interior = startObject *> interior <* endObject + +startArray :: AP.Parser () +startArray + = label "array starting brace ('[')" + $ lexeme + $ void + $ AP.word8 91 + +endArray :: AP.Parser () +endArray + = label "array ending brace (']')" + $ lexeme + $ void + $ AP.word8 93 + +labelSep :: AP.Parser () +labelSep = label "key-value separator (':')" $ void $ lexeme $ AP.string ":" + +anyDatum :: AP.Parser () +anyDatum = lexeme inner + where + inner + = runAttoparsecParser parseNull + <|> void (runAttoparsecParser parseBool) + <|> void (runAttoparsecParser parseText) + <|> void (runAttoparsecParser parseNumber) + <|> void (runAttoparsecParser parseBool) + <|> anyObject + <|> anyArray + +anyArray :: AP.Parser () +anyArray = label "ignored array" $ void $ do + startArray + anyDatum `AP.sepBy` comma + endArray + +number :: AP.Parser Scientific +number = CH.scientific + +anyObject :: AP.Parser () +anyObject = label "ignored object" $ void $ do + startObject + flip AP.sepBy comma $ do + parseJSONText + labelSep + anyDatum + endObject + +parseObjectField + :: Text.Text + -> AP.Parser a + -> AP.Parser a +parseObjectField t f = do + objectKey t + labelSep + lexeme f + +parseDictField + :: AP.Parser a + -> AP.Parser (Text.Text, a) +parseDictField p = do + key <- parseJSONText + labelSep + val <- p + pure (key, val) + +instance JSONObjectParser ObjectParser where + parseFieldWith label + = ObjectParser + . asPermutation + . parseObjectField label + . runAttoparsecParser + +newtype AttoparsecParser a + = AttoparsecParser + { runAttoparsecParser :: AP.Parser a } + deriving (Functor) + deriving (Semigroup, Monoid) via (Alt AP.Parser a) + +instance JSONTupleParser ArrayParser where + consumeItemWith = ArrayParser . runAttoparsecParser + +instance JSONParser AttoparsecParser where + parseObject _ p = AttoparsecParser $ inObjectBraces $ do + r <- wrapEffect parseAnyField comma $ runObjectParser p + label "junk object fields at the end of a parsed object" $ many junkFieldAtEnd + pure r + parseDictionary parse = AttoparsecParser $ inObjectBraces $ do + parseDictField (runAttoparsecParser parse) `AP.sepBy` comma + parseTextConstant c = AttoparsecParser (objectKey c "text constant" <> Text.unpack c) + parseText = AttoparsecParser parseJSONText + parseNumber = AttoparsecParser number + validateJSON v = AttoparsecParser $ do + r <- runAttoparsecParser v + case r of + Left err -> fail (Text.unpack err) + Right e -> pure e + parseTuple ap = AttoparsecParser $ do + lexeme $ AP.word8 91 + r <- runArrayParser ap + lexeme $ AP.word8 93 + pure r + parseArrayWith jp = AttoparsecParser $ do + startArray + r <- lexeme (runAttoparsecParser jp) `AP.sepBy` comma "array items" + endArray + pure r + parseBool = AttoparsecParser $ lexeme $ + (AP.string "true" $> True) <|> (AP.string "false" $> False) + parseNull = AttoparsecParser $ lexeme (AP.string "null" $> ()) + +-- | Convert an abstract JSON parser to an Attoparsec Parser. +-- This function will skip leading whitespace. +convertParserToAttoparsecParser :: (forall parser. JSONParser parser => parser a) -> AP.Parser a +convertParserToAttoparsecParser = (skipSpace *>) . runAttoparsecParser + +runParserViaAttoparsec :: (forall parser. JSONParser parser => parser a) -> ByteString -> Either String a +runParserViaAttoparsec p = AP.parseOnly (convertParserToAttoparsecParser p) + +-- | Parse a ByteString via an Attoparsec Parser. +parseViaAttoparsec :: (FromJSON val) => ByteString -> Either String val +parseViaAttoparsec = AP.parseOnly (skipSpace *> runAttoparsecParser fromJSON) + +-- | Get an Attoparsec parser for a particular JSON-parsable value. +attoparsecParser :: (FromJSON val) => AP.Parser val +attoparsecParser = runAttoparsecParser fromJSON diff --git a/lib/Jordan/FromJSON/Class.hs b/lib/Jordan/FromJSON/Class.hs new file mode 100644 --- /dev/null +++ b/lib/Jordan/FromJSON/Class.hs @@ -0,0 +1,322 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +-- | Parse JSON using finally-tagless style. +-- +-- This provides JSON parsing as an abstract interface. +-- This interface provides a way to parse JSON that is *inspectable* +-- and has some nice properties: for example, we can use it to build a parser that +-- directly parses your data structure, without building some intermediate value type! +module Jordan.FromJSON.Class + where + +import Control.Applicative (Alternative(..)) +import Data.Functor (($>)) +import qualified Data.Map.Strict as Map +import qualified Data.Monoid as Monoid +import Data.Proxy (Proxy(..)) +import qualified Data.Ratio as Ratio +import Data.Scientific (Scientific) +import qualified Data.Semigroup as Semigroup +import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Typeable +import GHC.Generics +import Jordan.Generic.Options + +-- | A class for parsing JSON objects. +class (Applicative f) => JSONObjectParser f where + -- | Parse an object field with a given label, using a parser. + -- + -- Note: in order to enable the generation of better documentation, use 'parseField' instead if at all possible! + parseFieldWith + :: T.Text + -- ^ Label of the field. + -- Will be parsed into escaped text, if need be. + -> (forall valueParser. JSONParser valueParser => valueParser a) + -- ^ How to parse the field. + -- Note the forall in this type signature: you cannot have this be specific to + -- any particular implementation of parsing, to keep the parsing of a JSON abstract. + -> f a + parseField + :: (FromJSON v) + => T.Text + -> f v + parseField t = parseFieldWith t fromJSON + +-- | A class for parsing JSON arrays. +class (Applicative f) => JSONTupleParser f where + -- | Use a JSON parser to consume a single item of an array, then move onto the next one. + -- + -- Note: you should prefer 'consumeItem' as it enables better documentation generation. + consumeItemWith + :: (forall valueParser. JSONParser valueParser => valueParser a) + -> f a + -- | Consume a single array item. + consumeItem + :: (FromJSON v) + => f v + consumeItem = consumeItemWith fromJSON + +-- | Abstract class representing various parsers. +-- +-- All parsers must have a Monoid instance that represents choice with failure as the identity. +class (Functor f, forall a. Monoid (f a)) => JSONParser f where + parseObject + :: T.Text + -- ^ A label for the object. + -- This label should, as much as possible, be "globally unique" in some way. + -- This will enable better generation of documentation. + -> (forall objectParser. JSONObjectParser objectParser => objectParser a) + -- ^ Instructions on how to parse the object. + -- Note that the actual implementation is kept abstract: you can only use methods found in JSONObjectParser, or + -- combinators of those methods. + -- This ensures that we can generate the proper parser in all cases. + -> f a + -- | Parse an object where you are okay if we parse strictly, IE, do not allow extra fields. + -- This sometimes enables us to generate parsers that run faster. + parseObjectStrict + :: T.Text + -> (forall objectParser. JSONObjectParser objectParser => objectParser a) + -> f a + parseObjectStrict = parseObject + -- | Parse a dictionary of key-value pairs. + parseDictionary + :: (forall jsonParser. JSONParser jsonParser => jsonParser a) + -> f [(T.Text, a)] + + -- | Parse a text field. + parseText + :: f T.Text + parseTextConstant + :: T.Text + -> f () + parseTextConstant t = validateJSON (validated <$> parseText) + where + validated q + | q == t = Right () + | otherwise = Left $ T.pack "Expected :" <> q + -- | Use a tuple parser to parse an array. + parseTuple + :: (forall arrayParser. JSONTupleParser arrayParser => arrayParser o) + -> f o + parseArray + :: (FromJSON a) + => f [a] + parseArray = parseArrayWith fromJSON + parseArrayWith + :: (forall jsonParser. JSONParser jsonParser => jsonParser a) + -> f [a] + parseNumber + :: f Scientific + parseNull + :: f () + parseBool + :: f Bool + validateJSON + :: f (Either T.Text a) + -> f a + +-- | A class to provide the canonical way to parse a JSON. +-- This class uses finally tagless tyle to keep the instructions for parsing abstract. +-- This allows us to automatically generate documentation, and to generate parsers that do not use intermediate structures. +-- +-- This class is derivable generically, and will generate a \"nice\" format. +-- In my opinion, at least. +class FromJSON value where + fromJSON :: (JSONParser f) => f value + default fromJSON :: (Generic value, GFromJSON (Rep value)) => (JSONParser f => f value) + fromJSON = to <$> gFromJSON @(Rep value) defaultOptions + +instance FromJSON () where + fromJSON = parseNull + +instance {-# OVERLAPPABLE #-} (FromJSON a) => FromJSON [a] where + fromJSON = parseArray + +instance {-# OVERLAPPING #-} FromJSON String where + fromJSON = T.unpack <$> parseText + +instance (FromJSON a) => FromJSON (Maybe a) where + fromJSON = (Nothing <$ parseNull) <> (Just <$> fromJSON) + +-- | Right-biased: will try to parse a 'Right' value first. +instance (FromJSON l, FromJSON r) => FromJSON (Either l r) where + fromJSON = (Right <$> fromJSON) <> (Left <$> fromJSON) + +instance (FromJSON Bool) where + fromJSON = parseBool + +instance FromJSON T.Text where + fromJSON = parseText + +instance FromJSON Int where + fromJSON = fmap round parseNumber + +instance FromJSON Float where + fromJSON = realToFrac <$> parseNumber + +instance FromJSON Double where + fromJSON = realToFrac <$> parseNumber + +instance FromJSON Integer where + fromJSON = fmap round parseNumber + +instance FromJSON Scientific where + fromJSON = parseNumber + +instance forall a. (Integral a, FromJSON a, Typeable a) => FromJSON (Ratio.Ratio a) where + fromJSON = parseObject objName $ + (Ratio.%) <$> parseField "num" <*> parseField "denom" + where + objName = T.pack $ tyName <> ".Ratio" + tyName = (tyConModule <> const "." <> tyConName) $ typeRepTyCon $ typeRep (Proxy :: Proxy a) + +instance FromJSON a => FromJSON (Monoid.Dual a) where + fromJSON = Monoid.Dual <$> fromJSON + +instance FromJSON Monoid.All where + fromJSON = Monoid.All <$> parseBool + +instance FromJSON Monoid.Any where + fromJSON = Monoid.Any <$> parseBool + +instance FromJSON a => FromJSON (Monoid.Sum a) where + fromJSON = Monoid.Sum <$> fromJSON + +instance FromJSON a => FromJSON (Monoid.Product a) where + fromJSON = Monoid.Product <$> fromJSON + +instance FromJSON a => FromJSON (Monoid.First a) where + fromJSON = Monoid.First <$> ((parseNull $> Nothing) <> (Just <$> fromJSON)) + +instance FromJSON a => FromJSON (Monoid.Last a) where + fromJSON = Monoid.Last <$> ((parseNull $> Nothing) <> (Just <$> fromJSON)) + +instance FromJSON (f a) => FromJSON (Monoid.Alt f a) where + fromJSON = Monoid.Alt <$> fromJSON + +instance FromJSON (f a) => FromJSON (Monoid.Ap f a) where + fromJSON = Monoid.Ap <$> fromJSON + +instance FromJSON a => FromJSON (Semigroup.Min a) where + fromJSON = Semigroup.Min <$> fromJSON + +instance FromJSON a => FromJSON (Semigroup.Max a) where + fromJSON = Semigroup.Max <$> fromJSON + +instance FromJSON a => FromJSON (Semigroup.First a) where + fromJSON = Semigroup.First <$> fromJSON + +instance FromJSON a => FromJSON (Semigroup.Last a) where + fromJSON = Semigroup.Last <$> fromJSON + +-- containers package +instance (FromJSON a, Ord a) => FromJSON (Set.Set a) where + fromJSON = Set.fromList <$> fromJSON + +instance FromJSON a => FromJSON (Map.Map T.Text a) where + fromJSON = foldMap (uncurry Map.singleton) <$> parseDictionary fromJSON + +data FromJSONOptions + = FromJSONOptions + { fromJSONEncodeSums :: SumTypeEncoding + , fromJSONBaseName :: String + , convertEnum :: String -> String + } + deriving (Generic) + +defaultOptions :: FromJSONOptions +defaultOptions = FromJSONOptions TagInField "" id + +addName :: String -> FromJSONOptions -> FromJSONOptions +addName s d = d { fromJSONBaseName = fromJSONBaseName d <> s } + +class GFromJSON v where + gFromJSON :: (JSONParser f) => FromJSONOptions -> f (v a) + +instance (FromJSON c) => GFromJSON (K1 i c) where + gFromJSON _ = K1 <$> fromJSON + +instance (GFromJSON f, Datatype t) => GFromJSON (D1 t f) where + gFromJSON opts = M1 <$> gFromJSON (addName name opts) + where + name = moduleName s <> "." <> datatypeName s + s :: D1 t f a + s = undefined + +instance {-# OVERLAPPABLE #-} forall c i. (GFromJSONObject i, Constructor c) => GFromJSON (C1 c i) where + gFromJSON opts = M1 <$> parseObject (T.pack name) (gFromJSONObject opts) + where + name = fromJSONBaseName opts <> "." <> conName n + n :: C1 c i a + n = undefined + +instance {-# OVERLAPS #-} (FromJSON s) => GFromJSON (C1 c (S1 (MetaSel 'Nothing su ss ds) (Rec0 s))) where + gFromJSON _ = M1 . M1 . K1 <$> fromJSON + +instance GFromJSON U1 where + gFromJSON opts = U1 <$ parseNull + +instance {-# OVERLAPS #-} (Constructor t) => GFromJSON (C1 t U1) where + gFromJSON opts = M1 U1 <$ parseTextConstant conn + where + conn = T.pack $ conName c + c :: C1 t U1 f + c = undefined + +instance {-# OVERLAPS #-} (Constructor t) => GFromJSON (PartOfSum (C1 t U1)) where + gFromJSON opts = PartOfSum (M1 U1) <$ parseTextConstant enumValue + where + enumValue = T.pack $ convertEnum opts $ conName (undefined :: C1 t U1 f) + +instance {-# OVERLAPPING #-} (GFromJSON (C1 t f), Constructor t) => GFromJSON (PartOfSum (C1 t f)) where + gFromJSON opts = PartOfSum <$> encoded + where + encoded = case fromJSONEncodeSums opts of + TagVal -> tagged + TagInField -> field + tagged = parseObject (objName name) $ + parseFieldWith "tag" (parseTextConstant name) + *> parseFieldWith "val" (gFromJSON opts) + field = parseObject (objName name) $ + parseFieldWith name (gFromJSON opts) + name = T.pack $ conName (undefined :: C1 t f a) + objName a = T.pack (fromJSONBaseName opts <> ".") <> a <> ".Input" + +instance {-# OVERLAPS #-} (GFromJSON (PartOfSum l), GFromJSON (PartOfSum r)) => GFromJSON (l :+: r) where + gFromJSON opts = + (L1 . getPartOfSum <$> gFromJSON opts) <> (R1 . getPartOfSum <$> gFromJSON opts) + +instance (GFromJSON (PartOfSum l), GFromJSON (PartOfSum r)) => GFromJSON (PartOfSum (l :+: r)) where + gFromJSON opts = PartOfSum <$> gFromJSON opts + +instance {-# OVERLAPPING #-} (Constructor t, Constructor t') => + GFromJSON (C1 t U1 :+: C1 t' U1) where + gFromJSON ops = (L1 <$> gFromJSON ops) <> (R1 <$> gFromJSON ops) + +class GFromJSONObject v where + gFromJSONObject :: (JSONObjectParser f) => FromJSONOptions -> f (v a) + +instance GFromJSONObject U1 where + gFromJSONObject _ = pure U1 + +instance (FromJSON c, Selector t) => GFromJSONObject (S1 t (K1 v c)) where + gFromJSONObject o + = M1 . K1 <$> parseField (T.pack $ selName v) + where + v :: M1 S t f a + v = undefined + +instance (GFromJSONObject lhs, GFromJSONObject rhs) => GFromJSONObject (lhs :*: rhs) where + gFromJSONObject o = (:*:) <$> gFromJSONObject o <*> gFromJSONObject o diff --git a/lib/Jordan/FromJSON/Megaparsec.hs b/lib/Jordan/FromJSON/Megaparsec.hs new file mode 100644 --- /dev/null +++ b/lib/Jordan/FromJSON/Megaparsec.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Jordan.FromJSON.Megaparsec + where + +import Control.Applicative +import Control.Applicative.Combinators (sepBy) +import qualified Data.ByteString as ByteString +import Data.Char (chr, digitToInt, isControl, isHexDigit, ord) +import Data.Foldable (asum, traverse_) +import Data.Functor (void, ($>)) +import Data.List (intercalate) +import Data.Monoid (Alt(..)) +import Data.Scientific (Scientific(..)) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Encoding +import Data.Void (Void) +import Data.Word (Word8) +import Debug.Trace (trace, traceM) +import Jordan.FromJSON.Class +import Jordan.FromJSON.ParseInternal +import Numeric (showHex) +import Text.Megaparsec (()) +import qualified Text.Megaparsec as T +import qualified Text.Megaparsec.Char as Char +import qualified Text.Megaparsec.Char.Lexer as Lexer + +type Parser = T.Parsec ErrorContext Text.Text +type ParseError = T.ParseErrorBundle Text.Text ErrorContext + +newtype ErrorContext + = ErrorContext { getErrorContext :: [Text.Text] } + deriving (Show, Eq, Ord) + +instance T.ShowErrorComponent ErrorContext where + showErrorComponent + = intercalate ", " + . fmap (("in " ++) . Text.unpack) + . getErrorContext + +newtype ObjectParser a = ObjectParser { getObjectParser :: Permutation Parser a } + deriving newtype (Functor, Applicative) + +newtype ArrayParser a + = ArrayParser { getArrayParser :: Parser a } + deriving (Functor) + +instance Applicative ArrayParser where + pure = ArrayParser . pure + (ArrayParser f) <*> (ArrayParser a) = ArrayParser $ + (f <* comma) <*> a + +lexeme :: Parser a -> Parser a +lexeme = Lexer.lexeme $ Lexer.space Char.space1 empty empty + +takeSpace :: Parser () +takeSpace = void $ many Char.space1 + +parseAnyField :: Parser () +parseAnyField = T.label "an extraneous object field we do not care about" $ do + T.label "ignored object key" parseJSONText + lexeme $ Char.char ':' + lexeme consumeJunkValue + +objectKey :: Text.Text -> Parser () +objectKey k = T.label ("object key '" <> Text.unpack k <> "'") $ lexeme $ do + Char.char '"' + T.label "object label" $ + Text.foldr (\c a -> parseCharInText c *> a) (pure ()) k + Char.char '"' + pure () + +parseCharInText :: Char -> Parser () +parseCharInText a = parseLit a <|> escaped a + where + parseLit :: Char -> Parser () + parseLit = \case + '\\' -> void $ T.chunk "\\\\" + '"' -> void $ T.chunk "\\\"" + '/' -> void $ T.chunk "/" <|> T.chunk "\\/" + '\b' -> void $ T.chunk "\\b" + '\f' -> void $ T.chunk "\\f" + '\n' -> void $ T.chunk "\\n" + '\r' -> void $ T.chunk "\\r" + '\t' -> void $ T.chunk "\\t" + a -> if isControl a then empty else void $ T.single a + escaped :: Char -> Parser () + escaped a = void $ T.chunk $ Text.pack $ withEscaped $ (showHex $ ord a) [] + withEscaped :: String -> String + withEscaped a@[_] = "\\u000" <> a + withEscaped a@[_,_] = "\\u00" <> a + withEscaped a@[_,_,_] = "\\u0" <> a + withEscaped r = "\\u" <> r + +parseDictField + :: Parser a + -> Parser (Text.Text, a) +parseDictField valParser = do + key <- parseJSONText + labelSep + val <- valParser + pure (key, val) + +parseObjectField + :: Text.Text + -> Parser a + -> Parser a +parseObjectField t f = do + T.try $ objectKey t + labelSep + lexeme f + +parseJSONText :: Parser Text.Text +parseJSONText = lexeme $ do + T.try $ Char.char '"' + innerText + +innerText :: Parser Text.Text +innerText = do + chunk <- T.takeWhileP Nothing $ \char -> char /= '\\' && char /= '"' + l <- T.lookAhead $ T.option Nothing (Just <$> T.anySingle) + case l of + Nothing -> fail "string without end" + Just '"' -> do + T.label "quotation mark" T.anySingle + pure chunk + Just '\\' -> do + T.anySingle + r <- parseEscape + rest <- innerText + pure $ chunk <> r <> rest + Just _ -> fail "IMPOSSIBLE" + +parseEscape :: Parser Text.Text +parseEscape + = quote + <|> backslash + <|> solidus + <|> backspace + <|> formfeed + <|> linefeed + <|> carriage + <|> tab + <|> escapedUnicode + where + backslash = T.chunk "\\" + quote = T.chunk "\"" + solidus = T.chunk "/" $> "/" + backspace = T.chunk "b" $> "\b" + formfeed = T.chunk "f" $> "\f" + linefeed = T.chunk "n" $> "\n" + carriage = T.chunk "r" $> "\r" + tab = T.chunk "t" $> "\t" + escapedUnicode = T.label "unicode escape code" $ do + Char.char 'u' + a <- parseHexDigit + b <- parseHexDigit + c <- parseHexDigit + d <- parseHexDigit + let s = (((a * 16) + b) * 16 + c) * 16 + d + pure $ Text.pack [chr s] + +parseHexDigit :: Parser Int +parseHexDigit = digitToInt <$> T.satisfy isHexDigit + +comma :: Parser () +comma = void $ lexeme $ Char.char ',' + +labelSep :: Parser () +labelSep = void $ lexeme $ Char.char ':' + +parseAnyObject :: Parser () +parseAnyObject = T.label "Ignored object" $ do + T.try $ lexeme $ Char.char '{' + parseAnyField `sepBy` comma + lexeme $ Char.char '}' + pure () + +parseAnyArray :: Parser () +parseAnyArray = T.label "Ignored array" $ do + T.try $ lexeme $ Char.char '[' + consumeJunkValue `sepBy` comma + lexeme $ Char.char ']' + pure () + +consumeJunkValue :: Parser () +consumeJunkValue + = void parseAnyObject + <|> void parseAnyArray + <|> void parseJSONText + <|> void parseJSONNumber + <|> void parseJSONNull + +parseJSONNumber :: Parser Scientific +parseJSONNumber = Lexer.signed (pure ()) Lexer.scientific + +parseJSONNull :: Parser () +parseJSONNull = void $ lexeme $ T.chunk "null" + +parseJSONBool :: Parser Bool +parseJSONBool = lexeme $ (T.chunk "true" $> True) <|> (T.chunk "false" $> False) + +junkFieldsAtEnd :: Parser () +junkFieldsAtEnd = T.label "misc fields after parsing is done" $ do + comma + parseAnyField `sepBy` comma + pure () + +newtype MegaparsecParser a + = MegaparsecParser { getMegaparsecParser :: Parser a } + deriving (Functor) + deriving (Monoid) via (Alt Parser a) + +instance Semigroup (MegaparsecParser a) where + (MegaparsecParser a) <> (MegaparsecParser b) = MegaparsecParser $ T.try a <|> T.try b + +instance JSONObjectParser ObjectParser where + parseFieldWith label + = ObjectParser + . asPermutation + . T.label ("field " <> Text.unpack label) + . parseObjectField label + . getMegaparsecParser + +instance JSONTupleParser ArrayParser where + consumeItemWith = ArrayParser . getMegaparsecParser + +instance JSONParser MegaparsecParser where + parseObject name p = MegaparsecParser $ T.label (Text.unpack name <> " object") $ do + T.label "object start" $ lexeme $ Char.char '{' + r <- wrapEffect parseAnyField comma $ getObjectParser p + T.label "object end" $ T.optional junkFieldsAtEnd + lexeme $ Char.char '}' + pure r + parseDictionary valParser = MegaparsecParser $ T.label "dictionary" $ do + lexeme $ Char.char '{' + r <- parseDictField (getMegaparsecParser valParser) `sepBy` comma + lexeme $ Char.char '}' + pure r + parseTuple p = MegaparsecParser $ do + lexeme $ T.label "Array start" $ Char.char '[' + r <- getArrayParser p + lexeme $ T.label "Array end" $ Char.char ']' + pure r + parseArrayWith p = MegaparsecParser $ do + lexeme $ T.label "Array start" $ Char.char '[' + r <- getMegaparsecParser p `sepBy` comma + lexeme $ T.label "Array end" $ Char.char ']' + pure r + parseTextConstant t = MegaparsecParser $ T.label "text constant" $ do + Char.char '"' + Text.foldr (\c a -> parseCharInText c *> a) (pure ()) t + Char.char '"' + pure () + parseText = MegaparsecParser parseJSONText + parseBool = MegaparsecParser parseJSONBool + parseNumber = MegaparsecParser parseJSONNumber + parseNull = MegaparsecParser $ T.label "null literal" parseJSONNull + validateJSON (MegaparsecParser f) = MegaparsecParser $ do + r <- f + case r of + Left a -> fail (Text.unpack a) + Right a -> pure a + +-- | Convert an abstract JSONParser to a Megaparsec parser. +convertParserToMegaparsecParser :: (forall parser. JSONParser parser => parser a) -> Parser a +convertParserToMegaparsecParser = getMegaparsecParser + +-- | Get a megaparsec parser for your JSON value. +-- This parser will not construct any intermediate maps or other structures - your object will be parsed directly! +-- +-- Note: this parser, until the ones that are built into the class, can consume whitespace at the start of the JSON. +megaparsecParser :: (FromJSON val) => Parser val +megaparsecParser = takeSpace *> getMegaparsecParser fromJSON + +-- | Run an abstract JSONParser via Megaparsec. +runParserViaMegaparsec :: (forall parser. JSONParser parser => parser a) -> Text.Text -> Either String a +runParserViaMegaparsec p t = + case T.runParser (convertParserToMegaparsecParser p) "" t of + Left r -> Left $ T.errorBundlePretty r + Right k -> Right k + +-- | Parse an object for which 'FromJSON' is defined via Megaparsec. +parseViaMegaparsec :: forall val. (FromJSON val) => Text.Text -> Either String val +parseViaMegaparsec = runParserViaMegaparsec fromJSON diff --git a/lib/Jordan/FromJSON/ParseInternal.hs b/lib/Jordan/FromJSON/ParseInternal.hs new file mode 100644 --- /dev/null +++ b/lib/Jordan/FromJSON/ParseInternal.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Module containing internal helpers for our parsers. +module Jordan.FromJSON.ParseInternal + where + +import Control.Applicative (Alternative(..)) +import Data.Foldable (asum) + +-- | A parser for permutations. +-- +-- Based on the paper Parsing Permutation Phrases by +-- Arthur Baars, Andres Loh, and S. Doaitse Swierstra. +-- +-- The source code for 'Control.Applicative.Permutations' really helped +-- in writing this, although this type is structured differently (and closer to the actual paper). +-- Thank you very much to Alex Washburn! +data Permutation parser a + = Choice [Branch parser a] + -- ^ We have multiple options for how to parse further. + | Empty a + -- ^ We have reached the end and only have a single value. + +-- | A branch of a permutation. +-- Permutation parsers work by building up the entire tree of +-- possible parsers, which is efficient in Haskell due to laziness. +data Branch parser a + = forall arg. Branch (Permutation parser (arg -> a)) (parser arg) + +instance (Functor m) => Functor (Branch m) where + fmap f (Branch perm p) = Branch (fmap (f .) perm) p + +instance (Functor m) => Functor (Permutation m) where + fmap f = \case + Choice c -> Choice $ fmap f <$> c + Empty a -> Empty (f a) + +instance (Alternative m) => Applicative (Branch m) where + pure a = Branch (pure $ const a) (pure ()) + (Branch permuteF argF) <*> (Branch permuteA argA) = + Branch (args <$> permuteF <*> permuteA) arguments + where + arguments = ((,) <$> argA <*> argF) <|> (flip (,) <$> argF <*> argA) + args :: (arg1 -> a -> b) -> (arg2 -> a) -> (arg2, arg1) -> b + args f a (aa, fa) = f fa (a aa) + +instance (Alternative m) => Applicative (Permutation m) where + pure = Empty + (Empty f) <*> (Empty a) = Empty $ f a + (Empty f) <*> (Choice choices) = Choice $ fmap f <$> choices + (Choice f) <*> (Empty a) = Choice $ fmap ($ a) <$> f + t1@(Choice bs1) <*> t2@(Choice bs2) = Choice (map ins2 bs1 ++ map ins1 bs2) + where + ins1 (Branch perm p) = Branch ((.) <$> t1 <*> perm) p + ins2 (Branch perm p) = Branch (flip <$> perm <*> t2) p + +-- | Wrap up a permutation parser with two effects: +-- +-- It will first interleave an infinite number of some effects, which represent parsing "junk" or unwanted fields. +-- At every stage of the permutation, we will first try to run the effect we want, and if it fails +-- we will try to run the "junk" effect instead, then try again. +-- +-- We attempt to *intersperse* the second effect afterwards. +-- It adds a new effect between every effect. +-- This is used in parsing JSON to add commas. +wrapEffect + :: forall m a b. (Alternative m) + => m b + -- ^ Consume a single, \"junk\" field. + -- Used to ignore JSON keys that we do not care about. + -> m b + -- ^ Consume a \"separator\" between items in the permutation. + -- This consumption is not done at the front of the permutation + -- or after the end of it. + -- This is used to parse commas between JSON fields. + -> Permutation m a + -- ^ The permutation parser to run. + -> m a + -- ^ The final parser. +wrapEffect takeSingle effAfter (Empty a) = pure a +wrapEffect takeSingle effAfter (Choice choices) = consumeMany + where + consumeMany + = asum (pars <$> choices) + -- Base case above: one of the choices of the permutation matched + <|> (takeSingle *> effAfter *> consumeMany) + -- Interleaving case: none of the choices of the permutation matched, + -- so run a "junk" effect, the separator, and try again. + -- Due to the recursion here we will do this infinitely until we either cannot + -- run the junk effect, *or* we have a field that matches one of the choices of the permutation. + runWithEffect :: Permutation m whatever -> m whatever + runWithEffect (Empty a) = pure a + runWithEffect (Choice choices) = effAfter *> consumeRec + where + consumeRec + = asum (pars <$> choices) + -- Run one of the effects from the permutation + <|> (takeSingle *> effAfter *> consumeRec) + -- Interleave a potentially infinite number of junk effects, with the separator effect between them. + pars :: Branch m whatever -> m whatever + pars (Branch perm arg) = do + a <- arg + rest <- runWithEffect perm + pure $ rest a + +asParser :: (Alternative f) => Permutation f a -> f a +asParser (Empty a) = pure a +asParser (Choice choices) = asum (pars <$> choices) + where + pars :: (Alternative f) => Branch f a -> f a + pars (Branch perm arg) = do + a <- arg + rest <- asParser perm + pure $ rest a + +asPermutation :: (Alternative f) => f a -> Permutation f a +asPermutation p = Choice $ pure $ Branch (pure id) p diff --git a/lib/Jordan/Generic/Options.hs b/lib/Jordan/Generic/Options.hs new file mode 100644 --- /dev/null +++ b/lib/Jordan/Generic/Options.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DeriveGeneric #-} +module Jordan.Generic.Options + where + +import GHC.Generics (Generic) + +data SumTypeEncoding + = TagVal + | TagInField + deriving (Show, Read, Eq, Ord, Bounded, Enum, Generic) + +newtype PartOfSum f a = PartOfSum { getPartOfSum :: f a } diff --git a/lib/Jordan/ToJSON/Builder.hs b/lib/Jordan/ToJSON/Builder.hs new file mode 100644 --- /dev/null +++ b/lib/Jordan/ToJSON/Builder.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +module Jordan.ToJSON.Builder + ( JSONBuilder (..) + , toJSONViaBuilder + , toJSONAsBuilder + ) where + +import Data.ByteString.Builder (Builder, toLazyByteString) +import qualified Data.ByteString.Builder.Prim as BP +import Data.ByteString.Builder.Scientific (scientificBuilder) +import qualified Data.ByteString.Lazy as LBS +import Data.Char (ord) +import Data.Functor.Contravariant +import Data.Functor.Contravariant.Divisible +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8BuilderEscaped) +import Data.Void (absurd) +import Data.Word (Word8) +import Jordan.ToJSON.Class + +-- | JSON Serializer that makes use of 'Data.ByteString.Builder' to do its work. +-- Should be really fast. +newtype JSONBuilder a + = JSONBuilder { runJSONBuilder :: a -> Builder } + deriving (Semigroup, Monoid) via (a -> Builder) + +instance Contravariant JSONBuilder where + contramap f (JSONBuilder a) = JSONBuilder $ a . f + +data CommaSep + = Written !Builder + | Empty + +instance Semigroup CommaSep where + Empty <> a = a + a <> Empty = a + (Written a) <> (Written b) = Written (a <> "," <> b) + +instance Monoid CommaSep where + mempty = Empty + +runCommaSep :: CommaSep -> Builder +runCommaSep Empty = "" +runCommaSep (Written w) = w + +newtype JSONCommaBuilder a + = JSONCommaBuilder { runCommaBuilder :: a -> CommaSep } + +-- Lifted from aeson (thanks to them!) +ascii2 :: (Char, Char) -> BP.BoundedPrim a +ascii2 cs = BP.liftFixedToBounded $ const cs BP.>$< BP.char7 BP.>*< BP.char7 +{-# INLINE ascii2 #-} + +-- | Also lifted from Aeson (once again, thanks to them!) +escapeAscii :: BP.BoundedPrim Word8 +escapeAscii = + BP.condB (== c2w '\\' ) (ascii2 ('\\','\\')) $ + BP.condB (== c2w '\"' ) (ascii2 ('\\','"' )) $ + BP.condB (>= c2w '\x20') (BP.liftFixedToBounded BP.word8) $ + BP.condB (== c2w '\n' ) (ascii2 ('\\','n' )) $ + BP.condB (== c2w '\r' ) (ascii2 ('\\','r' )) $ + BP.condB (== c2w '\t' ) (ascii2 ('\\','t' )) $ + BP.liftFixedToBounded hexEscape -- fallback for chars < 0x20 + where + c2w :: Char -> Word8 + c2w c = fromIntegral (ord c) + hexEscape :: BP.FixedPrim Word8 + hexEscape = (\c -> ('\\', ('u', fromIntegral c))) BP.>$< + BP.char8 BP.>*< BP.char8 BP.>*< BP.word16HexFixed +{-# INLINE escapeAscii #-} + +-- | Make a builder for a quoted string, which does all the cool escaping crap we need to do. +-- Mostly stolen shamelessly from Aeson. +writeQuotedString :: Text -> Builder +writeQuotedString t = "\"" <> encodeUtf8BuilderEscaped escapeAscii t <> "\"" + +writeKV :: (a -> Builder) -> Text -> a -> Builder +writeKV map k v = writeQuotedString k <> ": " <> map v + +instance Contravariant JSONCommaBuilder where + contramap f (JSONCommaBuilder a) = JSONCommaBuilder $ a . f + +instance Divisible JSONCommaBuilder where + conquer = JSONCommaBuilder $ const Empty + divide split sB sC = JSONCommaBuilder $ \a -> + case split a of + (b, c) -> runCommaBuilder sB b <> runCommaBuilder sC c + +instance JSONObjectSerializer JSONCommaBuilder where + writeField field (JSONBuilder a) = JSONCommaBuilder $ \arg -> + Written $ writeQuotedString field <> ": " <> a arg + +instance JSONTupleSerializer JSONCommaBuilder where + writeItem (JSONBuilder a) = JSONCommaBuilder $ Written . a + +instance Selectable JSONBuilder where + giveUp f = JSONBuilder $ \a -> absurd (f a) + select sel serL serR = JSONBuilder $ \a -> + case sel a of + Left lhs -> runJSONBuilder serL lhs + Right rhs -> runJSONBuilder serR rhs + +instance JSONSerializer JSONBuilder where + serializeObject _ (JSONCommaBuilder f) = JSONBuilder $ \a -> + case f a of + Written bu -> "{" <> bu <> "}" + Empty -> "{}" + serializeTuple (JSONCommaBuilder f) = JSONBuilder $ \a -> + case f a of + Written bu -> "[" <> bu <> "]" + Empty -> "[]" + serializeDictionary (JSONBuilder t) = JSONBuilder $ \a -> + "{" <> runCommaSep (foldMap (\(k,v) -> Written (writeKV t k v)) a) <> "}" + serializeText = JSONBuilder $ \t -> writeQuotedString t + serializeTextConstant = JSONBuilder . const . writeQuotedString + serializeNumber = JSONBuilder $ \a -> scientificBuilder a + serializeNull = JSONBuilder $ const "null" + serializeBool = JSONBuilder $ \case + True -> "true" + False -> "false" + serializeArray = JSONBuilder $ \array -> + case foldMap (Written . runJSONBuilder toJSON) array of + Empty -> "[]" + Written n -> "[" <> n <> "]" + +-- | Serialize a Haskell datatype to a 'Builder'. +-- +-- This is available for performance reasons: you may wish to use hPutBuilder +-- in order to (more or less) directly serialize some JSON object to a file handle. +toJSONAsBuilder :: (ToJSON a) => a -> Builder +toJSONAsBuilder = runJSONBuilder toJSON + +-- | Serialize a Haskell datatype to a lazy ByteString. +toJSONViaBuilder :: (ToJSON a) => a -> LBS.ByteString +toJSONViaBuilder = toLazyByteString . runJSONBuilder toJSON diff --git a/lib/Jordan/ToJSON/Class.hs b/lib/Jordan/ToJSON/Class.hs new file mode 100644 --- /dev/null +++ b/lib/Jordan/ToJSON/Class.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Jordan.ToJSON.Class + where + +import Data.Functor.Contravariant +import Data.Functor.Contravariant.Divisible +import qualified Data.Map.Strict as Map +import qualified Data.Ratio as Ratio +import Data.Scientific (Scientific) +import qualified Data.Scientific as Sci +import qualified Data.Semigroup as Semi +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable (Proxy(..), Typeable, tyConModule, tyConName, typeRep, typeRepTyCon) +import Data.Void (Void, absurd) +import GHC.Generics +import Jordan.Generic.Options + +-- | Basically just 'Data.Functor.Contravariant.Divisible.Decidable' but without +-- a superclass constraint that we cannot implement for JSON. +-- +-- More specifically, we can quite easily serialize some object into either a string or a number +-- as a top-level JSON value, but we cannot serialize both a string and a number as a top level key. +-- This means that we cannot implement 'Data.Functor.Contravariant.Divisible', but we can implement +-- all the operations from 'Data.Functor.Contravariant.Divisible.Decidable'. +-- +-- This class lets us decide without being able to divide, which is fun to say. +class (Contravariant f) => Selectable f where + -- | Give up trying to decide. + giveUp :: (arg -> Void) -> f arg + -- | Pick one thing, or another, as long as you can serialize both options. + select :: (arg -> Either lhs rhs) -> f lhs -> f rhs -> f arg + +-- | An abstract representation of how to serialize a JSON object. +-- Since serializing is the exact opposite of parsing, we have to be +-- 'Data.Functor.Contravariant.Decidable' instead of 'Control.Applicative.Alternative'. +-- +-- That is, if we are serializing a JSON object, we need to be able to break things apart. +-- +-- Unfortunately the combinators for breaking things apart are more annoying to use than +-- the combinators for putting things together, and involve a lot of tuples everywhere. +-- +-- Thankfully we provide a good interface to derive these classes generically! +class (Divisible f) => JSONObjectSerializer f where + writeField + :: Text + -- ^ Label for the field to write + -> (forall jsonSerializer. JSONSerializer jsonSerializer => jsonSerializer a) + -- ^ How to write the field. + -- The forall ensures that JSON serialization is kept completely abstract. + -- You can only use the methods of 'JSONSerializer' here. + -> f a + +class (Divisible f) => JSONTupleSerializer f where + writeItem + :: (forall jsonSerializer. JSONSerializer jsonSerializer => jsonSerializer a) + -- ^ Write a single item into the tuple. + -- The forall keeps things abstract. + -> f a + +-- | An abstract representation of how to serialize a Haskell value into JSON. +class (Selectable f) => JSONSerializer f where + serializeObject + :: Text + -- ^ A name for the object. Should be "globally unique" as much as possible. + -> (forall objSerializer. JSONObjectSerializer objSerializer => objSerializer a) + -- ^ How to serialize the object. + -- The forall here keeps things abstract: you are only allowed to use the methods of 'JSONObjectSerializer' here. + -> f a + serializeDictionary + :: (Foldable t) + => (forall jsonSerializer. JSONSerializer jsonSerializer => jsonSerializer a) + -> f (t (Text, a)) + serializeText + :: f Text + -- | Serialize some text constant. + -- Note that this returns a serializer of anything: if you are always going to serialize out the same string, + -- we don't need to even look at the thing we\'re serializing! + serializeTextConstant + :: Text + -> f a + serializeNull + :: f any + serializeNumber + :: f Scientific + serializeBool + :: f Bool + serializeTuple + :: (forall tupleSerializer. JSONTupleSerializer tupleSerializer => tupleSerializer a) + -> f a + serializeArray + :: (ToJSON a) + => f [a] + +-- | A class to provide the canonical way to encode a JSON. +-- +-- This class uses finally tagless style to keep the instructions for serializing abstract. +-- This allows us to automatically generate documentation, and to generate serializers that always avoid the need for intermediate structures. +-- +-- This class is derivable generically, and will generate a \"nice\" format. +-- In my opinion, at least. +class ToJSON v where + toJSON :: (JSONSerializer f) => f v + default toJSON :: (Generic v, GToJSON (Rep v)) => (JSONSerializer f) => f v + toJSON = contramap from $ gToJSON defaultToJSONOptions + +instance ToJSON () where + toJSON = serializeNull + +instance ToJSON Text where + toJSON = serializeText + +instance ToJSON Scientific where + toJSON = serializeNumber + +instance {-# OVERLAPPABLE #-} (ToJSON a) => ToJSON [a] where + toJSON = serializeArray + +-- | Nothings get serialized as null. +instance (ToJSON a) => ToJSON (Maybe a) where + toJSON = select find serializeNull toJSON + where + find Nothing = Left () + find (Just a) = Right a + +instance (ToJSON lhs, ToJSON rhs) => ToJSON (Either lhs rhs) where + toJSON = select id toJSON toJSON + +instance ToJSON Bool where + toJSON = serializeBool + +instance ToJSON Int where + toJSON = contramap fromIntegral serializeNumber + +instance ToJSON Integer where + toJSON = contramap fromInteger serializeNumber + +instance ToJSON Float where + toJSON = contramap realToFrac serializeNumber + +instance ToJSON Double where + toJSON = contramap realToFrac serializeNumber + +instance {-# OVERLAPPING #-} ToJSON String where + toJSON = contramap T.pack serializeText + +instance forall a. (ToJSON a, Typeable a) => ToJSON (Ratio.Ratio a) where + toJSON = serializeObject objName $ + divide divider (writeField "num" toJSON) (writeField "denom" toJSON) + where + divider :: Ratio.Ratio a -> (a,a) + divider = (,) <$> Ratio.numerator <*> Ratio.denominator + objName = T.pack $ tyName <> ".Ratio" + tyName = (tyConModule <> const "." <> tyConName) $ typeRepTyCon $ typeRep (Proxy :: Proxy a) + +instance (ToJSON a) => ToJSON (Semi.Min a) where + toJSON = contramap Semi.getMin toJSON + +instance (ToJSON a) => ToJSON (Semi.Max a) where + toJSON = contramap Semi.getMax toJSON + +instance (ToJSON a) => ToJSON (Semi.First a) where + toJSON = contramap Semi.getFirst toJSON + +instance (ToJSON a) => ToJSON (Semi.Last a) where + toJSON = contramap Semi.getLast toJSON + +instance (ToJSON a) => ToJSON (Semi.Dual a) where + toJSON = contramap Semi.getDual toJSON + +instance ToJSON Semi.All where + toJSON = contramap Semi.getAll serializeBool + +instance ToJSON Semi.Any where + toJSON = contramap Semi.getAny serializeBool + +instance (ToJSON a) => ToJSON (Semi.Sum a) where + toJSON = contramap Semi.getSum toJSON + +instance (ToJSON a) => ToJSON (Semi.Product a) where + toJSON = contramap Semi.getProduct toJSON + +instance (ToJSON a) => ToJSON (Map.Map Text a) where + toJSON = contramap Map.toList $ serializeDictionary toJSON + +data ToJSONOptions + = ToJSONOptions + { toJSONEncodeSums :: SumTypeEncoding + , toJSONBaseName :: String + , toJSONRenderEnum :: String -> String + } + +defaultToJSONOptions :: ToJSONOptions +defaultToJSONOptions + = ToJSONOptions TagInField "" id + +class GToJSON v where + gToJSON :: (JSONSerializer s) => ToJSONOptions -> s (v a) + +instance (ToJSON c) => GToJSON (K1 i c) where + gToJSON _ = contramap (\(K1 a) -> a) toJSON + +instance (GToJSON f, Datatype t) => GToJSON (D1 t f) where + gToJSON = contramap (\(M1 a) -> a) . gToJSON . addName + where + addName b = b { toJSONBaseName = toJSONBaseName b <> dtname } + dtname = moduleName s <> "." <> datatypeName s + s :: D1 t f a + s = undefined + +instance {-# OVERLAPS #-} (Constructor t) => GToJSON (PartOfSum (C1 t U1)) where + gToJSON opts = contramap getPartOfSum $ serializeTextConstant enumValue + where + enumValue = T.pack $ toJSONRenderEnum opts $ conName (undefined :: C1 t U1 f) + +instance {-# OVERLAPPABLE #-} (Constructor t, GToJSON (C1 t f)) => GToJSON (PartOfSum (C1 t f)) where + gToJSON opts = contramap getPartOfSum encoded + where + encoded = case toJSONEncodeSums opts of + TagVal -> tagged + TagInField -> field + field = serializeObject objName $ + writeField cn (gToJSON opts) + tagged = serializeObject objName $ + contramap ((),) $ + divided + (writeField "key" $ serializeTextConstant cn) + (writeField "value" $ gToJSON opts) + objName = T.pack (toJSONBaseName opts) <> "." <> cn <> ".Output" + cn = T.pack $ conName (undefined :: C1 t f a) + +sumToEither :: (l :+: r) a -> Either (l a) (r a) +sumToEither f = case f of + L1 a -> Left a + R1 a -> Right a + +instance forall l r. (GToJSON (PartOfSum l), GToJSON (PartOfSum r)) => GToJSON (l :+: r) where + gToJSON :: forall f a. (JSONSerializer f) => ToJSONOptions -> f ((l :+: r) a) + gToJSON opts = + select + sumToEither + (contramap PartOfSum $ gToJSON opts) + (contramap PartOfSum $ gToJSON opts) + +instance (GToJSON (PartOfSum l), GToJSON (PartOfSum r)) => GToJSON (PartOfSum (l :+: r)) where + gToJSON opts = contramap getPartOfSum (gToJSON opts) + +instance (GToJSON s) => GToJSON (S1 whatever s) where + gToJSON = contramap (\(M1 a) -> a) . gToJSON + +instance GToJSON V1 where + gToJSON _ = giveUp (error "how the hell did you construct a void data type?") + +class GToJSONObject v where + gToJSONObject :: (JSONObjectSerializer f) => ToJSONOptions -> f (v a) + +instance (GToJSON f, Selector t) => GToJSONObject (S1 t f) where + gToJSONObject o + = contramap (\(M1 a) -> a) + $ writeField (T.pack $ selName v) (gToJSON o) + where + v :: M1 S t f a + v = undefined + +instance (GToJSONObject lhs, GToJSONObject rhs) => GToJSONObject (lhs :*: rhs) where + gToJSONObject o = divide div (gToJSONObject o) (gToJSONObject o) + where + div (a :*: b) = (a,b) + +instance {-# OVERLAPPABLE #-} (GToJSONObject inner, Constructor t) => GToJSON (C1 t inner) where + gToJSON opts + = contramap (\(M1 a) -> a) + $ serializeObject name + $ gToJSONObject opts + where + name = T.pack $ toJSONBaseName opts <> "." <> conName (undefined :: C1 t inner a) <> ".Output" + +instance {-# OVERLAPS #-} (ToJSON i) => GToJSON (C1 c (S1 (MetaSel 'Nothing su ss ds) (Rec0 i))) where + gToJSON _ = contramap (\(M1 (M1 (K1 s))) -> s) toJSON diff --git a/lib/Jordan/ToJSON/Text.hs b/lib/Jordan/ToJSON/Text.hs new file mode 100644 --- /dev/null +++ b/lib/Jordan/ToJSON/Text.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Jordan.ToJSON.Text + where + +import Data.Functor.Contravariant +import Data.Functor.Contravariant.Divisible +import Data.List (intersperse) +import qualified Data.Scientific as Sci +import Data.Semigroup (Endo(..)) +import Data.String (IsString(..)) +import qualified Data.Text as T +import Data.Void (absurd) +import Jordan.ToJSON.Class + +data TextComma + = Written (T.Text -> T.Text) + | Empty + +runWritten :: TextComma -> T.Text -> T.Text +runWritten Empty = id +runWritten (Written f) = f + +instance IsString TextComma where + fromString s = Written (<> T.pack s) + +instance Semigroup TextComma where + Empty <> a = a + a <> Empty = a + (Written f) <> (Written f') = Written (f . (", " <>) . f') + +instance Monoid TextComma where + mempty = Empty + +newtype CommaBuilder v = CommaBuilder { runCommaBuilder :: v -> TextComma } + deriving (Semigroup, Monoid) via (v -> TextComma) + +runCommaBuilder' :: CommaBuilder v -> v -> T.Text -> T.Text +runCommaBuilder' (CommaBuilder f) = runWritten . f + +instance Contravariant CommaBuilder where + contramap f (CommaBuilder v) = CommaBuilder (v . f) + +instance Divisible CommaBuilder where + conquer = CommaBuilder (const Empty) + divide d (CommaBuilder b) (CommaBuilder c) = CommaBuilder $ \a -> + let (b', c') = d a in b b' <> c c' + +newtype TextArray v = TextArray { runTextArray :: v -> ([T.Text] -> [T.Text]) } + deriving (Semigroup, Monoid) via (v -> Endo [T.Text]) + +instance Contravariant TextArray where + contramap f (TextArray b) = TextArray $ \a -> b (f a) + +instance Divisible TextArray where + conquer = TextArray $ const mempty + divide d (TextArray b) (TextArray c) = TextArray $ \a -> + let (b', c') = d a in b b' . c c' + +instance Decidable TextArray where + lose _ = TextArray $ const mempty + choose f (TextArray b) (TextArray c) = TextArray $ \a -> + case f a of + Left b' -> b b' + Right c' -> c c' + +instance JSONTupleSerializer CommaBuilder where + writeItem f = CommaBuilder $ Written . runJSONText f + +instance JSONObjectSerializer CommaBuilder where + writeField t s = CommaBuilder $ \arg -> + Written (quoteString t . (": " <> ) . runJSONText s arg) + +instance JSONTupleSerializer TextArray where + writeItem f = TextArray $ \a -> ([runJSONText f a ""] <>) + +newtype JSONText a + = JSONText { runJSONText :: a -> (T.Text -> T.Text) } + deriving (Semigroup, Monoid) via (a -> Endo T.Text) + +instance Contravariant JSONText where + contramap f (JSONText s) = JSONText (s . f) + +instance Selectable JSONText where + giveUp f = JSONText $ \a -> absurd (f a) + select f (JSONText lhs) (JSONText rhs) = JSONText $ either lhs rhs . f + +convChar :: Char -> (T.Text -> T.Text) +convChar = \case + '\b' -> ("\\b" <>) + '\f' -> ("\\f" <>) + '\n' -> ("\\n" <>) + '\r' -> ("\\r" <>) + '\t' -> ("\\t" <>) + '"' -> ("\\\"" <>) + '\\' -> ("\\\\" <>) + o -> (T.singleton o <>) + +isBadChar :: Char -> Bool +isBadChar = \case + '\b' -> True + '\f' -> True + '\r' -> True + '\t' -> True + '\\' -> True + '"' -> True + _ -> False + +quoteString :: T.Text -> (T.Text -> T.Text) +quoteString t = ("\"" <>) . innerText . ("\"" <>) + where + innerText + | T.any isBadChar t = T.foldl' (\o a -> o . convChar a) id t + | otherwise = (t <>) + +sArray :: (a -> T.Text -> T.Text) -> [a] -> (T.Text -> T.Text) +sArray _ [] = id +sArray f [x] = f x +sArray f (x : xs) = f x . ("," <>) . sArray f xs + +instance JSONSerializer JSONText where + serializeNull = JSONText $ const ("null" <>) + serializeText = JSONText $ \a -> quoteString a + serializeTextConstant t = JSONText $ const $ quoteString t + serializeNumber = JSONText $ \n -> + ((T.pack $ Sci.formatScientific Sci.Generic Nothing n) <>) + serializeDictionary (JSONText serItem) = JSONText $ \n -> + ("{" <>) . keys n . ("}" <>) + where + keys v = runWritten $ foldMap (\(k, v) -> Written $ quoteString k . (": " <> ) . serItem v) v + serializeBool = JSONText $ \a -> ((if a then "true" else "false") <>) + serializeObject n obj = JSONText $ \arg -> + ("{" <>) . runCommaBuilder' obj arg . ("}" <>) + serializeTuple obj = JSONText $ \arg -> + ("[" <>) . runCommaBuilder' obj arg . ("}" <>) + serializeArray = JSONText $ \a -> ("[" <>) . sArray (runJSONText toJSON) a . (<> "]") + +toJSONText :: (ToJSON a) => a -> T.Text +toJSONText a = runJSONText toJSON a "" diff --git a/test/Jordan/FromJSON/AttoparsecSpec.hs b/test/Jordan/FromJSON/AttoparsecSpec.hs new file mode 100644 --- /dev/null +++ b/test/Jordan/FromJSON/AttoparsecSpec.hs @@ -0,0 +1,14 @@ +module Jordan.FromJSON.AttoparsecSpec + ( spec + ) where + +import Data.Text.Encoding (encodeUtf8) +import Jordan.FromJSON.Attoparsec +import Jordan.FromJSON.Class (FromJSON) +import Jordan.SpecDefs (basicParsingSpec) +import Test.Hspec (Spec, describe, it, shouldBe) + +spec :: Spec +spec = describe "Jordan.FromJSON.Attoparsec" $ do + basicParsingSpec $ \t v -> + parseViaAttoparsec (encodeUtf8 t) `shouldBe` Right v diff --git a/test/Jordan/FromJSON/MegaparsecSpec.hs b/test/Jordan/FromJSON/MegaparsecSpec.hs new file mode 100644 --- /dev/null +++ b/test/Jordan/FromJSON/MegaparsecSpec.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +module Jordan.FromJSON.MegaparsecSpec + ( spec + ) where + +import Data.Text (Text) +import Jordan.FromJSON.Class +import Jordan.FromJSON.Megaparsec +import Jordan.SpecDefs +import Test.Hspec (Spec, describe, it) +import Test.Hspec.Megaparsec +import Text.Megaparsec (parse) + +parse' a = parse a "" + +parseJ :: (FromJSON a) => Text -> Either ParseError a +parseJ = parse' megaparsecParser + +spec :: Spec +spec = describe "megaparsec parsing" $ do + commaSpec + anyFieldSpec + jsonTextSpec + basicParsingSpec (\t v -> parseJ t `shouldParse` v) + specialCaseSpec + +commaSpec :: Spec +commaSpec = describe "comma parser" $ do + it "parses just a comma" $ + parse' comma `shouldSucceedOn` "," + it "parses a comma with some extra whitespace" $ + parse' comma `shouldSucceedOn` ", \n\n" + +anyFieldSpec :: Spec +anyFieldSpec = describe "parseAnyField" $ do + it "parses a very basic null field" $ + parse' parseAnyField `shouldSucceedOn` "\"foo\": null" + it "parses an overly whitespaced field" $ + parse' parseAnyField `shouldSucceedOn` "\"foo\" : \n\n\n null" + +jsonTextSpec :: Spec +jsonTextSpec = describe "parseJSONText" $ do + let parseText = parse' parseJSONText + it "parses a super basic string" $ do + parseText `shouldSucceedOn` "\"foo\"" + it "parses with an escaped backslash" $ do + parseText "\"foo\\\\\"" `shouldParse` "foo\\" + it "parses with an escaped quote" $ do + parseText "\"foo\\\"\"" `shouldParse` "foo\"" + it "parses with unicode" $ do + parseText "\"foo\\u2795\"" `shouldParse` "foo➕" + it "parses with trailing whitespace" $ do + parseText "\"foo\" " `shouldParse` "foo" + +specialCaseSpec :: Spec +specialCaseSpec = describe "special cases" $ do + it "does not allow mismatched labels" $ + parse (megaparsecParser @GenericSum) "" `shouldFailOn` mismatchType diff --git a/test/Jordan/RoundTripSpec.hs b/test/Jordan/RoundTripSpec.hs new file mode 100644 --- /dev/null +++ b/test/Jordan/RoundTripSpec.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Jordan.RoundTripSpec + where + +import Data.ByteString.Lazy (fromStrict, toStrict) +import Data.Functor.Contravariant (Contravariant(..)) +import Data.Proxy (Proxy(..)) +import Data.Text (Text, unpack) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import GHC.Generics +import Jordan (parseViaAttoparsec, parseViaMegaparsec, toJSONText, toJSONViaBuilder) +import Jordan.FromJSON.Class (FromJSON(..), JSONParser(..)) +import Jordan.ToJSON.Class (JSONSerializer(..), ToJSON(..)) +import Test.Hspec (Spec, describe) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck +import Test.QuickCheck.Utf8 + +makeResult + :: (ToJSON a, FromJSON a, Arbitrary a, Show a, Eq a) + => Proxy a + -> (a -> b) + -> (b -> String) + -> (b -> Either String a) + -> Property +makeResult (Proxy :: Proxy a) convForward convString convBack = + forAllShow (arbitrary @a) showResult convert + where + showResult a + = show a + <> "\n" + <> convString (convForward a) + <> "\n" + <> showError (convBack $ convForward a) + convert a = convBack (convForward a) == pure a + showError :: Either String a -> String + showError (Left err) = "Error\n" <> err + showError (Right a) = "Success: " <> show a + +newtype ExtremelyBasic + = ExtremelyBasic { getExtremelyBasic :: () } + deriving (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +instance Arbitrary ExtremelyBasic where + arbitrary = ExtremelyBasic <$> arbitrary + +data TwoFieldsRec + = TwoFieldsRec { firstField :: Int, secondField :: Int } + deriving (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +instance Arbitrary TwoFieldsRec where + arbitrary = TwoFieldsRec <$> arbitrary <*> arbitrary + +data RLMSum + = Mike + | Jay + | Rich + | Jack + | Josh + deriving (Eq, Show, Generic, Bounded, Enum) + deriving anyclass (ToJSON, FromJSON) + +instance Arbitrary RLMSum where + arbitrary = arbitraryBoundedEnum + +data ManyChoices + = ChoseFirst { getFirst :: Int } + | ChoseSecond { getSecondA :: Int, getSecondB :: Int } + deriving (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +instance Arbitrary ManyChoices where + arbitrary + = oneof + [ ChoseFirst <$> arbitrary + , ChoseSecond <$> arbitrary <*> arbitrary + ] + +data FakePerson + = FakePerson + { age :: Int + , name :: String + , cool :: Bool + } deriving (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +instance Arbitrary FakePerson where + arbitrary + = FakePerson + <$> arbitrary + <*> fmap unpack genValidUtf8 + <*> arbitrary + +newtype OnlyText = OnlyText { getText :: Text } + deriving (Show, Eq) + +instance ToJSON OnlyText where + toJSON = contramap getText serializeText + +instance FromJSON OnlyText where + fromJSON = OnlyText <$> parseText + +instance Arbitrary OnlyText where + arbitrary = OnlyText <$> genValidUtf8 + +data EnumyObject + = EnumA + | EnumB + | EnumC + | EnumObject { enumValue :: Text } + deriving (Show, Eq, Generic) + deriving anyclass (ToJSON, FromJSON) + +instance Arbitrary EnumyObject where + arbitrary + = oneof + [ pure EnumA + , pure EnumB + , pure EnumC + , EnumObject <$> genValidUtf8 + ] + +data AllTogether + = AllTogether + { extremelyBasic :: ExtremelyBasic + , twoFieldsRec :: TwoFieldsRec + , rlmSum :: RLMSum + , fakePerson :: FakePerson + , onlyText :: OnlyText + , enumyObject :: EnumyObject + } deriving (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +instance Arbitrary AllTogether where + arbitrary + = AllTogether + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +showViaText :: (ToJSON a) => a -> String +showViaText = unpack . toJSONText + +showViaBuilder :: (ToJSON a) => a -> String +showViaBuilder = unpack . decodeUtf8 . toStrict . toJSONViaBuilder + +roundtrips + :: (Arbitrary a, Show a, Eq a, ToJSON a, FromJSON a) + => String + -> Proxy a + -> Spec +roundtrips n p = describe ("round-trippping " <> n) $ do + describe "when serializing via text" $ do + let q = makeResult p toJSONText unpack + prop "roundtrips back via megaparsec" $ + q parseViaMegaparsec + prop "roundtrips back via attoparsec" $ + q (parseViaAttoparsec . encodeUtf8) + describe "when serializing via a builder" $ do + let q = makeResult p toJSONViaBuilder (unpack . decodeUtf8 . toStrict) + prop "roundtrips back via megaparsec" $ + q (parseViaMegaparsec . decodeUtf8 . toStrict) + prop "roundtrips back via attoparsec" $ + q (parseViaAttoparsec . toStrict) + +spec :: Spec +spec = describe "round-tripping generic values" $ do + roundtrips "a newtype around ()" (Proxy @ExtremelyBasic) + roundtrips "a record with two int fields" (Proxy @TwoFieldsRec) + roundtrips "a sum enum type" (Proxy @RLMSum) + roundtrips "a type with some text" (Proxy @FakePerson) + roundtrips "just text" (Proxy @OnlyText) + roundtrips "an object with some constructors as enums" (Proxy @EnumyObject) + roundtrips "an object composed of all rountrip'd objects" (Proxy @AllTogether) diff --git a/test/Jordan/SpecDefs.hs b/test/Jordan/SpecDefs.hs new file mode 100644 --- /dev/null +++ b/test/Jordan/SpecDefs.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +module Jordan.SpecDefs + where + +import Control.Applicative (Alternative((<|>))) +import Data.Functor.Contravariant +import Data.Functor.Contravariant.Divisible +import Data.String (IsString(..)) +import Data.Text (Text, pack) +import GHC.Generics (Generic) +import Jordan.FromJSON.Class +import Jordan.ToJSON.Class +import Test.Hspec (Arg, Example, Spec, SpecWith, describe, it, shouldBe) +import Text.RawString.QQ + +newtype BasicStruct + = BasicStruct { bar :: () } + deriving (Show, Eq, Ord) + +goodBasic :: BasicStruct +goodBasic = BasicStruct () + +instance FromJSON BasicStruct where + fromJSON = (BasicStruct <$> fromNull) <> fromObject + where + fromObject = parseObject "TestItems.BasicStruct.Output" $ + BasicStruct <$> parseField "bar" + fromNull = parseNull + +instance ToJSON BasicStruct where + toJSON = serializeObject "TestItems.BasicStruct.Input" $ writeField "bar" serializeNull + +basicNull = pack [r| null |] +basicOneField = pack [r| { "bar": null } |] +basicEscaped = pack [r| { "\u0062\u0061\u0072": null } |] +basicPartialEscape = pack [r| { "\u0062a\u0072": null } |] + +basicExtraFields = pack [r| { "whatever": null, "bar": null, "baz": null } |] + +basicArray = pack [r| [null, { "whatever": null, "bar": null }, null, null] |] + +data TwoFields + = TwoFields { one :: (), two :: () } + deriving (Show, Eq, Ord, Generic) + +goodTwo :: TwoFields +goodTwo = TwoFields () () + +instance FromJSON TwoFields where + fromJSON = parseObject "TwoFields" $ TwoFields <$> parseField "one" <*> parseField "two" + +twoSimple = pack [r| { "one": null, "two": null } |] + +twoScramble = pack [r| { "two": null, "one": null } |] + +twoExtra = pack [r| + { + "ignore": [], + "one": null, + "bad": {}, + "another": [1,2,3], + "yetAgain": null, + "two": null, + "three": null } +|] + +twoScrambleExtra = pack [r| + { + "ignore": null, + "bad": null, + "two": null, + "another": null, + "yetAgain": null, + "one": null + } +|] + +data GenericStruct + = GenericStruct + { firstLabel :: () + , secondLabel :: [()] + } deriving (Show, Read, Eq, Ord, Generic) + +instance FromJSON GenericStruct + +genericDefault = pack [r| { "firstLabel": null, "secondLabel": [null] } |] + +data GenericSum + = GenericBasic BasicStruct + | GenericTwo TwoFields + deriving (Show, Eq, Ord, Generic) + +instance FromJSON GenericSum + +sumBasic = pack [r| { "GenericBasic": null } |] +sumBasicObj = pack [r| { "GenericBasic": { "bar": null } } |] + +sumTwo = pack [r| { "GenericTwo": { "one": null, "two": null, "bar": null } } |] +mismatchType = pack [r| { "GenericTwo": null } |] + +basicWritingSpec + :: (forall val. (ToJSON val, Show val) => val -> Text) + -> Spec +basicWritingSpec writeJSON = do + describe "writing basic primitives" $ do + it "writes nulls" $ + writeJSON () `shouldBe` "null" + it "writes True to true" $ + writeJSON True `shouldBe` "true" + it "writes False to false" $ + writeJSON False `shouldBe` "false" + it "writes an empty array" $ + writeJSON ([] :: [()]) `shouldBe` "[]" + it "writes an array with one item" $ do + writeJSON [()] `shouldBe` "[null]" + it "writes an array with two items" $ do + writeJSON [(),()] `shouldBe` "[null,null]" + it "writes the number 1" $ do + writeJSON (1 :: Int) `shouldBe` "1.0" + it "writes the number 1.5" $ do + writeJSON (1.5 :: Double) `shouldBe` "1.5" + + describe "writing text" $ do + it "writes with no escapes" $ do + writeJSON ("foo" :: Text) `shouldBe` [r|"foo"|] + it "writes with an escaped quote" $ do + writeJSON ("foo\"" :: Text) `shouldBe` [r|"foo\""|] + it "writes with an escaped backslash" $ do + writeJSON ("foo\\" :: Text) `shouldBe` [r|"foo\\"|] + describe "writing a basic object" $ do + it "writes properly" $ do + writeJSON goodBasic `shouldBe` [r|{"bar": null}|] + +basicParsingSpec + :: (Example a) + => (forall val. (FromJSON val, Show val, Eq val) => Text -> val -> a) + -> SpecWith (Arg a) +basicParsingSpec parseMatch = do + describe "parsing basic structure" $ do + it "parses true" $ + "true" `parseMatch` True + it "parses false" $ + "false" `parseMatch` False + it "parses a raw null" $ + "null" `parseMatch` () + it "parses an empty array of nulls" $ + "[]" `parseMatch` ([] :: [()]) + it "parses a one-null array" $ do + "[null ]" `parseMatch` [()] + it "parses a two-null array with weird spaces" $ do + "[null\n,null]" `parseMatch` [(), ()] + it "parses null to a basic struct" $ + basicNull `parseMatch` goodBasic + it "parses with field" $ + basicOneField `parseMatch` goodBasic + it "parses with two fields" $ + basicExtraFields `parseMatch` goodBasic + it "parses with a fully-escaped field" $ + basicEscaped `parseMatch` goodBasic + it "parses with a partially-escaped field" $ + basicPartialEscape `parseMatch` goodBasic + it "parses an array" $ + basicArray `parseMatch` replicate 4 goodBasic + describe "string parsing" $ do + it "parses with an escaped backslash" $ do + "\"foo\\\\\"" `parseMatch` ("foo\\" :: Text) + it "parses with an escaped quote" $ do + "\"foo\\\"\"" `parseMatch` ("foo\"" :: Text) + it "parses with unicode" $ do + "\"foo\\u2795\"" `parseMatch` ("foo➕" :: Text) + it "parses a text with no escapes" $ do + [r|"foo"|] `parseMatch` ("foo" :: Text) + it "parses a text with an escaped backslash" $ do + [r|"foo\\\\"|] `parseMatch` ([r|foo\\|] :: Text) + describe "parsing a two-field object" $ do + it "parses with only required fields" $ + twoSimple `parseMatch` goodTwo + it "parses with only required fields in wrong order" $ + twoScramble `parseMatch` goodTwo + it "parses with lots of extra crap" $ + twoExtra `parseMatch` goodTwo + it "parses in a weird order with extra crap" $ + twoScrambleExtra `parseMatch` goodTwo + describe "parsing a generically-derived object" $ do + it "parses correctly in the basic case" $ + genericDefault `parseMatch` GenericStruct () [()] + describe "parsing a generally-derived sum object" $ do + it "parses first correctly" $ + sumBasic `parseMatch` GenericBasic (BasicStruct ()) + it "parses first correctrly when using other alternate" $ + sumBasicObj `parseMatch` GenericBasic (BasicStruct ()) + it "parses second correctly" $ + sumTwo `parseMatch` GenericTwo (TwoFields () ()) diff --git a/test/Jordan/ToJSON/BuilderSpec.hs b/test/Jordan/ToJSON/BuilderSpec.hs new file mode 100644 --- /dev/null +++ b/test/Jordan/ToJSON/BuilderSpec.hs @@ -0,0 +1,13 @@ +module Jordan.ToJSON.BuilderSpec + ( spec + ) where + +import Data.ByteString.Lazy (toStrict) +import Data.Text.Encoding (decodeUtf8) +import Jordan.SpecDefs (basicWritingSpec) +import Jordan.ToJSON.Builder (toJSONViaBuilder) +import Test.Hspec (Spec, describe) + +spec :: Spec +spec = describe "Jordan.ToJSON.Builder" $ do + basicWritingSpec $ decodeUtf8 . toStrict . toJSONViaBuilder diff --git a/test/Jordan/ToJSON/TextSpec.hs b/test/Jordan/ToJSON/TextSpec.hs new file mode 100644 --- /dev/null +++ b/test/Jordan/ToJSON/TextSpec.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module Jordan.ToJSON.TextSpec + where + +import Data.Text (pack) +import GHC.Generics +import Jordan.SpecDefs (basicWritingSpec) +import Jordan.ToJSON.Class +import Jordan.ToJSON.Text +import Test.Hspec +import Text.RawString.QQ + +shouldRenderJSON + :: (ToJSON a, Show a, HasCallStack) + => a + -> String + -> Expectation +shouldRenderJSON f a = + runJSONText toJSON f "" `shouldBe` pack a + +data UselessTuple + = UselessTuple + { first :: () + , second :: () + } deriving (Show, Generic) + +instance ToJSON UselessTuple + +newtype NestedTuple + = NestedTuple + { getNestedTuple :: UselessTuple } + deriving (Show, Generic) + +instance ToJSON NestedTuple + +newtype WrapFoo + = WrapFoo { getFoo :: () } + deriving (Show, Generic) + +instance ToJSON WrapFoo + +newtype WrapBar + = WrapBar { getBar :: () } + deriving (Show, Generic) + +instance ToJSON WrapBar + +data PickOne + = PickFoo WrapFoo + | PickBar WrapBar + deriving (Show, Generic) + +instance ToJSON PickOne + +spec :: Spec +spec = describe "Jordan.ToJSON.Text" $ do + basicWritingSpec $ \v -> toJSONText v + arrayRendering + genericsRendering + +arrayRendering :: Spec +arrayRendering = describe "array rendering" $ do + it "renders an empty array properly" $ do + ([] :: [()]) `shouldRenderJSON` "[]" + it "renders a one-item array properly" $ do + [()] `shouldRenderJSON` "[null]" + it "renders a two-item array properly" $ do + [(), ()] `shouldRenderJSON` "[null,null]" + +genericsRendering :: Spec +genericsRendering = describe "generics rendering" $ do + it "can render a basic two-field object" $ do + UselessTuple () () `shouldRenderJSON` [r|{"first": null, "second": null}|] + it "can render a basic two-field object nested" $ do + NestedTuple (UselessTuple () ()) `shouldRenderJSON` + [r|{"getNestedTuple": {"first": null, "second": null}}|] + it "can render first case of PickOne" $ do + PickFoo (WrapFoo ()) `shouldRenderJSON` + [r|{"PickFoo": {"getFoo": null}}|] + it "can render second case of pickone" $ do + PickBar (WrapBar ()) `shouldRenderJSON` + [r|{"PickBar": {"getBar": null}}|] diff --git a/test/JordanSpec.hs b/test/JordanSpec.hs new file mode 100644 --- /dev/null +++ b/test/JordanSpec.hs @@ -0,0 +1,18 @@ +module Main + ( main + ) where + +import qualified Jordan.FromJSON.AttoparsecSpec as APS +import qualified Jordan.FromJSON.MegaparsecSpec as MPS +import qualified Jordan.RoundTripSpec as RTS +import qualified Jordan.ToJSON.BuilderSpec as BS +import qualified Jordan.ToJSON.TextSpec as TS +import Test.Hspec (hspec) + +main :: IO () +main = hspec $ do + MPS.spec + APS.spec + TS.spec + BS.spec + RTS.spec