{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- Copyright :  (c) Joseph Morag 2021-2022
-- License   :  BSD3
-- Maintainer:  Joseph Morag <jm@josephmorag.com>
-- Stability :  experimental
-- Portability: non-portable
--
-- This module exports orphan instances for @'Ixed' 'BValue'@, @'Plated'
-- 'BValue'@, @'Ixed' 'BDictMap'@, @'Plated' 'BDictMap'@, @'Traversable'
-- 'BDictMap'@, @'FunctorWithIndex' 'BDictMap'@, @'FoldableWithIndex'
-- 'BDictMap'@, and @'TraversbaleWithIndex' 'BDictMap'@.
module Data.BEncode.Lens
  ( -- * Prisms
    AsBValue (..),

    -- * BDicts and BLists
    members,
    key,
    nth,
    values,
  )
where

import Control.Lens
import Data.BEncode
import Data.BEncode.BDict as BE
import Data.BEncode.Types
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy

-- $setup
-- >>> import Control.Lens
-- >>> import Data.ByteString
-- >>> import Data.BEncode.BDict
-- >>> import Data.BEncode.Types
-- >>> :set -XOverloadedStrings

-- | Things that can be treated as a 'BValue'. Instances are provided for strict
-- and lazy 'ByteString' as well as 'BValue's themselves.
class AsBValue t where
  _BValue :: Prism' t BValue

  -- |
  -- >>> ("i3e" :: ByteString) ^? _BInteger
  -- Just 3
  _BInteger :: Prism' t BInteger
  _BInteger = p BValue (f BValue) -> p t (f t)
forall t. AsBValue t => Prism' t BValue
_BValue (p BValue (f BValue) -> p t (f t))
-> (p BInteger (f BInteger) -> p BValue (f BValue))
-> p BInteger (f BInteger)
-> p t (f t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BInteger -> BValue)
-> (BValue -> Maybe BInteger)
-> Prism BValue BValue BInteger BInteger
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' BInteger -> BValue
BInteger (\case BInteger BInteger
x -> BInteger -> Maybe BInteger
forall a. a -> Maybe a
Just BInteger
x; BValue
_ -> Maybe BInteger
forall a. Maybe a
Nothing)
  {-# INLINE _BInteger #-}

  -- |
  -- >>> ("0:" :: ByteString) ^? _BString
  -- Just ""
  --
  -- >>> ("4:spam" :: ByteString) ^? _BString
  -- Just "spam"
  _BString :: Prism' t BString
  _BString = p BValue (f BValue) -> p t (f t)
forall t. AsBValue t => Prism' t BValue
_BValue (p BValue (f BValue) -> p t (f t))
-> (p BString (f BString) -> p BValue (f BValue))
-> p BString (f BString)
-> p t (f t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BString -> BValue)
-> (BValue -> Maybe BString) -> Prism BValue BValue BString BString
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' BString -> BValue
BString (\case BString BString
x -> BString -> Maybe BString
forall a. a -> Maybe a
Just BString
x; BValue
_ -> Maybe BString
forall a. Maybe a
Nothing)
  {-# INLINE _BString #-}

  -- |
  -- >>> ("le" :: ByteString) ^? _BList
  -- Just []
  --
  -- >>> ("l4:spam4:eggse" :: ByteString) ^? _BList == Just [BString "spam", BString "eggs"]
  -- True
  _BList :: Prism' t BList
  _BList = p BValue (f BValue) -> p t (f t)
forall t. AsBValue t => Prism' t BValue
_BValue (p BValue (f BValue) -> p t (f t))
-> (p BList (f BList) -> p BValue (f BValue))
-> p BList (f BList)
-> p t (f t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BList -> BValue)
-> (BValue -> Maybe BList) -> Prism BValue BValue BList BList
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' BList -> BValue
BList (\case BList BList
x -> BList -> Maybe BList
forall a. a -> Maybe a
Just BList
x; BValue
_ -> Maybe BList
forall a. Maybe a
Nothing)
  {-# INLINE _BList #-}

  -- |
  -- >>> ("de" :: ByteString) ^? _BDict
  -- Just Nil
  --
  -- >>> ("d3:cow3:moo4:spam4:eggse" :: ByteString) ^? _BDict == Just (Cons "cow" (BString "moo") (Cons "spam" (BString "eggs") Nil))
  -- True
  _BDict :: Prism' t BDict
  _BDict = p BValue (f BValue) -> p t (f t)
forall t. AsBValue t => Prism' t BValue
_BValue (p BValue (f BValue) -> p t (f t))
-> (p BDict (f BDict) -> p BValue (f BValue))
-> p BDict (f BDict)
-> p t (f t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BDict -> BValue)
-> (BValue -> Maybe BDict) -> Prism BValue BValue BDict BDict
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' BDict -> BValue
BDict (\case BDict BDict
x -> BDict -> Maybe BDict
forall a. a -> Maybe a
Just BDict
x; BValue
_ -> Maybe BDict
forall a. Maybe a
Nothing)
  {-# INLINE _BDict #-}

instance AsBValue BValue where
  _BValue :: p BValue (f BValue) -> p BValue (f BValue)
_BValue = p BValue (f BValue) -> p BValue (f BValue)
forall a. a -> a
id
  {-# INLINE _BValue #-}

instance AsBValue Strict.ByteString where
  _BValue :: p BValue (f BValue) -> p BString (f BString)
_BValue = (BValue -> BString)
-> (BString -> Maybe BValue) -> Prism' BString BValue
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (Getting BString ByteString BString -> ByteString -> BString
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BString ByteString BString
forall lazy strict. Strict lazy strict => Iso' lazy strict
strict (ByteString -> BString)
-> (BValue -> ByteString) -> BValue -> BString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BValue -> ByteString
forall a. BEncode a => a -> ByteString
encode) ((BString -> Maybe BValue) -> Prism' BString BValue)
-> (BString -> Maybe BValue) -> Prism' BString BValue
forall a b. (a -> b) -> a -> b
$ (String -> Maybe BValue)
-> (BValue -> Maybe BValue) -> Either String BValue -> Maybe BValue
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe BValue -> String -> Maybe BValue
forall a b. a -> b -> a
const Maybe BValue
forall a. Maybe a
Nothing) BValue -> Maybe BValue
forall a. a -> Maybe a
Just (Either String BValue -> Maybe BValue)
-> (BString -> Either String BValue) -> BString -> Maybe BValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BString -> Either String BValue
forall a. BEncode a => BString -> Result a
decode
  {-# INLINE _BValue #-}

instance AsBValue Lazy.ByteString where
  _BValue :: p BValue (f BValue) -> p ByteString (f ByteString)
_BValue = (BValue -> ByteString)
-> (ByteString -> Maybe BValue) -> Prism' ByteString BValue
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' BValue -> ByteString
forall a. BEncode a => a -> ByteString
encode ((ByteString -> Maybe BValue) -> Prism' ByteString BValue)
-> (ByteString -> Maybe BValue) -> Prism' ByteString BValue
forall a b. (a -> b) -> a -> b
$ (String -> Maybe BValue)
-> (BValue -> Maybe BValue) -> Either String BValue -> Maybe BValue
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe BValue -> String -> Maybe BValue
forall a b. a -> b -> a
const Maybe BValue
forall a. Maybe a
Nothing) BValue -> Maybe BValue
forall a. a -> Maybe a
Just (Either String BValue -> Maybe BValue)
-> (ByteString -> Either String BValue)
-> ByteString
-> Maybe BValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BString -> Either String BValue
forall a. BEncode a => BString -> Result a
decode (BString -> Either String BValue)
-> (ByteString -> BString) -> ByteString -> Either String BValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting BString ByteString BString -> ByteString -> BString
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BString ByteString BString
forall lazy strict. Strict lazy strict => Iso' lazy strict
strict
  {-# INLINE _BValue #-}

-- |
-- >>> ("d3:cow3:moo4:spam4:eggse" :: ByteString) ^@.. members
-- [("cow",BString "moo"),("spam",BString "eggs")]
members :: AsBValue t => IndexedTraversal' BKey t BValue
members :: IndexedTraversal' BString t BValue
members = (BDict -> f BDict) -> t -> f t
forall t. AsBValue t => Prism' t BDict
_BDict ((BDict -> f BDict) -> t -> f t)
-> (p BValue (f BValue) -> BDict -> f BDict)
-> p BValue (f BValue)
-> t
-> f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p BValue (f BValue) -> BDict -> f BDict
forall i (t :: * -> *) a b.
TraversableWithIndex i t =>
IndexedTraversal i (t a) (t b) a b
itraversed
{-# INLINE members #-}

-- |
-- >>> ("d3:cow3:moo4:spam4:eggse" :: ByteString) ^? key "cow"
-- Just (BString "moo")
key :: AsBValue t => BKey -> Traversal' t BValue
key :: BString -> Traversal' t BValue
key BString
k = (BDict -> f BDict) -> t -> f t
forall t. AsBValue t => Prism' t BDict
_BDict ((BDict -> f BDict) -> t -> f t)
-> ((BValue -> f BValue) -> BDict -> f BDict)
-> (BValue -> f BValue)
-> t
-> f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index BDict -> Traversal' BDict (IxValue BDict)
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix BString
Index BDict
k
{-# INLINE key #-}

-- |
-- >>> ("li0ei1ee" :: ByteString) ^? nth 0
-- Just (BInteger 0)
nth :: AsBValue t => Int -> Traversal' t BValue
nth :: Int -> Traversal' t BValue
nth Int
i = (BList -> f BList) -> t -> f t
forall t. AsBValue t => Prism' t BList
_BList ((BList -> f BList) -> t -> f t)
-> ((BValue -> f BValue) -> BList -> f BList)
-> (BValue -> f BValue)
-> t
-> f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index BList -> Traversal' BList (IxValue BList)
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
Index BList
i
{-# INLINE nth #-}

-- |
-- >>> ("ll1:ae3:cow3:moo4:spam4:eggse" :: ByteString) ^.. values
-- [BList [BString "a"],BString "cow",BString "moo",BString "spam",BString "eggs"]
values :: AsBValue t => IndexedTraversal' Int t BValue
values :: IndexedTraversal' Int t BValue
values = (BList -> f BList) -> t -> f t
forall t. AsBValue t => Prism' t BList
_BList ((BList -> f BList) -> t -> f t)
-> (p BValue (f BValue) -> BList -> f BList)
-> p BValue (f BValue)
-> t
-> f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p BValue (f BValue) -> BList -> f BList
forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed
{-# INLINE values #-}

------------------------------------------------------------------------------
-- Orphan instances for lens library interop
------------------------------------------------------------------------------
instance Traversable BDictMap where
  traverse :: (a -> f b) -> BDictMap a -> f (BDictMap b)
traverse a -> f b
_ BDictMap a
Nil = BDictMap b -> f (BDictMap b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure BDictMap b
forall a. BDictMap a
Nil
  traverse a -> f b
f (Cons BString
k a
x BDictMap a
xs) = BString -> b -> BDictMap b -> BDictMap b
forall a. BString -> a -> BDictMap a -> BDictMap a
Cons BString
k (b -> BDictMap b -> BDictMap b)
-> f b -> f (BDictMap b -> BDictMap b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x f (BDictMap b -> BDictMap b) -> f (BDictMap b) -> f (BDictMap b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (a -> f b) -> BDictMap a -> f (BDictMap b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f BDictMap a
xs

instance FoldableWithIndex BKey BDictMap

instance FunctorWithIndex BKey BDictMap

instance TraversableWithIndex BKey BDictMap where
  itraverse :: (BString -> a -> f b) -> BDictMap a -> f (BDictMap b)
itraverse BString -> a -> f b
_ BDictMap a
Nil = BDictMap b -> f (BDictMap b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure BDictMap b
forall a. BDictMap a
Nil
  itraverse BString -> a -> f b
f (Cons BString
k a
x BDictMap a
xs) = BString -> b -> BDictMap b -> BDictMap b
forall a. BString -> a -> BDictMap a -> BDictMap a
Cons BString
k (b -> BDictMap b -> BDictMap b)
-> f b -> f (BDictMap b -> BDictMap b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BString -> a -> f b
f BString
k a
x f (BDictMap b -> BDictMap b) -> f (BDictMap b) -> f (BDictMap b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (BString -> a -> f b) -> BDictMap a -> f (BDictMap b)
forall i (t :: * -> *) (f :: * -> *) a b.
(TraversableWithIndex i t, Applicative f) =>
(i -> a -> f b) -> t a -> f (t b)
itraverse BString -> a -> f b
f BDictMap a
xs

type instance Index (BDictMap a) = BKey

type instance IxValue (BDictMap a) = a

type instance Index BValue = BKey

type instance IxValue BValue = BValue

instance At (BDictMap a) where
  at :: BKey -> Lens' (BDictMap a) (Maybe a)
  at :: BString -> Lens' (BDictMap a) (Maybe a)
at BString
k Maybe a -> f (Maybe a)
f BDictMap a
m =
    Maybe a -> f (Maybe a)
f Maybe a
mv f (Maybe a) -> (Maybe a -> BDictMap a) -> f (BDictMap a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
      Maybe a
Nothing -> BDictMap a -> (a -> BDictMap a) -> Maybe a -> BDictMap a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe BDictMap a
m (BDictMap a -> a -> BDictMap a
forall a b. a -> b -> a
const (BString -> BDictMap a -> BDictMap a
forall a. BString -> BDictMap a -> BDictMap a
delete BString
k BDictMap a
m)) Maybe a
mv
      Just a
v' -> BString -> a -> BDictMap a -> BDictMap a
forall a. BString -> a -> BDictMap a -> BDictMap a
insert BString
k a
v' BDictMap a
m
    where
      mv :: Maybe a
mv = BString -> BDictMap a -> Maybe a
forall a. BString -> BDictMap a -> Maybe a
BE.lookup BString
k BDictMap a
m
  {-# INLINE at #-}

-- | Insert a key value pair into a BDictMap. Overwrites the value for an
-- existing key
insert :: BKey -> a -> BDictMap a -> BDictMap a
insert :: BString -> a -> BDictMap a -> BDictMap a
insert BString
k a
v BDictMap a
Nil = BString -> a -> BDictMap a
forall a. BString -> a -> BDictMap a
BE.singleton BString
k a
v
insert BString
k a
v bd :: BDictMap a
bd@(Cons BString
k' a
x BDictMap a
xs)
  | BString
k BString -> BString -> Bool
forall a. Eq a => a -> a -> Bool
== BString
k' = BString -> a -> BDictMap a -> BDictMap a
forall a. BString -> a -> BDictMap a -> BDictMap a
Cons BString
k a
v BDictMap a
xs
  | BString
k BString -> BString -> Bool
forall a. Ord a => a -> a -> Bool
< BString
k' = BString -> a -> BDictMap a -> BDictMap a
forall a. BString -> a -> BDictMap a -> BDictMap a
Cons BString
k a
v BDictMap a
bd
  | Bool
otherwise = BString -> a -> BDictMap a -> BDictMap a
forall a. BString -> a -> BDictMap a -> BDictMap a
Cons BString
k' a
x (BString -> a -> BDictMap a -> BDictMap a
forall a. BString -> a -> BDictMap a -> BDictMap a
insert BString
k a
v BDictMap a
xs)

-- | Delete a key from a BDictMap. Returns the BDictMap unchanged if the key is
-- not present.
delete :: BKey -> BDictMap a -> BDictMap a
delete :: BString -> BDictMap a -> BDictMap a
delete BString
_ BDictMap a
Nil = BDictMap a
forall a. BDictMap a
Nil
delete BString
k bd :: BDictMap a
bd@(Cons BString
k' a
x BDictMap a
xs)
  | BString
k BString -> BString -> Bool
forall a. Eq a => a -> a -> Bool
== BString
k' = BDictMap a
xs
  | BString
k BString -> BString -> Bool
forall a. Ord a => a -> a -> Bool
> BString
k' = BDictMap a
bd
  | Bool
otherwise = BString -> a -> BDictMap a -> BDictMap a
forall a. BString -> a -> BDictMap a -> BDictMap a
Cons BString
k' a
x (BString -> BDictMap a -> BDictMap a
forall a. BString -> BDictMap a -> BDictMap a
delete BString
k BDictMap a
xs)

instance Ixed (BDictMap a)

instance Ixed BValue where
  ix :: Index BValue -> Traversal' BValue (IxValue BValue)
ix Index BValue
i IxValue BValue -> f (IxValue BValue)
f (BDict BDict
o) = BDict -> BValue
BDict (BDict -> BValue) -> f BDict -> f BValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Index BDict
-> (IxValue BDict -> f (IxValue BDict)) -> BDict -> f BDict
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index BValue
Index BDict
i IxValue BValue -> f (IxValue BValue)
IxValue BDict -> f (IxValue BDict)
f BDict
o
  ix Index BValue
_ IxValue BValue -> f (IxValue BValue)
_ BValue
v = BValue -> f BValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure BValue
v
  {-# INLINE ix #-}

instance Plated BValue where
  plate :: (BValue -> f BValue) -> BValue -> f BValue
plate BValue -> f BValue
f (BDict BDict
o) = BDict -> BValue
BDict (BDict -> BValue) -> f BDict -> f BValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BValue -> f BValue) -> BDict -> f BDict
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse BValue -> f BValue
f BDict
o
  plate BValue -> f BValue
f (BList BList
l) = BList -> BValue
BList (BList -> BValue) -> f BList -> f BValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BValue -> f BValue) -> BList -> f BList
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse BValue -> f BValue
f BList
l
  plate BValue -> f BValue
_ BValue
xs = BValue -> f BValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure BValue
xs
  {-# INLINE plate #-}