{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeFamilies          #-}
-- |
--
-- Some high level prisms for interacting with something that could be JSON.
--
module Waargonaut.Lens
  (
    -- * Prisms
    _TextJson
  , _Number
  , _String
  , _Bool
  , _ArrayOf
  , _ObjHashMapOf
  , _Null
  ) where

import           Prelude                         (Bool, Show)

import           Control.Applicative             (liftA2)
import           Control.Category                ((.))
import           Control.Error.Util              (note)
import           Control.Lens                    (Prism', cons, preview, prism,
                                                  review, (^?), _1, _Wrapped)
import           Control.Monad                   (Monad, void)
import           Data.Foldable                   (foldr)
import           Data.Function                   (const, ($))
import           Data.Functor                    (fmap)
import           Data.Scientific                 (Scientific)
import           Data.Tuple                      (uncurry)

import           Data.Bifunctor                  (first)
import           Data.Either                     (Either (..))

import           Text.Parser.Char                (CharParsing)

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

import           Data.Vector                     (Vector)
import qualified Data.Vector                     as V

import           Data.HashMap.Strict             (HashMap)
import qualified Data.HashMap.Strict             as HM

import qualified Waargonaut.Types.JObject.JAssoc as JA

import qualified Waargonaut.Types.CommaSep       as CS
import           Waargonaut.Types.JString        (_JStringText)

import           Waargonaut.Types.JNumber        (_JNumberScientific)
import           Waargonaut.Types.Json           (AsJType (..), Json)

import qualified Waargonaut.Decode               as D
import qualified Waargonaut.Encode               as E

-- | 'Prism'' between 'Json' and 'Text'
_TextJson
  :: ( CharParsing g
     , Monad g
     , Show e
     )
  => (forall a. g a -> Text -> Either e a)
  -> Prism' Text Json
_TextJson :: (forall a. g a -> Text -> Either e a) -> Prism' Text Json
_TextJson forall a. g a -> Text -> Either e a
pf = (Json -> Text) -> (Text -> Either Text Json) -> Prism' Text Json
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism
  (Text -> Text
TL.toStrict (Text -> Text) -> (Json -> Text) -> Json -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Encoder Identity Json -> Json -> Text
forall a. Encoder Identity a -> a -> Text
E.simplePureEncodeText Encoder Identity Json
forall (f :: * -> *). Applicative f => Encoder f Json
E.json)
  (\Text
b -> ((DecodeError, CursorHistory) -> Text)
-> Either (DecodeError, CursorHistory) Json -> Either Text Json
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> (DecodeError, CursorHistory) -> Text
forall a b. a -> b -> a
const Text
b) (Either (DecodeError, CursorHistory) Json -> Either Text Json)
-> Either (DecodeError, CursorHistory) Json -> Either Text Json
forall a b. (a -> b) -> a -> b
$ (forall a. g a -> Text -> Either e a)
-> Decoder Identity Json
-> Text
-> Either (DecodeError, CursorHistory) Json
forall (f :: * -> *) e x.
(Monad f, CharParsing f, Show e) =>
(forall a. f a -> Text -> Either e a)
-> Decoder Identity x
-> Text
-> Either (DecodeError, CursorHistory) x
D.pureDecodeFromText forall a. g a -> Text -> Either e a
pf Decoder Identity Json
forall (f :: * -> *). Monad f => Decoder f Json
D.json Text
b)
{-# INLINE _TextJson #-}

-- | 'Prism'' between some 'Json' and a 'Scientific' value
_Number  :: Prism' Json Scientific
_Number :: p Scientific (f Scientific) -> p Json (f Json)
_Number = (Scientific -> Json)
-> (Json -> Either Json Scientific)
-> Prism Json Json Scientific Scientific
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism (Encoder Identity Scientific -> Scientific -> Json
forall a. Encoder Identity a -> a -> Json
E.asJson' Encoder Identity Scientific
forall (f :: * -> *). Applicative f => Encoder f Scientific
E.scientific) (\Json
j -> Json -> Maybe Scientific -> Either Json Scientific
forall a b. a -> Maybe b -> Either a b
note Json
j (Maybe Scientific -> Either Json Scientific)
-> Maybe Scientific -> Either Json Scientific
forall a b. (a -> b) -> a -> b
$ Json
j Json
-> Getting (First Scientific) Json Scientific -> Maybe Scientific
forall s a. s -> Getting (First a) s a -> Maybe a
^? ((JNumber, WS) -> Const (First Scientific) (JNumber, WS))
-> Json -> Const (First Scientific) Json
forall r ws a. AsJType r ws a => Prism' r (JNumber, ws)
_JNum (((JNumber, WS) -> Const (First Scientific) (JNumber, WS))
 -> Json -> Const (First Scientific) Json)
-> ((Scientific -> Const (First Scientific) Scientific)
    -> (JNumber, WS) -> Const (First Scientific) (JNumber, WS))
-> Getting (First Scientific) Json Scientific
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (JNumber -> Const (First Scientific) JNumber)
-> (JNumber, WS) -> Const (First Scientific) (JNumber, WS)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((JNumber -> Const (First Scientific) JNumber)
 -> (JNumber, WS) -> Const (First Scientific) (JNumber, WS))
-> ((Scientific -> Const (First Scientific) Scientific)
    -> JNumber -> Const (First Scientific) JNumber)
-> (Scientific -> Const (First Scientific) Scientific)
-> (JNumber, WS)
-> Const (First Scientific) (JNumber, WS)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Scientific -> Const (First Scientific) Scientific)
-> JNumber -> Const (First Scientific) JNumber
Prism' JNumber Scientific
_JNumberScientific)
{-# INLINE _Number #-}

-- | 'Prism'' between some 'Json' and a 'Text' value
_String :: Prism' Json Text
_String :: p Text (f Text) -> p Json (f Json)
_String = (Text -> Json)
-> (Json -> Either Json Text) -> Prism Json Json Text Text
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism (Encoder Identity Text -> Text -> Json
forall a. Encoder Identity a -> a -> Json
E.asJson' Encoder Identity Text
forall (f :: * -> *). Applicative f => Encoder f Text
E.text) (\Json
j -> Json -> Maybe Text -> Either Json Text
forall a b. a -> Maybe b -> Either a b
note Json
j (Maybe Text -> Either Json Text) -> Maybe Text -> Either Json Text
forall a b. (a -> b) -> a -> b
$ Json
j Json -> Getting (First Text) Json Text -> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? ((JString, WS) -> Const (First Text) (JString, WS))
-> Json -> Const (First Text) Json
forall r ws a. AsJType r ws a => Prism' r (JString, ws)
_JStr (((JString, WS) -> Const (First Text) (JString, WS))
 -> Json -> Const (First Text) Json)
-> ((Text -> Const (First Text) Text)
    -> (JString, WS) -> Const (First Text) (JString, WS))
-> Getting (First Text) Json Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (JString -> Const (First Text) JString)
-> (JString, WS) -> Const (First Text) (JString, WS)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((JString -> Const (First Text) JString)
 -> (JString, WS) -> Const (First Text) (JString, WS))
-> ((Text -> Const (First Text) Text)
    -> JString -> Const (First Text) JString)
-> (Text -> Const (First Text) Text)
-> (JString, WS)
-> Const (First Text) (JString, WS)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Text -> Const (First Text) Text)
-> JString -> Const (First Text) JString
forall (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Applicative f) =>
p Text (f Text) -> p JString (f JString)
_JStringText)
{-# INLINE _String #-}

-- | 'Prism'' between some 'Json' and a '()' value
_Null :: Prism' Json ()
_Null :: p () (f ()) -> p Json (f Json)
_Null = (() -> Json) -> (Json -> Either Json ()) -> Prism Json Json () ()
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism (Encoder Identity () -> () -> Json
forall a. Encoder Identity a -> a -> Json
E.asJson' Encoder Identity ()
forall (f :: * -> *). Applicative f => Encoder f ()
E.null) (\Json
j -> Json -> Maybe () -> Either Json ()
forall a b. a -> Maybe b -> Either a b
note Json
j (Maybe () -> Either Json ())
-> (Maybe WS -> Maybe ()) -> Maybe WS -> Either Json ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Maybe WS -> Maybe ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Maybe WS -> Either Json ()) -> Maybe WS -> Either Json ()
forall a b. (a -> b) -> a -> b
$ Json
j Json -> Getting (First WS) Json WS -> Maybe WS
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First WS) Json WS
forall r ws a. AsJType r ws a => Prism' r ws
_JNull)
{-# INLINE _Null #-}

-- | 'Prism'' between some 'Json' and a 'Bool' value
_Bool :: Prism' Json Bool
_Bool :: p Bool (f Bool) -> p Json (f Json)
_Bool = (Bool -> Json)
-> (Json -> Either Json Bool) -> Prism Json Json Bool Bool
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism (Encoder Identity Bool -> Bool -> Json
forall a. Encoder Identity a -> a -> Json
E.asJson' Encoder Identity Bool
forall (f :: * -> *). Applicative f => Encoder f Bool
E.bool) (\Json
j -> Json -> Maybe Bool -> Either Json Bool
forall a b. a -> Maybe b -> Either a b
note Json
j (Maybe Bool -> Either Json Bool) -> Maybe Bool -> Either Json Bool
forall a b. (a -> b) -> a -> b
$ Json
j Json -> Getting (First Bool) Json Bool -> Maybe Bool
forall s a. s -> Getting (First a) s a -> Maybe a
^? ((Bool, WS) -> Const (First Bool) (Bool, WS))
-> Json -> Const (First Bool) Json
forall r ws a. AsJType r ws a => Prism' r (Bool, ws)
_JBool (((Bool, WS) -> Const (First Bool) (Bool, WS))
 -> Json -> Const (First Bool) Json)
-> ((Bool -> Const (First Bool) Bool)
    -> (Bool, WS) -> Const (First Bool) (Bool, WS))
-> Getting (First Bool) Json Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Bool -> Const (First Bool) Bool)
-> (Bool, WS) -> Const (First Bool) (Bool, WS)
forall s t a b. Field1 s t a b => Lens s t a b
_1)
{-# INLINE _Bool#-}

-- | 'Prism'' between some 'Json' and an array of something given the provided 'Prism''
_ArrayOf :: Prism' Json x -> Prism' Json (Vector x)
_ArrayOf :: Prism' Json x -> Prism' Json (Vector x)
_ArrayOf Prism' Json x
_Value = (Vector x -> Json)
-> (Json -> Either Json (Vector x)) -> Prism' Json (Vector x)
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism Vector x -> Json
fromJ Json -> Either Json (Vector x)
toJ
  where
    fromJ :: Vector x -> Json
fromJ = Encoder Identity (Vector Json) -> Vector Json -> Json
forall a. Encoder Identity a -> a -> Json
E.asJson' (Encoder Identity Json -> Encoder Identity (Vector Json)
forall (f :: * -> *) (t :: * -> *) a.
(Applicative f, Traversable t) =>
Encoder f a -> Encoder f (t a)
E.traversable Encoder Identity Json
forall (f :: * -> *). Applicative f => Encoder f Json
E.json) (Vector Json -> Json)
-> (Vector x -> Vector Json) -> Vector x -> Json
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (x -> Json) -> Vector x -> Vector Json
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (AReview Json x -> x -> Json
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview Json x
Prism' Json x
_Value)
    {-# INLINE fromJ #-}
    toJ :: Json -> Either Json (Vector x)
toJ = Traversal' Json (CommaSeparated WS Json)
-> Vector x
-> (Elems WS x -> Vector x)
-> (Json -> Maybe x)
-> Json
-> Either Json (Vector x)
forall j ws x v a.
Traversal' j (CommaSeparated ws x)
-> v -> (Elems ws a -> v) -> (x -> Maybe a) -> j -> Either j v
CS.fromCommaSep (((JArray WS Json, WS) -> f (JArray WS Json, WS)) -> Json -> f Json
forall r ws a. AsJType r ws a => Prism' r (JArray ws a, ws)
_JArr (((JArray WS Json, WS) -> f (JArray WS Json, WS))
 -> Json -> f Json)
-> ((CommaSeparated WS Json -> f (CommaSeparated WS Json))
    -> (JArray WS Json, WS) -> f (JArray WS Json, WS))
-> (CommaSeparated WS Json -> f (CommaSeparated WS Json))
-> Json
-> f Json
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (JArray WS Json -> f (JArray WS Json))
-> (JArray WS Json, WS) -> f (JArray WS Json, WS)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((JArray WS Json -> f (JArray WS Json))
 -> (JArray WS Json, WS) -> f (JArray WS Json, WS))
-> ((CommaSeparated WS Json -> f (CommaSeparated WS Json))
    -> JArray WS Json -> f (JArray WS Json))
-> (CommaSeparated WS Json -> f (CommaSeparated WS Json))
-> (JArray WS Json, WS)
-> f (JArray WS Json, WS)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (CommaSeparated WS Json -> f (CommaSeparated WS Json))
-> JArray WS Json -> f (JArray WS Json)
forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped) Vector x
forall a. Vector a
V.empty ((x -> Vector x -> Vector x) -> Vector x -> Elems WS x -> Vector x
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr x -> Vector x -> Vector x
forall s a. Cons s s a a => a -> s -> s
cons Vector x
forall a. Vector a
V.empty) (Getting (First x) Json x -> Json -> Maybe x
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First x) Json x
Prism' Json x
_Value)
    {-# INLINE toJ #-}
{-# INLINE _ArrayOf #-}

-- | 'Prism'' between some 'Json' and a strict 'HashMap' with 'Text' keys, and
-- some value of a type provided by the given @Prism' Json x@.
_ObjHashMapOf :: Prism' Json x -> Prism' Json (HashMap Text x)
_ObjHashMapOf :: Prism' Json x -> Prism' Json (HashMap Text x)
_ObjHashMapOf Prism' Json x
_Value = (HashMap Text x -> Json)
-> (Json -> Either Json (HashMap Text x))
-> Prism' Json (HashMap Text x)
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism HashMap Text x -> Json
toJ Json -> Either Json (HashMap Text x)
fromJ
  where
    toJ :: HashMap Text x -> Json
toJ = Encoder Identity [(Text, x)] -> [(Text, x)] -> Json
forall a. Encoder Identity a -> a -> Json
E.asJson' (Encoder Identity x -> Encoder Identity [(Text, x)]
forall (f :: * -> *) (g :: * -> *) a.
(Monad f, Foldable g) =>
Encoder f a -> Encoder f (g (Text, a))
E.keyValueTupleFoldable (Prism' Json x -> Encoder Identity Json -> Encoder Identity x
forall a b (f :: * -> *). Prism' a b -> Encoder f a -> Encoder f b
E.prismE Prism' Json x
_Value Encoder Identity Json
forall (f :: * -> *). Applicative f => Encoder f Json
E.json)) ([(Text, x)] -> Json)
-> (HashMap Text x -> [(Text, x)]) -> HashMap Text x -> Json
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. HashMap Text x -> [(Text, x)]
forall k v. HashMap k v -> [(k, v)]
HM.toList
    {-# INLINE toJ #-}

    toVals :: JAssoc WS Json -> Maybe (Text, x)
toVals JAssoc WS Json
el = (Text -> x -> (Text, x))
-> Maybe Text -> Maybe x -> Maybe (Text, x)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,)
      (Getting (First Text) (JAssoc WS Json) Text
-> JAssoc WS Json -> Maybe Text
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((JString -> Const (First Text) JString)
-> JAssoc WS Json -> Const (First Text) (JAssoc WS Json)
forall c ws a. HasJAssoc c ws a => Lens' c JString
JA.jsonAssocKey ((JString -> Const (First Text) JString)
 -> JAssoc WS Json -> Const (First Text) (JAssoc WS Json))
-> ((Text -> Const (First Text) Text)
    -> JString -> Const (First Text) JString)
-> Getting (First Text) (JAssoc WS Json) Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Text -> Const (First Text) Text)
-> JString -> Const (First Text) JString
forall (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Applicative f) =>
p Text (f Text) -> p JString (f JString)
_JStringText) JAssoc WS Json
el)
      (Getting (First x) (JAssoc WS Json) x -> JAssoc WS Json -> Maybe x
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((Json -> Const (First x) Json)
-> JAssoc WS Json -> Const (First x) (JAssoc WS Json)
forall c ws a. HasJAssoc c ws a => Lens' c a
JA.jsonAssocVal ((Json -> Const (First x) Json)
 -> JAssoc WS Json -> Const (First x) (JAssoc WS Json))
-> ((x -> Const (First x) x) -> Json -> Const (First x) Json)
-> Getting (First x) (JAssoc WS Json) x
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (x -> Const (First x) x) -> Json -> Const (First x) Json
Prism' Json x
_Value) JAssoc WS Json
el)
    {-# INLINE toVals #-}

    fromJ :: Json -> Either Json (HashMap Text x)
fromJ = Traversal' Json (CommaSeparated WS (JAssoc WS Json))
-> HashMap Text x
-> (Elems WS (Text, x) -> HashMap Text x)
-> (JAssoc WS Json -> Maybe (Text, x))
-> Json
-> Either Json (HashMap Text x)
forall j ws x v a.
Traversal' j (CommaSeparated ws x)
-> v -> (Elems ws a -> v) -> (x -> Maybe a) -> j -> Either j v
CS.fromCommaSep (((JObject WS Json, WS) -> f (JObject WS Json, WS))
-> Json -> f Json
forall r ws a. AsJType r ws a => Prism' r (JObject ws a, ws)
_JObj (((JObject WS Json, WS) -> f (JObject WS Json, WS))
 -> Json -> f Json)
-> ((CommaSeparated WS (JAssoc WS Json)
     -> f (CommaSeparated WS (JAssoc WS Json)))
    -> (JObject WS Json, WS) -> f (JObject WS Json, WS))
-> (CommaSeparated WS (JAssoc WS Json)
    -> f (CommaSeparated WS (JAssoc WS Json)))
-> Json
-> f Json
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (JObject WS Json -> f (JObject WS Json))
-> (JObject WS Json, WS) -> f (JObject WS Json, WS)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((JObject WS Json -> f (JObject WS Json))
 -> (JObject WS Json, WS) -> f (JObject WS Json, WS))
-> ((CommaSeparated WS (JAssoc WS Json)
     -> f (CommaSeparated WS (JAssoc WS Json)))
    -> JObject WS Json -> f (JObject WS Json))
-> (CommaSeparated WS (JAssoc WS Json)
    -> f (CommaSeparated WS (JAssoc WS Json)))
-> (JObject WS Json, WS)
-> f (JObject WS Json, WS)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (CommaSeparated WS (JAssoc WS Json)
 -> f (CommaSeparated WS (JAssoc WS Json)))
-> JObject WS Json -> f (JObject WS Json)
forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped) HashMap Text x
forall k v. HashMap k v
HM.empty
      (((Text, x) -> HashMap Text x -> HashMap Text x)
-> HashMap Text x -> Elems WS (Text, x) -> HashMap Text x
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Text -> x -> HashMap Text x -> HashMap Text x)
-> (Text, x) -> HashMap Text x -> HashMap Text x
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> x -> HashMap Text x -> HashMap Text x
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert) HashMap Text x
forall k v. HashMap k v
HM.empty) JAssoc WS Json -> Maybe (Text, x)
toVals
    {-# INLINE fromJ #-}
{-# INLINE _ObjHashMapOf #-}