{- |
Module                  : Toml.Codec.Di
Copyright               : (c) 2018-2022 Kowainik
SPDX-License-Identifier : MPL-2.0
Maintainer              : Kowainik <xrom.xkov@gmail.com>
Stability               : Stable
Portability             : Portable

Forward and backward mapping functions and combinators (similar to profunctors).

@since 1.3.0.0
-}

module Toml.Codec.Di
    ( dimap
    , dioptional
    , diwrap
    , dimatch
    , (.=)
    ) where

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

import Toml.Codec.Types (Codec (..), TomlCodec, (<!>))


{- | 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
@

@since 0.2.0
-}
dimap
    :: (b -> a)    -- ^ Mapper for consumer
    -> (a -> b)  -- ^ Mapper for producer
    -> TomlCodec a  -- ^ Source 'Codec' object
    -> TomlCodec b  -- ^ Target 'Codec' object
dimap :: forall b a. (b -> a) -> (a -> b) -> TomlCodec a -> TomlCodec b
dimap b -> a
f a -> b
g TomlCodec a
codec = Codec
    { codecRead :: TomlEnv b
codecRead  = (a -> b)
-> Validation [TomlDecodeError] a -> Validation [TomlDecodeError] b
forall a b.
(a -> b)
-> Validation [TomlDecodeError] a -> Validation [TomlDecodeError] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
g (Validation [TomlDecodeError] a -> Validation [TomlDecodeError] b)
-> (TOML -> Validation [TomlDecodeError] a) -> TomlEnv b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TomlCodec a -> TOML -> Validation [TomlDecodeError] a
forall i o. Codec i o -> TomlEnv o
codecRead TomlCodec a
codec
    , codecWrite :: b -> TomlState b
codecWrite = (a -> b) -> TomlState a -> TomlState b
forall a b. (a -> b) -> TomlState a -> TomlState b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
g (TomlState a -> TomlState b)
-> (b -> TomlState a) -> b -> TomlState b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TomlCodec a -> a -> TomlState a
forall i o. Codec i o -> i -> TomlState o
codecWrite TomlCodec a
codec (a -> TomlState a) -> (b -> a) -> b -> TomlState a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
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
@

@since 0.5.0
-}
dioptional
    :: TomlCodec a
    -> TomlCodec (Maybe a)
dioptional :: forall a. TomlCodec a -> TomlCodec (Maybe a)
dioptional Codec{a -> TomlState a
TomlEnv a
codecRead :: forall i o. Codec i o -> TomlEnv o
codecWrite :: forall i o. Codec i o -> i -> TomlState o
codecRead :: TomlEnv a
codecWrite :: a -> TomlState a
..} = Codec
    { codecRead :: TomlEnv (Maybe a)
codecRead  = (a -> Maybe a)
-> Validation [TomlDecodeError] a
-> Validation [TomlDecodeError] (Maybe a)
forall a b.
(a -> b)
-> Validation [TomlDecodeError] a -> Validation [TomlDecodeError] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (Validation [TomlDecodeError] a
 -> Validation [TomlDecodeError] (Maybe a))
-> TomlEnv a -> TomlEnv (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TomlEnv a
codecRead TomlEnv (Maybe a) -> TomlEnv (Maybe a) -> TomlEnv (Maybe a)
forall (f :: * -> *) a x.
Alternative f =>
(a -> f x) -> (a -> f x) -> a -> f x
<!> \TOML
_ -> Maybe a -> Validation [TomlDecodeError] (Maybe a)
forall a. a -> Validation [TomlDecodeError] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    , codecWrite :: Maybe a -> TomlState (Maybe a)
codecWrite = (a -> TomlState a) -> Maybe a -> TomlState (Maybe a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse a -> TomlState 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
@

@since 1.0.0
-}
diwrap
    :: forall b a .
       (Coercible a b)
    => TomlCodec a
    -> TomlCodec b
diwrap :: forall b a. Coercible a b => TomlCodec a -> TomlCodec b
diwrap = TomlCodec a -> TomlCodec 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.pair
    (Toml.bool "a")
    (Toml.int "b")

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

@since 1.2.0.0
-}
dimatch
    :: (b -> Maybe a)  -- ^ Mapper for consumer
    -> (a -> b)     -- ^ Mapper for producer
    -> TomlCodec a  -- ^ Source 'Codec' object
    -> TomlCodec b  -- ^ Target 'Codec' object
dimatch :: forall b a.
(b -> Maybe a) -> (a -> b) -> TomlCodec a -> TomlCodec b
dimatch b -> Maybe a
match a -> b
ctor TomlCodec a
codec = Codec
    { codecRead :: TomlEnv b
codecRead = (a -> b)
-> Validation [TomlDecodeError] a -> Validation [TomlDecodeError] b
forall a b.
(a -> b)
-> Validation [TomlDecodeError] a -> Validation [TomlDecodeError] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
ctor (Validation [TomlDecodeError] a -> Validation [TomlDecodeError] b)
-> (TOML -> Validation [TomlDecodeError] a) -> TomlEnv b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TomlCodec a -> TOML -> Validation [TomlDecodeError] a
forall i o. Codec i o -> TomlEnv o
codecRead TomlCodec a
codec
    , codecWrite :: b -> TomlState b
codecWrite = \b
c -> case b -> Maybe a
match b
c of
        Maybe a
Nothing -> TomlState b
forall a. TomlState a
forall (f :: * -> *) a. Alternative f => f a
empty
        Just a
d  -> a -> b
ctor (a -> b) -> TomlState a -> TomlState b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TomlCodec a -> a -> TomlState a
forall i o. Codec i o -> i -> TomlState o
codecWrite TomlCodec a
codec a
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 field a -> (object -> field) -> Codec object a
Codec field a
codec .= :: forall field a object.
Codec field a -> (object -> field) -> Codec object a
.= object -> field
getter = Codec field a
codec { codecWrite = codecWrite codec . getter }
{-# INLINE (.=) #-}