jordan 0.1.0.0 → 0.2.0.0

raw patch · 27 files changed

+3279/−1434 lines, 27 filesdep +deepseqdep +ghc-primdep −megaparsecdep ~basedep ~textPVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq, ghc-prim

Dependencies removed: megaparsec

Dependency ranges changed: base, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−1
• jordan.cabal +18/−17
• lib/Jordan.hs +76/−31
• lib/Jordan/FromJSON/Attoparsec.hs +91/−241
• lib/Jordan/FromJSON/Class.hs +286/−125
• lib/Jordan/FromJSON/Internal/Attoparsec.hs +431/−0
• lib/Jordan/FromJSON/Internal/Permutation.hs +153/−0
• lib/Jordan/FromJSON/Internal/UnboxedParser.hs +546/−0
• lib/Jordan/FromJSON/Internal/UnboxedReporting.hs +351/−0
• lib/Jordan/FromJSON/Megaparsec.hs +0/−295
• lib/Jordan/FromJSON/ParseInternal.hs +0/−120
• lib/Jordan/FromJSON/UnboxedReporting.hs +246/−0
• lib/Jordan/Generic/Options.hs +75/−4
• lib/Jordan/ToJSON/Builder.hs +37/−31
• lib/Jordan/ToJSON/Class.hs +235/−98
• lib/Jordan/ToJSON/Text.hs +0/−142
• lib/Jordan/Types/Internal/AccumE.hs +115/−0
• lib/Jordan/Types/Internal/MergeMap.hs +28/−0
• lib/Jordan/Types/JSONError.hs +107/−0
• lib/Jordan/Types/JSONType.hs +23/−0
• lib/Jordan/Types/JSONValue.hs +68/−0
• test/Jordan/FromJSON/MegaparsecSpec.hs +0/−59
• test/Jordan/FromJSON/UnboxedReportingSpec.hs +25/−0
• test/Jordan/RoundTripSpec.hs +195/−94
• test/Jordan/SpecDefs.hs +153/−85
• test/Jordan/ToJSON/TextSpec.hs +0/−85
• test/JordanSpec.hs +5/−6

@@ -1,5 +1,19 @@ # Revision history for jordan -## 0.1.0.0 -- YYYY-mm-dd+## 0.2.0.0 - 2022-07-04 +* Removed support for serializing to `Text`.+* Removed support for parsing via Megaparsec.+* Added support for parsing directly to a value or an error report, via a custom unbox-sum-based parser type.+* Added `parseFieldWithDefault`.+* Added `serializeJust`.+* Changed the methods of `JSONObjectSerializer` and `JSONTupleSerializer` to be more consistent with the rest of the library.+* Got rid of mandatory identifiers for object parsers.+* Got rid of mandatory identifiers for object serializers.+* Improved Generic Deriving Mechanisms.+* Lots of optimizations.++## 0.1.0.0 -- ???+ * First version. Released on an unsuspecting world.+* I forgot to document this originally.

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               jordan-version:            0.1.0.0+version:            0.2.0.0 synopsis:           JSON with Structure  -- A longer description of the package.@@ -38,30 +38,32 @@     , 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+    , text >= 1.2.3.0 && <2.1     , contravariant >= 1.5.5 && <1.6     , parser-combinators >= 1.3.0 && < 1.4+    , deepseq >= 1.4 && <= 1.5+    , ghc-prim >= 0.6.1 && <0.9+    , base >= 4.14.1 && <4.17  library     import: build-deps     exposed-modules:         Jordan.FromJSON.Class-      , Jordan.FromJSON.Megaparsec       , Jordan.FromJSON.Attoparsec-      , Jordan.FromJSON.ParseInternal+      , Jordan.FromJSON.Internal.Attoparsec+      , Jordan.FromJSON.Internal.UnboxedParser+      , Jordan.FromJSON.Internal.Permutation+      , Jordan.FromJSON.Internal.UnboxedReporting+      , Jordan.FromJSON.UnboxedReporting+      , Jordan.Types.Internal.MergeMap+      , Jordan.Types.Internal.AccumE+      , Jordan.Types.JSONValue+      , Jordan.Types.JSONType+      , Jordan.Types.JSONError       , 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 @@ -75,14 +77,13 @@       , QuickCheck       , quickcheck-text     other-modules:-        Jordan.FromJSON.MegaparsecSpec-      , Jordan.FromJSON.AttoparsecSpec+        Jordan.FromJSON.AttoparsecSpec+      , Jordan.FromJSON.UnboxedReportingSpec       , 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+    ghc-options: -fprint-potential-instances

@@ -2,39 +2,84 @@ -- -- 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+  ( -- * JSON Parsing +    -- ** Abstractly+    FromJSON (..),+    JSONParser (..),+    JSONObjectParser (..),+    JSONTupleParser (..),++    -- ** Concretely++    -- *** Via Attoparsec+    -- $viaAP+    parseViaAttoparsec,+    parseViaAttoparsecWith,+    attoparsecParser,+    attoparsecParserFor,++    -- *** With Error Reporting+    -- $withReport+    parseOrReport,+    parseOrReportWith,++    -- *** Generically+    gFromJSON,+    FromJSONOptions (..),++    -- * JSON Serialization++    -- ** Abstractly+    ToJSON (..),+    JSONSerializer (..),+    JSONObjectSerializer (..),++    -- **** Re-Exports for Serialization+    Contravariant (..),+    Divisible (..),+    Selectable (..),++    -- ** Concretely+    toJSONAsBuilder,+    toJSONViaBuilder,++    -- *** Generically+    gToJSON,+    ToJSONOptions (..),++    -- * Parsing or Serializing Arbitrary JSON+    JSONValue (..),++    -- * Newtypes for DerivingVia+    WithOptions (..),+    OmitNothingFields,+    KeepNothingFields,+  )+where++import Data.Functor.Contravariant+import Data.Functor.Contravariant.Divisible import Jordan.FromJSON.Attoparsec import Jordan.FromJSON.Class-import Jordan.FromJSON.Megaparsec+import Jordan.FromJSON.UnboxedReporting+import Jordan.Generic.Options import Jordan.ToJSON.Builder (toJSONAsBuilder, toJSONViaBuilder) import Jordan.ToJSON.Class-import Jordan.ToJSON.Text (toJSONText)+import Jordan.Types.JSONValue (JSONValue (..))++-- $viaAP+--+-- These parsers use the excellent Attoparsec library to do their work.+-- This means that they're quite fast, but that they also provide less-than-ideal error messages.+-- You should use these when speed is needed, or when you're reasonably certain that nobody will make a mistake.+-- APIs intended only for internal use, for example.++-- $withReport+--+-- These parsers parse to either a value or an *error report*, which is a detailed report of what exactly what wrong.+-- This uses a roll-our-own parsing library based on *unboxed sums*.+-- It's been tested via QuickCheck, but it is doing some spooky-scary raw pointer opertions.+--+-- This is a bit slower than the attoparsec parser, but *much* better at error handling.+-- Use it for external-facing APIs---assuming that you trust my ability to write primops.

@@ -1,276 +1,115 @@+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+ -- | 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.+-- This means that it is pretty fast!+-- However, you also get basically *zero* error reporting, which is generally not what you want. module Jordan.FromJSON.Attoparsec-    ( convertParserToAttoparsecParser-    , runParserViaAttoparsec-    , parseViaAttoparsec-    , attoparsecParser-    ) where+  ( attoparsecParserFor,+    parseViaAttoparsecWith,+    parseViaAttoparsec,+    attoparsecParser,+  )+where -import Control.Applicative (Alternative(..))+import Control.Applicative (Alternative (..))+import Control.Monad (void, when) import Data.Attoparsec.ByteString ((<?>))+import qualified Data.Attoparsec.ByteString as A import qualified Data.Attoparsec.ByteString as AP import qualified Data.Attoparsec.ByteString.Char8 as CH+import qualified Data.Attoparsec.Combinator as AC import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B import Data.Char (chr, digitToInt, isControl, isHexDigit, ord) import Data.Functor (void, ($>))-import Data.Monoid (Alt(..))+import Data.Monoid (Alt (..)) import Data.Scientific (Scientific)+import qualified Data.Scientific as Sci+import qualified Data.Scientific as Scientific import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Debug.Trace import Jordan.FromJSON.Class-import Jordan.FromJSON.ParseInternal+import Jordan.FromJSON.Internal.Attoparsec+import Jordan.FromJSON.Internal.Permutation import Numeric (showHex)-import qualified Text.Megaparsec as Text -newtype ObjectParser a-  = ObjectParser-  { runObjectParser :: Permutation AP.Parser a }+newtype ObjectParser a = ObjectParser+  {runObjectParser :: Permutation AP.Parser a}   deriving (Functor, Applicative) -newtype ArrayParser a-  = ArrayParser-  { runArrayParser :: AP.Parser a }+type role ArrayParser representational++data ArrayParser a+  = ParseNoEffect a+  | ParseWithEffect (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+  pure = ParseNoEffect+  f <*> a = case f of+    ParseNoEffect fab -> case a of+      ParseNoEffect a' -> ParseNoEffect (fab a')+      ParseWithEffect pa -> ParseWithEffect (fab <$> pa)+    ParseWithEffect pa -> case a of+      ParseNoEffect a' -> ParseWithEffect (fmap ($ a') pa)+      ParseWithEffect pa' -> ParseWithEffect $ do+        f' <- pa+        comma+        f' <$> pa' -parseDictField-  :: AP.Parser a-  -> AP.Parser (Text.Text, a)-parseDictField p = do-  key <- parseJSONText-  labelSep-  val <- p-  pure (key, val)+runArrayParser :: ArrayParser a -> AP.Parser a+runArrayParser (ParseNoEffect a) = pure a+runArrayParser (ParseWithEffect eff) = eff  instance JSONObjectParser ObjectParser where-  parseFieldWith label-    = ObjectParser-    . asPermutation-    . parseObjectField label-    . runAttoparsecParser+  parseFieldWith label parser =+    ObjectParser $+      asPermutation $+        parseObjectField+          label+          (runAttoparsecParser parser)+  {-# INLINE parseFieldWith #-}+  parseFieldWithDefault f = \(AttoparsecParser parseField) def ->+    ObjectParser $+      asPermutationWithDefault (parseObjectField f (parseField <?> ("field " <> show f))) def -newtype AttoparsecParser a-  = AttoparsecParser-  { runAttoparsecParser :: AP.Parser a }+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+  consumeItemWith = \parser -> ParseWithEffect $ runAttoparsecParser parser  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+  parseObject = \parser -> AttoparsecParser $+    label "Object" $ do+      startObject+      r <- wrapEffect (parseAnyField <?> "ignored field in the middle of an object") comma $ runObjectParser parser+      objectEndWithJunk+      pure r+  {-# INLINE parseObject #-}+  parseDictionary parse = AttoparsecParser $+    inObjectBraces $ do+      parseDictField (runAttoparsecParser parse) `AP.sepBy` comma   parseTextConstant c = AttoparsecParser (objectKey c <?> "text constant" <> Text.unpack c)+  {-# INLINE parseTextConstant #-}   parseText = AttoparsecParser parseJSONText+  {-# INLINE parseText #-}   parseNumber = AttoparsecParser number+  {-# INLINE parseNumber #-}   validateJSON v = AttoparsecParser $ do     r <- runAttoparsecParser v     case r of@@ -281,27 +120,38 @@     r <- runArrayParser ap     lexeme $ AP.word8 93     pure r+  {-# INLINE parseTuple #-}   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)+  {-# INLINE parseArrayWith #-}+  parseBool =+    AttoparsecParser $+      lexeme $+        (AP.string "true" $> True) <|> (AP.string "false" $> False)   parseNull = AttoparsecParser $ lexeme (AP.string "null" $> ())+  nameParser l = \(AttoparsecParser a) ->+    AttoparsecParser $+      label ("Parser '" <> Text.unpack l <> "'") a  -- | 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+attoparsecParserFor :: (forall parser. JSONParser parser => parser a) -> AP.Parser a+attoparsecParserFor = \parser -> (skipSpace *>) $ runAttoparsecParser parser+{-# INLINE attoparsecParserFor #-} -runParserViaAttoparsec :: (forall parser. JSONParser parser => parser a) -> ByteString -> Either String a-runParserViaAttoparsec p = AP.parseOnly (convertParserToAttoparsecParser p)+parseViaAttoparsecWith :: (forall parser. JSONParser parser => parser a) -> ByteString -> Either String a+parseViaAttoparsecWith p = AP.parseOnly (attoparsecParserFor p)+{-# INLINE parseViaAttoparsecWith #-}  -- | Parse a ByteString via an Attoparsec Parser.-parseViaAttoparsec :: (FromJSON val) => ByteString -> Either String val-parseViaAttoparsec = AP.parseOnly (skipSpace *> runAttoparsecParser fromJSON)+parseViaAttoparsec :: forall val. (FromJSON val) => ByteString -> Either String val+parseViaAttoparsec = parseViaAttoparsecWith (fromJSON @val)+{-# INLINE parseViaAttoparsec #-}  -- | Get an Attoparsec parser for a particular JSON-parsable value. attoparsecParser :: (FromJSON val) => AP.Parser val attoparsecParser = runAttoparsecParser fromJSON+{-# INLINE attoparsecParser #-}

@@ -1,9 +1,11 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-}@@ -11,133 +13,219 @@ {-# 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+module Jordan.FromJSON.Class where -import Control.Applicative (Alternative(..))+import Control.Applicative (Alternative (..))+import Data.Coerce import Data.Functor (($>))+import qualified Data.Int as I+import Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import qualified Data.Monoid as Monoid-import Data.Proxy (Proxy(..))+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 qualified Data.Text.Read as TR import Data.Typeable import GHC.Generics+import GHC.TypeLits (KnownSymbol, symbolVal) import Jordan.Generic.Options  -- | A class for parsing JSON objects.-class (Applicative f) => JSONObjectParser f where+class (Applicative f, Representational 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.+  parseFieldWith ::+    -- | Label of the field.     -- Will be parsed into escaped text, if need be.-    -> (forall valueParser. JSONParser valueParser => valueParser a)-    -- ^ How to parse the field.+    T.Text ->+    -- | 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+    (forall valueParser. JSONParser valueParser => valueParser a) ->+    f a++  parseDescribeFieldWith ::+    -- | Field key to parse+    T.Text ->+    -- | Description of the field+    T.Text ->+    -- | Parser for the field+    (forall valueParser. JSONParser valueParser => valueParser a) ->+    f a+  parseDescribeFieldWith field _ = parseFieldWith field+  parseField ::+    (FromJSON v) =>+    T.Text ->+    f v   parseField t = parseFieldWith t fromJSON+  {-# INLINE parseField #-}+  parseDescribeField ::+    (FromJSON v) =>+    T.Text ->+    T.Text ->+    f v+  parseDescribeField key desc = parseDescribeFieldWith key desc fromJSON+  parseFieldWithDefault ::+    -- | Label of the field.+    T.Text ->+    -- | Parse the value from the field+    (forall valueParser. JSONParser valueParser => valueParser a) ->+    -- | Default value for the field+    a ->+    -- | Field in the object.+    f a+  parseDescribeFieldWithDefault ::+    -- | Label of the field+    T.Text ->+    -- | Description of the field+    T.Text ->+    -- | Parser for the field+    (forall valueParser. JSONParser valueParser => valueParser a) ->+    a ->+    f a+  parseDescribeFieldWithDefault field _ = parseFieldWithDefault field  -- | A class for parsing JSON arrays.-class (Applicative f) => JSONTupleParser f where+class (Applicative f, Representational 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+  consumeItemWith ::+    (forall valueParser. JSONParser valueParser => valueParser a) ->+    f a+   -- | Consume a single array item.-  consumeItem-    :: (FromJSON v)-    => f v+  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.+class (Functor f, forall a. Semigroup (f a), Representational f) => JSONParser f where+  parseObject ::+    -- | 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+    (forall objectParser. JSONObjectParser objectParser => objectParser a) ->+    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 ::+    (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)]+  parseDictionary ::+    (forall jsonParser. JSONParser jsonParser => jsonParser a) ->+    f [(T.Text, a)]    -- | Parse a text field.-  parseText-    :: f T.Text-  parseTextConstant-    :: T.Text-    -> f ()+  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]+  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+  parseArrayWith ::+    (forall jsonParser. JSONParser jsonParser => jsonParser a) ->+    f [a]+  parseNumber ::+    f Scientific+  parseInteger ::+    f Integer+  parseInteger = round <$> parseNumber+  parseNull ::+    f ()+  parseBool ::+    f Bool+  validateJSON ::+    f (Either T.Text a) ->+    f a +  -- | Give a parser a unique name.+  -- May be used for documentation.+  nameParser ::+    T.Text ->+    f a ->+    f a+  nameParser _ a = a++  -- | Add information about the format of a particular parser.+  addFormat ::+    T.Text ->+    f a ->+    f a+  addFormat _ a = 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.+--+-- If you want to customize this JSON, the newtype 'WithOptions' can be helpful, as it allows you to specify options for the generic serialization.+-- Unfortunately, due to a weird GHC quirk, you need to use it with @ -XStandaloneDeriving @ as well as @ -XDerivingVia @.+-- That is, you should write:+--+--+-- @+-- data PersonFilter = PersonFilter { filterFirstName :: Maybe Text, filterLastName :: Maybe Text }+--   deriving (Show, Read, Eq, Ord, Generic)+--+-- deriving via (WithOptions '[KeepNothingFields] PersonFilter) instance (FromJSON PersonFilter)+-- @+--+-- === __Laws__+--+-- This instance is lawless, unless 'Jordan.ToJSON.Class.ToJSON' is also defined for this type.+-- In that case, the representation parsed by 'FromJSON' should match that of the representation serialized by+-- 'Jordan.ToJSON.Class.ToJSON'. 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+  {-# INLINE fromJSON #-}+  default fromJSON :: (Generic value, GFromJSON (Rep value), Typeable value) => (JSONParser f => f value)+  fromJSON = to <$> gFromJSON @(Rep value) defaultOptions {fromJSONBaseName = bn}+    where+      bn = T.unpack $ fullyQualifyName $ typeRep (Proxy :: Proxy value) +instance (Generic a, GFromJSON (Rep a), Typeable a, SpecifiesFromJSONOptions options) => FromJSON (WithOptions options a) where+  fromJSON = WithOptions . to <$> gFromJSON @(Rep a) (specifiedFromJSONOptions @options) {fromJSONBaseName = bn}+    where+      bn = T.unpack $ fullyQualifyName $ typeRep (Proxy :: Proxy a)+ instance FromJSON () where   fromJSON = parseNull @@ -148,7 +236,7 @@   fromJSON = T.unpack <$> parseText  instance (FromJSON a) => FromJSON (Maybe a) where-  fromJSON = (Nothing <$ parseNull) <> (Just <$> fromJSON)+  fromJSON = (Just <$> fromJSON) <> (parseNull $> Nothing)  -- | Right-biased: will try to parse a 'Right' value first. instance (FromJSON l, FromJSON r) => FromJSON (Either l r) where@@ -161,26 +249,32 @@   fromJSON = parseText  instance FromJSON Int where-  fromJSON = fmap round parseNumber+  fromJSON = fromInteger <$> parseInteger  instance FromJSON Float where-  fromJSON = realToFrac <$> parseNumber+  fromJSON = addFormat "float" $ realToFrac <$> parseNumber  instance FromJSON Double where-  fromJSON = realToFrac <$> parseNumber+  fromJSON = addFormat "double" $ realToFrac <$> parseNumber +instance FromJSON I.Int32 where+  fromJSON = addFormat "int32" $ fromInteger <$> parseInteger++instance FromJSON I.Int64 where+  fromJSON = addFormat "int64" $ fromInteger <$> parseInteger+ instance FromJSON Integer where-  fromJSON = fmap round parseNumber+  fromJSON = parseInteger  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 forall a. (Integral a, FromJSON a) => FromJSON (Ratio.Ratio a) where+  fromJSON =+    parseObject $+      (Ratio.%)+        <$> parseDescribeField "num" "numerator of the ratio"+        <*> parseDescribeField "denom" "denominator of the ratio"  instance FromJSON a => FromJSON (Monoid.Dual a) where   fromJSON = Monoid.Dual <$> fromJSON@@ -228,95 +322,162 @@ 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+instance FromJSON a => FromJSON (Map.Map Integer a) where+  fromJSON = foldMap toSingleDict <$> parseDictionary fromJSON+    where+      toSingleDict (k, v) = case TR.signed TR.decimal k of+        Left s -> mempty+        Right (i, rest) -> if rest == mempty then Map.singleton i v else mempty++instance (FromJSON a) => FromJSON (NE.NonEmpty a) where+  fromJSON = validateJSON $ fmap toNonEmpty parseArray+    where+      toNonEmpty a = case NE.nonEmpty a of+        Nothing -> Left "Empty list"+        Just a -> pure a++data FromJSONOptions = FromJSONOptions+  { fromJSONEncodeSums :: SumTypeEncoding,+    fromJSONBaseName :: String,+    convertEnum :: String -> String,+    fromJSONOmitNothingFields :: Bool   }   deriving (Generic)  defaultOptions :: FromJSONOptions-defaultOptions = FromJSONOptions TagInField "" id+defaultOptions = FromJSONOptions TagInField "" id True +class SpecifiesFromJSONOptions (a :: [*]) where+  specifiedFromJSONOptions :: FromJSONOptions++instance SpecifiesFromJSONOptions '[] where+  specifiedFromJSONOptions = defaultOptions++instance+  (SpecifiesFromJSONOptions xs) =>+  SpecifiesFromJSONOptions (OmitNothingFields ': xs)+  where+  specifiedFromJSONOptions = (specifiedFromJSONOptions @xs) {fromJSONOmitNothingFields = True}++instance+  (SpecifiesFromJSONOptions xs) =>+  SpecifiesFromJSONOptions (KeepNothingFields ': xs)+  where+  specifiedFromJSONOptions =+    (specifiedFromJSONOptions @xs) {fromJSONOmitNothingFields = False}+ addName :: String -> FromJSONOptions -> FromJSONOptions-addName s d = d { fromJSONBaseName = fromJSONBaseName d <> s }+addName s d = d {fromJSONBaseName = fromJSONBaseName d <> s}  class GFromJSON v where   gFromJSON :: (JSONParser f) => FromJSONOptions -> f (v a) +-- | Top-level metadata is ignored. instance (FromJSON c) => GFromJSON (K1 i c) where   gFromJSON _ = K1 <$> fromJSON +-- | Datatype metadata: we name the overall datatype with the baseName+-- provided in the options, then serialize the inner information. 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+  gFromJSON opts = nameParser (T.pack (fromJSONBaseName opts)) $ M1 <$> gFromJSON opts -instance {-# OVERLAPPABLE #-} forall c i. (GFromJSONObject i, Constructor c) => GFromJSON (C1 c i) where-  gFromJSON opts = M1 <$> parseObject (T.pack name) (gFromJSONObject opts)+-- | If we have a constructor with arguments, and those arguments+-- do not have selectors (IE, this is not a record), then we should parse as a tuple.+instance+  {-# OVERLAPPABLE #-}+  (GFromJSONTuple inner, KnownSymbol n) =>+  GFromJSON (C1 (MetaCons n s 'False) inner)+  where+  gFromJSON opts = nameParser objName $ M1 <$> parseTuple (gFromJSONTuple 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+      objName = T.pack (fromJSONBaseName opts) <> "." <> conName+      conName = T.pack $ symbolVal (Proxy :: Proxy n) -instance {-# OVERLAPS #-} (Constructor t) => GFromJSON (C1 t U1) where-  gFromJSON opts = M1 U1 <$ parseTextConstant conn+-- | If we have a constructor with arguments, and those arguments+-- do have selectors (IE, this is a record), then we should parse as a record.+instance {-# OVERLAPS #-} forall c i n s. (GFromJSONObject i, KnownSymbol n) => GFromJSON (C1 (MetaCons n s 'True) i) where+  gFromJSON opts = M1 <$> nameParser (T.pack name) (parseObject $ gFromJSONObject opts)     where-      conn = T.pack $ conName c-      c :: C1 t U1 f-      c = undefined+      name = fromJSONBaseName opts <> "." <> symbolVal (Proxy @n) -instance {-# OVERLAPS #-} (Constructor t) => GFromJSON (PartOfSum (C1 t U1)) where-  gFromJSON opts = PartOfSum (M1 U1) <$ parseTextConstant enumValue+-- | Special-case: a one-argument constructor with no field selector gets its own parser, skipping the tuple entirely.+instance {-# OVERLAPS #-} (FromJSON inner, KnownSymbol n) => GFromJSON (C1 (MetaCons n s 'False) (S1 (MetaSel Nothing ss su dl) (Rec0 inner))) where+  gFromJSON opts =+    M1 . M1 . K1+      <$> fromJSON     where-      enumValue = T.pack $ convertEnum opts $ conName (undefined :: C1 t U1 f)+      connName = T.pack $ symbolVal $ Proxy @n -instance {-# OVERLAPPING #-} (GFromJSON (C1 t f), Constructor t) => GFromJSON (PartOfSum (C1 t f)) where-  gFromJSON opts  = PartOfSum <$> encoded+-- | When rendering a sum type, if we have a more complex value (IE, maybe+-- this is a constructor that takes arguments), we want to use whatever+-- sum encoding was provided in the options.+instance {-# OVERLAPPABLE #-} (GFromJSON (C1 t f), Constructor t) => GFromJSON (PartOfSum (C1 t f)) where+  gFromJSON opts = MkPartOfSum <$> 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)+      tagged =+        parseObject $+          parseFieldWith "tag" (parseTextConstant name)+            *> parseFieldWith "val" (gFromJSON opts)+      field =+        parseObject $+          parseFieldWith name (gFromJSON opts)       name = T.pack $ conName (undefined :: C1 t f a)-      objName a = T.pack (fromJSONBaseName opts <> ".") <> a <> ".Input"+      objName = T.pack (fromJSONBaseName opts <> ".") <> name +instance {-# OVERLAPPABLE #-} (KnownSymbol connName) => GFromJSON (C1 (MetaCons connName dontCare 'False) U1) where+  gFromJSON _ = M1 U1 <$ parseTextConstant constName+    where+      constName = T.pack (symbolVal $ Proxy @connName)++instance {-# OVERLAPS #-} (KnownSymbol connName) => GFromJSON (PartOfSum (C1 (MetaCons connName dontCare 'False) U1)) where+  gFromJSON opts = MkPartOfSum <$> gFromJSON opts++-- | If we can parse both sides of a sum-type, we can parse the entire sum type. 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)+instance {-# OVERLAPS #-} (GFromJSON (PartOfSum l), GFromJSON (PartOfSum r)) => GFromJSON (PartOfSum (l :+: r)) where+  gFromJSON opts =+    MkPartOfSum+      <$> (L1 . getPartOfSum <$> gFromJSON opts) <> (R1 . getPartOfSum <$> gFromJSON opts) +-- | Class that helps us parse JSON objects. 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 {-# OVERLAPPABLE #-} (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 {-# OVERLAPS #-} (FromJSON c, Selector t) => GFromJSONObject (S1 t (K1 v (Maybe c))) where+  gFromJSONObject o =+    M1 . K1 <$> parse+    where+      parse+        | fromJSONOmitNothingFields o = parseFieldWithDefault field ((Just <$> fromJSON) <> (parseNull $> Nothing)) Nothing+        | otherwise = parseField field+      field = T.pack $ selName v+      v :: M1 S t f a+      v = undefined+ instance (GFromJSONObject lhs, GFromJSONObject rhs) => GFromJSONObject (lhs :*: rhs) where   gFromJSONObject o = (:*:) <$> gFromJSONObject o <*> gFromJSONObject o++class GFromJSONTuple v where+  gFromJSONTuple :: (JSONTupleParser f) => FromJSONOptions -> f (v a)++instance (GFromJSONTuple lhs, GFromJSONTuple rhs) => GFromJSONTuple (lhs :*: rhs) where+  gFromJSONTuple o = (:*:) <$> gFromJSONTuple o <*> gFromJSONTuple o++instance (GFromJSON f) => GFromJSONTuple (S1 (MetaSel Nothing su ss ds) f) where+  gFromJSONTuple o = M1 <$> consumeItemWith (gFromJSON o)

@@ -0,0 +1,431 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module Jordan.FromJSON.Internal.Attoparsec where++import Control.Applicative (Alternative (..))+import Control.Monad (void, when)+import Data.Attoparsec.ByteString ((<?>))+import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.ByteString as AP+import qualified Data.Attoparsec.ByteString.Char8 as CH+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B+import Data.Char (chr, digitToInt, isControl, isHexDigit, ord)+import Data.Functor (void, ($>))+import Data.Monoid (Alt (..))+import Data.Scientific (Scientific)+import qualified Data.Scientific as Sci+import qualified Data.Scientific as Scientific+import qualified Data.Text as Text+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Numeric (showHex)++skipSpace :: AP.Parser ()+skipSpace = AP.skipWhile isSpace <?> "skipped space"+  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 =+  {-# SCC ignoredObjectField #-}+  label "ignored object field" $+    void $ do+      lexeme parseJunkText+      labelSep+      anyDatum++objectEndWithJunk :: AP.Parser ()+objectEndWithJunk = endObject <|> junkFieldAndEnd+  where+    junkFieldAndEnd = void $ do+      comma+      label "ignored extra field at object end" parseAnyField+      objectEndWithJunk++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++-- | A parser for a JSON text value that skips its input.+-- Avoids doing UTF-8 Decoding.+parseJunkText :: AP.Parser ()+parseJunkText = label "Ignored JSON Text Literal" $ do+  quotation+  junkInnerText+{-# INLINE parseJunkText #-}++-- | Parses the bit of a JSON string after the quotation.+innerText :: AP.Parser Text.Text+innerText = do+  chunk <- label "Skipped text body" $+    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 "Impossibe: Parsed until we parsed a '\\' or a '\"', yet next char was neither"++junkInnerText :: AP.Parser ()+junkInnerText =+  {-# SCC ignoredTextBetweenQuotes #-}+  do+    AP.skipWhile $ \char -> char /= 92 && char /= 34+    !l <- AP.peekWord8+    case l of+      Nothing -> fail "string without end"+      Just 34 -> AP.anyWord8 $> ()+      Just 93 -> do+        AP.anyWord8+        parseEscape+        -- Yes we could save a miniscule amount of time by replacing this with an "ignoring" version.+        -- However, laziness means that we probably don't save *that* much.+        junkInnerText+      Just _ -> fail "Impossible: Skipped until we parsed a '\\' or a '\"', yet next char was neither"+{-# INLINE junkInnerText #-}++parseEscape :: AP.Parser Text.Text+parseEscape =+  quote+    <|> backslash+    <|> solidus+    <|> backspace+    <|> formfeed+    <|> linefeed+    <|> carriage+    <|> tab+    <|> escaped+  where+    backslash = AP.string "\\" $> "\\" <?> "Backslash escape"+    quote = AP.string "\"" $> "\"" <?> "Quote escape"+    solidus = AP.string "/" $> "/" <?> "Solidus escape"+    backspace = AP.string "b" $> "\b" <?> "Backspace escape"+    formfeed = AP.string "f" $> "\f" <?> "Formfeed escape"+    linefeed = AP.string "n" $> "\n" <?> "Linefeed escape"+    carriage = AP.string "r" $> "\r" <?> "Carriage escape"+    tab = AP.string "t" $> "\t" <?> "Tab escape"+    escaped = label "UTF Code Escape" $ 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++mustBeEscaped :: Char -> Bool+mustBeEscaped = \case+  '\\' -> True+  '"' -> True+  '/' -> True+  '\b' -> True+  '\f' -> True+  '\n' -> True+  '\r' -> True+  '\t' -> True+  _ -> False++canParseDirectly :: Text.Text -> Bool+canParseDirectly t = not $ Text.foldr (\c v -> v || mustBeEscaped c) False t++parseTextBody :: Text.Text -> AP.Parser ()+parseTextBody text+  | canParseDirectly text = void (A.string (encodeUtf8 text)) <|> parseViaChars text+  | otherwise = parseViaChars text++parseViaChars = Text.foldr (\c a -> parseCharInText c *> a) (pure ())++objectKey :: Text.Text -> AP.Parser ()+objectKey k = lexeme $ do+  quotation+  {-# SCC "knownObjectKeyBetweenQuotes" #-} parseTextBody 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 $+    {-# SCC "ignoredJSONValue" #-}+    do+      t <- AP.peekWord8+      case t of+        Just 102 -> void $ AP.string "false"+        Just 110 -> void $ AP.string "null"+        Just 116 -> void $ AP.string "true"+        Just 123 -> anyObject+        Just 34 -> parseJunkText+        Just 43 -> parseJunkNumber+        Just 45 -> parseJunkNumber+        Just 48 -> parseJunkNumber+        Just 49 -> parseJunkNumber+        Just 50 -> parseJunkNumber+        Just 51 -> parseJunkNumber+        Just 52 -> parseJunkNumber+        Just 53 -> parseJunkNumber+        Just 54 -> parseJunkNumber+        Just 55 -> parseJunkNumber+        Just 57 -> parseJunkNumber+        Just 59 -> parseJunkNumber+        Just 91 -> anyArray+        Just _ -> fail "not a valid starter of any JSON value"+        Nothing -> fail "empty input"+{-# INLINE anyDatum #-}++anyArray :: AP.Parser ()+anyArray = label "ignored array" $+  void $ do+    startArray+    endArray <|> junkItems+  where+    junkItems = do+      anyDatum+      endArray <|> (comma *> junkItems)++parseJunkDecimalZero :: AP.Parser ()+parseJunkDecimalZero = do+  let zero = 48+  digits <- A.takeWhile1 CH.isDigit_w8+  when (B.length digits > 1 && B.unsafeHead digits == zero) $+    fail "leading zero"++parseJunkExponent :: AP.Parser ()+parseJunkExponent = label "junk exponent" $ do+  A.satisfy (\ex -> ex == 101 || ex == 69)+  A.skipWhile (\ch -> ch == 45 || ch == 43)+  parseJunkDecimalZero++parseJunkNumber :: AP.Parser ()+parseJunkNumber = do+  A.skipWhile (\ch -> ch == 45 || ch == 43)+  parseJunkDecimalZero+  -- skip decimal+  dot <- A.peekWord8+  case dot of+    Just 46 -> void $ A.anyWord8 *> A.takeWhile1 CH.isDigit_w8+    _ -> pure ()+  parseJunkExponent <|> pure ()++------ Scientific parser, copy/pasted from Aeson. ----++-- (This parser was in turn copy-pasted itself from various soruces so this is kohser)++-- A strict pair+data SP = SP !Integer {-# UNPACK #-} !Int++decimal0 :: AP.Parser Integer+decimal0 = do+  let zero = 48+  digits <- A.takeWhile1 CH.isDigit_w8+  if B.length digits > 1 && B.unsafeHead digits == zero+    then fail "leading zero"+    else return (bsToInteger digits)++-- | Parse a JSON number.+--+-- This function is wholesale copy/pasted from Aeson.+-- Thanks to them.+scientific :: AP.Parser Scientific+scientific = do+  let minus = 45+      plus = 43+  sign <- A.peekWord8'+  let !positive = sign == plus || sign /= minus+  when (sign == plus || sign == minus) $+    void A.anyWord8++  n <- decimal0++  let f fracDigits =+        SP+          (B.foldl' step n fracDigits)+          (negate $ B.length fracDigits)+      step a w = a * 10 + fromIntegral (w - 48)++  dotty <- A.peekWord8+  -- '.' -> ascii 46+  SP c e <- case dotty of+    Just 46 -> A.anyWord8 *> (f <$> A.takeWhile1 CH.isDigit_w8)+    _ -> pure (SP n 0)++  let !signedCoeff+        | positive = c+        | otherwise = - c++  let littleE = 101+      bigE = 69+  ( A.satisfy (\ex -> ex == littleE || ex == bigE)+      *> fmap (Scientific.scientific signedCoeff . (e +)) (CH.signed CH.decimal)+    )+    <|> return (Scientific.scientific signedCoeff e)+{-# INLINE scientific #-}++bsToInteger :: B.ByteString -> Integer+bsToInteger bs+  | l > 40 = valInteger 10 l [fromIntegral (w - 48) | w <- B.unpack bs]+  | otherwise = bsToIntegerSimple bs+  where+    l = B.length bs++bsToIntegerSimple :: B.ByteString -> Integer+bsToIntegerSimple = B.foldl' step 0+  where+    step a b = a * 10 + fromIntegral (b - 48) -- 48 = '0'++-- A sub-quadratic algorithm for Integer. Pairs of adjacent radix b+-- digits are combined into a single radix b^2 digit. This process is+-- repeated until we are left with a single digit. This algorithm+-- performs well only on large inputs, so we use the simple algorithm+-- for smaller inputs.+valInteger :: Integer -> Int -> [Integer] -> Integer+valInteger = go+  where+    go :: Integer -> Int -> [Integer] -> Integer+    go _ _ [] = 0+    go _ _ [d] = d+    go b l ds+      | l > 40 = b' `seq` go b' l' (combine b ds')+      | otherwise = valSimple b ds+      where+        -- ensure that we have an even number of digits+        -- before we call combine:+        ds' = if even l then ds else 0 : ds+        b' = b * b+        l' = (l + 1) `quot` 2++    combine b (d1 : d2 : ds) = d `seq` (d : combine b ds)+      where+        d = d1 * b + d2+    combine _ [] = []+    combine _ [_] = errorWithoutStackTrace "this should not happen"++-- The following algorithm is only linear for types whose Num operations+-- are in constant time.+valSimple :: Integer -> [Integer] -> Integer+valSimple base = go 0+  where+    go r [] = r+    go r (d : ds) = r' `seq` go r' ds+      where+        r' = r * base + fromIntegral d++number :: AP.Parser Scientific+number = scientific+{-# INLINE number #-}++anyObject :: AP.Parser ()+anyObject =+  {-# SCC ignoredJSONObject #-}+  label "ignored object" $+    void $ do+      startObject+      endObject <|> junkField+  where+    junkField = do+      parseAnyField+      endObject <|> (comma *> junkField)++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 <- lexeme parseJSONText+  labelSep+  val <- p+  pure (key, val)

@@ -0,0 +1,153 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}++-- | Module containing internal helpers for our parsers.+module Jordan.FromJSON.Internal.Permutation where++import Control.Applicative (Alternative (..))+import Control.Monad (void, when)+import Data.Bifunctor+import Data.Foldable (asum)+import Data.Functor.Compose+import qualified Data.Map.Lazy as Map+import Data.Maybe (fromMaybe, isJust)+import Debug.Trace++data FailingParser parser+  = FailingParser (forall a. parser a)+  | NoFailingParser++instance (Applicative parser) => Semigroup (FailingParser parser) where+  (FailingParser a) <> (FailingParser b) = FailingParser (a *> b)+  (FailingParser a) <> NoFailingParser = FailingParser a+  NoFailingParser <> (FailingParser a) = FailingParser a+  NoFailingParser <> NoFailingParser = NoFailingParser++eliminateFailing :: (Alternative parser) => FailingParser parser -> parser a+eliminateFailing (FailingParser f) = f+eliminateFailing NoFailingParser = empty++type role Permutation nominal representational++-- | 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+  = Permutation !(Maybe a) !(FailingParser parser) [Branch parser a]++type role Branch nominal representational++-- | 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 (Permutation def failing branches) =+    Permutation (f <$> def) failing (fmap f <$> branches)++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 val = Permutation (Just val) NoFailingParser empty++  t1@(Permutation defF failingF choiceF) <*> t2@(Permutation defA failingA choiceA) =+    Permutation (defF <*> defA) NoFailingParser (map ins2 choiceF ++ map ins1 choiceA)+    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) =>+  -- | 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.+  m b ->+  -- | The permutation parser to run.+  Permutation m a ->+  -- | The final parser.+  m a+wrapEffect takeSingle effAfter (Permutation def failing choices) = consumeMany+  where+    consumeMany =+      foldr ((<|>) . pars) empty choices+        -- Base case above: one of the choices of the permutation matched+        <|> (takeSingle *> effAfter *> consumeMany)+        <|> maybe empty pure def++    -- 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 (Permutation def failing choices) = (effAfter *> consumeRec) <|> maybe (eliminateFailing failing) pure def+      where+        consumeRec =+          foldr ((<|>) . pars) empty 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 (Permutation def failing choices) = asum (pars <$> choices) <|> maybe empty pure def <|> eliminateFailing failing+  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 = Permutation Nothing NoFailingParser $ pure $ Branch (pure id) p++asPermutationWithDefault :: (Alternative f) => f a -> a -> Permutation f a+asPermutationWithDefault per def = Permutation (Just def) NoFailingParser $ pure $ Branch (pure id) per++asPermutationWithFailing :: (Alternative f) => f a -> (forall b. f b) -> Permutation f a+asPermutationWithFailing parse fail = Permutation Nothing (FailingParser fail) $ pure $ Branch (pure id) parse++asPermutationWithDefaultFailing :: (Alternative f) => f a -> (forall b. f b) -> a -> Permutation f a+asPermutationWithDefaultFailing parse fail def = Permutation (Just def) (FailingParser fail) $ pure $ Branch (pure id) parse

@@ -0,0 +1,546 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnliftedNewtypes #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++-- | A parser module using unboxed types for speed.+--+-- This is done because parsing to a JSON error report needs custom handling.+module Jordan.FromJSON.Internal.UnboxedParser where++import Control.Applicative+import Control.Monad (when)+import Data.Bifunctor+import qualified Data.ByteString as BS+import Data.ByteString.Internal+import Data.Functor+import Data.Monoid (Alt (..))+import Data.Word+import Debug.Trace (trace)+import GHC.Exts+import GHC.ForeignPtr+import GHC.Prim+import GHC.Types+import GHC.Word+import qualified Jordan.Types.Internal.AccumE as AE+import Jordan.Types.JSONError (JSONArrayError, JSONError, JSONObjectError)+import System.IO.Unsafe++#if __GLASGOW_HASKELL__ > 900+-- | Type of Word8 in GHC prim land. On GHC > 9.0, this is its own type.+type WordPrim = Word8#+#elif __GLASGOW_HASKELL__ > 800+-- | Type of word8 in GHC prim land.+-- On the GHC 8 series, this is 'Word#'.+type WordPrim = Word#+#endif++-- | Newtype wrapper around the state of an input.+--+-- This is just the offset into the buffer.+newtype InputState = InputState# {getInputOffset :: Int#}++-- | Pattern synonym so we can use our above unlifted newtype like a record, if we do desire.+pattern InputState :: Int# -> InputState+pattern InputState {offset} =+  InputState# offset++{-# COMPLETE InputState #-}++maxOffset :: InputState -> InputState -> InputState+maxOffset (InputState# lhs) (InputState# rhs) =+  InputState#+    (if isTrue# (lhs ># rhs) then lhs else rhs)++-- | Environment of a parser.+--+-- This is basically unpacked parts of a ByteString.+newtype InputRead = InputRead# {getInputRead :: (# ForeignPtrContents, Addr#, Int# #)}++pattern InputRead :: ForeignPtrContents -> Addr# -> Int# -> InputRead+pattern InputRead {foreignPtr, addr, endOffset} = InputRead# (# foreignPtr, addr, endOffset #)++{-# COMPLETE InputRead #-}++-- | Unboxed type similar to 'Jordan.Types.Internal.AccumE'.+newtype AccumE err a = AccumE {getAccumE :: (# err| a #)}++pattern AccumER :: a -> AccumE err a+pattern AccumER a = AccumE (# | a #)++pattern AccumEL :: err -> AccumE err a+pattern AccumEL err = AccumE (# err | #)++{-# COMPLETE AccumEL, AccumER #-}++newtype ParseResult# err res = ParseResult# {getParseResult# :: (# (# InputState, AccumE err res #)| (# #) #)}++pattern JustParseResult :: InputState -> AccumE err res -> ParseResult# err res+pattern JustParseResult {inputState, res} = ParseResult# (# (# inputState, res #) | #)++pattern NoParseResult :: ParseResult# err res+pattern NoParseResult = ParseResult# (# | (##) #)++bimapAcc :: (err -> err') -> (a -> a') -> AccumE err a -> AccumE err' a'+bimapAcc first _ (AccumEL a) = AccumEL (first a)+bimapAcc _ second (AccumER a) = AccumER (second a)++eitherAcc :: Either err a -> AccumE err a+eitherAcc (Left e) = AccumEL e+eitherAcc (Right a) = AccumER a++appAcc ::+  Semigroup err =>+  AccumE err (a1 -> a2) ->+  AccumE err a1 ->+  AccumE err a2+appAcc (AccumER f) (AccumER a) = AccumER (f a)+appAcc (AccumEL lhs) (AccumEL rhs) = AccumEL (lhs <> rhs)+appAcc (AccumEL lhs) _ = AccumEL lhs+appAcc _ (AccumEL rhs) = AccumEL rhs++accSet :: a1 -> AccumE err a2 -> AccumE err a1+accSet a (AccumER _) = AccumER a+accSet _ (AccumEL err) = AccumEL err++{-# COMPLETE JustParseResult, NoParseResult #-}++-- | We need a parser with *error recovery*.+-- So the basic idea is that we separate errors reported during parsing from errors that make parsing stop.+-- IE, if we expect a JSON null but we get a JSON string, and the string is well-formed, we can keep parsing, but we+-- will *report* an error.+newtype Parser# s err res = Parser# {runParser :: InputRead -> InputState -> State# s -> (# State# s, ParseResult# err res #)}++bimapParser :: (err -> err') -> (a -> a') -> Parser# s err a -> Parser# s err' a'+bimapParser l r (Parser# cb) = Parser# $ \env input s ->+  case cb env input s of+    (# s', a #) ->+      (#+        s',+        case a of+          NoParseResult -> NoParseResult+          JustParseResult is e -> JustParseResult is (bimapAcc l r e)+      #)++fmapParser :: (a -> res) -> Parser# s err a -> Parser# s err res+fmapParser f (Parser# cb) = Parser# $ \env input s ->+  case cb env input s of+    (# s', a #) ->+      (#+        s,+        case a of+          NoParseResult -> NoParseResult+          JustParseResult is (AccumER !r) -> JustParseResult is (AccumER (f r))+          JustParseResult is (AccumEL !l) -> JustParseResult is (AccumEL l)+      #)+{-# INLINE fmapParser #-}++pureParser :: (Semigroup err) => a -> Parser# s err a+pureParser !a = Parser# $ \_ state s -> (# s, JustParseResult state (AccumER a) #)+{-# INLINE pureParser #-}++apParser :: (Semigroup err) => Parser# s err (a -> b) -> Parser# s err a -> Parser# s err b+apParser (Parser# fcb) (Parser# acb) = Parser# $ \env input s ->+  case fcb env input s of+    (# s', NoParseResult #) -> (# s', NoParseResult #)+    (# s', JustParseResult !input' !f #) ->+      case acb env input' s' of+        (# s'', a #) ->+          (#+            s'',+            case a of+              NoParseResult -> NoParseResult+              JustParseResult !input'' !a -> JustParseResult input'' (f `appAcc` a)+          #)+{-# SPECIALIZE apParser :: Parser# s JSONError (a -> b) -> Parser# s JSONError a -> Parser# s JSONError b #-}+{-# SPECIALIZE apParser :: Parser# s JSONObjectError (a -> b) -> Parser# s JSONObjectError a -> Parser# s JSONObjectError b #-}+{-# SPECIALIZE apParser :: Parser# s JSONArrayError (a -> b) -> Parser# s JSONArrayError a -> Parser# s JSONArrayError b #-}+{-# INLINE apParser #-}++-- | Alternative instance for a parser.+-- This has weird behavior in that, if we have two results with delayed errors, this will act as if it skipped the *largest* amount+-- of said errors.+altParser :: (Monoid err) => Parser# s err a -> Parser# s err a -> Parser# s err a+altParser (Parser# lhs) (Parser# rhs) = Parser# $ \env input s ->+  let (# s', !lhs' #) = lhs env input s+   in case lhs' of+        -- If the parser failed to parse, we also fail to parse+        NoParseResult -> rhs env input s'+        JustParseResult state (AccumER !res) -> (# s', JustParseResult state (AccumER res) #)+        JustParseResult state res@(AccumEL !err) ->+          case rhs env input s' of+            (# s'', NoParseResult #) -> (# s'', JustParseResult state res #)+            (# s'', JustParseResult state' (AccumER !res) #) -> (# s'', JustParseResult (maxOffset state state') (AccumER res) #)+            (# s'', JustParseResult state' (AccumEL !err') #) ->+              (# s'', JustParseResult (maxOffset state state') (AccumEL (err <> err')) #)+{-# SPECIALIZE altParser :: Parser# s JSONError a -> Parser# s JSONError a -> Parser# s JSONError a #-}+{-# SPECIALIZE altParser :: Parser# s JSONObjectError a -> Parser# s JSONObjectError a -> Parser# s JSONObjectError a #-}+{-# SPECIALIZE altParser :: Parser# s JSONArrayError a -> Parser# s JSONArrayError a -> Parser# s JSONArrayError a #-}+{-# INLINE altParser #-}++-- | Monadic bind for these parsers.+--+-- Note that this breaks the monad laws, as we do more error accumulation with (<*>) than we do ap.+-- Oh well.+bindParser :: Parser# s err a -> (a -> Parser# s err b) -> Parser# s err b+bindParser (Parser# arg) cont =+  Parser# $+    {-# SCC unboxedParserBindInner #-}+    \env state s ->+      let (# s', result #) = arg env state s+       in case result of+            NoParseResult -> (# s', NoParseResult #)+            JustParseResult state' (AccumEL err) -> (# s', JustParseResult state (AccumEL err) #)+            JustParseResult state' (AccumER r) -> runParser (cont r) env state' s'+{-# INLINE bindParser #-}++emptyParser :: Parser# s err a+emptyParser = Parser# $ \_ _ s -> (# s, NoParseResult #)++newtype Parser err res = Parser {getParser :: Parser# RealWorld err res}+  deriving (Semigroup, Monoid) via (Alt (Parser err) res)++instance Bifunctor Parser where+  bimap l r (Parser p) = Parser (bimapParser l r p)+  {-# INLINE bimap #-}++instance Functor (Parser err) where+  fmap f (Parser a) = Parser (fmapParser f a)+  {-# INLINE fmap #-}+  a <$ (Parser (Parser# cb)) = Parser $+    Parser# $ \env state token ->+      let (# s', res #) = cb env state token+       in case res of+            NoParseResult -> (# s', NoParseResult #)+            JustParseResult state r -> (# s', JustParseResult state (a `accSet` r) #)+  {-# INLINE (<$) #-}++instance (Semigroup err) => Applicative (Parser err) where+  pure = Parser . pureParser+  {-# INLINE pure #-}+  (Parser f) <*> (Parser a) = Parser (f `apParser` a)+  {-# INLINE (<*>) #-}+  {-# SPECIALIZE (<*>) :: Parser JSONError (a -> b) -> Parser JSONError a -> Parser JSONError b #-}+  {-# SPECIALIZE (<*>) :: Parser JSONObjectError (a -> b) -> Parser JSONObjectError a -> Parser JSONObjectError b #-}++instance (Monoid err) => Alternative (Parser err) where+  empty = Parser emptyParser+  {-# INLINE empty #-}+  (Parser l) <|> (Parser r) = Parser (l `altParser` r)+  {-# INLINE (<|>) #-}++instance (Semigroup err) => Monad (Parser err) where+  (Parser f) >>= cb = Parser (f `bindParser` (\res -> getParser (cb res)))+  {-# INLINE (>>=) #-}++parseBSIO :: Parser err res -> ByteString -> IO (Maybe (AE.AccumE err res))+parseBSIO (Parser (Parser# cb)) (PS (ForeignPtr addr contents) offset' len) = IO parse'+  where+    (I# endOffset) = offset' + len+    (I# startOffset) = offset'+    parse' s =+      let (# s', res #) = cb (InputRead contents addr endOffset) (InputState# startOffset) s+       in case res of+            NoParseResult -> (# s', Nothing #)+            JustParseResult _ (AccumEL err) -> (# s', Just (AE.AccumEL err) #)+            JustParseResult _ (AccumER res) -> (# s', Just (AE.AccumER res) #)++parseBS :: Parser err res -> ByteString -> Maybe (AE.AccumE err res)+parseBS parser bs = unsafeDupablePerformIO (parseBSIO parser bs)++currentOffset :: Parser err Int+currentOffset = Parser $+  Parser# $ \env i@(InputState# cs) s ->+    (# s, JustParseResult i (AccumER (I# cs)) #)+{-# INLINE currentOffset #-}++getEndOffset :: Parser err Int+getEndOffset = Parser $+  Parser# $ \env i s ->+    (# s, JustParseResult i (AccumER (I# (endOffset env))) #)+{-# INLINE getEndOffset #-}++parsedPtr :: Parser err (ForeignPtr Word8)+parsedPtr = Parser $+  Parser# $ \env i s -> (# s, JustParseResult i (AccumER $ ForeignPtr (addr env) (foreignPtr env)) #)++currentEnv :: Parser err (ForeignPtrContents, Ptr a, Int)+currentEnv = Parser $+  Parser# $ \env i s -> (# s, JustParseResult i (AccumER (foreignPtr env, Ptr (addr env), I# (endOffset env))) #)++failParse :: Parser err a+failParse = Parser $+  Parser# $ \env i s -> (# s, NoParseResult #)++maybeWord :: Parser err (Maybe Word8)+maybeWord = Parser $+  Parser# $ \env state@(InputState# input) s ->+    if isTrue# (input ==# endOffset env)+      then (# s, JustParseResult state (AccumER Nothing) #)+      else+        let (# s', word #) = readWord8OffAddr# (addr env) input s+         in (# s', JustParseResult (InputState# (input +# 1#)) (AccumER $ Just $ W8# word) #)++orFail :: Parser err (Maybe a) -> Parser err a+orFail (Parser (Parser# cb)) = Parser $+  Parser# $ \env s state ->+    let (# s', r #) = cb env s state+     in case r of+          NoParseResult -> (# s', NoParseResult #)+          JustParseResult state a ->+            case a of+              AccumER (Just a) -> (# s', JustParseResult state (AccumER a) #)+              _ -> (# s', NoParseResult #)++failWith :: err -> Parser err a+failWith err = Parser $+  Parser# $ \env s state -> (# state, JustParseResult s (AccumEL err) #)++asFailure :: Parser err err -> Parser err a+asFailure (Parser (Parser# cb)) = Parser $+  Parser# $ \env s state ->+    let (# s', r #) = cb env s state+     in case r of+          NoParseResult -> (# s', NoParseResult #)+          JustParseResult state a ->+            case a of+              AccumER a -> (# s', JustParseResult state (AccumEL a) #)+              AccumEL a -> (# s', JustParseResult state (AccumEL a) #)++-- | Lower a parsed error to a *parser error*.+lowerErr :: Parser err (Either err a) -> Parser err a+lowerErr (Parser (Parser# cb)) = Parser $+  Parser# $ \env s state ->+    let (# s', r #) = cb env s state+     in case r of+          NoParseResult -> (# s', NoParseResult #)+          JustParseResult state res ->+            case res of+              AccumER e -> (# s', JustParseResult state (eitherAcc e) #)+              AccumEL l -> (# s', JustParseResult state (AccumEL l) #)++-- | Do we have any further input?+hasFurther :: Parser err Bool+hasFurther = Parser $+  Parser# $ \env i@(InputState# input) s ->+    if isTrue# (input ==# endOffset env)+      then (# s, JustParseResult i (AccumER False) #)+      else (# s, JustParseResult i (AccumER True) #)++-- | Advance forward one word, fail if we can't+advanceWord :: Parser err ()+advanceWord = Parser $+  Parser# $ \env (InputState# input) s ->+    if isTrue# (input ==# endOffset env)+      then (# s, NoParseResult #)+      else (# s, JustParseResult (InputState# (input +# 1#)) (AccumER ()) #)++-- | Peek the next word, fail if there's nothing there+peekWord :: Parser err Word8+peekWord = Parser $+  Parser# $ \env i@(InputState# input) s ->+    if isTrue# (input ==# endOffset env)+      then (# s, NoParseResult #)+      else+        let (# s', word #) = readWord8OffAddr# (addr env) input s+         in (# s', JustParseResult i (AccumER $ W8# word) #)++-- | Peek a word, or nothing.+-- Never fails.+peekWordMaybe :: Parser err (Maybe Word8)+peekWordMaybe = Parser $+  Parser# $ \env i@(InputState# input) s ->+    if isTrue# (input ==# endOffset env)+      then (# s, JustParseResult i (AccumER Nothing) #)+      else+        let (# s', word #) = readWord8OffAddr# (addr env) input s+         in (# s', JustParseResult i (AccumER (Just (W8# word))) #)++word :: Parser err Word8+word = Parser $+  Parser# $ \env (InputState# input) s ->+    if isTrue# (input ==# endOffset env)+      then (# s, NoParseResult #)+      else+        let (# s', word #) = readWord8OffAddr# (addr env) input s+         in (# s', JustParseResult (InputState# (input +# 1#)) (AccumER $ W8# word) #)++specificWord w = orFail (cb <$> word)+  where+    cb w' =+      if w == w' then Just () else Nothing++-- | Skip over while the callback returns true.+--+-- Unlifted version, probably use skipWord8+skipWord8# :: (WordPrim -> Bool) -> Parser err ()+skipWord8# cb =+  Parser $+    Parser# (skipWord8CB# cb)+{-# INLINE skipWord8# #-}++-- | Skip over while the callback returns true+skipWord8 :: (Word8 -> Bool) -> Parser err ()+skipWord8 cb = skipWord8# (\byte -> cb (W8# byte {- HLINT ignore "Avoid lambda" -}))+{-# INLINE skipWord8 #-}++-- | Private: callback used for skipWord8+skipWord8CB# ::+  (WordPrim -> Bool) ->+  InputRead ->+  InputState ->+  State# RealWorld ->+  (# State# RealWorld, ParseResult# err () #)+skipWord8CB# cb env (InputState# input) s =+  let (# s', newOff #) = go input s+   in (# s', JustParseResult (InputState# newOff) (AccumER ()) #)+  where+    go :: Int# -> State# RealWorld -> (# State# RealWorld, Int# #)+    go inputOffset s =+      if isTrue# (inputOffset ==# endOffset env)+        then (# s, inputOffset #)+        else+          let (# s', word #) = readWord8OffAddr# (addr env) inputOffset s+           in if cb word then go (inputOffset +# 1#) s' else (# s', inputOffset #)++skipWhitespace :: Parser err ()+skipWhitespace = Parser $ Parser# skipWhitespaceCB+{-# INLINE skipWhitespace #-}++skipWhitespaceCB ::+  InputRead ->+  InputState ->+  State# RealWorld ->+  (# State# RealWorld, ParseResult# err () #)+skipWhitespaceCB env (InputState# input) s =+  let (# s', newOff #) = go input s+   in (# s', JustParseResult (InputState# newOff) (AccumER ()) #)+  where+    go :: Int# -> State# RealWorld -> (# State# RealWorld, Int# #)+    go inputOffset s+      | isTrue# (inputOffset ==# endOffset env) = (# s, inputOffset #)+      | otherwise =+        let (# s', word #) = readWord8OffAddr# (addr env) inputOffset s+         in case W8# word of+              40 -> go (inputOffset +# 1#) s'+              0x20 -> go (inputOffset +# 1#) s'+              0x0A -> go (inputOffset +# 1#) s'+              0x0D -> go (inputOffset +# 1#) s'+              0x09 -> go (inputOffset +# 1#) s'+              _ -> (# s', inputOffset #)+    {-# INLINE go #-}+{-# INLINE skipWhitespaceCB #-}++signed :: (Monoid err, Num a) => Parser err a -> Parser err a+signed parser = withSign <|> parser+  where+    withSign = do+      r <- (specificWord 43 $> True) <|> (specificWord 45 $> False)+      if r+        then negate <$> parser+        else parser+{-# INLINE signed #-}++orNegative :: (Monoid err, Num a) => Parser err a -> Parser err a+orNegative parse =+  (specificWord 45 *> (negate <$> parse))+    <|> parse+{-# INLINE orNegative #-}++-- | Parse an integral number with possible leading zeros.+parseIntegral :: forall err i. (Monoid err, Integral i) => Parser err (Int, i)+parseIntegral = parseIntegralGo 0 0+{-# INLINE parseIntegral #-}++parseIntegralNoLeadingZero :: forall err i. (Monoid err, Integral i) => Parser err (Int, i)+parseIntegralNoLeadingZero = do+  w <- word+  if w >= 49 && w <= 57+    then parseIntegralGo 1 (fromIntegral $ w - 48)+    else failParse+{-# INLINE parseIntegralNoLeadingZero #-}++parseIntegralGo :: (Monoid err, Integral i) => Int -> i -> Parser err (Int, i)+parseIntegralGo digits acc = do+  r <- peekWordMaybe+  case r of+    Nothing -> pure (digits, acc)+    Just !w+      | w >= 48 && w <= 57 -> do+        let !accd = fromIntegral $ w - 48+        let !after = (acc * 10) + accd+        if after < 0 -- checks for overflow.+          then failParse+          else word *> parseIntegralGo (digits + 1) after+      | otherwise -> failParse+{-# SPECIALIZE parseIntegralGo :: (Monoid err) => Int -> Int -> Parser err (Int, Int) #-}+{-# SPECIALIZE parseIntegralGo :: (Monoid err) => Int -> Integer -> Parser err (Int, Integer) #-}++takeWord8Cont :: (Semigroup err) => (Word8 -> Bool) -> (BS.ByteString -> a) -> Parser err a+takeWord8Cont cb cont = do+  ptr <- parsedPtr+  offsetBefore <- currentOffset+  skipWord8 cb+  offsetAfter <- currentOffset+  pure $ cont (PS ptr offsetBefore (offsetAfter - offsetBefore))+{-# INLINE takeWord8Cont #-}++takeWord8 :: (Semigroup err) => (Word8 -> Bool) -> Parser err BS.ByteString+takeWord8 cb = takeWord8Cont cb id++takeWord81 :: (Semigroup err) => (Word8 -> Bool) -> Parser err BS.ByteString+takeWord81 cb = takeWord81Cont cb id++takeWord81Cont ::+  Semigroup err =>+  (Word8 -> Bool) ->+  (ByteString -> b) ->+  Parser err b+takeWord81Cont cb cont = do+  ptr <- parsedPtr+  offsetBefore <- currentOffset+  skipWord8 cb+  offsetAfter <- currentOffset+  let len = offsetAfter - offsetBefore+  when (len < 1) failParse+  pure $ cont (PS ptr offsetBefore len)++peekRest :: (Semigroup err) => Parser err BS.ByteString+peekRest = do+  ptr <- parsedPtr+  offset <- currentOffset+  es <- getEndOffset+  pure $ PS ptr offset (es - offset)++chunkOfLength :: Int -> Parser err BS.ByteString+chunkOfLength len@(I# len') = Parser $+  Parser# $ \env is@(InputState# off) s ->+    if+        | len < 0 -> (# s, NoParseResult #)+        | isTrue# (off +# len' ># endOffset env) -> (# s, NoParseResult #)+        | otherwise ->+          (#+            s,+            JustParseResult+              (InputState# (off +# len'))+              (AccumER $ PS (ForeignPtr (addr env) (foreignPtr env)) (I# off) len)+          #)++parseChunk :: ByteString -> Parser err ()+parseChunk chunk = orFail $ isChunkMaybe <$> chunkOfLength (BS.length chunk)+  where+    isChunkMaybe c = if chunk == c then Just () else Nothing++testParser :: Parser () (Word8, ByteString)+testParser = ((,) <$> word <*> takeWord8 (\c -> c >= 38 && c <= 57)) <|> ((,) <$> word <*> pure mempty)

@@ -0,0 +1,351 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++module Jordan.FromJSON.Internal.UnboxedReporting where++import Control.Applicative (Alternative (empty, (<|>)))+import Control.Applicative.Combinators (sepBy)+import Control.Monad (when)+import Data.Bifunctor+import qualified Data.ByteString as BS+import Data.ByteString.Unsafe as BS+import Data.Char (chr, isControl, ord)+import Data.Functor (void, ($>))+import qualified Data.Map.Strict as Map+import Data.Maybe (isJust)+import Data.Monoid (Alt (..))+import Data.Scientific (Scientific)+import qualified Data.Scientific as Scientific+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8', encodeUtf8)+import Data.Word (Word8)+import Debug.Trace (traceM)+import Jordan.FromJSON.Class+import Jordan.FromJSON.Internal.Attoparsec (bsToInteger)+import Jordan.FromJSON.Internal.Permutation+import Jordan.FromJSON.Internal.UnboxedParser as UP hiding (AccumE (..), AccumEL, AccumER)+import Jordan.Types.Internal.AccumE (AccumE (AccumE))+import Jordan.Types.JSONError+  ( JSONArrayError (..),+    JSONError+      ( ErrorBadArray,+        ErrorBadObject,+        ErrorBadTextConstant,+        ErrorBadType,+        ErrorInvalidJSON,+        ErrorMesage,+        ErrorNoValue+      ),+    JSONObjectError (..),+  )+import Jordan.Types.JSONType (JSONType (..))+import Numeric (showHex)++skipWithFailure :: JSONError -> Parser JSONError a+skipWithFailure err =+  UP.asFailure $+    skipAnything $> err++lexeme :: Semigroup err => Parser err a -> Parser err a+lexeme p = p <* UP.skipWhitespace+{-# INLINE lexeme #-}++jsonTypeFromWord :: Word8 -> Maybe JSONType+jsonTypeFromWord jt+  | jt == 34 = pure JSONTypeText+  | jt == 116 || jt == 102 = pure JSONTypeBool+  | jt == 110 = pure JSONTypeNull+  | jt >= 48 && jt <= 57 = pure JSONTypeNumber+  | jt == 45 = pure JSONTypeNumber+  | jt == 91 = pure JSONTypeArray+  | jt == 123 = pure JSONTypeObject+  | otherwise = Nothing+{-# INLINE jsonTypeFromWord #-}++peekJSONType :: (Monoid err) => Parser err JSONType+peekJSONType = UP.orFail (jsonTypeFromWord <$> UP.peekWord)+{-# INLINE peekJSONType #-}++skipNullExpecting :: JSONType -> Parser JSONError a+skipNullExpecting jt =+  UP.asFailure $ nullParser $> ErrorBadType jt JSONTypeNull++-- | Parse a NULL value.+nullParser :: Semigroup err => Parser err ()+nullParser = lexeme $ UP.parseChunk "null" $> ()+{-# INLINE nullParser #-}++skipBoolExpecting :: JSONType -> Parser JSONError a+skipBoolExpecting jt =+  UP.asFailure $+    boolParser $> ErrorBadType jt JSONTypeBool+{-# INLINE skipBoolExpecting #-}++boolParser :: (Monoid err) => Parser err Bool+boolParser =+  lexeme $+    (UP.parseChunk "true" $> True)+      <|> (UP.parseChunk "false" $> False)+{-# INLINE boolParser #-}++skipTextExpecting :: JSONType -> Parser JSONError a+skipTextExpecting jt =+  UP.asFailure $+    textParser $> ErrorBadType jt JSONTypeText+{-# INLINE skipTextExpecting #-}++textParser :: (Monoid err) => Parser err T.Text+textParser = lexeme $ do+  UP.specificWord 34+  parseAfterQuote+{-# INLINE textParser #-}++sepByVoid :: Alternative f => f a1 -> f a2 -> f ()+sepByVoid elem sep = void $ sepBy (void elem) sep+{-# INLINE sepByVoid #-}++skipNumber :: (Monoid err) => Parser err ()+skipNumber = void scientific+{-# INLINE skipNumber #-}++skipNumberExpecting :: JSONType -> Parser JSONError a+skipNumberExpecting jt =+  UP.asFailure $+    skipNumber $> ErrorBadType jt JSONTypeNumber++skipAnything :: Monoid err => Parser err ()+skipAnything = do+  r <- UP.peekWord+  if+      | r == 110 -> lexeme $ UP.parseChunk "null"+      | r == 116 -> lexeme $ UP.parseChunk "true" -- t -> true+      | r == 102 -> lexeme $ UP.parseChunk "false"+      | r == 34 -> void textParser -- " -> text+      | r == 123 -> skipObject -- { -> object+      | r == 91 -> skipArray -- [ -> array+      | r == 45 || (r >= 48 && r <= 57) -> skipNumber+      | otherwise -> (orFail $ pure Nothing)+{-# INLINE skipAnything #-}++skipArray :: (Monoid err) => Parser err ()+skipArray = do+  startArray+  sepByVoid skipAnything comma+  endArray+{-# INLINE skipArray #-}++kvSep :: Semigroup err => Parser err ()+kvSep = lexeme $ UP.specificWord 58++skipAnyKV :: Monoid err => Parser err ()+skipAnyKV = do+  textParser+  kvSep+  skipAnything++comma :: Semigroup err => Parser err ()+comma = lexeme $ UP.specificWord 44++skipObject :: Monoid err => Parser err ()+skipObject = do+  lexeme $ UP.specificWord 123+  sepByVoid skipAnyKV comma+  lexeme $ UP.specificWord 125+{-# INLINE skipObject #-}++failOnError :: (Monoid err) => Either a T.Text -> Parser err T.Text+failOnError = \case+  Left _ -> failParse+  Right txt -> pure txt++parseAfterQuote :: (Monoid err) => Parser err T.Text+parseAfterQuote = do+  chunk <- UP.takeWord8Cont (\c -> c /= 92 && c /= 34) decodeUtf8'+  decoded <- failOnError chunk+  (lexeme (specificWord 34) $> decoded) <|> do+    specificWord 92+    escape <- parseEscape+    res <- parseAfterQuote+    pure $ decoded <> escape <> res+{-# INLINE parseAfterQuote #-}++hexDigit :: Semigroup err => Parser err Word8+hexDigit = do+  r <- UP.word+  orFail $+    if+        | r >= 48 && r <= 57 -> pure $ Just (r - 48)+        | r >= 97 && r <= 103 -> pure $ Just ((r - 97) + 10)+        | otherwise -> pure Nothing+{-# INLINE hexDigit #-}++parseEscape :: (Monoid err) => UP.Parser err T.Text+parseEscape =+  quote+    <|> backslash+    <|> solidus+    <|> backspace+    <|> formfeed+    <|> linefeed+    <|> carriage+    <|> tab+    <|> unicode+  where+    quote = specificWord 34 $> "\""+    backslash = specificWord 92 $> "\\"+    solidus = specificWord 47 $> "/"+    backspace = specificWord 98 $> "\b"+    formfeed = specificWord 102 $> "\f"+    linefeed = specificWord 110 $> "\n"+    carriage = specificWord 114 $> "\r"+    tab = specificWord 116 $> "\t"+    unicode = do+      specificWord 117+      a <- hexDigit+      b <- hexDigit+      c <- hexDigit+      d <- hexDigit+      let res = (((fromIntegral a * 16) + fromIntegral b) * 16 + fromIntegral c) * 16 + fromIntegral d+      pure $ T.pack [chr res]+{-# INLINE parseEscape #-}++parseCharInText (c :: Char) = parseLit c <|> escaped c+  where+    parseLit = \case+      '\\' -> UP.parseChunk "\\\\"+      '"' -> UP.parseChunk "\\\""+      '/' -> UP.parseChunk "/" <|> UP.parseChunk "\\/"+      '\b' -> UP.parseChunk "\\b"+      '\f' -> UP.parseChunk "\\f"+      '\n' -> UP.parseChunk "\\n"+      '\r' -> UP.parseChunk "\\r"+      '\t' -> UP.parseChunk "\\t"+      a -> if isControl a then empty else UP.parseChunk (encodeUtf8 $ T.singleton a)+    escaped c = UP.parseChunk $ encodeUtf8 $ "\\u" <> T.justifyRight 4 '0' (T.pack $ showHex (ord c) mempty)+{-# INLINE parseCharInText #-}++parseSpecificKeyInQuotes :: Monoid err => T.Text -> Parser err ()+parseSpecificKeyInQuotes t = UP.specificWord 34 *> parseSpecificKeyAfterQuote t+{-# INLINE parseSpecificKeyInQuotes #-}++parseSpecificKeyAfterQuote :: Monoid err => T.Text -> Parser err ()+parseSpecificKeyAfterQuote key = (parseRaw <|> parseChars) *> lexeme (UP.specificWord 34)+  where+    parseChars = T.foldr (\c a -> parseCharInText c *> a) (pure ()) key+    parseRaw =+      if isJust $ T.findIndex invalidTextChar key+        then empty+        else UP.parseChunk (encodeUtf8 key)++startBracket :: Semigroup err => Parser err ()+startBracket = lexeme $ UP.specificWord 123++endBracket :: Semigroup err => Parser err ()+endBracket = lexeme $ UP.specificWord 125++startArray :: Semigroup err => Parser err ()+startArray = lexeme $ UP.specificWord 91++endArray :: Semigroup err => Parser err ()+endArray = lexeme $ UP.specificWord 93++parseObjectKV :: Monoid err => T.Text -> Parser err b -> Parser err b+parseObjectKV key v = do+  lexeme $ parseSpecificKeyInQuotes key+  lexeme $ UP.specificWord 58+  v++invalidTextChar :: Char -> Bool+invalidTextChar c =+  c == '"'+    || c == '\\'+    || isControl c++data SP = SP !Integer {-# UNPACK #-} !Int++-- A sub-quadratic algorithm for Integer. Pairs of adjacent radix b+-- digits are combined into a single radix b^2 digit. This process is+-- repeated until we are left with a single digit. This algorithm+-- performs well only on large inputs, so we use the simple algorithm+-- for smaller inputs.+valInteger :: Integer -> Int -> [Integer] -> Integer+valInteger = go+  where+    go :: Integer -> Int -> [Integer] -> Integer+    go _ _ [] = 0+    go _ _ [d] = d+    go b l ds+      | l > 40 = b' `seq` go b' l' (combine b ds')+      | otherwise = valSimple b ds+      where+        -- ensure that we have an even number of digits+        -- before we call combine:+        ds' = if even l then ds else 0 : ds+        b' = b * b+        l' = (l + 1) `quot` 2++    combine b (d1 : d2 : ds) = d `seq` (d : combine b ds)+      where+        d = d1 * b + d2+    combine _ [] = []+    combine _ [_] = errorWithoutStackTrace "this should not happen"+{-# INLINE valInteger #-}++-- The following algorithm is only linear for types whose Num operations+-- are in constant time.+valSimple :: Integer -> [Integer] -> Integer+valSimple base = go 0+  where+    go r [] = r+    go r (d : ds) = r' `seq` go r' ds+      where+        r' = r * base + fromIntegral d+{-# INLINE valSimple #-}++isDigitWord8 :: Word8 -> Bool+isDigitWord8 c = c >= 48 && c <= 57+{-# INLINE isDigitWord8 #-}++decimal0 :: Semigroup err => Parser err Integer+decimal0 = do+  let zero = 48+  digits <- UP.takeWord8 isDigitWord8+  let !length = BS.length digits+  when (length == 0) UP.failParse+  if length > 1 && BS.unsafeHead digits == zero+    then UP.failParse+    else return (bsToInteger digits)+{-# INLINE decimal0 #-}++scientific :: (Monoid err) => UP.Parser err Scientific+scientific = lexeme $ do+  let minus = 45+      plus = 43+  sign <- UP.peekWord+  let !positive = sign == plus || sign /= minus+  when (sign == plus || sign == minus) $+    void UP.word+  n <- decimal0+  let f fracDigits =+        SP+          (BS.foldl' step n fracDigits)+          (negate $ BS.length fracDigits)+      step a w = a * 10 + fromIntegral (w - 48)+  dotty <- UP.peekWordMaybe+  SP c e <- case dotty of+    Just 46 -> UP.word *> UP.takeWord81Cont isDigitWord8 f+    _ -> pure (SP n 0)+  let !signedCoeff+        | positive = c+        | otherwise = - c+  ( (UP.specificWord 101 <|> UP.specificWord 69)+      *> fmap (Scientific.scientific signedCoeff . (e +)) (UP.signed (snd <$> UP.parseIntegral))+    )+    <|> pure (Scientific.scientific signedCoeff e)+{-# INLINE scientific #-}

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

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

@@ -0,0 +1,246 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++-- | Attempts to parse to either a result type or a direct report, by using a custom parser.+-- This parser uses Haskell primops to try to avoid allocations.+-- At the end of the day, it's not as fast as Attoparsec, but it's pretty dang fast.+--+-- We could not use Attoparsec directly due to the need for differnet error handling.+-- Other libraries with correct error handling behavior do exist, but in order to keep the dependency footprint low,+-- we rolled our own.+module Jordan.FromJSON.UnboxedReporting (parseOrReportWith, parseOrReport) where++import Control.Applicative (Alternative (empty, (<|>)))+import Control.Applicative.Combinators (sepBy)+import Control.Monad (when)+import Data.Bifunctor+import qualified Data.ByteString as BS+import Data.ByteString.Unsafe as BS+import Data.Char (chr, isControl, ord)+import Data.Functor (void, ($>))+import qualified Data.Map.Strict as Map+import Data.Maybe (isJust)+import Data.Monoid (Alt (..))+import Data.Scientific (Scientific)+import qualified Data.Scientific as Scientific+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8', encodeUtf8)+import Data.Word (Word8)+import Jordan.FromJSON.Class+import Jordan.FromJSON.Internal.Attoparsec (bsToInteger)+import Jordan.FromJSON.Internal.Permutation+import Jordan.FromJSON.Internal.UnboxedParser as UP hiding (AccumE (..), AccumEL, AccumER)+import Jordan.FromJSON.Internal.UnboxedReporting+import Jordan.Types.Internal.AccumE (AccumE (AccumE))+import Jordan.Types.JSONError+  ( JSONArrayError (..),+    JSONError+      ( ErrorBadArray,+        ErrorBadObject,+        ErrorBadTextConstant,+        ErrorBadType,+        ErrorInvalidJSON,+        ErrorMesage,+        ErrorNoValue+      ),+    JSONObjectError (..),+  )+import Jordan.Types.JSONType (JSONType (..))+import Numeric (showHex)++newtype ReportingParser a = ReportingParser {runReportingParser :: UP.Parser JSONError a}+  deriving (Functor) via (UP.Parser JSONError)+  deriving (Semigroup) via (Alt (UP.Parser JSONError) a)++newtype ReportingObjectParser a = ReportingObjectParser+  {runReportingObjectParser :: Permutation (UP.Parser JSONObjectError) a}+  deriving (Functor, Applicative) via (Permutation (UP.Parser JSONObjectError))++newtype ReportingTupleParser a = ReportingTupleParser+  {runReportingTupleParser :: Integer -> (Integer, UP.Parser JSONArrayError a)}++instance Functor ReportingTupleParser where+  fmap f (ReportingTupleParser cb) =+    ReportingTupleParser $ \index -> second (f <$>) $ cb index++instance Applicative ReportingTupleParser where+  pure a = ReportingTupleParser (,pure a)+  (ReportingTupleParser f) <*> (ReportingTupleParser a) =+    ReportingTupleParser $ \index ->+      let (index', fp) = f index+          (index'', ap) = a index+       in ( index'',+            do+              f' <- fp+              when (index /= index' && index /= index'') comma+              f' <$> ap+          )++toObjectParser :: T.Text -> Parser JSONError a -> ReportingObjectParser a+toObjectParser field itemParser =+  ReportingObjectParser $+    asPermutationWithFailing parseKV failNoValue+  where+    failNoValue = do+      r <- UP.peekRest+      UP.failWith $+        MkJSONObjectError $ Map.singleton field ErrorNoValue+    parseKV = first (MkJSONObjectError . Map.singleton field) $ parseObjectKV field itemParser+{-# INLINE toObjectParser #-}++toObjectParserDef field itemParser def =+  ReportingObjectParser $+    asPermutationWithDefault parseKV def+  where+    parseKV = first (MkJSONObjectError . Map.singleton field) $ do+      parseObjectKV field itemParser++parseArrayInner :: UP.Parser JSONError a -> Integer -> UP.Parser JSONArrayError [a]+parseArrayInner parse index =+  ((:) <$> parseElem <*> ((comma *> parseArrayInner parse (index + 1)) <|> pure []))+    <|> pure []+  where+    parseElem = first (MkJSONArrayError . Map.singleton index) parse+{-# INLINE parseArrayInner #-}++parseDictKey :: UP.Parser JSONError a -> UP.Parser JSONObjectError (T.Text, a)+parseDictKey parseVal = do+  key <- textParser+  kvSep+  val <- first (MkJSONObjectError . Map.singleton key) parseVal+  pure (key, val)++instance JSONTupleParser ReportingTupleParser where+  consumeItemWith = \(ReportingParser itemParser) ->+    ReportingTupleParser $+      \index ->+        (index + 1, first (MkJSONArrayError . Map.singleton index) itemParser)++instance JSONObjectParser ReportingObjectParser where+  parseFieldWith field = \(ReportingParser itemParser) ->+    toObjectParser field itemParser+  parseFieldWithDefault field = \(ReportingParser itemParser) def ->+    toObjectParserDef field itemParser def++instance JSONParser ReportingParser where+  parseTuple (ReportingTupleParser tp) =+    ReportingParser $ do+      jt <- peekJSONType+      case jt of+        JSONTypeArray -> tuple+        other -> skipWithFailure $ ErrorBadType JSONTypeArray other+    where+      tuple = do+        startArray+        let (_, arrayParse) = tp 0+        arr <- first ErrorBadArray arrayParse+        endArray+        pure arr+  {-# INLINE parseTuple #-}+  parseTextConstant tc =+    ReportingParser $ do+      jt <- peekJSONType+      case jt of+        JSONTypeText -> textConstant+        other -> skipWithFailure $ ErrorBadType JSONTypeText other+    where+      textConstant = do+        r <- UP.specificWord 34+        void (parseSpecificKeyAfterQuote tc) <|> do+          r <- parseAfterQuote+          UP.failWith (ErrorBadTextConstant tc r)+  {-# INLINE parseTextConstant #-}+  parseArrayWith (ReportingParser rp) =+    ReportingParser $+      array+        <|> skipNullExpecting JSONTypeArray+        <|> skipBoolExpecting JSONTypeArray+        <|> skipTextExpecting JSONTypeArray+        <|> skipNumberExpecting JSONTypeArray+    where+      array = do+        startArray+        arr <- first ErrorBadArray $ parseArrayInner rp 0+        endArray+        pure arr+  {-# INLINE parseDictionary #-}+  parseDictionary (ReportingParser dict) =+    ReportingParser $ do+      jt <- peekJSONType+      case jt of+        JSONTypeObject -> parseDict+        other -> UP.asFailure $ skipAnything $> ErrorBadType JSONTypeObject other+    where+      parseDict = do+        startBracket+        r <- first ErrorBadObject $ parseDictKey dict `sepBy` comma+        endBracket+        pure r+  parseObject (ReportingObjectParser permute) = ReportingParser $ do+    r <- peekJSONType+    case r of+      JSONTypeObject -> po+      other -> UP.asFailure $ skipAnything $> ErrorBadType JSONTypeObject other+    where+      po = first ErrorBadObject $ do+        startBracket+        a <-+          wrapEffect+            skipAnyKV+            comma+            permute+        rest <- peekRest+        endBracket <|> do+          comma+          skipAnyKV `sepByVoid` comma+          endBracket+        pure a+  {-# INLINE parseObject #-}+  parseNull =+    ReportingParser $ do+      jt <- peekJSONType+      case jt of+        JSONTypeNull -> nullParser+        other -> skipWithFailure $ ErrorBadType JSONTypeNull other+  {-# INLINE parseNull #-}+  parseBool = ReportingParser $ do+    jt <- peekJSONType+    case jt of+      JSONTypeBool -> boolParser+      other -> skipWithFailure $ ErrorBadType JSONTypeBool other+  {-# INLINE parseBool #-}+  parseText = ReportingParser $ do+    jt <- peekJSONType+    case jt of+      JSONTypeText -> textParser+      other -> skipWithFailure $ ErrorBadType JSONTypeText other+  {-# INLINE parseText #-}+  parseNumber =+    ReportingParser $ do+      r <- peekJSONType+      case r of+        JSONTypeNumber -> scientific+        other -> UP.asFailure $ skipAnything $> ErrorBadType JSONTypeNumber other+  {-# INLINE parseNumber #-}+  validateJSON (ReportingParser rp) =+    ReportingParser $+      lowerErr (fmap (first ErrorMesage) rp)+  {-# INLINE validateJSON #-}++parseOrReportWith ::+  (forall parser. JSONParser parser => parser a) ->+  BS.ByteString ->+  Either JSONError a+parseOrReportWith (ReportingParser rp) bs =+  case UP.parseBS (UP.skipWhitespace *> rp) bs of+    Nothing -> Left ErrorInvalidJSON+    Just (AccumE r) -> r+{-# INLINE parseOrReportWith #-}++parseOrReport :: (FromJSON a) => BS.ByteString -> Either JSONError a+parseOrReport = parseOrReportWith fromJSON+{-# INLINE parseOrReport #-}

@@ -1,12 +1,83 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-}-module Jordan.Generic.Options-    where+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} -import GHC.Generics (Generic)+module Jordan.Generic.Options where +import Data.Coerce+import Data.Text (Text)+import qualified Data.Text as T+import Data.Type.Bool+import Data.Typeable (TypeRep, splitTyConApp, tyConModule, tyConName)+import GHC.Exts (Constraint)+import GHC.Generics+import GHC.TypeLits++type Representational (f :: * -> *) =+  (forall a b. (Coercible a b) => Coercible (f a) (f b) :: Constraint)+ data SumTypeEncoding   = TagVal   | TagInField   deriving (Show, Read, Eq, Ord, Bounded, Enum, Generic) -newtype PartOfSum f a = PartOfSum { getPartOfSum :: f a }+type family AllNullary cons where+  AllNullary (C1 ('MetaCons _ _ 'False) (S1 ('MetaSel 'Nothing _ _ _) U1)) = True+  AllNullary (a :+: b) = AllNullary a && AllNullary b+  AllNullary _ = False++newtype PartOfSum f a = MkPartOfSum {getPartOfSum :: f a}+  deriving (Show, Read, Eq, Ord, Generic)++-- | A newtype wrapper, designed to make it easier to derive ToJSON and FromJSON instances.+-- The API of abstract JSON serializing is awkward due to the somewhat bad ergonomics of the+-- 'Data.Functor.Contravariant.Divisible.Divisible' and (especially)+-- 'Data.Functor.Contravariant.Divisible.Decidable' typeclasses.+--+-- In general, using @ -XDerivingVia @, @ -XDeriveGeneric @, @ -XDataKinds @ and this wrapper will make your life much easier.+-- Unfortunately, due to a weird GHC quirk, you also need @ -XDerivingVia @.+--+-- That is, the following won't work, complaining about role errors:+--+-- @+--  data PersonFilter = PersonFilter { filterFirstName :: Maybe Text, filterLastName :: Maybe Text }+--    deriving (Show, Generic)+--    deriving (ToJSON, FromJSON) via (WithOptions '[KeepNothingFields] PersonFilter)+-- @+--+-- But this will:+--+-- @+--  data PersonFilter = PersonFilter { filterFirstName :: Maybe Text, filterLastName :: Maybe Text }+--    deriving (Show, Generic)+--+--  deriving via (WithOptions '[KeepNothingFields] PersonFilter) instance (ToJSON PersonFilter)+--  deriving via (WithOptions '[KeepNothingFields] PersonFilter) instance (FromJSON PersonFilter)+-- @+newtype WithOptions (options :: [*]) a = WithOptions {getWithOptions :: a}+  deriving (Show, Eq, Ord)++-- | Newtype for use with GeneralizedNewtypeDeriving.+-- Will have us omit Nothing fields for parsing and serializing.+data OmitNothingFields = OmitNothingFields++-- | Keep nothing fields.+-- Will have us omit @ null @ when serializing Maybe types.+data KeepNothingFields = KeepNothingFields++fullyQualifyName ::+  TypeRep ->+  Text+fullyQualifyName tr =+  case splitTyConApp tr of+    (tc, []) -> baseName tc+    (tc, args) -> baseName tc <> "(" <> T.intercalate "," (fullyQualifyName <$> args) <> ")"+  where+    baseName tc = T.pack (tyConModule tc <> "." <> tyConName tc)

@@ -2,11 +2,13 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+ module Jordan.ToJSON.Builder-    ( JSONBuilder (..)-    , toJSONViaBuilder-    , toJSONAsBuilder-    ) where+  ( JSONBuilder (..),+    toJSONViaBuilder,+    toJSONAsBuilder,+  )+where  import Data.ByteString.Builder (Builder, toLazyByteString) import qualified Data.ByteString.Builder.Prim as BP@@ -23,8 +25,7 @@  -- | JSON Serializer that makes use of 'Data.ByteString.Builder' to do its work. -- Should be really fast.-newtype JSONBuilder a-  = JSONBuilder { runJSONBuilder :: a -> Builder }+newtype JSONBuilder a = JSONBuilder {runJSONBuilder :: a -> Builder}   deriving (Semigroup, Monoid) via (a -> Builder)  instance Contravariant JSONBuilder where@@ -46,39 +47,41 @@ runCommaSep Empty = "" runCommaSep (Written w) = w -newtype JSONCommaBuilder a-  = JSONCommaBuilder { runCommaBuilder :: a -> CommaSep }+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!)+-- | Mostly lifted from Aeson (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+  -- Irritatingly we have a few non-control characters we need to escape,+  -- so we try to do that first.+  BP.condB (== 0x5c) (ascii2 ('\\', '\\')) $ -- a backslash+    BP.condB (== 0x22) (ascii2 ('\\', '"')) $ -- a quote+      BP.condB (>= 0x20) (BP.liftFixedToBounded BP.word8) $ -- Now, if we have an ordinal above 0x20, we can just encode directly+        BP.condB (== 0x0a) (ascii2 ('\\', 'n')) $ -- Special control character \n+          BP.condB (== 0x0d) (ascii2 ('\\', 'r')) $ -- special control character \r+            BP.condB (== 0x09) (ascii2 ('\\', 't')) $ -- Special control character \t+              BP.condB (== 0x0c) (ascii2 ('\\', 'f')) $ -- Special control character \f+                BP.condB (== 0x08) (ascii2 ('\\', 'b')) $ -- Special control character \b+                  BP.liftFixedToBounded hexEscape -- fallback for other control characters   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+    hexEscape =+      (\c -> ('\\', ('u', ('0', ('0', c)))))+        BP.>$< BP.char7 BP.>*< BP.char7 BP.>*< BP.char7 BP.>*< BP.char7 BP.>*< BP.word8HexFixed {-# 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 <> "\""+serializeQuotedString :: Text -> Builder+serializeQuotedString t = "\"" <> encodeUtf8BuilderEscaped escapeAscii t <> "\"" -writeKV :: (a -> Builder) -> Text -> a -> Builder-writeKV map k v = writeQuotedString k <> ": " <> map v+serializeKV :: (a -> Builder) -> Text -> a -> Builder+serializeKV map k v = serializeQuotedString k <> ": " <> map v  instance Contravariant JSONCommaBuilder where   contramap f (JSONCommaBuilder a) = JSONCommaBuilder $ a . f@@ -90,11 +93,14 @@       (b, c) -> runCommaBuilder sB b <> runCommaBuilder sC c  instance JSONObjectSerializer JSONCommaBuilder where-  writeField field (JSONBuilder a) = JSONCommaBuilder $ \arg ->-    Written $ writeQuotedString field <> ": " <> a arg+  serializeFieldWith field (JSONBuilder a) = JSONCommaBuilder $ \arg ->+    Written $ serializeQuotedString field <> ": " <> a arg+  serializeJust field (JSONBuilder a) = JSONCommaBuilder $ \case+    Nothing -> Empty+    Just a' -> Written $ serializeQuotedString field <> ": " <> a a'  instance JSONTupleSerializer JSONCommaBuilder where-  writeItem (JSONBuilder a) = JSONCommaBuilder $ Written . a+  serializeItemWith (JSONBuilder a) = JSONCommaBuilder $ Written . a  instance Selectable JSONBuilder where   giveUp f = JSONBuilder $ \a -> absurd (f a)@@ -104,7 +110,7 @@       Right rhs -> runJSONBuilder serR rhs  instance JSONSerializer JSONBuilder where-  serializeObject _ (JSONCommaBuilder f) = JSONBuilder $ \a ->+  serializeObject (JSONCommaBuilder f) = JSONBuilder $ \a ->     case f a of       Written bu -> "{" <> bu <> "}"       Empty -> "{}"@@ -113,9 +119,9 @@       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+    "{" <> runCommaSep (foldMap (\(k, v) -> Written (serializeKV t k v)) a) <> "}"+  serializeText = JSONBuilder $ \t -> serializeQuotedString t+  serializeTextConstant = JSONBuilder . const . serializeQuotedString   serializeNumber = JSONBuilder $ \a -> scientificBuilder a   serializeNull = JSONBuilder $ const "null"   serializeBool = JSONBuilder $ \case

@@ -1,29 +1,37 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-module Jordan.ToJSON.Class-    where +module Jordan.ToJSON.Class where++import Data.Foldable (fold) import Data.Functor.Contravariant import Data.Functor.Contravariant.Divisible+import Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import qualified Data.Ratio as Ratio-import Data.Scientific (Scientific)+import Data.Scientific import qualified Data.Scientific as Sci import qualified Data.Semigroup as Semi-import Data.Text (Text)+import qualified Data.Set as Set+import Data.Text (Text, pack) import qualified Data.Text as T-import Data.Typeable (Proxy(..), Typeable, tyConModule, tyConName, typeRep, typeRepTyCon)+import Data.Typeable (Proxy (..), TypeRep, Typeable, splitTyConApp, tyConModule, tyConName, typeRep, typeRepTyCon) import Data.Void (Void, absurd) import GHC.Generics+import GHC.TypeLits (KnownSymbol, symbolVal) import Jordan.Generic.Options  -- | Basically just 'Data.Functor.Contravariant.Divisible.Decidable' but without@@ -38,9 +46,13 @@ 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 +selected :: (Selectable f) => f lhs -> f rhs -> f (Either lhs rhs)+selected = select id+ -- | 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'.@@ -51,57 +63,87 @@ -- 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.+class (Divisible f, Representational f) => JSONObjectSerializer f where+  serializeFieldWith ::+    -- | Label for the field to serialize+    Text ->+    -- | How to serialize the field.     -- The forall ensures that JSON serialization is kept completely abstract.     -- You can only use the methods of 'JSONSerializer' here.-    -> f a+    (forall jsonSerializer. JSONSerializer jsonSerializer => jsonSerializer a) ->+    f a+  serializeField :: (ToJSON a) => Text -> f a+  serializeField t = serializeFieldWith t toJSON+  serializeDescribeFieldWith ::+    -- | Field key to serialize.+    Text ->+    -- | Field description.+    Text ->+    -- | Serializer for the field.+    (forall valueSerializer. JSONSerializer valueSerializer => valueSerializer a) ->+    f a+  serializeDescribeFieldWith t _ = serializeFieldWith t -class (Divisible f) => JSONTupleSerializer f where-  writeItem-    :: (forall jsonSerializer. JSONSerializer jsonSerializer => jsonSerializer a)-    -- ^ Write a single item into the tuple.+  -- | Write if we have Just a value. Do not add the field otherwise.+  serializeJust ::+    -- | Label for the field to serialize+    Text ->+    -- | Serializer for Just+    (forall jsonSerializer. JSONSerializer jsonSerializer => jsonSerializer a) ->+    f (Maybe a)++class (Divisible f, Representational f) => JSONTupleSerializer f where+  serializeItemWith ::+    -- | Write a single item into the tuple.     -- The forall keeps things abstract.-    -> f a+    (forall jsonSerializer. JSONSerializer jsonSerializer => jsonSerializer a) ->+    f a+  serializeItem ::+    (ToJSON a) => f a+  serializeItem = serializeItemWith toJSON  -- | 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.+class (Selectable f, Representational f) => JSONSerializer f where+  serializeObject ::+    -- | 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+    (forall objSerializer. JSONObjectSerializer objSerializer => objSerializer a) ->+    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]+  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]++  -- | Give a name to a serializer.+  -- Should be globally unique, if possible.+  nameSerializer ::+    Text ->+    f a ->+    f a+  nameSerializer _ a = 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.@@ -109,11 +151,36 @@ -- -- This class is derivable generically, and will generate a \"nice\" format. -- In my opinion, at least.+--+-- If you want to customize this JSON, the newtype 'WithOptions' can be helpful, as it allows you to specify options for the generic serialization.+-- Unfortunately, due to a weird GHC quirk, you need to use it with @ -XStandaloneDeriving @ as well as @ -XDerivingVia @.+-- That is, you should write:+--+--+-- @+-- data PersonFilter = PersonFilter { filterFirstName :: Maybe Text, filterLastName :: Maybe Text }+--   deriving (Show, Read, Eq, Ord, Generic)+--+-- deriving via (WithOptions '[KeepNothingFields] PersonFilter) instance (ToJSON PersonFilter)+-- @++---- === __Laws__+--+-- This instance is lawless, unless 'Jordan.FromJSON.Class.FromJSON' is also defined for this type.+-- In that case, the representation serialized by 'ToJSON' should match that of the representation parsed by+-- 'Jordan.FromJSON.Class.FromJSON'. 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+  toJSON :: (forall f. (JSONSerializer f) => f v)+  default toJSON :: (Generic v, GToJSON (Rep v), Typeable v) => (JSONSerializer f) => f v+  toJSON = contramap from $ gToJSON defaultToJSONOptions {toJSONBaseName = fq}+    where+      fq = T.unpack $ fullyQualifyName $ typeRep (Proxy :: Proxy v) +instance (Generic a, GToJSON (Rep a), Typeable a, SpecifiesToJSONOptions options) => ToJSON (WithOptions options a) where+  toJSON = contramap getWithOptions . contramap from $ gToJSON (specifiedToJSONOptions @options) {toJSONBaseName = fq}+    where+      fq = T.unpack $ fullyQualifyName $ typeRep (Proxy :: Proxy a)+ instance ToJSON () where   toJSON = serializeNull @@ -155,13 +222,14 @@   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)+  toJSON =+    serializeObject $+      divide divider (serializeField "num") (serializeField "denom")     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)+      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@@ -193,97 +261,166 @@ 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+instance (ToJSON a) => ToJSON (Map.Map Integer a) where+  toJSON = contramap (fmap toTextKey . Map.toList) $ serializeDictionary toJSON+    where+      toTextKey (key, value) = (pack $ show key, value)++instance (ToJSON a) => ToJSON (NE.NonEmpty a) where+  toJSON = contramap NE.toList serializeArray++instance (ToJSON a) => ToJSON (Set.Set a) where+  toJSON = contramap Set.toList serializeArray++data ToJSONOptions = ToJSONOptions+  { toJSONEncodeSums :: SumTypeEncoding,+    toJSONBaseName :: String,+    toJSONRenderEnum :: String -> String,+    toJSONOmitNothingFields :: Bool   }  defaultToJSONOptions :: ToJSONOptions-defaultToJSONOptions-  = ToJSONOptions TagInField "" id+defaultToJSONOptions =+  ToJSONOptions TagInField "" id True +class SpecifiesToJSONOptions (a :: [*]) where+  specifiedToJSONOptions :: ToJSONOptions++instance SpecifiesToJSONOptions '[] where+  specifiedToJSONOptions = defaultToJSONOptions++instance+  (SpecifiesToJSONOptions xs) =>+  SpecifiesToJSONOptions (OmitNothingFields ': xs)+  where+  specifiedToJSONOptions = (specifiedToJSONOptions @xs) {toJSONOmitNothingFields = True}++instance+  (SpecifiesToJSONOptions xs) =>+  SpecifiesToJSONOptions (KeepNothingFields ': xs)+  where+  specifiedToJSONOptions =+    (specifiedToJSONOptions @xs) {toJSONOmitNothingFields = False}+ class GToJSON v where   gToJSON :: (JSONSerializer s) => ToJSONOptions -> s (v a) +-- | Top-level metadata is ignored. instance (ToJSON c) => GToJSON (K1 i c) where   gToJSON _ = contramap (\(K1 a) -> a) toJSON +-- | Datatype metadata: we name the overall datatype with the baseName+-- passed in the options, then serialize the inner information. instance (GToJSON f, Datatype t) => GToJSON (D1 t f) where-  gToJSON = contramap (\(M1 a) -> a) . gToJSON . addName+  gToJSON opts = nameSerializer (T.pack $ toJSONBaseName opts) $ contramap (\(M1 a) -> a) $ gToJSON opts++-- | Serialize out a no-argument constructor via a string value of its name.+-- This allows us to serialize out enum keys more easily.+--+-- This does not get a unique name as recursion cannot happen.+instance {-# OVERLAPS #-} (KnownSymbol name) => GToJSON (C1 (MetaCons name fixity 'False) U1) where+  gToJSON opts =+    serializeTextConstant (T.pack connNameS)     where-      addName b = b { toJSONBaseName = toJSONBaseName b <> dtname }-      dtname = moduleName s <> "." <> datatypeName s-      s :: D1 t f a-      s = undefined+      connNameS = symbolVal (Proxy :: Proxy name) -instance {-# OVERLAPS #-} (Constructor t) => GToJSON (PartOfSum (C1 t U1)) where-  gToJSON opts = contramap getPartOfSum $ serializeTextConstant enumValue+instance {-# OVERLAPS #-} (KnownSymbol name) => GToJSON (PartOfSum (C1 (MetaCons name fixity 'False) U1)) where+  gToJSON = contramap getPartOfSum . gToJSON++-- | IF we have a constructor with arguments, but not selectors, then+-- we serialize as a tuple.+instance {-# OVERLAPPABLE #-} (GToJSONTuple inner, Constructor (MetaCons n s 'False)) => GToJSON (C1 (MetaCons n s 'False) inner) where+  gToJSON opts =+    contramap (\(M1 a) -> a) $+      serializeTuple $ gToJSONTuple opts++-- | If we have a constructor with arguments AND selectors (IE, a record), then+-- we serialize out a JSON object.+instance {-# OVERLAPPABLE #-} (GToJSONObject inner, Constructor (MetaCons n s 'True)) => GToJSON (C1 (MetaCons n s 'True) inner) where+  gToJSON opts =+    contramap (\(M1 a) -> a) $+      serializeObject $+        gToJSONObject opts     where-      enumValue = T.pack $ toJSONRenderEnum opts $ conName (undefined :: C1 t U1 f)+      name = T.pack $ toJSONBaseName opts <> "." <> conName (undefined :: C1 (MetaCons n s 'True) inner a) +-- | If we have a single-argument constructor with no selectors, we want to just parse it directly.+instance {-# OVERLAPS #-} (ToJSON i) => GToJSON (C1 (MetaCons n s 'False) (S1 (MetaSel 'Nothing su ss ds) (Rec0 i))) where+  gToJSON _ = contramap (\(M1 (M1 (K1 s))) -> s) toJSON++-- | When rendering a sum type, and this is NOT an enum value, render via+-- the sum encoding option the user provided. 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)+      field =+        serializeObject $+          serializeFieldWith cn (gToJSON opts)+      tagged =+        serializeObject $+          contramap ((),) $+            divided+              (serializeFieldWith "key" $ serializeTextConstant cn)+              (serializeFieldWith "value" $ gToJSON opts)       objName = T.pack (toJSONBaseName opts) <> "." <> cn <> ".Output"-      cn =  T.pack $ conName (undefined :: C1 t f a)+      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 +-- | If we can serialize out both sides of a sum-type, we can serialize out the sum type. 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)+      (contramap MkPartOfSum $ gToJSON opts)+      (contramap MkPartOfSum $ 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?") +-- | Type class for generically converting to a JSON object.+-- We can do this if all the fields under a constructor are named. 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 {-# OVERLAPPABLE #-} (GToJSON f, KnownSymbol selector) => GToJSONObject (S1 (MetaSel (Just selector) su ss ds) f) where+  gToJSONObject o =+    contramap (\(M1 a) -> a) $+      serializeFieldWith (T.pack $ symbolVal (Proxy :: Proxy selector)) (gToJSON o) +instance {-# OVERLAPS #-} (ToJSON a, KnownSymbol selector) => GToJSONObject (S1 (MetaSel (Just selector) su ss ds) (Rec0 (Maybe a))) where+  gToJSONObject o = contramap map fieldWriter+    where+      fieldWriter+        | toJSONOmitNothingFields o = serializeJust name toJSON+        | otherwise = serializeFieldWith name toJSON+      map (M1 (K1 a)) = a+      name = T.pack $ symbolVal (Proxy :: Proxy selector)+ instance (GToJSONObject lhs, GToJSONObject rhs) => GToJSONObject (lhs :*: rhs) where   gToJSONObject o = divide div (gToJSONObject o) (gToJSONObject o)     where-      div (a :*: b) = (a,b)+      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+class GToJSONTuple v where+  gToJSONTuple :: (JSONTupleSerializer f) => ToJSONOptions -> f (v a)++instance (GToJSONTuple lhs, GToJSONTuple rhs) => GToJSONTuple (lhs :*: rhs) where+  gToJSONTuple o = divide div (gToJSONTuple o) (gToJSONTuple o)     where-      name = T.pack $ toJSONBaseName opts <> "." <> conName (undefined :: C1 t inner a) <> ".Output"+      div (a :*: b) = (a, b) -instance {-# OVERLAPS #-} (ToJSON i) => GToJSON (C1 c (S1 (MetaSel 'Nothing su ss ds) (Rec0 i))) where-  gToJSON _ = contramap (\(M1 (M1 (K1 s))) -> s) toJSON+instance (GToJSON f) => GToJSONTuple (S1 (MetaSel Nothing su ss ds) f) where+  gToJSONTuple o =+    contramap (\(M1 a) -> a) $+      serializeItemWith (gToJSON o)

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

@@ -0,0 +1,115 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}++-- | Either, but with an Applicative instance that combines errors via '<>'.+--+-- This is sometimes known as the validation Applicative.+-- There are Haskell packages providing this type, however, in the interest of minimized+-- dependency footprint we use this.+module Jordan.Types.Internal.AccumE+  ( AccumE+      ( AccumE,+        getAccumE,+        AccumEL,+        AccumER+      ),+  )+where++import Control.Applicative+import Data.Bifunctor+import GHC.Generics+import Text.Read++-- | A version of Either that accumulates errors via an instance of 'Semigroup'.+--+-- This is sometimes called the validation applicative.+newtype AccumE err val = AccumE {getAccumE :: Either err val}+  deriving (Functor) via Either err+  deriving (Bifunctor) via Either+  deriving (Generic)++-- | Show instance uses the 'AccumER' and 'AccumEL' pattern synonyms.+instance (Show a, Show b) => Show (AccumE a b) where+  showsPrec prec = \case+    AccumEL l ->+      showParen (prec > 10) $+        showString "AccumEL " . showsPrec 11 l+    AccumER r ->+      showParen (prec > 10) $+        showString "AccumER " . showsPrec 11 r++-- | Read instance uses the 'AccumER' and 'AccumEL' pattern synonyms.+instance (Read a, Read b) => Read (AccumE a b) where+  readPrec = parens $ left +++ right+    where+      left = do+        Ident "AccumEL" <- lexP+        AccumEL <$> step readPrec+      right = do+        Ident "AccumER" <- lexP+        AccumER <$> step readPrec++-- | Construct an error value.+pattern AccumEL :: err -> AccumE err val+pattern AccumEL l = AccumE (Left l)++-- | Construct a good value.+-- Equivalent to 'pure'.+pattern AccumER :: val -> AccumE err val+pattern AccumER r = AccumE (Right r)++{-# COMPLETE AccumEL, AccumER #-}++-- | Applicative accumulates errors.+--+-- Note that this is *strict* in the error, because this+-- can sometimes reduce the number of allocations in the places+-- where we use this.+instance (Semigroup e) => Applicative (AccumE e) where+  pure !a = AccumE (Right a)+  {-# INLINE pure #-}+  (AccumE !f) <*> (AccumE !a) = AccumE $ case f of+    Left !e -> case a of+      Left !e' -> Left $ e <> e'+      Right !a' -> Left e+    Right !fab -> case a of+      Left !e -> Left e+      Right !arg -> Right $ fab arg+  {-# INLINE (<*>) #-}+  liftA2 f (AccumE arg) (AccumE arg') =+    AccumE+      ( case arg of+          Left e -> case arg' of+            Left e' -> Left $ e <> e'+            Right b -> Left e+          Right a -> case arg' of+            Left e -> Left e+            Right b -> Right (f a b)+      )+  {-# INLINE liftA2 #-}++-- | Alternative takes the first result if there is a result.+-- If there is not, will *not* accumulate errors.+instance (Monoid m) => Alternative (AccumE m) where+  empty = AccumEL mempty+  (AccumER a) <|> _ = AccumER a+  (AccumEL _) <|> (AccumER a) = AccumER a+  (AccumEL a) <|> (AccumEL _) = AccumEL a+  {-# INLINE (<|>) #-}++-- | Semigroup accumulates errors if both are errors, otherwise+-- it returns the first good value.+instance (Semigroup e) => Semigroup (AccumE e a) where+  (AccumE lhs) <> (AccumE rhs) = AccumE $ case lhs of+    Left e -> case rhs of+      Left e' -> Left $ e <> e'+      Right a -> Right a+    Right a -> Right a++-- mempty is an error with 'mempty'+instance (Monoid err) => Monoid (AccumE err a) where+  mempty = AccumEL mempty

@@ -0,0 +1,28 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Provides a MergeMap, which is basically a map with+module Jordan.Types.Internal.MergeMap where++import qualified Data.Map as Map+import GHC.Exts (IsList (..))++-- | A map where '<>' merges values with '<>'.+newtype MergeMap key val = MergeMap {getMergeMap :: Map.Map key val}+  deriving (Eq)+  deriving (IsList) via (Map.Map key val)+  deriving (Functor, Foldable) via (Map.Map key)++instance Traversable (MergeMap key) where+  traverse f (MergeMap m) = MergeMap <$> traverse f m++instance (Semigroup val, Ord key) => Semigroup (MergeMap key val) where+  (MergeMap lhs) <> (MergeMap rhs) = MergeMap $ Map.unionWith (<>) lhs rhs+  {-# INLINE (<>) #-}++instance (Semigroup val, Ord key) => Monoid (MergeMap key val) where+  mempty = MergeMap mempty+  {-# INLINE mempty #-}++mergeSingleton :: k -> v -> MergeMap k v+mergeSingleton k v = MergeMap (Map.singleton k v)

@@ -0,0 +1,107 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++module Jordan.Types.JSONError where++import Control.DeepSeq+import Data.Coerce+import Data.Foldable+import Data.Functor.Contravariant+import qualified Data.List.NonEmpty as NE+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Text (Text, pack)+import qualified Data.Text.Lazy.Builder as LB+import GHC.Exts (IsList (..))+import GHC.Generics+import Jordan.FromJSON.Class+import Jordan.ToJSON.Class+import Jordan.Types.Internal.MergeMap+import Jordan.Types.JSONType++data JSONError+  = -- | Generic, user-provided error message+    ErrorMesage Text+  | -- | JSON was not up to spec+    ErrorInvalidJSON+  | -- | Bad type encountered (Expected, Actual)+    ErrorBadType {expectedType :: !JSONType, actualType :: !JSONType}+  | -- | There was no value for this JSON+    ErrorNoValue+  | -- | Text constant was wrong.+    ErrorBadTextConstant {expectedText :: !Text, actualText :: !Text}+  | -- | An object had some bad values.+    ErrorBadObject JSONObjectError+  | -- | An array had some bad indices+    ErrorBadArray JSONArrayError+  | -- | One of multiple possible errors.+    ErrorChoice !(Set.Set JSONError)+  deriving (Show, Eq, Read, Ord, Generic)+  deriving anyclass (ToJSON, FromJSON)++instance Semigroup JSONError where+  (<>) ErrorNoValue ErrorNoValue = ErrorNoValue+  (<>) ErrorNoValue !a = a+  (<>) !a ErrorNoValue = a+  (<>) (ErrorChoice lhs) (ErrorChoice rhs) = ErrorChoice $ lhs <> rhs+  (<>) (ErrorChoice a) !rhs = ErrorChoice $ a <> Set.singleton rhs+  (<>) !a (ErrorChoice rhs) = ErrorChoice (Set.singleton a <> rhs)+  (<>) !lhs !rhs = ErrorChoice (Set.singleton lhs <> Set.singleton rhs)++instance NFData JSONError++-- | 'mempty' is 'ErrorNoValue'+instance Monoid JSONError where+  mempty = ErrorNoValue++newtype JSONObjectError = MkJSONObjectError (Map.Map Text JSONError)+  deriving (Eq, Ord, Generic)+  deriving (NFData, IsList, Show, Read) via (Map.Map Text JSONError)+  deriving (Semigroup, Monoid) via (MergeMap Text JSONError)++instance FromJSON JSONObjectError where+  fromJSON = MkJSONObjectError <$> fromJSON++instance ToJSON JSONObjectError where+  toJSON = contramap (Map.toAscList . keyValueErrors) $ serializeDictionary toJSON++singleObjectError :: Text -> JSONError -> JSONObjectError+singleObjectError t = MkJSONObjectError . Map.singleton t++keyValueErrors :: JSONObjectError -> Map.Map Text JSONError+keyValueErrors = coerce++newtype JSONArrayError = MkJSONArrayError (Map.Map Integer JSONError)+  deriving (Eq, Ord, Generic)+  deriving (NFData, IsList, Show, Read) via (Map.Map Integer JSONError)+  deriving (Semigroup, Monoid) via (MergeMap Integer JSONError)++indexErrors :: JSONArrayError -> Map.Map Integer JSONError+indexErrors = coerce++instance FromJSON JSONArrayError where+  fromJSON = MkJSONArrayError <$> fromJSON++instance ToJSON JSONArrayError where+  toJSON = contramap indexErrors toJSON++prettyPrintJSONError :: JSONError -> Text+prettyPrintJSONError = go id+  where+    go :: (Text -> Text) -> JSONError -> Text+    go mapper = \case+      ErrorMesage txt -> mapper txt+      ErrorInvalidJSON -> mapper "Invalid JSON"+      ErrorBadType jt jt' -> mapper "Bad type: Expected " <> pack (show jt) <> " got " <> pack (show jt')+      ErrorNoValue -> mapper "Expected to receive a value, but did not"+      ErrorBadTextConstant txt txt' -> mapper "Bad text constant: Expected \"" <> txt <> "\", got \"" <> txt' <> "\""+      ErrorBadObject (MkJSONObjectError map) -> Map.foldlWithKey (\acc key value -> acc <> "\n" <> mapper key <> ":\n" <> go (mapper . ("  " <>)) value) mempty map+      ErrorBadArray (MkJSONArrayError map) -> Map.foldlWithKey (\acc key value -> acc <> "\n" <> mapper (pack $ show key) <> ":\n" <> go (mapper . ("  " <>)) value) mempty map+      ErrorChoice ne -> mapper "One of:\n" <> foldl' (\acc err -> acc <> go newMap err) mempty ne+        where+          newMap = mapper . ("  " <>)

@@ -0,0 +1,23 @@+{-# LANGUAGE DeriveGeneric #-}++module Jordan.Types.JSONType where++import Control.DeepSeq+import GHC.Generics+import Jordan.FromJSON.Class (FromJSON)+import Jordan.ToJSON.Class (ToJSON)++data JSONType+  = JSONTypeNull+  | JSONTypeBool+  | JSONTypeText+  | JSONTypeNumber+  | JSONTypeArray+  | JSONTypeObject+  deriving (Show, Eq, Read, Ord, Bounded, Enum, Generic)++instance ToJSON JSONType++instance FromJSON JSONType++instance NFData JSONType

@@ -0,0 +1,68 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+module Jordan.Types.JSONValue+    ( JSONValue (..)+    ) where++import Data.Functor (($>))+import Data.Functor.Contravariant (Contravariant(..))+import qualified Data.Map.Strict as Map+import Data.Scientific (Scientific)+import Data.Text (Text)+import GHC.Generics (Generic(..))+import Jordan.FromJSON.Class (FromJSON(..), JSONParser(..))+import Jordan.ToJSON.Class (JSONSerializer(..), Selectable(..), ToJSON(..), selected)++-- | A type for any JSON value.+-- This is a basic Haskell sum type representation.+--+-- This is intended to for use when working with JSON where you do not know much about its structure.+data JSONValue+  = JNull+  | JBool Bool+  | JText Text+  | JNumber Scientific+  | JArray [JSONValue]+  | JObject (Map.Map Text JSONValue)+  deriving (Show, Eq, Ord, Generic)++instance FromJSON JSONValue where+  fromJSON+    = (parseNull $> JNull)+    <> (JText <$> parseText)+    <> (JBool <$> parseBool)+    <> (JNumber <$> parseNumber)+    <> nameParser "Jordan.JSONValue.Array.Input" (JArray <$> parseArrayWith fromJSON)+    <> nameParser "Jordan.JSONValue.Map.Input" (JObject . Map.fromList <$> parseDictionary fromJSON)++type AsEither+  = Either ()+      (Either Bool+        (Either Text+          (Either Scientific+            (Either [JSONValue] (Map.Map Text JSONValue)))))++toNestedEither+  :: JSONValue+  -> AsEither+toNestedEither = \case+  JNull -> Left ()+  JBool b -> Right (Left b)+  JText txt -> Right (Right (Left txt))+  JNumber sci -> Right (Right (Right (Left sci)))+  JArray jvs -> Right (Right (Right (Right (Left jvs))))+  JObject map -> Right (Right (Right (Right (Right map))))++instance ToJSON JSONValue where+  toJSON = select toNestedEither serializeNull s1+    where+      s1 = selected serializeBool s2+      s2 = selected serializeText s3+      s3 = selected serializeNumber s4+      s4+        = selected (nameSerializer "Jordan.JSONValue.Array.Output" serializeArray)+        $ nameSerializer "Jordan.JSONValue.Map.Output"+        $ contramap Map.toList+        $ serializeDictionary toJSON

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

@@ -0,0 +1,25 @@+{-# LANGUAGE LambdaCase #-}++module Jordan.FromJSON.UnboxedReportingSpec+  ( spec,+    prettyWhenError,+  )+where++import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)+import Jordan+import Jordan.FromJSON.Class (FromJSON (fromJSON))+import Jordan.SpecDefs (basicParsingSpec)+import Jordan.Types.JSONError+import Test.Hspec (Spec, describe, it, shouldBe)++prettyWhenError :: Either JSONError a -> Either Text a+prettyWhenError = \case+  Left je -> Left $ prettyPrintJSONError je+  Right a -> Right a++spec :: Spec+spec = describe "Jordan.FromJSON.Reporting" $ do+  basicParsingSpec $ \t v ->+    prettyWhenError (parseOrReport (encodeUtf8 t)) `shouldBe` Right v

@@ -1,56 +1,80 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}-module Jordan.RoundTripSpec-    where -import Data.ByteString.Lazy (fromStrict, toStrict)-import Data.Functor.Contravariant (Contravariant(..))-import Data.Proxy (Proxy(..))+module Jordan.RoundTripSpec where++import Data.ByteString.Lazy (ByteString, fromStrict, toStrict)+import qualified Data.ByteString.Lazy as LBS+import Data.Functor.Contravariant (Contravariant (..)) import Data.Text (Text, unpack)+import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.Typeable (Proxy (..), Typeable) import GHC.Generics-import Jordan (parseViaAttoparsec, parseViaMegaparsec, toJSONText, toJSONViaBuilder)-import Jordan.FromJSON.Class (FromJSON(..), JSONParser(..))-import Jordan.ToJSON.Class (JSONSerializer(..), ToJSON(..))+import Jordan (parseViaAttoparsec, toJSONViaBuilder)+import Jordan.FromJSON.Class (FromJSON (..), GFromJSON (..), JSONParser (..))+import Jordan.FromJSON.UnboxedReporting (parseOrReport)+import Jordan.Generic.Options+import Jordan.ToJSON.Class (GToJSON (..), 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+data PropertyResult exp = MkPropertyResult+  { expectedValue :: exp,+    actualValue :: Either String exp,+    jsonStringTested :: Text+  }+  deriving (Show, Read)++roundtripProperty ::+  (ToJSON a, FromJSON a, Arbitrary a, Show a, Eq a, Eq err, Show err) =>+  Proxy a ->+  (ByteString -> Either err a) ->+  (err -> String) ->+  Property+roundtripProperty (Proxy :: Proxy a) parser mapErr =+  forAllShrink (arbitrary @a) (shrink @a) $ \a ->+    let built = toJSONViaBuilder a+     in counterexample (show built) $ parser (toJSONViaBuilder a) === Right a++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+  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 :: () }+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 }+data TwoFieldsRec = TwoFieldsRec {firstField :: Int, secondField :: Int}   deriving (Eq, Show, Generic)   deriving anyclass (ToJSON, FromJSON) @@ -69,37 +93,43 @@ instance Arbitrary RLMSum where   arbitrary = arbitraryBoundedEnum -data ManyChoices-  = ChoseFirst { getFirst :: Int }-  | ChoseSecond { getSecondA :: Int, getSecondB :: Int }+data TwoChoices+  = 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-    ]+instance Arbitrary TwoChoices where+  arbitrary =+    oneof+      [ ChoseFirst <$> arbitrary,+        ChoseSecond <$> arbitrary <*> arbitrary+      ] -data FakePerson-  = FakePerson-  { age :: Int-  , name :: String-  , cool :: Bool-  } deriving (Eq, Show, Generic)+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+  arbitrary =+    FakePerson+      <$> arbitrary+      <*> fmap unpack genValidUtf8+      <*> arbitrary -newtype OnlyText = OnlyText { getText :: Text }-  deriving (Show, Eq)+newtype OnlyText = OnlyText {getText :: Text}+  deriving (Show, Eq, Generic) +shrinkText :: Text -> [Text]+shrinkText t+  | Text.length t == 0 = []+  | Text.length t == 1 = [""]+  | otherwise = Text.singleton <$> Text.unpack t+ instance ToJSON OnlyText where   toJSON = contramap getText serializeText @@ -108,70 +138,139 @@  instance Arbitrary OnlyText where   arbitrary = OnlyText <$> genValidUtf8+  shrink (OnlyText t) = OnlyText <$> shrinkText t  data EnumyObject   = EnumA   | EnumB   | EnumC-  | EnumObject { enumValue :: Text }+  | EnumObject {enumValue :: Text}+  | EnumOther OnlyText   deriving (Show, Eq, Generic)   deriving anyclass (ToJSON, FromJSON)  instance Arbitrary EnumyObject where-  arbitrary-    = oneof-    [ pure EnumA-    , pure EnumB-    , pure EnumC-    , EnumObject <$> genValidUtf8-    ]+  arbitrary =+    oneof+      [ pure EnumA,+        pure EnumB,+        pure EnumC,+        EnumObject <$> genValidUtf8,+        EnumOther <$> arbitrary+      ]+  shrink (EnumObject o) = EnumObject <$> shrinkText o+  shrink (EnumOther ot) = EnumOther <$> shrink ot+  shrink _ = [] -data AllTogether-  = AllTogether-  { extremelyBasic :: ExtremelyBasic-  , twoFieldsRec :: TwoFieldsRec-  , rlmSum :: RLMSum-  , fakePerson :: FakePerson-  , onlyText :: OnlyText-  , enumyObject :: EnumyObject-  } deriving (Eq, Show, Generic)+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+  arbitrary =+    AllTogether+      <$> arbitrary+      <*> arbitrary+      <*> arbitrary+      <*> arbitrary+      <*> arbitrary+      <*> arbitrary+  shrink (AllTogether ub tfr rs fp ot eo) =+    AllTogether+      <$> shrink ub+      <*> shrink tfr+      <*> shrink rs+      <*> shrink fp+      <*> shrink ot+      <*> shrink eo +data AnnoyinglyOptional = AnnoyinglyOptional+  { annoyingFirst :: Maybe Int,+    annoyingSecond :: Maybe Int,+    annoyingThird :: Maybe Int+  }+  deriving (Show, Read, Eq, Ord, Generic)+  deriving anyclass (ToJSON, FromJSON)++instance Arbitrary AnnoyinglyOptional where+  arbitrary =+    pure $ AnnoyinglyOptional Nothing Nothing Nothing++-- <$> arbitrary <*> arbitrary <*> arbitrary++data JustNulls = JustNulls+  { jna :: (),+    jnb :: (),+    jnc :: (),+    jnd :: (),+    jne :: (),+    jnf :: ()+  }+  deriving (Show, Read, Eq, Ord, Generic)+  deriving anyclass (ToJSON, FromJSON)++instance Arbitrary JustNulls where+  arbitrary =+    pure $+      JustNulls () () () () () ()+ showViaText :: (ToJSON a) => a -> String-showViaText = unpack . toJSONText+showViaText = unpack . decodeUtf8 . LBS.toStrict . toJSONViaBuilder  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)+showLeft :: (Show a) => Either a b -> Either [Char] b+showLeft = \case+  Left a -> Left (show a)+  Right b -> Right b++instance Arbitrary a => Arbitrary (WithOptions opts a) where+  arbitrary = WithOptions <$> arbitrary+  shrink (WithOptions a) = WithOptions <$> shrink a++roundtrips' ::+  (Arbitrary a, Show a, Eq a, ToJSON a, FromJSON a) =>+  Proxy a ->+  Spec+roundtrips' p = do   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)+      roundtripProperty p (parseViaAttoparsec . toStrict) show+    prop "roundstrips back via unboxed reporting" $+      roundtripProperty p (parseOrReport . toStrict) show +roundtrips ::+  ( Arbitrary a,+    Typeable a,+    Show a,+    Eq a,+    ToJSON a,+    FromJSON a,+    Generic a,+    GToJSON (Rep a),+    GFromJSON (Rep a)+  ) =>+  String ->+  Proxy a ->+  Spec+roundtrips n p@(Proxy :: Proxy a) = describe ("round-tripping " <> n) $ do+  describe "default roundtrips" $+    roundtrips' p+  describe "roundtrips with no options" $+    roundtrips' (Proxy @(WithOptions '[] a))+  describe "Roundtrips omitting nothing fields" $+    roundtrips' (Proxy @(WithOptions '[OmitNothingFields] a))+  describe "Roundtrips keeping nothing fields" $+    roundtrips' (Proxy @(WithOptions '[KeepNothingFields] a))+ spec :: Spec spec = describe "round-tripping generic values" $ do   roundtrips "a newtype around ()" (Proxy @ExtremelyBasic)@@ -181,3 +280,5 @@   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)+  roundtrips "an object with optional fields" (Proxy @AnnoyinglyOptional)+  roundtrips "an object that is jut a bunch of nulls" (Proxy @JustNulls)

@@ -1,23 +1,27 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-}-module Jordan.SpecDefs-    where -import Control.Applicative (Alternative((<|>)))+module Jordan.SpecDefs where++import Control.Applicative (Alternative ((<|>)))+import Data.Foldable import Data.Functor.Contravariant import Data.Functor.Contravariant.Divisible-import Data.String (IsString(..))+import Data.Scientific (Scientific, scientific)+import Data.String (IsString (..)) import Data.Text (Text, pack) import GHC.Generics (Generic) import Jordan.FromJSON.Class+import Jordan.Generic.Options import Jordan.ToJSON.Class-import Test.Hspec (Arg, Example, Spec, SpecWith, describe, it, shouldBe)+import Test.Hspec (Arg, Example, Spec, SpecWith, describe, fit, it, shouldBe) import Text.RawString.QQ -newtype BasicStruct-  = BasicStruct { bar :: () }+newtype BasicStruct = BasicStruct {bar :: ()}   deriving (Show, Eq, Ord)  goodBasic :: BasicStruct@@ -26,48 +30,62 @@ instance FromJSON BasicStruct where   fromJSON = (BasicStruct <$> fromNull) <> fromObject     where-      fromObject = parseObject "TestItems.BasicStruct.Output" $-        BasicStruct <$> parseField "bar"+      fromObject =+        parseObject $+          BasicStruct <$> parseField "bar"       fromNull = parseNull  instance ToJSON BasicStruct where-  toJSON = serializeObject "TestItems.BasicStruct.Input" $ writeField "bar" serializeNull+  toJSON = serializeObject $ serializeFieldWith "bar" serializeNull  basicNull = pack [r| null |]++basicOneFieldNoSpace = pack [r|{"bar":null}|]+ basicOneField = pack [r| { "bar": null } |]-basicEscaped = pack [r| { "\u0062\u0061\u0072": null } |]++basicEscaped = pack [r| { "\u0062\u0061\u0072": null }|]++basicEscapedNoSpace = 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 :: () }+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"+  fromJSON = parseObject $ TwoFields <$> parseField "one" <*> parseField "two" -twoSimple = pack [r| { "one": null, "two": null } |]+twoSimple = pack [r| { "one"   :   null, "two": null } |] -twoScramble = pack [r| { "two": null, "one": null } |]+twoScramble = pack [r| {"two":null,"one":null} |] -twoExtra = pack [r|+twoExtra =+  pack+    [r|   {     "ignore": [],     "one": null,-    "bad": {},-    "another": [1,2,3],-    "yetAgain": null,+    "four": [],+    "five": "test",+    "seven": {},+    "six": "why tho",     "two": null,-    "three": null }+    "three": {},+    "ignored": [1,2,3,4, { " foo " : null }]+  } |] -twoScrambleExtra = pack [r|+twoScrambleExtra =+  pack+    [r|   {     "ignore": null,     "bad": null,@@ -78,11 +96,11 @@   } |] -data GenericStruct-  = GenericStruct-  { firstLabel :: ()-  , secondLabel :: [()]-  } deriving (Show, Read, Eq, Ord, Generic)+data GenericStruct = GenericStruct+  { firstLabel :: (),+    secondLabel :: [()]+  }+  deriving (Show, Read, Eq, Ord, Generic)  instance FromJSON GenericStruct @@ -96,14 +114,57 @@ 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+data Coord = Coord {x :: !Double, y :: !Double}+  deriving (Show, Eq, Ord, Generic)++instance FromJSON Coord where+  fromJSON = fromObject <> fromArray+    where+      fromObject = parseObject $ Coord <$> parseField "x" <*> parseField "y"+      fromArray = parseTuple $ Coord <$> consumeItem <*> consumeItem++coordBasic = pack [r|{ "x": 10, "y": 10 } |]++coordReverse = pack [r| { "y": 11, "x": 12 } |]++coordExtra = pack [r| { "x": 1, "y": 2, "z": 3 } |]++coordNoSpaceDecimal = pack [r|{"x":0.0,"y":0.0}|]++coordTuple = pack [r| [1, 20] |]++data HomogenousCoord = HomogenousCoord {hx :: !Double, hy :: !Double, hz :: !Double}+  deriving (Show, Read, Eq, Ord, Generic)++instance FromJSON HomogenousCoord where+  fromJSON = fromObject <> fromObjectZero <> fromArray <> fromArrayZero+    where+      fromObject = parseObject $ mk <$> parseField "x" <*> parseField "y" <*> parseField "z"+      fromObjectZero = parseObject $ mk <$> parseField "x" <*> parseField "y" <*> pure 1.0+      fromArray = parseTuple $ mk <$> consumeItem <*> consumeItem <*> consumeItem+      fromArrayZero = parseTuple $ mk <$> consumeItem <*> consumeItem <*> pure 1.0+      mk = HomogenousCoord++data WeirdFeedback+  = GeneralFeedback Text+  | SpecificFeedback [(Text, Text)]+  deriving (Show, Eq)++instance FromJSON WeirdFeedback where+  fromJSON =+    parseObject (GeneralFeedback <$> parseField "general")+      <> (SpecificFeedback <$> parseDictionary fromJSON)++basicWritingSpec ::+  (forall val. (ToJSON val, Show val) => val -> Text) ->+  Spec basicWritingSpec writeJSON = do   describe "writing basic primitives" $ do     it "writes nulls" $@@ -117,7 +178,7 @@     it "writes an array with one item" $ do       writeJSON [()] `shouldBe` "[null]"     it "writes an array with two items" $ do-      writeJSON [(),()] `shouldBe` "[null,null]"+      writeJSON [(), ()] `shouldBe` "[null,null]"     it "writes the number 1" $ do       writeJSON (1 :: Int) `shouldBe` "1.0"     it "writes the number 1.5" $ do@@ -134,63 +195,70 @@     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 ::+  (Example a) =>+  (forall val. (FromJSON val, Show val, Eq val) => Text -> val -> a) ->+  SpecWith (Arg a) basicParsingSpec parseMatch = do+  let parseExample t v = it ("parses " <> show t <> " to " <> show v) $ t `parseMatch` v+   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+    parseExample "true" True+    parseExample "false" False+    parseExample "null" ()+  describe "parsing numbers" $ do+    let m (t, e, i) = parseExample t $ scientific e i+    traverse_+      m+      [ ("0", 0, 0),+        ("1", 1, 0),+        ("20", 20, 0),+        ("190865", 190865, 0),+        ("-0", 0, 0),+        ("-1", -1, 0),+        ("-10.5", -105, -1),+        ("-1e100", -1, 100)+      ]+  describe "basic array parsing" $ do+    "[]" `parseExample` ([] :: [()])+    "[null ]" `parseExample` [()]+    "[null\n,null]" `parseExample` [(), ()]+    basicNull `parseExample` goodBasic+    basicArray `parseExample` replicate 4 goodBasic+  describe "basic object parsing" $ do+    basicOneFieldNoSpace `parseExample` goodBasic+    basicOneField `parseExample` goodBasic+    basicExtraFields `parseExample` goodBasic+    basicEscaped `parseExample` goodBasic+    basicEscapedNoSpace `parseExample` goodBasic+    basicPartialEscape `parseExample` goodBasic+  describe "parsing coordinates" $ do+    coordBasic `parseExample` Coord 10 10+    coordReverse `parseExample` Coord 12 11+    coordExtra `parseExample` Coord 1 2+    coordTuple `parseExample` Coord 1 20+    coordNoSpaceDecimal `parseExample` Coord 0 0+  describe "parsing homogenous coords" $ do+    "[1,2]" `parseExample` HomogenousCoord 1 2 1+    "[1,2,2]" `parseExample` HomogenousCoord 1 2 2+    "{ \"x\": 1, \"y\": 2, \"z\": 10 }" `parseExample` HomogenousCoord 1 2 10   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)+    "\"foo\\\\\"" `parseExample` ("foo\\" :: Text)+    "\"foo\\\"\"" `parseExample` ("foo\"" :: Text)+    "\"foo\\u2795\"" `parseExample` ("foo➕" :: Text)+    [r|"foo"|] `parseExample` ("foo" :: Text)+    [r|"foo\\\\"|] `parseExample` ([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+    twoSimple `parseExample` goodTwo+    twoScramble `parseExample` goodTwo+    twoExtra `parseExample` goodTwo+    twoScrambleExtra `parseExample` goodTwo   describe "parsing a generically-derived object" $ do-    it "parses correctly in the basic case" $-      genericDefault `parseMatch` GenericStruct () [()]+    genericDefault `parseExample` 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 () ())+    sumBasic `parseExample` GenericBasic (BasicStruct ())+    sumBasicObj `parseExample` GenericBasic (BasicStruct ())+    sumTwo `parseExample` GenericTwo (TwoFields () ())+  describe "object parsing with possible weirdness" $ do+    pack [r| {"general": "it sucked", "foo": "bar"} |] `parseExample` GeneralFeedback "it sucked"+    pack [r| {"foo": "bar"} |] `parseExample` SpecificFeedback [("foo", "bar")]

@@ -1,85 +0,0 @@-{-# 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}}|]

@@ -1,18 +1,17 @@ module Main-    ( main-    ) where+  ( main,+  )+where  import qualified Jordan.FromJSON.AttoparsecSpec as APS-import qualified Jordan.FromJSON.MegaparsecSpec as MPS+import qualified Jordan.FromJSON.UnboxedReportingSpec as UR 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+  UR.spec