{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DefaultSignatures     #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
-- |
--
-- This module contains the types and functions that power the 'Generic' functions for Waargonaut. Code
-- that writes the code so you don't have to.
--
module Waargonaut.Generic
  (
    -- * Rationale
    -- $rationale

    -- * Quick Start
    -- $quick

    -- * Tagged
    -- $tagged

    -- * GHC >= 8 Convenience
    -- $nice

    -- * TypeClasses
    JsonEncode (..)
  , JsonDecode (..)

    -- * Tag
  , GWaarg

    -- * Options
  , NewtypeName (..)
  , Options (..)
  , defaultOpts
  , trimPrefixLowerFirst

    -- * Creation
  , gEncoder
  , gDecoder
  , gObjEncoder

    -- * Reexports
  , module Data.Tagged
  , Generic (..)
  , HasDatatypeInfo (..)
  ) where

import           Generics.SOP
import           Generics.SOP.Record           (IsRecord)

import           Control.Lens                  (findOf, folded, isn't, ( # ),
                                                _Empty, _Left)
import           Control.Monad                 ((>=>))
import           Control.Monad.Except          (lift, throwError)
import           Control.Monad.Reader          (runReaderT)
import           Control.Monad.State           (modify)

import qualified Data.Char                     as Char
import           Data.Function                 ((&))
import           Data.Maybe                    (fromMaybe)

import           Data.Foldable                 (foldl')

import           Data.List.NonEmpty            (NonEmpty)

import           Data.ByteString               (ByteString)

import           Data.Text                     (Text)
import qualified Data.Text                     as Text

import           Data.Scientific               (Scientific)

import           Data.Tagged
import qualified Data.Tagged                   as T

import           Waargonaut                    (Json)
import           Waargonaut.Types              (JObject, WS)

import           Waargonaut.Encode             (Encoder, Encoder')
import qualified Waargonaut.Encode             as E

import           HaskellWorks.Data.Positioning (Count)

import           Waargonaut.Decode             (Decoder)
import qualified Waargonaut.Decode             as D

import           Waargonaut.Decode.Error       (DecodeError (..))
import           Waargonaut.Decode.Internal    (CursorHistory' (..),
                                                DecodeResultT (..),
                                                runDecoderResultT)
import           Waargonaut.Decode.Types       (unDecodeResult)

-- $setup
-- >>> :set -XOverloadedStrings

-- $rationale
-- Although creating your 'Decoder's and 'Encoder's explicitly is the preferred way of utilising
-- Waargonaut. The 'Generic' mechanism within Haskell provides immense opportunity to reduce or
-- eliminate the need to write code. Given the mechanical nature of JSON this a benefit that cannot
-- be ignored.
--
-- There are two typeclasses provided, 'JsonEncode' and 'JsonDecode'. Each with a single function
-- that will generate a 'Encoder' or 'Decoder' for that type. Normally, typeclasses such as these
-- are only parameterised over the type that is to be encoded/decoded. Which is acceptable if there
-- is only ever a single possible way to encode or decode a value of that type. However this is
-- rarely the case, even with respect to strings or numbers.
--
-- To account for this, the 'JsonEncode' and 'JsonDecode' typeclasses require an additional type
-- parameter @ t @. This parameter allows you to differentiate between the alternative ways of
-- encoding or decoding a single type @ a @. This parameter is attached to the 'Encoder' or
-- 'Decoder' using the 'Tagged' newtype. Allowing the type system to help you keep track of them.
--

-- $quick
-- A quick example on how to use the Waargonaut 'Generic' functionality. We will use the following
-- type and let GHC and 'Generic' write our 'Encoder' and 'Decoder' for us.
--
-- @
-- data Image = Image
--   { _imageWidth    :: Int
--   , _imageHeight   :: Int
--   , _imageTitle    :: Text
--   , _imageAnimated :: Bool
--   , _imageIDs      :: [Int]
--   }
--   deriving (Eq, Show)
-- @
--
-- Ensure we have the required imports and language options:
--
-- @
-- {-\# LANGUAGE DeriveGeneric \#-}
-- import qualified GHC.Generic as GHC
-- import Waargonaut.Generic (Generic, HasDatatypeInfo, JsonEncode, JsonDecode, GWaarg)
-- @
--
-- Update our data type 'deriving' to have GHC to do the heavy lifting:
--
-- @
-- data Image = Image
--   ...
--   deriving (..., GHC.Generic)
-- @
--
-- Because Waargonaut uses the <https://hackage.haskell.org/package/generics-sop 'generics-sop'>
-- package to make the 'Generic' functions easier to write and maintain. We need two more instances,
-- note that we don't have to write these either. We can leave these empty and the default
-- implementations, courtesy of 'Generic', will handle it for us.
--
-- @
-- instance HasDatatypeInfo Image
-- instance Generic Image
-- @
--
-- Now we can define our 'JsonEncode' and 'JsonDecode' instances. We need to provide the @ t @
-- parameter. Assume we have no special requirements, so we can use the 'GWaarg' tag.
--
-- @
-- instance JsonEncode GWaarg Image
-- instance JsonDecode GWaarg Image
-- @
--
-- That's it! We can now use 'mkEncoder' and 'mkDecoder' to write the code for our @Image@ type.
-- These will be tagged with our 'GWaarg' phantom type parameter:
--
-- @
-- mkEncoder :: Applicative f => Tagged GWaarg (Encoder f Image)
-- mkDecoder :: Monad f       => Tagged GWaarg (Decoder f Image)
-- @
--
-- The encoding and decoding "runner" functions will require that you remove the tag. You can use
-- the 'untag' function for this. The next section will discuss the 'Tagged' type.
--
-- There is Template Haskell available that can write all of the 'Generic' deriving for you, see the
-- <https://hackage.haskell.org/package/generics-sop/docs/Generics-SOP-TH.html 'Generics.SOP.TH'>
-- module in the 'generics-sop' package for more. Given how little boilerplate code is required and
-- that the Template Haskell extension enforces a strict ordering of code within the file. It is not
-- the recommended solution. But I'm not your supervisor, I'm just a library.

-- $tagged
-- #tagged#
-- The 'Tagged' type comes from the <https://hackage.haskell.org/package/tagged 'tagged'> package.
-- It is a 'newtype' that provides a phantom type parameter. As well as having a several useful
-- typeclass instances and helpful functions already written for us.
--
-- When dealing with the 'Tagged' 'Encoder's and 'Decoder's there are two functions that are
-- particularly useful; 'untag', and 'proxy'.
--
-- The 'untag' function removes the tag from the inner type:
--
-- @
-- untag :: -- forall k (s :: k) b. Tagged s b -> b
-- @
--
-- When used with one of the 'Tagged' 'Generic' functions:
--
-- @
-- let e = mkEncoder :: Applicative f => Tagged GWaarg (Encoder f Image)
--
-- untag e :: Applicative f => Encoder f Image
-- @
--
-- The other function 'proxy', allows you to use 'mkEncoder' or 'mkDecoder' with the desired @ t @
-- parameter and then immediately remove the tag. This function requires the use of some @proxy@
-- that carries the same @ t @ of your instance:
--
-- @
-- proxy :: Tagged s a -> proxy s -> a
-- @
--
-- One way to utilise this function is in combination with 'Data.Proxy.Proxy' from @base@:
--
-- @
-- (proxy mkDecoder (Proxy :: Proxy GWaarg)) :: Monad f => Decoder f Image
-- @
--
-- This lets you skip the 'untag' step but without losing the safety of the 'Tagged' phantom type.
--

-- $nice
-- All of the techniques described above are explicit and will work in all versions of GHC that
-- Waargonaut supports. Should you be running a GHC that is version 8.0.1 or later, then you have
-- access to a language extension called <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#extension-TypeApplications TypeApplications>.
--
-- This extension allows you to avoid much of the explicit type annotations described in Tagged
-- section of "Waargonaut.Generic#tagged". For example the 'proxy' function may be utilised like so:
--
-- @
-- (proxy mkDecoder (Proxy :: Proxy GWaarg)) :: Monad f => Decoder f Image
-- @
--
-- Becomes:
--
-- @
-- (proxy mkDecoder \@GWaarg) :: Monad f => Decoder f Image
-- @
--
-- You can also use the @TypeApplications@ directly on the 'mkEncoder' or 'mkDecoder' function:
--
-- @
-- mkEncoder \@GWaarg :: Applicative f => Tagged GWaarg (Encoder f Image)
-- mkDecoder \@GWaarg :: Monad f       => Tagged GWaarg (Decoder f Image)
-- @
--

-- | This is a provided tag that may be used for tagging the 'JsonEncode' and 'JsonDecode'
-- instances. You are encouraged to make your own tags for full control of your own instances.
data GWaarg

-- | The options we currently have for using the 'Generic' mechanism to handle 'newtype' values:
data NewtypeName

  -- | Discard the newtype wrapper and encode the inner value.
  --
  -- @
  -- newtype Foo = Foo Text
  --
  -- let x = Foo \"Fred\"
  -- @
  --
  -- Will be encoded as: @ \"Fred\" @
  --
  = Unwrap

  -- | Encode the newtype value as an object using the constructor as the "key".
  --
  -- @
  -- newtype Foo = Foo Text
  --
  -- let x = Foo \"Fred\"
  -- @
  --
  -- Will be encoded as: @ {\"Foo\":\"Fred\"} @
  --
  | ConstructorNameAsKey

  -- | Encode the newtype value as an object, treaing the field accessor as the "key", and
  -- passing that field name through the '_optionsFieldName' function.
  --
  -- @
  -- newtype Foo = Foo { deFoo :: Text }
  --
  -- let x = Foo \"Fred\"
  -- @
  --
  -- Will be encoded as: @ {\"deFoo\":\"Fred\"} @
  | FieldNameAsKey
  deriving (Int -> NewtypeName -> ShowS
[NewtypeName] -> ShowS
NewtypeName -> String
(Int -> NewtypeName -> ShowS)
-> (NewtypeName -> String)
-> ([NewtypeName] -> ShowS)
-> Show NewtypeName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NewtypeName] -> ShowS
$cshowList :: [NewtypeName] -> ShowS
show :: NewtypeName -> String
$cshow :: NewtypeName -> String
showsPrec :: Int -> NewtypeName -> ShowS
$cshowsPrec :: Int -> NewtypeName -> ShowS
Show, NewtypeName -> NewtypeName -> Bool
(NewtypeName -> NewtypeName -> Bool)
-> (NewtypeName -> NewtypeName -> Bool) -> Eq NewtypeName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NewtypeName -> NewtypeName -> Bool
$c/= :: NewtypeName -> NewtypeName -> Bool
== :: NewtypeName -> NewtypeName -> Bool
$c== :: NewtypeName -> NewtypeName -> Bool
Eq)

-- | The configuration options for creating 'Generic' encoder or decoder values.
data Options = Options
  { -- | When encoding/decoding a record type, this function will be used on the field names to
    -- determine how they will be encoded. Or what keys to look up on the JSON object when it is being
    -- decoded.
    Options -> ShowS
_optionsFieldName           :: String -> String

    -- | How to handle 'newtype' values. See 'NewtypeName' for more info.
  , Options -> NewtypeName
_optionsNewtypeWithConsName :: NewtypeName
  }

-- | Default options for 'Generic' functionality:
--
-- * Field names are left untouched: ('id')
-- * Newtype values are encoded as raw values: ('Unwrap')
--
defaultOpts :: Options
defaultOpts :: Options
defaultOpts = ShowS -> NewtypeName -> Options
Options ShowS
forall a. a -> a
id NewtypeName
Unwrap

-- |
-- Helper function to alter record field names for encoding and decoding. Intended use is to be
-- given the prefix you would like to have removed and then included in the 'Options' for the
-- typeclass you are implementing.
--
-- A common use case when encoding Haskell record types is to remove a prefix and then lower-case
-- the first letter:
--
-- >>> trimPrefixLowerFirst "_image" "_imageHeight"
-- "height"
--
-- >>> trimPrefixLowerFirst "_image" "Height"
-- "Height"
--
-- >>> trimPrefixLowerFirst "_image" ""
-- ""
--
-- >>> trimPrefixLowerFirst "" "_imageHeight"
-- "_imageHeight"
--
trimPrefixLowerFirst :: Text -> String -> String
trimPrefixLowerFirst :: Text -> ShowS
trimPrefixLowerFirst Text
p String
n = String -> ((Char, Text) -> String) -> Maybe (Char, Text) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
n (Char, Text) -> String
f
  (Maybe (Char, Text) -> String) -> Maybe (Char, Text) -> String
forall a b. (a -> b) -> a -> b
$ Text -> Maybe (Char, Text)
Text.uncons (Text -> Maybe (Char, Text)) -> Maybe Text -> Maybe (Char, Text)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Text -> Maybe Text
Text.stripPrefix Text
p (String -> Text
Text.pack String
n)
  where f :: (Char, Text) -> String
f (Char
h',Text
t') = Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Char -> Text -> Text
Text.cons (Char -> Char
Char.toLower Char
h') Text
t'

-- |
-- Encoding Typeclass for Waargonaut.
--
-- This type class is responsible for creating an 'Encoder' for the type of @ a @, differentiated
-- from the other possible instances of this typeclass for type @ a @ by the tag type @ t @.
--
-- To create a 'Tagged' 'Encoder' for the purposes of writing an instance your self, you need only
-- data constructor 'Tagged' from 'Data.Tagged'. It has been re-exported from this module.
--
-- @
-- instance JsonEncode GWaarg Foo where
--   mkEncoder = Tagged fooEncoderIWroteEarlier
-- @

class JsonEncode t a where
  mkEncoder :: Applicative f => Tagged t (Encoder f a)

  default mkEncoder
    :: ( Applicative f
       , Generic a
       , HasDatatypeInfo a
       , All2 (JsonEncode t) (Code a)
       )
    => Tagged t (Encoder f a)
  mkEncoder =
    Options -> Tagged t (Encoder f a)
forall k (t :: k) a (f :: * -> *).
(Generic a, Applicative f, HasDatatypeInfo a,
 All2 (JsonEncode t) (Code a)) =>
Options -> Tagged t (Encoder f a)
gEncoder Options
defaultOpts

instance JsonEncode t a                   => JsonEncode t (Maybe a)    where mkEncoder :: Tagged t (Encoder f (Maybe a))
mkEncoder = Encoder f a -> Encoder f (Maybe a)
forall (f :: * -> *) a.
Applicative f =>
Encoder f a -> Encoder f (Maybe a)
E.maybeOrNull (Encoder f a -> Encoder f (Maybe a))
-> Tagged t (Encoder f a) -> Tagged t (Encoder f (Maybe a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tagged t (Encoder f a)
forall k (t :: k) a (f :: * -> *).
(JsonEncode t a, Applicative f) =>
Tagged t (Encoder f a)
mkEncoder
instance (JsonEncode t a, JsonEncode t b) => JsonEncode t (Either a b) where mkEncoder :: Tagged t (Encoder f (Either a b))
mkEncoder = Encoder f a -> Encoder f b -> Encoder f (Either a b)
forall (f :: * -> *) a b.
Functor f =>
Encoder f a -> Encoder f b -> Encoder f (Either a b)
E.either (Encoder f a -> Encoder f b -> Encoder f (Either a b))
-> Tagged t (Encoder f a)
-> Tagged t (Encoder f b -> Encoder f (Either a b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tagged t (Encoder f a)
forall k (t :: k) a (f :: * -> *).
(JsonEncode t a, Applicative f) =>
Tagged t (Encoder f a)
mkEncoder Tagged t (Encoder f b -> Encoder f (Either a b))
-> Tagged t (Encoder f b) -> Tagged t (Encoder f (Either a b))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Tagged t (Encoder f b)
forall k (t :: k) a (f :: * -> *).
(JsonEncode t a, Applicative f) =>
Tagged t (Encoder f a)
mkEncoder
instance (JsonEncode t a)                 => JsonEncode t [a]          where mkEncoder :: Tagged t (Encoder f [a])
mkEncoder = Encoder f a -> Encoder f [a]
forall (f :: * -> *) a.
Applicative f =>
Encoder f a -> Encoder f [a]
E.list (Encoder f a -> Encoder f [a])
-> Tagged t (Encoder f a) -> Tagged t (Encoder f [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tagged t (Encoder f a)
forall k (t :: k) a (f :: * -> *).
(JsonEncode t a, Applicative f) =>
Tagged t (Encoder f a)
mkEncoder
instance (JsonEncode t a)                 => JsonEncode t (NonEmpty a) where mkEncoder :: Tagged t (Encoder f (NonEmpty a))
mkEncoder = Encoder f a -> Encoder f (NonEmpty a)
forall (f :: * -> *) a.
Applicative f =>
Encoder f a -> Encoder f (NonEmpty a)
E.nonempty (Encoder f a -> Encoder f (NonEmpty a))
-> Tagged t (Encoder f a) -> Tagged t (Encoder f (NonEmpty a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tagged t (Encoder f a)
forall k (t :: k) a (f :: * -> *).
(JsonEncode t a, Applicative f) =>
Tagged t (Encoder f a)
mkEncoder
instance JsonEncode t Text                                             where mkEncoder :: Tagged t (Encoder f Text)
mkEncoder = Encoder f Text -> Tagged t (Encoder f Text)
forall k (s :: k) b. b -> Tagged s b
Tagged Encoder f Text
forall (f :: * -> *). Applicative f => Encoder f Text
E.text
instance JsonEncode t Int                                              where mkEncoder :: Tagged t (Encoder f Int)
mkEncoder = Encoder f Int -> Tagged t (Encoder f Int)
forall k (s :: k) b. b -> Tagged s b
Tagged Encoder f Int
forall (f :: * -> *). Applicative f => Encoder f Int
E.int
instance JsonEncode t Scientific                                       where mkEncoder :: Tagged t (Encoder f Scientific)
mkEncoder = Encoder f Scientific -> Tagged t (Encoder f Scientific)
forall k (s :: k) b. b -> Tagged s b
Tagged Encoder f Scientific
forall (f :: * -> *). Applicative f => Encoder f Scientific
E.scientific
instance JsonEncode t Bool                                             where mkEncoder :: Tagged t (Encoder f Bool)
mkEncoder = Encoder f Bool -> Tagged t (Encoder f Bool)
forall k (s :: k) b. b -> Tagged s b
Tagged Encoder f Bool
forall (f :: * -> *). Applicative f => Encoder f Bool
E.bool
instance JsonEncode t Json                                             where mkEncoder :: Tagged t (Encoder f Json)
mkEncoder = Encoder f Json -> Tagged t (Encoder f Json)
forall k (s :: k) b. b -> Tagged s b
Tagged Encoder f Json
forall (f :: * -> *). Applicative f => Encoder f Json
E.json

-- |
-- Decoding Typeclass for Waargonaut
--
-- Responsible for creating a 'Decoder' for the type @ a @, differentiated from the other possible
-- instances of this typeclass for type @ a @ by the tag type @ t @.
--
-- To create a 'Tagged' 'Decoder' for the purposes of writing an instance your self, you need only
-- data constructor 'Tagged' from 'Data.Tagged'. It has been re-exported from this module.
--
-- @
-- instance JsonDecode GWaarg Foo where
--   mkDecoder = Tagged fooDecoderIWroteEarlier
-- @
--
class JsonDecode t a where
  mkDecoder :: Monad f => Tagged t (Decoder f a)

  default mkDecoder
    :: ( Monad f
       , Generic a
       , HasDatatypeInfo a
       , All2 (JsonDecode t) (Code a)
       ) => Tagged t (Decoder f a)
  mkDecoder =
    Options -> Tagged t (Decoder f a)
forall k (f :: * -> *) a (t :: k).
(Generic a, HasDatatypeInfo a, All2 (JsonDecode t) (Code a),
 Monad f) =>
Options -> Tagged t (Decoder f a)
gDecoder Options
defaultOpts

instance JsonDecode t a                   => JsonDecode t (Maybe a)    where mkDecoder :: Tagged t (Decoder f (Maybe a))
mkDecoder = Decoder f a -> Decoder f (Maybe a)
forall (f :: * -> *) a.
Monad f =>
Decoder f a -> Decoder f (Maybe a)
D.maybeOrNull (Decoder f a -> Decoder f (Maybe a))
-> Tagged t (Decoder f a) -> Tagged t (Decoder f (Maybe a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tagged t (Decoder f a)
forall k (t :: k) a (f :: * -> *).
(JsonDecode t a, Monad f) =>
Tagged t (Decoder f a)
mkDecoder
instance (JsonDecode t a, JsonDecode t b) => JsonDecode t (Either a b) where mkDecoder :: Tagged t (Decoder f (Either a b))
mkDecoder = Decoder f a -> Decoder f b -> Decoder f (Either a b)
forall (f :: * -> *) a b.
Monad f =>
Decoder f a -> Decoder f b -> Decoder f (Either a b)
D.either (Decoder f a -> Decoder f b -> Decoder f (Either a b))
-> Tagged t (Decoder f a)
-> Tagged t (Decoder f b -> Decoder f (Either a b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tagged t (Decoder f a)
forall k (t :: k) a (f :: * -> *).
(JsonDecode t a, Monad f) =>
Tagged t (Decoder f a)
mkDecoder Tagged t (Decoder f b -> Decoder f (Either a b))
-> Tagged t (Decoder f b) -> Tagged t (Decoder f (Either a b))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Tagged t (Decoder f b)
forall k (t :: k) a (f :: * -> *).
(JsonDecode t a, Monad f) =>
Tagged t (Decoder f a)
mkDecoder
instance (JsonDecode t a)                 => JsonDecode t [a]          where mkDecoder :: Tagged t (Decoder f [a])
mkDecoder = Decoder f a -> Decoder f [a]
forall (f :: * -> *) a. Monad f => Decoder f a -> Decoder f [a]
D.list (Decoder f a -> Decoder f [a])
-> Tagged t (Decoder f a) -> Tagged t (Decoder f [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tagged t (Decoder f a)
forall k (t :: k) a (f :: * -> *).
(JsonDecode t a, Monad f) =>
Tagged t (Decoder f a)
mkDecoder
instance (JsonDecode t a)                 => JsonDecode t (NonEmpty a) where mkDecoder :: Tagged t (Decoder f (NonEmpty a))
mkDecoder = Decoder f a -> Decoder f (NonEmpty a)
forall (f :: * -> *) a.
Monad f =>
Decoder f a -> Decoder f (NonEmpty a)
D.nonempty (Decoder f a -> Decoder f (NonEmpty a))
-> Tagged t (Decoder f a) -> Tagged t (Decoder f (NonEmpty a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tagged t (Decoder f a)
forall k (t :: k) a (f :: * -> *).
(JsonDecode t a, Monad f) =>
Tagged t (Decoder f a)
mkDecoder
instance JsonDecode t Text                                             where mkDecoder :: Tagged t (Decoder f Text)
mkDecoder = Decoder f Text -> Tagged t (Decoder f Text)
forall k (s :: k) b. b -> Tagged s b
Tagged Decoder f Text
forall (f :: * -> *). Monad f => Decoder f Text
D.text
instance JsonDecode t Int                                              where mkDecoder :: Tagged t (Decoder f Int)
mkDecoder = Decoder f Int -> Tagged t (Decoder f Int)
forall k (s :: k) b. b -> Tagged s b
Tagged Decoder f Int
forall (f :: * -> *). Monad f => Decoder f Int
D.int
instance JsonDecode t Scientific                                       where mkDecoder :: Tagged t (Decoder f Scientific)
mkDecoder = Decoder f Scientific -> Tagged t (Decoder f Scientific)
forall k (s :: k) b. b -> Tagged s b
Tagged Decoder f Scientific
forall (f :: * -> *). Monad f => Decoder f Scientific
D.scientific
instance JsonDecode t Bool                                             where mkDecoder :: Tagged t (Decoder f Bool)
mkDecoder = Decoder f Bool -> Tagged t (Decoder f Bool)
forall k (s :: k) b. b -> Tagged s b
Tagged Decoder f Bool
forall (f :: * -> *). Monad f => Decoder f Bool
D.bool
instance JsonDecode t Json                                             where mkDecoder :: Tagged t (Decoder f Json)
mkDecoder = Decoder f Json -> Tagged t (Decoder f Json)
forall k (s :: k) b. b -> Tagged s b
Tagged Decoder f Json
forall (f :: * -> *). Monad f => Decoder f Json
D.json

type JTag = String

data Tag
  = NoTag
  | Tag JTag
  deriving Int -> Tag -> ShowS
[Tag] -> ShowS
Tag -> String
(Int -> Tag -> ShowS)
-> (Tag -> String) -> ([Tag] -> ShowS) -> Show Tag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tag] -> ShowS
$cshowList :: [Tag] -> ShowS
show :: Tag -> String
$cshow :: Tag -> String
showsPrec :: Int -> Tag -> ShowS
$cshowsPrec :: Int -> Tag -> ShowS
Show

data JsonInfo :: [*] -> * where
  JsonZero :: ConstructorName -> JsonInfo '[]
  JsonOne  :: Tag -> JsonInfo '[a]
  JsonMul  :: SListI xs => Tag -> JsonInfo xs
  JsonRec  :: SListI xs => Tag -> NP (K Text) xs -> JsonInfo xs

inObj :: Encoder' a -> String -> Encoder' a
inObj :: Encoder' a -> String -> Encoder' a
inObj Encoder' a
en String
t = (a -> MapLikeObj WS Json -> MapLikeObj WS Json) -> Encoder' a
forall ws a i.
(AsJType Json ws a, Semigroup ws, Monoid ws) =>
(i -> MapLikeObj ws a -> MapLikeObj ws a) -> Encoder' i
E.mapLikeObj' (Index (MapLikeObj WS Json)
-> Encoder' a -> a -> MapLikeObj WS Json -> MapLikeObj WS Json
forall t a.
(At t, IxValue t ~ Json) =>
Index t -> Encoder' a -> a -> t -> t
E.atKey' (String -> Text
Text.pack String
t) Encoder' a
en)

tagVal
  :: Applicative f
  => Tag
  -> f Json
  -> K (f Json) xs
tagVal :: Tag -> f Json -> K (f Json) xs
tagVal  Tag
NoTag  f Json
v =
  f Json -> K (f Json) xs
forall k a (b :: k). a -> K a b
K f Json
v
tagVal (Tag String
t) f Json
v =
  f Json -> K (f Json) xs
forall k a (b :: k). a -> K a b
K (f Json -> K (f Json) xs) -> f Json -> K (f Json) xs
forall a b. (a -> b) -> a -> b
$ Encoder Identity Json -> Json -> Json
forall a. Encoder Identity a -> a -> Json
E.asJson' (Encoder Identity Json -> String -> Encoder Identity Json
forall a. Encoder' a -> String -> Encoder' a
inObj Encoder Identity Json
E.json' String
t) (Json -> Json) -> f Json -> f Json
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Json
v

unTagVal
  :: Monad f
  => Tag
  -> Decoder f c
  -> D.JCurs
  -> D.DecodeResult f c
unTagVal :: Tag -> Decoder f c -> JCurs -> DecodeResult f c
unTagVal Tag
NoTag   Decoder f c
d =
  Decoder f c -> JCurs -> DecodeResult f c
forall (f :: * -> *) a.
Monad f =>
Decoder f a -> JCurs -> DecodeResult f a
D.focus Decoder f c
d
unTagVal (Tag String
n) Decoder f c
d =
  JCurs -> DecodeResult f JCurs
forall (f :: * -> *). Monad f => JCurs -> DecodeResult f JCurs
D.down (JCurs -> DecodeResult f JCurs)
-> (JCurs -> DecodeResult f c) -> JCurs -> DecodeResult f c
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Text -> Decoder f c -> JCurs -> DecodeResult f c
forall (f :: * -> *) b.
Monad f =>
Text -> Decoder f b -> JCurs -> DecodeResult f b
D.fromKey (String -> Text
Text.pack String
n) Decoder f c
d

jInfoFor
  :: forall xs.
     Options
  -> DatatypeName
  -> (ConstructorName -> Tag)
  -> ConstructorInfo xs
  -> JsonInfo xs
jInfoFor :: Options
-> String -> (String -> Tag) -> ConstructorInfo xs -> JsonInfo xs
jInfoFor Options
_ String
_ String -> Tag
tag (Infix String
n Associativity
_ Int
_) = Tag -> JsonInfo xs
forall (xs :: [*]). SListI xs => Tag -> JsonInfo xs
JsonMul (String -> Tag
tag String
n)
jInfoFor Options
_ String
_ String -> Tag
tag (Constructor String
n) =
  case Shape xs
forall k (xs :: [k]). SListI xs => Shape xs
shape :: Shape xs of
    Shape xs
ShapeNil           -> String -> JsonInfo '[]
JsonZero String
n
    ShapeCons Shape xs
ShapeNil -> Tag -> JsonInfo '[x]
forall a. Tag -> JsonInfo '[a]
JsonOne (String -> Tag
tag String
n)
    Shape xs
_                  -> Tag -> JsonInfo xs
forall (xs :: [*]). SListI xs => Tag -> JsonInfo xs
JsonMul (String -> Tag
tag String
n)
jInfoFor Options
opts String
_ String -> Tag
tag (Record String
n NP FieldInfo xs
fs) =
  Tag -> NP (K Text) xs -> JsonInfo xs
forall (xs :: [*]).
SListI xs =>
Tag -> NP (K Text) xs -> JsonInfo xs
JsonRec (String -> Tag
tag String
n) ((forall a. FieldInfo a -> K Text a)
-> NP FieldInfo xs -> NP (K Text) xs
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hliftA forall a. FieldInfo a -> K Text a
fname NP FieldInfo xs
fs)
  where
    fname :: FieldInfo a -> K Text a
    fname :: FieldInfo a -> K Text a
fname (FieldInfo String
name) = Text -> K Text a
forall k a (b :: k). a -> K a b
K (Text -> K Text a) -> (String -> Text) -> String -> K Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> K Text a) -> String -> K Text a
forall a b. (a -> b) -> a -> b
$ Options -> ShowS
_optionsFieldName Options
opts String
name

jsonInfo
  :: forall a.
     ( HasDatatypeInfo a
     , SListI (Code a)
     )
  => Options
  -> Proxy a
  -> NP JsonInfo (Code a)
jsonInfo :: Options -> Proxy a -> NP JsonInfo (Code a)
jsonInfo Options
opts Proxy a
pa =
  case Proxy a -> DatatypeInfo (Code a)
forall a (proxy :: * -> *).
HasDatatypeInfo a =>
proxy a -> DatatypeInfo (Code a)
datatypeInfo Proxy a
pa of
    Newtype String
_ String
n ConstructorInfo '[x]
c -> case Options -> NewtypeName
_optionsNewtypeWithConsName Options
opts of
      NewtypeName
Unwrap               -> Tag -> JsonInfo '[x]
forall a. Tag -> JsonInfo '[a]
JsonOne Tag
NoTag JsonInfo '[x] -> NP JsonInfo '[] -> NP JsonInfo '[ '[x]]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP JsonInfo '[]
forall k (a :: k -> *). NP a '[]
Nil
      NewtypeName
ConstructorNameAsKey -> Tag -> JsonInfo '[x]
forall a. Tag -> JsonInfo '[a]
JsonOne (String -> Tag
Tag (String -> Tag) -> String -> Tag
forall a b. (a -> b) -> a -> b
$ Options -> ShowS
_optionsFieldName Options
opts String
n) JsonInfo '[x] -> NP JsonInfo '[] -> NP JsonInfo '[ '[x]]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP JsonInfo '[]
forall k (a :: k -> *). NP a '[]
Nil
      NewtypeName
FieldNameAsKey       -> Options
-> String
-> (String -> Tag)
-> ConstructorInfo '[x]
-> JsonInfo '[x]
forall (xs :: [*]).
Options
-> String -> (String -> Tag) -> ConstructorInfo xs -> JsonInfo xs
jInfoFor Options
opts String
n (String -> Tag
Tag (String -> Tag) -> ShowS -> String -> Tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> ShowS
_optionsFieldName Options
opts) ConstructorInfo '[x]
c JsonInfo '[x] -> NP JsonInfo '[] -> NP JsonInfo '[ '[x]]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP JsonInfo '[]
forall k (a :: k -> *). NP a '[]
Nil

#if MIN_VERSION_generics_sop(0,5,0)
    ADT String
_ String
n NP ConstructorInfo (Code a)
cs POP StrictnessInfo (Code a)
_
#else
    ADT _ n cs
#endif
      -> (forall (a :: [*]). ConstructorInfo a -> JsonInfo a)
-> NP ConstructorInfo (Code a) -> NP JsonInfo (Code a)
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hliftA (Options
-> String -> (String -> Tag) -> ConstructorInfo a -> JsonInfo a
forall (xs :: [*]).
Options
-> String -> (String -> Tag) -> ConstructorInfo xs -> JsonInfo xs
jInfoFor Options
opts String
n (NP ConstructorInfo (Code a) -> String -> Tag
tag NP ConstructorInfo (Code a)
cs)) NP ConstructorInfo (Code a)
cs
  where
    tag :: NP ConstructorInfo (Code a) -> ConstructorName -> Tag
    tag :: NP ConstructorInfo (Code a) -> String -> Tag
tag (ConstructorInfo x
_ :* NP ConstructorInfo xs
Nil) = Tag -> String -> Tag
forall a b. a -> b -> a
const Tag
NoTag
    tag NP ConstructorInfo (Code a)
_          = String -> Tag
Tag

-- |
-- Create a 'Tagged' 'Encoder' for type @ a @, tagged by @ t @, using the given 'Options'.
--
-- Combined with the 'defaultOpts' this is the default implementation of 'JsonEncode'.
--
-- Some examples:
--
-- @
-- instance JsonEncode GWaarg Image where
--   mkEncoder = gEncoder defaultOpts
-- @
--
-- @
-- instance JsonEncode GWaarg Image where
--   mkEncoder = gEncoder (defaultOpts { _optionsFieldName = trimPrefixLowerFirst "_image" })
-- @
--
gEncoder
  :: forall t a f.
     ( Generic a
     , Applicative f
     , HasDatatypeInfo a
     , All2 (JsonEncode t) (Code a)
     )
  => Options
  -> Tagged t (Encoder f a)
gEncoder :: Options -> Tagged t (Encoder f a)
gEncoder Options
opts = Encoder f a -> Tagged t (Encoder f a)
forall k (s :: k) b. b -> Tagged s b
Tagged (Encoder f a -> Tagged t (Encoder f a))
-> ((a -> f Json) -> Encoder f a)
-> (a -> f Json)
-> Tagged t (Encoder f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f Json) -> Encoder f a
forall a (f :: * -> *). (a -> f Json) -> Encoder f a
E.encodeA ((a -> f Json) -> Tagged t (Encoder f a))
-> (a -> f Json) -> Tagged t (Encoder f a)
forall a b. (a -> b) -> a -> b
$ \a
a -> NS (K (f Json)) (Code a) -> CollapseTo NS (f Json)
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NS (K (f Json)) (Code a) -> CollapseTo NS (f Json))
-> NS (K (f Json)) (Code a) -> CollapseTo NS (f Json)
forall a b. (a -> b) -> a -> b
$ Proxy (All (JsonEncode t))
-> (forall (a :: [*]).
    All (JsonEncode t) a =>
    JsonInfo a -> NP I a -> K (f Json) a)
-> Prod NS JsonInfo (Code a)
-> NS (NP I) (Code a)
-> NS (K (f Json)) (Code a)
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a)
-> Prod h f xs
-> h f' xs
-> h f'' xs
hcliftA2
  (Proxy (All (JsonEncode t))
forall k (t :: k). Proxy t
Proxy :: Proxy (All (JsonEncode t)))
  (Proxy (JsonEncode t)
-> Proxy t -> Options -> JsonInfo a -> NP I a -> K (f Json) a
forall k (xs :: [*]) (f :: * -> *) (t :: k).
(All (JsonEncode t) xs, Applicative f) =>
Proxy (JsonEncode t)
-> Proxy t -> Options -> JsonInfo xs -> NP I xs -> K (f Json) xs
gEncoder' Proxy (JsonEncode t)
pjE Proxy t
pt Options
opts)
  (Options -> Proxy a -> NP JsonInfo (Code a)
forall a.
(HasDatatypeInfo a, SListI (Code a)) =>
Options -> Proxy a -> NP JsonInfo (Code a)
jsonInfo Options
opts (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a))
  (SOP I (Code a) -> NS (NP I) (Code a)
forall k (f :: k -> *) (xss :: [[k]]). SOP f xss -> NS (NP f) xss
unSOP (SOP I (Code a) -> NS (NP I) (Code a))
-> SOP I (Code a) -> NS (NP I) (Code a)
forall a b. (a -> b) -> a -> b
$ a -> SOP I (Code a)
forall a. Generic a => a -> Rep a
from a
a)
  where
    pjE :: Proxy (JsonEncode t)
pjE = Proxy (JsonEncode t)
forall k (t :: k). Proxy t
Proxy :: Proxy (JsonEncode t)
    pt :: Proxy t
pt  = Proxy t
forall k (t :: k). Proxy t
Proxy :: Proxy t

-- | Create a 'Tagged' 'ObjEncoder' for type @ a @, tagged by @ t @.
--
-- This isn't compatible with the 'JsonEncode' typeclass because it creates an
-- 'ObjEncoder' and for consistency reasons the 'JsonEncode' typeclass produces
-- 'Encoder's.
--
-- However it lets you more easily access the 'Data.Functor.Contravariant.Contravariant'
-- functionality that is part of the 'ObjEncoder' type.
--
-- @
-- data Foo = Foo { fooA :: Text, fooB :: Int } deriving (Eq, Show)
-- deriveGeneric ''Foo
--
-- objEncFoo :: Applicative f => ObjEncoder f Foo
-- objEncFoo = untag $ gObjEncoder (defaultOps { _optionsFieldName = drop 3 })
--
-- @
--
-- NB: This function overrides the newtype options to use the 'FieldNameAsKey' option to
-- be consistent with the behaviour of the record encoding.
--
gObjEncoder
  :: forall t a f xs.
     ( Generic a
     , Applicative f
     , HasDatatypeInfo a
     , All2 (JsonEncode t) (Code a)
     , IsRecord a xs
     )
  => Options
  -> Tagged t (E.ObjEncoder f a)
gObjEncoder :: Options -> Tagged t (ObjEncoder f a)
gObjEncoder Options
opts = ObjEncoder f a -> Tagged t (ObjEncoder f a)
forall k (s :: k) b. b -> Tagged s b
Tagged (ObjEncoder f a -> Tagged t (ObjEncoder f a))
-> ((a -> f (JObject WS Json)) -> ObjEncoder f a)
-> (a -> f (JObject WS Json))
-> Tagged t (ObjEncoder f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f (JObject WS Json)) -> ObjEncoder f a
forall a (f :: * -> *).
(a -> f (JObject WS Json)) -> EncoderFns (JObject WS Json) f a
E.objEncoder ((a -> f (JObject WS Json)) -> Tagged t (ObjEncoder f a))
-> (a -> f (JObject WS Json)) -> Tagged t (ObjEncoder f a)
forall a b. (a -> b) -> a -> b
$ \a
a -> NS (K (f (JObject WS Json))) '[GetSingleton (Code a)]
-> CollapseTo NS (f (JObject WS Json))
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NS (K (f (JObject WS Json))) '[GetSingleton (Code a)]
 -> CollapseTo NS (f (JObject WS Json)))
-> NS (K (f (JObject WS Json))) '[GetSingleton (Code a)]
-> CollapseTo NS (f (JObject WS Json))
forall a b. (a -> b) -> a -> b
$ Proxy (All (JsonEncode t))
-> (forall (a :: [*]).
    All (JsonEncode t) a =>
    JsonInfo a -> NP I a -> K (f (JObject WS Json)) a)
-> Prod NS JsonInfo '[GetSingleton (Code a)]
-> NS (NP I) '[GetSingleton (Code a)]
-> NS (K (f (JObject WS Json))) '[GetSingleton (Code a)]
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a)
-> Prod h f xs
-> h f' xs
-> h f'' xs
hcliftA2
  (Proxy (All (JsonEncode t))
forall k (t :: k). Proxy t
Proxy :: Proxy (All (JsonEncode t)))
  forall (ys :: [*]).
(All (JsonEncode t) ys, Applicative f) =>
JsonInfo ys -> NP I ys -> K (f (JObject WS Json)) ys
forall (a :: [*]).
All (JsonEncode t) a =>
JsonInfo a -> NP I a -> K (f (JObject WS Json)) a
createObject
  (Options -> Proxy a -> NP JsonInfo (Code a)
forall a.
(HasDatatypeInfo a, SListI (Code a)) =>
Options -> Proxy a -> NP JsonInfo (Code a)
jsonInfo (Options
opts { _optionsNewtypeWithConsName :: NewtypeName
_optionsNewtypeWithConsName = NewtypeName
FieldNameAsKey }) (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a))
  (SOP I '[GetSingleton (Code a)]
-> NS (NP I) '[GetSingleton (Code a)]
forall k (f :: k -> *) (xss :: [[k]]). SOP f xss -> NS (NP f) xss
unSOP (SOP I '[GetSingleton (Code a)]
 -> NS (NP I) '[GetSingleton (Code a)])
-> SOP I '[GetSingleton (Code a)]
-> NS (NP I) '[GetSingleton (Code a)]
forall a b. (a -> b) -> a -> b
$ a -> Rep a
forall a. Generic a => a -> Rep a
from a
a)
  where
    createObject :: ( All (JsonEncode t) ys
                    , Applicative f
                    )
                 => JsonInfo ys
                 -> NP I ys
                 -> K (f (JObject WS Json)) ys
    createObject :: JsonInfo ys -> NP I ys -> K (f (JObject WS Json)) ys
createObject (JsonRec Tag
_ NP (K Text) ys
fields) NP I ys
cs = f (JObject WS Json) -> K (f (JObject WS Json)) ys
forall k a (b :: k). a -> K a b
K (f (JObject WS Json) -> K (f (JObject WS Json)) ys)
-> (NP (K (JObject WS Json -> JObject WS Json)) ys
    -> f (JObject WS Json))
-> NP (K (JObject WS Json -> JObject WS Json)) ys
-> K (f (JObject WS Json)) ys
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JObject WS Json -> f (JObject WS Json)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JObject WS Json -> f (JObject WS Json))
-> (NP (K (JObject WS Json -> JObject WS Json)) ys
    -> JObject WS Json)
-> NP (K (JObject WS Json -> JObject WS Json)) ys
-> f (JObject WS Json)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      (JObject WS Json
 -> (JObject WS Json -> JObject WS Json) -> JObject WS Json)
-> JObject WS Json
-> [JObject WS Json -> JObject WS Json]
-> JObject WS Json
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' JObject WS Json
-> (JObject WS Json -> JObject WS Json) -> JObject WS Json
forall a b. a -> (a -> b) -> b
(&) (Tagged () (Identity ())
-> Tagged (JObject WS Json) (Identity (JObject WS Json))
forall a. AsEmpty a => Prism' a ()
_Empty (Tagged () (Identity ())
 -> Tagged (JObject WS Json) (Identity (JObject WS Json)))
-> () -> JObject WS Json
forall t b. AReview t b -> b -> t
# ()) ([JObject WS Json -> JObject WS Json] -> JObject WS Json)
-> (NP (K (JObject WS Json -> JObject WS Json)) ys
    -> [JObject WS Json -> JObject WS Json])
-> NP (K (JObject WS Json -> JObject WS Json)) ys
-> JObject WS Json
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP (K (JObject WS Json -> JObject WS Json)) ys
-> [JObject WS Json -> JObject WS Json]
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NP (K (JObject WS Json -> JObject WS Json)) ys
 -> K (f (JObject WS Json)) ys)
-> NP (K (JObject WS Json -> JObject WS Json)) ys
-> K (f (JObject WS Json)) ys
forall a b. (a -> b) -> a -> b
$ Proxy (JsonEncode t)
-> (forall a.
    JsonEncode t a =>
    K Text a -> I a -> K (JObject WS Json -> JObject WS Json) a)
-> Prod NP (K Text) ys
-> NP I ys
-> NP (K (JObject WS Json -> JObject WS Json)) ys
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a)
-> Prod h f xs
-> h f' xs
-> h f'' xs
hcliftA2 Proxy (JsonEncode t)
pjE forall a.
JsonEncode t a =>
K Text a -> I a -> K (JObject WS Json -> JObject WS Json) a
toObj Prod NP (K Text) ys
NP (K Text) ys
fields NP I ys
cs

    createObject (JsonOne (Tag String
t)) (I x
a :* NP I xs
Nil) = f (JObject WS Json) -> K (f (JObject WS Json)) ys
forall k a (b :: k). a -> K a b
K (f (JObject WS Json) -> K (f (JObject WS Json)) ys)
-> (JObject WS Json -> f (JObject WS Json))
-> JObject WS Json
-> K (f (JObject WS Json)) ys
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JObject WS Json -> f (JObject WS Json)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JObject WS Json -> K (f (JObject WS Json)) ys)
-> JObject WS Json -> K (f (JObject WS Json)) ys
forall a b. (a -> b) -> a -> b
$
      Text
-> Json
-> Encoder Identity Json
-> JObject WS Json
-> JObject WS Json
forall b.
Text -> b -> Encoder' b -> JObject WS Json -> JObject WS Json
E.onObj' (String -> Text
Text.pack String
t) (Encoder Identity x -> x -> Json
forall a. Encoder Identity a -> a -> Json
E.asJson' (Tagged t (Encoder Identity x) -> Proxy t -> Encoder Identity x
forall k (s :: k) a (proxy :: k -> *). Tagged s a -> proxy s -> a
T.proxy Tagged t (Encoder Identity x)
forall k (t :: k) a (f :: * -> *).
(JsonEncode t a, Applicative f) =>
Tagged t (Encoder f a)
mkEncoder Proxy t
pt) x
a) Encoder Identity Json
forall (f :: * -> *). Applicative f => Encoder f Json
E.json (Tagged () (Identity ())
-> Tagged (JObject WS Json) (Identity (JObject WS Json))
forall a. AsEmpty a => Prism' a ()
_Empty (Tagged () (Identity ())
 -> Tagged (JObject WS Json) (Identity (JObject WS Json)))
-> () -> JObject WS Json
forall t b. AReview t b -> b -> t
# ())

    -- IsRecord constraint should make this impossible.
    createObject JsonInfo ys
_ NP I ys
_ =
      String -> K (f (JObject WS Json)) ys
forall a. HasCallStack => String -> a
error String
"The impossible has happened. Please report this as a bug: https://github.com/qfpl/waargonaut"

    toObj :: JsonEncode t x => K Text x -> I x -> K (JObject WS Json -> JObject WS Json) x
    toObj :: K Text x -> I x -> K (JObject WS Json -> JObject WS Json) x
toObj K Text x
f I x
a = (JObject WS Json -> JObject WS Json)
-> K (JObject WS Json -> JObject WS Json) x
forall k a (b :: k). a -> K a b
K ((JObject WS Json -> JObject WS Json)
 -> K (JObject WS Json -> JObject WS Json) x)
-> (JObject WS Json -> JObject WS Json)
-> K (JObject WS Json -> JObject WS Json) x
forall a b. (a -> b) -> a -> b
$ Text
-> Json
-> Encoder Identity Json
-> JObject WS Json
-> JObject WS Json
forall b.
Text -> b -> Encoder' b -> JObject WS Json -> JObject WS Json
E.onObj' (K Text x -> Text
forall k a (b :: k). K a b -> a
unK K Text x
f) (Encoder Identity x -> x -> Json
forall a. Encoder Identity a -> a -> Json
E.asJson' (Tagged t (Encoder Identity x) -> Proxy t -> Encoder Identity x
forall k (s :: k) a (proxy :: k -> *). Tagged s a -> proxy s -> a
T.proxy Tagged t (Encoder Identity x)
forall k (t :: k) a (f :: * -> *).
(JsonEncode t a, Applicative f) =>
Tagged t (Encoder f a)
mkEncoder Proxy t
pt) (I x -> x
forall a. I a -> a
unI I x
a)) Encoder Identity Json
forall (f :: * -> *). Applicative f => Encoder f Json
E.json

    pt :: Proxy t
pt = Proxy t
forall k (t :: k). Proxy t
Proxy :: Proxy t
    pjE :: Proxy (JsonEncode t)
pjE = Proxy (JsonEncode t)
forall k (t :: k). Proxy t
Proxy :: Proxy (JsonEncode t)

gEncoder'
  :: forall xs f t.
     ( All (JsonEncode t) xs
     , Applicative f
     )
  => Proxy (JsonEncode t)
  -> Proxy t
  -> Options
  -> JsonInfo xs
  -> NP I xs
  -> K (f Json) xs
gEncoder' :: Proxy (JsonEncode t)
-> Proxy t -> Options -> JsonInfo xs -> NP I xs -> K (f Json) xs
gEncoder' Proxy (JsonEncode t)
_ Proxy t
_ Options
_ (JsonZero String
n) NP I xs
Nil           =
  f Json -> K (f Json) xs
forall k a (b :: k). a -> K a b
K (Encoder f Text -> Text -> f Json
forall (f :: * -> *) a. Applicative f => Encoder f a -> a -> f Json
E.asJson (Tagged Any (Encoder f Text) -> Encoder f Text
forall k (s :: k) b. Tagged s b -> b
T.untag Tagged Any (Encoder f Text)
forall k (t :: k) a (f :: * -> *).
(JsonEncode t a, Applicative f) =>
Tagged t (Encoder f a)
mkEncoder) (String -> Text
Text.pack String
n))

gEncoder' Proxy (JsonEncode t)
_ Proxy t
pT Options
_ (JsonOne Tag
tag) (I x
a :* NP I xs
Nil) =
  Tag -> f Json -> K (f Json) xs
forall k (f :: * -> *) (xs :: k).
Applicative f =>
Tag -> f Json -> K (f Json) xs
tagVal Tag
tag (f Json -> K (f Json) xs) -> f Json -> K (f Json) xs
forall a b. (a -> b) -> a -> b
$ Encoder f x -> x -> f Json
forall (f :: * -> *) a. Applicative f => Encoder f a -> a -> f Json
E.asJson (Tagged t (Encoder f x) -> Proxy t -> Encoder f x
forall k (s :: k) a (proxy :: k -> *). Tagged s a -> proxy s -> a
T.proxy Tagged t (Encoder f x)
forall k (t :: k) a (f :: * -> *).
(JsonEncode t a, Applicative f) =>
Tagged t (Encoder f a)
mkEncoder Proxy t
pT) x
a

gEncoder' Proxy (JsonEncode t)
p Proxy t
pT Options
_ (JsonMul Tag
tag) NP I xs
cs           =
  Tag -> f Json -> K (f Json) xs
forall k (f :: * -> *) (xs :: k).
Applicative f =>
Tag -> f Json -> K (f Json) xs
tagVal Tag
tag (f Json -> K (f Json) xs)
-> (NP (K Json) xs -> f Json) -> NP (K Json) xs -> K (f Json) xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoder f [Json] -> [Json] -> f Json
forall (f :: * -> *) a. Applicative f => Encoder f a -> a -> f Json
E.asJson (Encoder f Json -> Encoder f [Json]
forall (f :: * -> *) a.
Applicative f =>
Encoder f a -> Encoder f [a]
E.list Encoder f Json
forall (f :: * -> *). Applicative f => Encoder f Json
E.json) ([Json] -> f Json)
-> (NP (K Json) xs -> [Json]) -> NP (K Json) xs -> f Json
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP (K Json) xs -> [Json]
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NP (K Json) xs -> K (f Json) xs)
-> NP (K Json) xs -> K (f Json) xs
forall a b. (a -> b) -> a -> b
$ Proxy (JsonEncode t)
-> (forall a. JsonEncode t a => I a -> K Json a)
-> NP I xs
-> NP (K Json) xs
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcliftA Proxy (JsonEncode t)
p forall a. JsonEncode t a => I a -> K Json a
ik NP I xs
cs
  where
    ik :: JsonEncode t x => I x -> K Json x
    ik :: I x -> K Json x
ik = Json -> K Json x
forall k a (b :: k). a -> K a b
K (Json -> K Json x) -> (I x -> Json) -> I x -> K Json x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoder Identity x -> x -> Json
forall a. Encoder Identity a -> a -> Json
E.asJson' (Tagged t (Encoder Identity x) -> Proxy t -> Encoder Identity x
forall k (s :: k) a (proxy :: k -> *). Tagged s a -> proxy s -> a
T.proxy Tagged t (Encoder Identity x)
forall k (t :: k) a (f :: * -> *).
(JsonEncode t a, Applicative f) =>
Tagged t (Encoder f a)
mkEncoder Proxy t
pT) (x -> Json) -> (I x -> x) -> I x -> Json
forall b c a. (b -> c) -> (a -> b) -> a -> c
. I x -> x
forall a. I a -> a
unI

gEncoder' Proxy (JsonEncode t)
p Proxy t
pT Options
_ (JsonRec Tag
tag NP (K Text) xs
fields) NP I xs
cs    =
  Tag -> f Json -> K (f Json) xs
forall k (f :: * -> *) (xs :: k).
Applicative f =>
Tag -> f Json -> K (f Json) xs
tagVal Tag
tag (f Json -> K (f Json) xs)
-> (NP (K (Text, Json)) xs -> f Json)
-> NP (K (Text, Json)) xs
-> K (f Json) xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Json)] -> f Json
enc ([(Text, Json)] -> f Json)
-> (NP (K (Text, Json)) xs -> [(Text, Json)])
-> NP (K (Text, Json)) xs
-> f Json
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP (K (Text, Json)) xs -> [(Text, Json)]
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NP (K (Text, Json)) xs -> K (f Json) xs)
-> NP (K (Text, Json)) xs -> K (f Json) xs
forall a b. (a -> b) -> a -> b
$ Proxy (JsonEncode t)
-> (forall a.
    JsonEncode t a =>
    K Text a -> I a -> K (Text, Json) a)
-> Prod NP (K Text) xs
-> NP I xs
-> NP (K (Text, Json)) xs
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a)
-> Prod h f xs
-> h f' xs
-> h f'' xs
hcliftA2 Proxy (JsonEncode t)
p forall a. JsonEncode t a => K Text a -> I a -> K (Text, Json) a
tup Prod NP (K Text) xs
NP (K Text) xs
fields NP I xs
cs
  where
    tup :: JsonEncode t x => K Text x -> I x -> K (Text, Json) x
    tup :: K Text x -> I x -> K (Text, Json) x
tup K Text x
f I x
a = (Text, Json) -> K (Text, Json) x
forall k a (b :: k). a -> K a b
K ( K Text x -> Text
forall k a (b :: k). K a b -> a
unK K Text x
f
                , Encoder Identity x -> x -> Json
forall a. Encoder Identity a -> a -> Json
E.asJson' (Tagged t (Encoder Identity x) -> Proxy t -> Encoder Identity x
forall k (s :: k) a (proxy :: k -> *). Tagged s a -> proxy s -> a
T.proxy Tagged t (Encoder Identity x)
forall k (t :: k) a (f :: * -> *).
(JsonEncode t a, Applicative f) =>
Tagged t (Encoder f a)
mkEncoder Proxy t
pT) (I x -> x
forall a. I a -> a
unI I x
a)
                )

    enc :: [(Text, Json)] -> f Json
enc = Json -> f Json
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Json -> f Json)
-> ([(Text, Json)] -> Json) -> [(Text, Json)] -> f Json
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoder Identity [(Text, Json)] -> [(Text, Json)] -> Json
forall a. Encoder Identity a -> a -> Json
E.asJson' (Encoder Identity Json -> Encoder Identity [(Text, Json)]
forall (f :: * -> *) (g :: * -> *) a.
(Monad f, Foldable g) =>
Encoder f a -> Encoder f (g (Text, a))
E.keyValueTupleFoldable Encoder Identity Json
forall (f :: * -> *). Applicative f => Encoder f Json
E.json)

-- |
-- Create a 'Tagged' 'Decoder' for type @ a @, tagged by @ t @, using the given 'Options'.
--
-- Combined with the 'defaultOpts' this is the default implementation of 'JsonEncode'.
--
-- Some examples:
--
-- @
-- instance JsonEncode GWaarg Image where
--   mkDecoder = gDecoder defaultOpts
-- @
--
-- @
-- instance JsonEncode GWaarg Image where
--   mkDecoder = gDecoder (defaultOpts { _optionsFieldName = trimPrefixLowerFirst "_image" })
-- @
--
gDecoder
  :: forall f a t.
     ( Generic a
     , HasDatatypeInfo a
     , All2 (JsonDecode t) (Code a)
     , Monad f
     )
  => Options
  -> Tagged t (Decoder f a)
gDecoder :: Options -> Tagged t (Decoder f a)
gDecoder Options
opts = Decoder f a -> Tagged t (Decoder f a)
forall k (s :: k) b. b -> Tagged s b
Tagged (Decoder f a -> Tagged t (Decoder f a))
-> Decoder f a -> Tagged t (Decoder f a)
forall a b. (a -> b) -> a -> b
$ (ParseFn -> JCurs -> DecodeResultT Count DecodeError f a)
-> Decoder f a
forall (f :: * -> *) a.
(ParseFn -> JCurs -> DecodeResultT Count DecodeError f a)
-> Decoder f a
D.Decoder ((ParseFn -> JCurs -> DecodeResultT Count DecodeError f a)
 -> Decoder f a)
-> (ParseFn -> JCurs -> DecodeResultT Count DecodeError f a)
-> Decoder f a
forall a b. (a -> b) -> a -> b
$ \ParseFn
parseFn JCurs
cursor ->
  SOP I (Code a) -> a
forall a. Generic a => Rep a -> a
to (SOP I (Code a) -> a)
-> DecodeResultT Count DecodeError f (SOP I (Code a))
-> DecodeResultT Count DecodeError f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options
-> Proxy (All (JsonDecode t))
-> ParseFn
-> JCurs
-> NP JsonInfo (Code a)
-> DecodeResultT Count DecodeError f (SOP I (Code a))
forall k (xss :: [[*]]) (f :: * -> *) (t :: k).
(All2 (JsonDecode t) xss, Monad f) =>
Options
-> Proxy (All (JsonDecode t))
-> ParseFn
-> JCurs
-> NP JsonInfo xss
-> DecodeResultT Count DecodeError f (SOP I xss)
gDecoderConstructor
           Options
opts
           (Proxy (All (JsonDecode t))
forall k (t :: k). Proxy t
Proxy :: Proxy (All (JsonDecode t)))
           ParseFn
parseFn
           JCurs
cursor
           (Options -> Proxy a -> NP JsonInfo (Code a)
forall a.
(HasDatatypeInfo a, SListI (Code a)) =>
Options -> Proxy a -> NP JsonInfo (Code a)
jsonInfo Options
opts (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a))

gDecoderConstructor
  :: forall (xss :: [[*]]) f t.
     ( All2 (JsonDecode t) xss
     , Monad f
     )
  => Options
  -> Proxy (All (JsonDecode t))
  -> (ByteString -> Either DecodeError Json)
  -> D.JCurs
  -> NP JsonInfo xss
  -> DecodeResultT Count DecodeError f (SOP I xss)
gDecoderConstructor :: Options
-> Proxy (All (JsonDecode t))
-> ParseFn
-> JCurs
-> NP JsonInfo xss
-> DecodeResultT Count DecodeError f (SOP I xss)
gDecoderConstructor Options
opts Proxy (All (JsonDecode t))
pJAll ParseFn
parseFn JCurs
cursor NP JsonInfo xss
ninfo =
  [DecodeResult f (SOP I xss)]
-> DecodeResultT Count DecodeError f (SOP I xss)
foldForRight ([DecodeResult f (SOP I xss)]
 -> DecodeResultT Count DecodeError f (SOP I xss))
-> (NP (K (DecodeResult f (SOP I xss))) xss
    -> [DecodeResult f (SOP I xss)])
-> NP (K (DecodeResult f (SOP I xss))) xss
-> DecodeResultT Count DecodeError f (SOP I xss)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP (K (DecodeResult f (SOP I xss))) xss
-> [DecodeResult f (SOP I xss)]
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NP (K (DecodeResult f (SOP I xss))) xss
 -> DecodeResultT Count DecodeError f (SOP I xss))
-> NP (K (DecodeResult f (SOP I xss))) xss
-> DecodeResultT Count DecodeError f (SOP I xss)
forall a b. (a -> b) -> a -> b
$ Proxy (All (JsonDecode t))
-> (forall (a :: [*]).
    All (JsonDecode t) a =>
    JsonInfo a
    -> Injection (NP I) xss a -> K (DecodeResult f (SOP I xss)) a)
-> Prod NP JsonInfo xss
-> NP (Injection (NP I) xss) xss
-> NP (K (DecodeResult f (SOP I xss))) xss
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a)
-> Prod h f xs
-> h f' xs
-> h f'' xs
hcliftA2 Proxy (All (JsonDecode t))
pJAll (Options
-> Proxy (JsonDecode t)
-> JCurs
-> JsonInfo a
-> Injection (NP I) xss a
-> K (DecodeResult f (SOP I xss)) a
forall k (t :: k) (xss :: [[*]]) (xs :: [*]) (f :: * -> *).
(All (JsonDecode t) xs, Monad f) =>
Options
-> Proxy (JsonDecode t)
-> JCurs
-> JsonInfo xs
-> Injection (NP I) xss xs
-> K (DecodeResult f (SOP I xss)) xs
mkGDecoder Options
opts Proxy (JsonDecode t)
pJDec JCurs
cursor) Prod NP JsonInfo xss
NP JsonInfo xss
ninfo NP (Injection (NP I) xss) xss
injs
  where
    pJDec :: Proxy (JsonDecode t)
pJDec = Proxy (JsonDecode t)
forall k (t :: k). Proxy t
Proxy :: Proxy (JsonDecode t)

    err :: Either (DecodeError, CursorHistory' i) b
err = (DecodeError, CursorHistory' i)
-> Either (DecodeError, CursorHistory' i) b
forall a b. a -> Either a b
Left ( Text -> DecodeError
ConversionFailure Text
"Generic Decoder has failed, please file a bug."
               , Seq (ZipperMove, i) -> CursorHistory' i
forall i. Seq (ZipperMove, i) -> CursorHistory' i
CursorHistory' Seq (ZipperMove, i)
forall a. Monoid a => a
mempty
               )

    failure :: (e, b) -> m b
failure (e
e,b
h) = (b -> b) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (b -> b -> b
forall a b. a -> b -> a
const b
h) m () -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> e -> m b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e

    runDR :: DecodeResult f (SOP I xss)
-> f (Either (DecodeError, CursorHistory' Count) (SOP I xss))
runDR = DecodeResultT Count DecodeError f (SOP I xss)
-> f (Either (DecodeError, CursorHistory' Count) (SOP I xss))
forall (f :: * -> *) i a.
Monad f =>
DecodeResultT i DecodeError f a
-> f (Either (DecodeError, CursorHistory' i) a)
runDecoderResultT
      (DecodeResultT Count DecodeError f (SOP I xss)
 -> f (Either (DecodeError, CursorHistory' Count) (SOP I xss)))
-> (DecodeResult f (SOP I xss)
    -> DecodeResultT Count DecodeError f (SOP I xss))
-> DecodeResult f (SOP I xss)
-> f (Either (DecodeError, CursorHistory' Count) (SOP I xss))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT ParseFn (DecodeResultT Count DecodeError f) (SOP I xss)
 -> ParseFn -> DecodeResultT Count DecodeError f (SOP I xss))
-> ParseFn
-> ReaderT ParseFn (DecodeResultT Count DecodeError f) (SOP I xss)
-> DecodeResultT Count DecodeError f (SOP I xss)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT ParseFn (DecodeResultT Count DecodeError f) (SOP I xss)
-> ParseFn -> DecodeResultT Count DecodeError f (SOP I xss)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ParseFn
parseFn
      (ReaderT ParseFn (DecodeResultT Count DecodeError f) (SOP I xss)
 -> DecodeResultT Count DecodeError f (SOP I xss))
-> (DecodeResult f (SOP I xss)
    -> ReaderT ParseFn (DecodeResultT Count DecodeError f) (SOP I xss))
-> DecodeResult f (SOP I xss)
-> DecodeResultT Count DecodeError f (SOP I xss)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecodeResult f (SOP I xss)
-> ReaderT ParseFn (DecodeResultT Count DecodeError f) (SOP I xss)
forall (f :: * -> *) a.
DecodeResult f a
-> ReaderT ParseFn (DecodeResultT Count DecodeError f) a
unDecodeResult

    -- Pretty sure there is a better way to manage this, as my intuition about
    -- generic-sop says that I will only have one successful result for any
    -- given type. But I'm not 100% sure that this is actually the case.
    foldForRight :: [D.DecodeResult f (SOP I xss)] -> DecodeResultT Count DecodeError f (SOP I xss)
    foldForRight :: [DecodeResult f (SOP I xss)]
-> DecodeResultT Count DecodeError f (SOP I xss)
foldForRight [DecodeResult f (SOP I xss)]
xs = (f [Either (DecodeError, CursorHistory' Count) (SOP I xss)]
-> DecodeResultT
     Count
     DecodeError
     f
     [Either (DecodeError, CursorHistory' Count) (SOP I xss)]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (f [Either (DecodeError, CursorHistory' Count) (SOP I xss)]
 -> DecodeResultT
      Count
      DecodeError
      f
      [Either (DecodeError, CursorHistory' Count) (SOP I xss)])
-> ([f (Either (DecodeError, CursorHistory' Count) (SOP I xss))]
    -> f [Either (DecodeError, CursorHistory' Count) (SOP I xss)])
-> [f (Either (DecodeError, CursorHistory' Count) (SOP I xss))]
-> DecodeResultT
     Count
     DecodeError
     f
     [Either (DecodeError, CursorHistory' Count) (SOP I xss)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [f (Either (DecodeError, CursorHistory' Count) (SOP I xss))]
-> f [Either (DecodeError, CursorHistory' Count) (SOP I xss)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([f (Either (DecodeError, CursorHistory' Count) (SOP I xss))]
 -> DecodeResultT
      Count
      DecodeError
      f
      [Either (DecodeError, CursorHistory' Count) (SOP I xss)])
-> [f (Either (DecodeError, CursorHistory' Count) (SOP I xss))]
-> DecodeResultT
     Count
     DecodeError
     f
     [Either (DecodeError, CursorHistory' Count) (SOP I xss)]
forall a b. (a -> b) -> a -> b
$ DecodeResult f (SOP I xss)
-> f (Either (DecodeError, CursorHistory' Count) (SOP I xss))
runDR (DecodeResult f (SOP I xss)
 -> f (Either (DecodeError, CursorHistory' Count) (SOP I xss)))
-> [DecodeResult f (SOP I xss)]
-> [f (Either (DecodeError, CursorHistory' Count) (SOP I xss))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DecodeResult f (SOP I xss)]
xs)
      DecodeResultT
  Count
  DecodeError
  f
  [Either (DecodeError, CursorHistory' Count) (SOP I xss)]
-> ([Either (DecodeError, CursorHistory' Count) (SOP I xss)]
    -> DecodeResultT Count DecodeError f (SOP I xss))
-> DecodeResultT Count DecodeError f (SOP I xss)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((DecodeError, CursorHistory' Count)
 -> DecodeResultT Count DecodeError f (SOP I xss))
-> (SOP I xss -> DecodeResultT Count DecodeError f (SOP I xss))
-> Either (DecodeError, CursorHistory' Count) (SOP I xss)
-> DecodeResultT Count DecodeError f (SOP I xss)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (DecodeError, CursorHistory' Count)
-> DecodeResultT Count DecodeError f (SOP I xss)
forall (m :: * -> *) b e b.
(MonadState b m, MonadError e m) =>
(e, b) -> m b
failure SOP I xss -> DecodeResultT Count DecodeError f (SOP I xss)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (DecodeError, CursorHistory' Count) (SOP I xss)
 -> DecodeResultT Count DecodeError f (SOP I xss))
-> ([Either (DecodeError, CursorHistory' Count) (SOP I xss)]
    -> Either (DecodeError, CursorHistory' Count) (SOP I xss))
-> [Either (DecodeError, CursorHistory' Count) (SOP I xss)]
-> DecodeResultT Count DecodeError f (SOP I xss)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (DecodeError, CursorHistory' Count) (SOP I xss)
-> Maybe (Either (DecodeError, CursorHistory' Count) (SOP I xss))
-> Either (DecodeError, CursorHistory' Count) (SOP I xss)
forall a. a -> Maybe a -> a
fromMaybe Either (DecodeError, CursorHistory' Count) (SOP I xss)
forall i b. Either (DecodeError, CursorHistory' i) b
err (Maybe (Either (DecodeError, CursorHistory' Count) (SOP I xss))
 -> Either (DecodeError, CursorHistory' Count) (SOP I xss))
-> ([Either (DecodeError, CursorHistory' Count) (SOP I xss)]
    -> Maybe (Either (DecodeError, CursorHistory' Count) (SOP I xss)))
-> [Either (DecodeError, CursorHistory' Count) (SOP I xss)]
-> Either (DecodeError, CursorHistory' Count) (SOP I xss)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (Endo
     (Maybe (Either (DecodeError, CursorHistory' Count) (SOP I xss))))
  [Either (DecodeError, CursorHistory' Count) (SOP I xss)]
  (Either (DecodeError, CursorHistory' Count) (SOP I xss))
-> (Either (DecodeError, CursorHistory' Count) (SOP I xss) -> Bool)
-> [Either (DecodeError, CursorHistory' Count) (SOP I xss)]
-> Maybe (Either (DecodeError, CursorHistory' Count) (SOP I xss))
forall a s.
Getting (Endo (Maybe a)) s a -> (a -> Bool) -> s -> Maybe a
findOf Getting
  (Endo
     (Maybe (Either (DecodeError, CursorHistory' Count) (SOP I xss))))
  [Either (DecodeError, CursorHistory' Count) (SOP I xss)]
  (Either (DecodeError, CursorHistory' Count) (SOP I xss))
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded (APrism
  (Either (DecodeError, CursorHistory' Count) (SOP I xss))
  (Either Any (SOP I xss))
  (DecodeError, CursorHistory' Count)
  Any
-> Either (DecodeError, CursorHistory' Count) (SOP I xss) -> Bool
forall s t a b. APrism s t a b -> s -> Bool
isn't APrism
  (Either (DecodeError, CursorHistory' Count) (SOP I xss))
  (Either Any (SOP I xss))
  (DecodeError, CursorHistory' Count)
  Any
forall a c b. Prism (Either a c) (Either b c) a b
_Left)

    injs :: NP (Injection (NP I) xss) xss
    injs :: NP (Injection (NP I) xss) xss
injs = NP (Injection (NP I) xss) xss
forall k (xs :: [k]) (f :: k -> *).
SListI xs =>
NP (Injection f xs) xs
injections

mkGDecoder
  :: forall t (xss :: [[*]]) (xs :: [*]) f.
     ( All (JsonDecode t) xs
     , Monad f
     )
  => Options
  -> Proxy (JsonDecode t)
  -> D.JCurs
  -> JsonInfo xs
  -> Injection (NP I) xss xs
  -> K (D.DecodeResult f (SOP I xss)) xs
mkGDecoder :: Options
-> Proxy (JsonDecode t)
-> JCurs
-> JsonInfo xs
-> Injection (NP I) xss xs
-> K (DecodeResult f (SOP I xss)) xs
mkGDecoder Options
opts Proxy (JsonDecode t)
pJDec JCurs
cursor JsonInfo xs
info (Fn NP I xs -> K (NS (NP I) xss) xs
inj) = DecodeResult f (SOP I xss) -> K (DecodeResult f (SOP I xss)) xs
forall k a (b :: k). a -> K a b
K (DecodeResult f (SOP I xss) -> K (DecodeResult f (SOP I xss)) xs)
-> DecodeResult f (SOP I xss) -> K (DecodeResult f (SOP I xss)) xs
forall a b. (a -> b) -> a -> b
$ do
  NP (K Count) xs
val <- Options
-> Proxy (JsonDecode t)
-> JCurs
-> JsonInfo xs
-> DecodeResult f (NP (K Count) xs)
forall k (t :: k) (xs :: [*]) (f :: * -> *).
(All (JsonDecode t) xs, Monad f) =>
Options
-> Proxy (JsonDecode t)
-> JCurs
-> JsonInfo xs
-> DecodeResult f (NP (K Count) xs)
mkGDecoder2 Options
opts Proxy (JsonDecode t)
pJDec JCurs
cursor JsonInfo xs
info
  NS (NP I) xss -> SOP I xss
forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP (NS (NP I) xss -> SOP I xss)
-> (NP I xs -> NS (NP I) xss) -> NP I xs -> SOP I xss
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K (NS (NP I) xss) xs -> NS (NP I) xss
forall k a (b :: k). K a b -> a
unK (K (NS (NP I) xss) xs -> NS (NP I) xss)
-> (NP I xs -> K (NS (NP I) xss) xs) -> NP I xs -> NS (NP I) xss
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP I xs -> K (NS (NP I) xss) xs
inj (NP I xs -> SOP I xss)
-> DecodeResult f (NP I xs) -> DecodeResult f (SOP I xss)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NP (DecodeResult f) xs -> DecodeResult f (NP I xs)
forall l (h :: (* -> *) -> l -> *) (xs :: l) (f :: * -> *).
(SListIN h xs, SListIN (Prod h) xs, HSequence h, Applicative f) =>
h f xs -> f (h I xs)
hsequence (Proxy (JsonDecode t)
-> (forall a. JsonDecode t a => K Count a -> DecodeResult f a)
-> NP (K Count) xs
-> NP (DecodeResult f) xs
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcliftA Proxy (JsonDecode t)
pJDec forall a. JsonDecode t a => K Count a -> DecodeResult f a
aux NP (K Count) xs
val)
  where
    aux :: JsonDecode t x => K Count x -> D.DecodeResult f x
    aux :: K Count x -> DecodeResult f x
aux (K Count
rnk) = Count -> JCurs -> DecodeResult f JCurs
forall (f :: * -> *).
Monad f =>
Count -> JCurs -> DecodeResult f JCurs
D.moveToRankN Count
rnk JCurs
cursor DecodeResult f JCurs
-> (JCurs -> DecodeResult f x) -> DecodeResult f x
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Decoder f x -> JCurs -> DecodeResult f x
forall (f :: * -> *) a.
Monad f =>
Decoder f a -> JCurs -> DecodeResult f a
D.focus (Tagged t (Decoder f x) -> Proxy t -> Decoder f x
forall k (s :: k) a (proxy :: k -> *). Tagged s a -> proxy s -> a
T.proxy Tagged t (Decoder f x)
forall k (t :: k) a (f :: * -> *).
(JsonDecode t a, Monad f) =>
Tagged t (Decoder f a)
mkDecoder (Proxy t
forall k (t :: k). Proxy t
Proxy :: Proxy t))

mkGDecoder2
  :: forall t (xs :: [*]) f.
     ( All (JsonDecode t) xs
     , Monad f
    )
  => Options
  -> Proxy (JsonDecode t)
  -> D.JCurs
  -> JsonInfo xs
  -> D.DecodeResult f (NP (K Count) xs)
mkGDecoder2 :: Options
-> Proxy (JsonDecode t)
-> JCurs
-> JsonInfo xs
-> DecodeResult f (NP (K Count) xs)
mkGDecoder2 Options
_ Proxy (JsonDecode t)
_ JCurs
cursor (JsonZero String
_) =
  NP (K Count) '[]
forall k (a :: k -> *). NP a '[]
Nil NP (K Count) '[]
-> DecodeResult f Count -> DecodeResult f (NP (K Count) '[])
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tag -> Decoder f Count -> JCurs -> DecodeResult f Count
forall (f :: * -> *) c.
Monad f =>
Tag -> Decoder f c -> JCurs -> DecodeResult f c
unTagVal Tag
NoTag Decoder f Count
forall (f :: * -> *). Monad f => Decoder f Count
D.rank JCurs
cursor

mkGDecoder2 Options
_ Proxy (JsonDecode t)
_ JCurs
cursor (JsonOne Tag
tag) =
  (\Count
j -> Count -> K Count a
forall k a (b :: k). a -> K a b
K Count
j K Count a -> NP (K Count) '[] -> NP (K Count) '[a]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP (K Count) '[]
forall k (a :: k -> *). NP a '[]
Nil) (Count -> NP (K Count) '[a])
-> DecodeResult f Count -> DecodeResult f (NP (K Count) '[a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tag -> Decoder f Count -> JCurs -> DecodeResult f Count
forall (f :: * -> *) c.
Monad f =>
Tag -> Decoder f c -> JCurs -> DecodeResult f c
unTagVal Tag
tag Decoder f Count
forall (f :: * -> *). Monad f => Decoder f Count
D.rank JCurs
cursor

mkGDecoder2 Options
_ Proxy (JsonDecode t)
_ JCurs
cursor (JsonMul Tag
tag) = do
  [Count]
xs <- Tag -> Decoder f [Count] -> JCurs -> DecodeResult f [Count]
forall (f :: * -> *) c.
Monad f =>
Tag -> Decoder f c -> JCurs -> DecodeResult f c
unTagVal Tag
tag (Decoder f Count -> Decoder f [Count]
forall (f :: * -> *) a. Monad f => Decoder f a -> Decoder f [a]
D.list Decoder f Count
forall (f :: * -> *). Monad f => Decoder f Count
D.rank) JCurs
cursor
  DecodeResult f (NP (K Count) xs)
-> (NP (K Count) xs -> DecodeResult f (NP (K Count) xs))
-> Maybe (NP (K Count) xs)
-> DecodeResult f (NP (K Count) xs)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DecodeResult f (NP (K Count) xs)
forall a. DecodeResult f a
err NP (K Count) xs -> DecodeResult f (NP (K Count) xs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Count] -> Maybe (NP (K Count) xs)
forall k (xs :: [k]) a. SListI xs => [a] -> Maybe (NP (K a) xs)
fromList [Count]
xs)
  where
    err :: DecodeResult f a
err = DecodeError -> DecodeResult f a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> DecodeError
ConversionFailure Text
"Generic List Decode Failed")

mkGDecoder2 Options
_ Proxy (JsonDecode t)
pJDec JCurs
cursor (JsonRec Tag
tag NP (K Text) xs
fields) = do
  JCurs
c' <- JCurs -> DecodeResult f JCurs
forall (f :: * -> *). Monad f => JCurs -> DecodeResult f JCurs
D.down JCurs
cursor
  NP (K (DecodeResult f Count)) xs
-> DecodeResult f (NP (K Count) xs)
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: * -> *) a.
(SListIN h xs, SListIN (Prod h) xs, Applicative f, HSequence h) =>
h (K (f a)) xs -> f (h (K a) xs)
hsequenceK (NP (K (DecodeResult f Count)) xs
 -> DecodeResult f (NP (K Count) xs))
-> NP (K (DecodeResult f Count)) xs
-> DecodeResult f (NP (K Count) xs)
forall a b. (a -> b) -> a -> b
$ Proxy (JsonDecode t)
-> (forall a.
    JsonDecode t a =>
    K Text a -> K (DecodeResult f Count) a)
-> NP (K Text) xs
-> NP (K (DecodeResult f Count)) xs
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcliftA Proxy (JsonDecode t)
pJDec ((Text -> DecodeResult f Count)
-> K Text a -> K (DecodeResult f Count) a
forall k1 k2 a b (c :: k1) (d :: k2). (a -> b) -> K a c -> K b d
mapKK (JCurs -> Text -> DecodeResult f Count
decodeAtKey JCurs
c')) NP (K Text) xs
fields
  where
    decodeAtKey :: JCurs -> Text -> DecodeResult f Count
decodeAtKey JCurs
c Text
k = Tag -> Decoder f Count -> JCurs -> DecodeResult f Count
forall (f :: * -> *) c.
Monad f =>
Tag -> Decoder f c -> JCurs -> DecodeResult f c
unTagVal Tag
tag (
      (JCurs -> DecodeResult f Count) -> Decoder f Count
forall (f :: * -> *) a. (JCurs -> DecodeResult f a) -> Decoder f a
D.withCursor ((JCurs -> DecodeResult f Count) -> Decoder f Count)
-> (JCurs -> DecodeResult f Count) -> Decoder f Count
forall a b. (a -> b) -> a -> b
$ Text -> Decoder f Count -> JCurs -> DecodeResult f Count
forall (f :: * -> *) b.
Monad f =>
Text -> Decoder f b -> JCurs -> DecodeResult f b
D.fromKey Text
k Decoder f Count
forall (f :: * -> *). Monad f => Decoder f Count
D.rank
      ) JCurs
c