packages feed

jordan (empty) → 0.1.0.0

raw patch · 19 files changed

+2346/−0 lines, 19 filesdep +QuickCheckdep +attoparsecdep +base

Dependencies added: QuickCheck, attoparsec, base, bytestring, containers, contravariant, hspec, hspec-megaparsec, jordan, megaparsec, parser-combinators, quickcheck-text, raw-strings-qq, scientific, text

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for jordan++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -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.
+ jordan.cabal view
@@ -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
+ lib/Jordan.hs view
@@ -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)
+ lib/Jordan/FromJSON/Attoparsec.hs view
@@ -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
+ lib/Jordan/FromJSON/Class.hs view
@@ -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
+ lib/Jordan/FromJSON/Megaparsec.hs view
@@ -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
+ lib/Jordan/FromJSON/ParseInternal.hs view
@@ -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
+ lib/Jordan/Generic/Options.hs view
@@ -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 }
+ lib/Jordan/ToJSON/Builder.hs view
@@ -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
+ lib/Jordan/ToJSON/Class.hs view
@@ -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
+ lib/Jordan/ToJSON/Text.hs view
@@ -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 ""
+ test/Jordan/FromJSON/AttoparsecSpec.hs view
@@ -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
+ test/Jordan/FromJSON/MegaparsecSpec.hs view
@@ -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
+ test/Jordan/RoundTripSpec.hs view
@@ -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)
+ test/Jordan/SpecDefs.hs view
@@ -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 () ())
+ test/Jordan/ToJSON/BuilderSpec.hs view
@@ -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
+ test/Jordan/ToJSON/TextSpec.hs view
@@ -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}}|]
+ test/JordanSpec.hs view
@@ -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