-- | Contains general underlying monad for bidirectional conversion.

module Toml.Bi.Monad
       ( Codec (..)
       , BiCodec
       , dimap
       , dioptional
       , diwrap
       , dimatch
       , (<!>)
       , (.=)
       ) where

import Control.Applicative (Alternative (..), optional)
import Control.Monad (MonadPlus (..))
import Data.Coerce (Coercible, coerce)


{- | Monad for bidirectional conversion. Contains pair of functions:

1. How to read value of type @a@ from immutable environment context @r@?
2. How to store value of type @a@ in stateful context @w@?

In practice instead of @r@ we will use some @Reader Toml@ and instead of @w@ we will
use @State Toml@. This approach with the bunch of utility functions allows to
have single description for from/to @TOML@ conversion.

In practice this type will always be used in the following way:

@
type 'BiCodec' r w a = 'Codec' r w a a
@

Type parameter @c@ if fictional. Here some trick is used. This trick is
implemented in the [codec](http://hackage.haskell.org/package/codec) package and
described in more details in related blog post:
<https://blog.poisson.chat/posts/2016-10-12-bidirectional-serialization.html>.
-}
data Codec r w c a = Codec
    { -- | Extract value of type @a@ from monadic context @r@.
      Codec r w c a -> r a
codecRead  :: r a

      -- | Store value of type @c@ inside monadic context @w@ and returning
      -- value of type @a@. Type of this function actually should be @a -> w ()@ but with
      -- such type it's impossible to have 'Monad' and other instances.
    , Codec r w c a -> c -> w a
codecWrite :: c -> w a
    }

-- | Specialized version of 'Codec' data type. This type alias is used in practice.
type BiCodec r w a = Codec r w a a

instance (Functor r, Functor w) => Functor (Codec r w c) where
    fmap :: (a -> b) -> Codec r w c a -> Codec r w c b
    fmap :: (a -> b) -> Codec r w c a -> Codec r w c b
fmap f :: a -> b
f codec :: Codec r w c a
codec = Codec :: forall (r :: * -> *) (w :: * -> *) c a.
r a -> (c -> w a) -> Codec r w c a
Codec
        { codecRead :: r b
codecRead  = a -> b
f (a -> b) -> r a -> r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Codec r w c a -> r a
forall (r :: * -> *) (w :: * -> *) c a. Codec r w c a -> r a
codecRead Codec r w c a
codec
        , codecWrite :: c -> w b
codecWrite = (a -> b) -> w a -> w b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (w a -> w b) -> (c -> w a) -> c -> w b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Codec r w c a -> c -> w a
forall (r :: * -> *) (w :: * -> *) c a. Codec r w c a -> c -> w a
codecWrite Codec r w c a
codec
        }
    {-# INLINE fmap #-}

instance (Applicative r, Applicative w) => Applicative (Codec r w c) where
    pure :: a -> Codec r w c a
    pure :: a -> Codec r w c a
pure a :: a
a = Codec :: forall (r :: * -> *) (w :: * -> *) c a.
r a -> (c -> w a) -> Codec r w c a
Codec
        { codecRead :: r a
codecRead  = a -> r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
        , codecWrite :: c -> w a
codecWrite = \_ -> a -> w a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
        }
    {-# INLINE pure #-}

    (<*>) :: Codec r w c (a -> b) -> Codec r w c a -> Codec r w c b
    codecf :: Codec r w c (a -> b)
codecf <*> :: Codec r w c (a -> b) -> Codec r w c a -> Codec r w c b
<*> codeca :: Codec r w c a
codeca = Codec :: forall (r :: * -> *) (w :: * -> *) c a.
r a -> (c -> w a) -> Codec r w c a
Codec
        { codecRead :: r b
codecRead  = Codec r w c (a -> b) -> r (a -> b)
forall (r :: * -> *) (w :: * -> *) c a. Codec r w c a -> r a
codecRead Codec r w c (a -> b)
codecf r (a -> b) -> r a -> r b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Codec r w c a -> r a
forall (r :: * -> *) (w :: * -> *) c a. Codec r w c a -> r a
codecRead Codec r w c a
codeca
        , codecWrite :: c -> w b
codecWrite = \c :: c
c -> Codec r w c (a -> b) -> c -> w (a -> b)
forall (r :: * -> *) (w :: * -> *) c a. Codec r w c a -> c -> w a
codecWrite Codec r w c (a -> b)
codecf c
c w (a -> b) -> w a -> w b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Codec r w c a -> c -> w a
forall (r :: * -> *) (w :: * -> *) c a. Codec r w c a -> c -> w a
codecWrite Codec r w c a
codeca c
c
        }
    {-# INLINE (<*>) #-}

instance (Monad r, Monad w) => Monad (Codec r w c) where
    (>>=) :: Codec r w c a -> (a -> Codec r w c b) -> Codec r w c b
    codec :: Codec r w c a
codec >>= :: Codec r w c a -> (a -> Codec r w c b) -> Codec r w c b
>>= f :: a -> Codec r w c b
f = Codec :: forall (r :: * -> *) (w :: * -> *) c a.
r a -> (c -> w a) -> Codec r w c a
Codec
        { codecRead :: r b
codecRead  = Codec r w c a -> r a
forall (r :: * -> *) (w :: * -> *) c a. Codec r w c a -> r a
codecRead Codec r w c a
codec r a -> (a -> r b) -> r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a :: a
a -> Codec r w c b -> r b
forall (r :: * -> *) (w :: * -> *) c a. Codec r w c a -> r a
codecRead (a -> Codec r w c b
f a
a)
        , codecWrite :: c -> w b
codecWrite = \c :: c
c -> Codec r w c a -> c -> w a
forall (r :: * -> *) (w :: * -> *) c a. Codec r w c a -> c -> w a
codecWrite Codec r w c a
codec c
c w a -> (a -> w b) -> w b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a :: a
a -> Codec r w c b -> c -> w b
forall (r :: * -> *) (w :: * -> *) c a. Codec r w c a -> c -> w a
codecWrite (a -> Codec r w c b
f a
a) c
c
        }
    {-# INLINE (>>=) #-}

instance (Alternative r, Alternative w) => Alternative (Codec r w c) where
    empty :: Codec r w c a
    empty :: Codec r w c a
empty = Codec :: forall (r :: * -> *) (w :: * -> *) c a.
r a -> (c -> w a) -> Codec r w c a
Codec
        { codecRead :: r a
codecRead  = r a
forall (f :: * -> *) a. Alternative f => f a
empty
        , codecWrite :: c -> w a
codecWrite = \_ -> w a
forall (f :: * -> *) a. Alternative f => f a
empty
        }
    {-# INLINE empty #-}

    (<|>) :: Codec r w c a -> Codec r w c a -> Codec r w c a
    codec1 :: Codec r w c a
codec1 <|> :: Codec r w c a -> Codec r w c a -> Codec r w c a
<|> codec2 :: Codec r w c a
codec2 = Codec :: forall (r :: * -> *) (w :: * -> *) c a.
r a -> (c -> w a) -> Codec r w c a
Codec
        { codecRead :: r a
codecRead  = Codec r w c a -> r a
forall (r :: * -> *) (w :: * -> *) c a. Codec r w c a -> r a
codecRead Codec r w c a
codec1 r a -> r a -> r a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Codec r w c a -> r a
forall (r :: * -> *) (w :: * -> *) c a. Codec r w c a -> r a
codecRead Codec r w c a
codec2
        , codecWrite :: c -> w a
codecWrite = \c :: c
c -> Codec r w c a -> c -> w a
forall (r :: * -> *) (w :: * -> *) c a. Codec r w c a -> c -> w a
codecWrite Codec r w c a
codec1 c
c w a -> w a -> w a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Codec r w c a -> c -> w a
forall (r :: * -> *) (w :: * -> *) c a. Codec r w c a -> c -> w a
codecWrite Codec r w c a
codec2 c
c
        }
    {-# INLINE (<|>) #-}

instance (MonadPlus r, MonadPlus w) => MonadPlus (Codec r w c) where
    mzero :: Codec r w c a
mzero = Codec r w c a
forall (f :: * -> *) a. Alternative f => f a
empty
    {-# INLINE mzero #-}
    mplus :: Codec r w c a -> Codec r w c a -> Codec r w c a
mplus = Codec r w c a -> Codec r w c a -> Codec r w c a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)
    {-# INLINE mplus #-}

-- | Alternative instance for function arrow but without 'empty'.
infixl 3 <!>
(<!>) :: Alternative f => (a -> f x) -> (a -> f x) -> (a -> f x)
f :: a -> f x
f <!> :: (a -> f x) -> (a -> f x) -> a -> f x
<!> g :: a -> f x
g = \a :: a
a -> a -> f x
f a
a f x -> f x -> f x
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> f x
g a
a
{-# INLINE (<!>) #-}

{- | This is an instance of @Profunctor@ for 'Codec'. But since there's no
@Profunctor@ type class in @base@ or package with no dependencies (and we don't
want to bring extra dependencies) this instance is implemented as a single
top-level function.

Useful when you want to parse @newtype@s. For example, if you had data type like
this:

@
__data__ Example = Example
    { foo :: Bool
    , bar :: Text
    }
@

Bidirectional TOML converter for this type will look like this:

@
exampleCodec :: TomlCodec Example
exampleCodec = Example
    \<$\> Toml.bool "foo" '.=' foo
    \<*\> Toml.text "bar" '.=' bar
@

Now if you change your type in the following way:

@
__newtype__ Email = Email { unEmail :: Text }

__data__ Example = Example
    { foo :: Bool
    , bar :: Email
    }
@

you need to patch your TOML codec like this:

@
exampleCodec :: TomlCodec Example
exampleCodec = Example
    \<$\> Toml.bool "foo" '.=' foo
    \<*\> 'dimap' unEmail Email (Toml.text "bar") '.=' bar
@
-}
dimap
    :: (Functor r, Functor w)
    => (c -> d)       -- ^ Mapper for consumer
    -> (a -> b)       -- ^ Mapper for producer
    -> Codec r w d a  -- ^ Source 'Codec' object
    -> Codec r w c b  -- ^ Target 'Codec' object
dimap :: (c -> d) -> (a -> b) -> Codec r w d a -> Codec r w c b
dimap f :: c -> d
f g :: a -> b
g codec :: Codec r w d a
codec = Codec :: forall (r :: * -> *) (w :: * -> *) c a.
r a -> (c -> w a) -> Codec r w c a
Codec
    { codecRead :: r b
codecRead  = a -> b
g (a -> b) -> r a -> r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Codec r w d a -> r a
forall (r :: * -> *) (w :: * -> *) c a. Codec r w c a -> r a
codecRead Codec r w d a
codec
    , codecWrite :: c -> w b
codecWrite = (a -> b) -> w a -> w b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
g (w a -> w b) -> (c -> w a) -> c -> w b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Codec r w d a -> d -> w a
forall (r :: * -> *) (w :: * -> *) c a. Codec r w c a -> c -> w a
codecWrite Codec r w d a
codec (d -> w a) -> (c -> d) -> c -> w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> d
f
    }
{-# INLINE dimap #-}

{- | Bidirectional converter for @Maybe a@ values. For example, given the data
type:

@
__data__ Example = Example
    { foo :: Bool
    , bar :: Maybe Int
    }
@

the TOML codec will look like

@
exampleCodec :: TomlCodec Example
exampleCodec = Example
    \<$\> Toml.bool "foo" '.=' foo
    \<*\> 'dioptional' (Toml.int "bar") '.=' bar
@
-}
dioptional
    :: (Alternative r, Applicative w)
    => Codec r w c a
    -> Codec r w (Maybe c) (Maybe a)
dioptional :: Codec r w c a -> Codec r w (Maybe c) (Maybe a)
dioptional Codec{..} = Codec :: forall (r :: * -> *) (w :: * -> *) c a.
r a -> (c -> w a) -> Codec r w c a
Codec
    { codecRead :: r (Maybe a)
codecRead  = r a -> r (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional r a
codecRead
    , codecWrite :: Maybe c -> w (Maybe a)
codecWrite = (c -> w a) -> Maybe c -> w (Maybe a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse c -> w a
codecWrite
    }
{-# INLINE dioptional #-}

{- | Combinator used for @newtype@ wrappers. For example, given the data types:

@
__newtype__ N = N Int

__data__ Example = Example
    { foo :: Bool
    , bar :: N
    }
@

the TOML codec can look like

@
exampleCodec :: TomlCodec Example
exampleCodec = Example
    \<$\> Toml.bool "foo" '.=' foo
    \<*\> 'diwrap' (Toml.int "bar") '.=' bar
@
-}
diwrap
    :: forall b a r w .
       (Coercible a b, Functor r, Functor w)
    => BiCodec r w a
    -> BiCodec r w b
diwrap :: BiCodec r w a -> BiCodec r w b
diwrap = (b -> a) -> (a -> b) -> BiCodec r w a -> BiCodec r w b
forall (r :: * -> *) (w :: * -> *) c d a b.
(Functor r, Functor w) =>
(c -> d) -> (a -> b) -> Codec r w d a -> Codec r w c b
dimap b -> a
forall a b. Coercible a b => a -> b
coerce a -> b
forall a b. Coercible a b => a -> b
coerce
{-# INLINE diwrap #-}

{- | Bidirectional converter for @sum types@. For example, given the data
type:

@
__data__ Example
    = Foo Int
    | Bar Bool Int
@

the TOML codec will look like

@
matchFoo :: Example -> Maybe Int
matchFoo (Foo num) = Just num
matchFoo _         = Nothing

matchBar :: Example -> Maybe (Bool, Int)
matchBar (Bar b num) = Just (b, num)
matchBar _           = Nothing

barCodec :: TomlCodec (Bool, Int)
barCodec = (,)
    \<$\> Toml.bool "a" '.=' fst
    \<*\> Toml.int "b" '.=' snd

exampleCodec :: TomlCodec Example
exampleCodec =
    dimatch matchFoo Foo (Toml.int "foo")
    \<|\> dimatch matchBar (uncurry Bar) (Toml.table barCodec "bar")
@

@since 1.2.0.0
-}
dimatch
    :: (Functor r, Alternative w)
    => (c -> Maybe d) -- ^ Mapper for consumer
    -> (a -> b)       -- ^ Mapper for producer
    -> Codec r w d a  -- ^ Source 'Codec' object
    -> Codec r w c b  -- ^ Target 'Codec' object
dimatch :: (c -> Maybe d) -> (a -> b) -> Codec r w d a -> Codec r w c b
dimatch match :: c -> Maybe d
match ctor :: a -> b
ctor codec :: Codec r w d a
codec = Codec :: forall (r :: * -> *) (w :: * -> *) c a.
r a -> (c -> w a) -> Codec r w c a
Codec
    { codecRead :: r b
codecRead = a -> b
ctor (a -> b) -> r a -> r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Codec r w d a -> r a
forall (r :: * -> *) (w :: * -> *) c a. Codec r w c a -> r a
codecRead Codec r w d a
codec
    , codecWrite :: c -> w b
codecWrite = \c :: c
c -> case c -> Maybe d
match c
c of
        Nothing -> w b
forall (f :: * -> *) a. Alternative f => f a
empty
        Just d :: d
d  -> a -> b
ctor (a -> b) -> w a -> w b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Codec r w d a -> d -> w a
forall (r :: * -> *) (w :: * -> *) c a. Codec r w c a -> c -> w a
codecWrite Codec r w d a
codec d
d
    }
{-# INLINE dimatch #-}

{- | Operator to connect two operations:

1. How to get field from object?
2. How to write this field to toml?

In code this should be used like this:

@
__data__ Foo = Foo
    { fooBar :: Int
    , fooBaz :: String
    }

fooCodec :: TomlCodec Foo
fooCodec = Foo
    \<$\> Toml.int "bar" '.=' fooBar
    \<*\> Toml.str "baz" '.=' fooBaz
@
-}
infixl 5 .=
(.=) :: Codec r w field a -> (object -> field) -> Codec r w object a
codec :: Codec r w field a
codec .= :: Codec r w field a -> (object -> field) -> Codec r w object a
.= getter :: object -> field
getter = Codec r w field a
codec { codecWrite :: object -> w a
codecWrite = Codec r w field a -> field -> w a
forall (r :: * -> *) (w :: * -> *) c a. Codec r w c a -> c -> w a
codecWrite Codec r w field a
codec (field -> w a) -> (object -> field) -> object -> w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. object -> field
getter }
{-# INLINE (.=) #-}