{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UndecidableInstances  #-}

{- |
Copyright: (c) 2018-2020 Kowainik
SPDX-License-Identifier: MPL-2.0
Maintainer: Kowainik <xrom.xkov@gmail.com>

Contains general underlying monad for bidirectional conversion.

@since 1.3.0.0
-}

module Toml.Codec.Types
       ( -- * Toml Codec
         TomlCodec
         -- * Toml Environment
       , TomlEnv
         -- * Toml State
       , TomlState (..)
       , eitherToTomlState

         -- * Codec
       , Codec (..)

         -- * Function alternative
       , (<!>)
       ) where

import Control.Applicative (Alternative (..), liftA2)
import Control.Monad.State (MonadState (..))
import Data.Bifunctor (first)
import Validation (Validation (..))

import Toml.Codec.Error (TomlDecodeError)
import Toml.Type (TOML (..))


{- | Immutable environment for TOML conversion.

@since 1.3.0.0
-}
type TomlEnv a = TOML -> Validation [TomlDecodeError] a


{- | Specialied 'Codec' type alias for bidirectional TOML serialization. Keeps
'TOML' object as both environment and state.

@since 0.5.0
-}
type TomlCodec a = Codec a a

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

1. How to read value of type @o@ (out) from immutable environment context
('TomlEnv')?
2. How to store a value of type @i@ (in) in stateful context ('TomlState') and
return a value of type @o@?

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 'TomlCodec' a = 'Codec' a a
@

Type parameter @i@ 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>.

@since 0.0.0
-}
data Codec i o = Codec
    { -- | Extract value of type @o@ from monadic context 'TomlEnv'.
      Codec i o -> TomlEnv o
codecRead  :: TomlEnv o

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

-- | @since 0.0.0
instance Functor (Codec i) where
    fmap :: (oA -> oB) -> Codec i oA -> Codec i oB
    fmap :: (oA -> oB) -> Codec i oA -> Codec i oB
fmap f :: oA -> oB
f codec :: Codec i oA
codec = Codec :: forall i o. TomlEnv o -> (i -> TomlState o) -> Codec i o
Codec
        { codecRead :: TomlEnv oB
codecRead  = (oA -> oB)
-> Validation [TomlDecodeError] oA
-> Validation [TomlDecodeError] oB
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap oA -> oB
f (Validation [TomlDecodeError] oA
 -> Validation [TomlDecodeError] oB)
-> (TOML -> Validation [TomlDecodeError] oA) -> TomlEnv oB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Codec i oA -> TOML -> Validation [TomlDecodeError] oA
forall i o. Codec i o -> TomlEnv o
codecRead Codec i oA
codec
        , codecWrite :: i -> TomlState oB
codecWrite = (oA -> oB) -> TomlState oA -> TomlState oB
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap oA -> oB
f (TomlState oA -> TomlState oB)
-> (i -> TomlState oA) -> i -> TomlState oB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Codec i oA -> i -> TomlState oA
forall i o. Codec i o -> i -> TomlState o
codecWrite Codec i oA
codec
        }
    {-# INLINE fmap #-}

-- | @since 0.0.0
instance Applicative (Codec i) where
    pure :: o -> Codec i o
    pure :: o -> Codec i o
pure a :: o
a = Codec :: forall i o. TomlEnv o -> (i -> TomlState o) -> Codec i o
Codec
        { codecRead :: TomlEnv o
codecRead  = \_ -> o -> Validation [TomlDecodeError] o
forall e a. a -> Validation e a
Success o
a
        , codecWrite :: i -> TomlState o
codecWrite = \_ -> o -> TomlState o
forall (f :: * -> *) a. Applicative f => a -> f a
pure o
a
        }
    {-# INLINE pure #-}

    (<*>) :: Codec i (oA -> oB) -> Codec i oA -> Codec i oB
    codecf :: Codec i (oA -> oB)
codecf <*> :: Codec i (oA -> oB) -> Codec i oA -> Codec i oB
<*> codeca :: Codec i oA
codeca = Codec :: forall i o. TomlEnv o -> (i -> TomlState o) -> Codec i o
Codec
        { codecRead :: TomlEnv oB
codecRead  = (Validation [TomlDecodeError] (oA -> oB)
 -> Validation [TomlDecodeError] oA
 -> Validation [TomlDecodeError] oB)
-> (TOML -> Validation [TomlDecodeError] (oA -> oB))
-> (TOML -> Validation [TomlDecodeError] oA)
-> TomlEnv oB
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Validation [TomlDecodeError] (oA -> oB)
-> Validation [TomlDecodeError] oA
-> Validation [TomlDecodeError] oB
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) (Codec i (oA -> oB)
-> TOML -> Validation [TomlDecodeError] (oA -> oB)
forall i o. Codec i o -> TomlEnv o
codecRead Codec i (oA -> oB)
codecf) (Codec i oA -> TOML -> Validation [TomlDecodeError] oA
forall i o. Codec i o -> TomlEnv o
codecRead Codec i oA
codeca)
        , codecWrite :: i -> TomlState oB
codecWrite = \c :: i
c -> Codec i (oA -> oB) -> i -> TomlState (oA -> oB)
forall i o. Codec i o -> i -> TomlState o
codecWrite Codec i (oA -> oB)
codecf i
c TomlState (oA -> oB) -> TomlState oA -> TomlState oB
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Codec i oA -> i -> TomlState oA
forall i o. Codec i o -> i -> TomlState o
codecWrite Codec i oA
codeca i
c
        }
    {-# INLINE (<*>) #-}

instance Alternative (Codec i) where
    empty :: Codec i o
    empty :: Codec i o
empty = Codec :: forall i o. TomlEnv o -> (i -> TomlState o) -> Codec i o
Codec
        { codecRead :: TomlEnv o
codecRead  = \_ -> Validation [TomlDecodeError] o
forall (f :: * -> *) a. Alternative f => f a
empty
        , codecWrite :: i -> TomlState o
codecWrite = \_ -> TomlState o
forall (f :: * -> *) a. Alternative f => f a
empty
        }
    {-# INLINE empty #-}

    (<|>) :: Codec i o -> Codec i o -> Codec i o
    codec1 :: Codec i o
codec1 <|> :: Codec i o -> Codec i o -> Codec i o
<|> codec2 :: Codec i o
codec2 = Codec :: forall i o. TomlEnv o -> (i -> TomlState o) -> Codec i o
Codec
        { codecRead :: TomlEnv o
codecRead  = Codec i o -> TomlEnv o
forall i o. Codec i o -> TomlEnv o
codecRead Codec i o
codec1 TomlEnv o -> TomlEnv o -> TomlEnv o
forall (f :: * -> *) a x.
Alternative f =>
(a -> f x) -> (a -> f x) -> a -> f x
<!> Codec i o -> TomlEnv o
forall i o. Codec i o -> TomlEnv o
codecRead Codec i o
codec2
        , codecWrite :: i -> TomlState o
codecWrite = \c :: i
c -> Codec i o -> i -> TomlState o
forall i o. Codec i o -> i -> TomlState o
codecWrite Codec i o
codec1 i
c TomlState o -> TomlState o -> TomlState o
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Codec i o -> i -> TomlState o
forall i o. Codec i o -> i -> TomlState o
codecWrite Codec i o
codec2 i
c
        }
    {-# INLINE (<|>) #-}

-- | 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 (<!>) #-}

{- | Mutable context for TOML conversion.
We are introducing our own implemetation of state with 'MonadState' instance due
to some limitation in the design connected to the usage of State.

This newtype is equivalent to the following transformer:

@
MaybeT (State TOML)
@


@since 1.3.0.0
-}
newtype TomlState a = TomlState
    { TomlState a -> TOML -> (Maybe a, TOML)
unTomlState :: TOML -> (Maybe a, TOML)
    }

-- | @since 1.3.0.0
instance Functor TomlState where
    fmap :: (a -> b) -> TomlState a -> TomlState b
    fmap :: (a -> b) -> TomlState a -> TomlState b
fmap f :: a -> b
f TomlState{..} = (TOML -> (Maybe b, TOML)) -> TomlState b
forall a. (TOML -> (Maybe a, TOML)) -> TomlState a
TomlState ((Maybe a -> Maybe b) -> (Maybe a, TOML) -> (Maybe b, TOML)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) ((Maybe a, TOML) -> (Maybe b, TOML))
-> (TOML -> (Maybe a, TOML)) -> TOML -> (Maybe b, TOML)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TOML -> (Maybe a, TOML)
unTomlState)
    {-# INLINE fmap #-}

    (<$) :: a -> TomlState b -> TomlState a
    a :: a
a <$ :: a -> TomlState b -> TomlState a
<$ TomlState{..} = (TOML -> (Maybe a, TOML)) -> TomlState a
forall a. (TOML -> (Maybe a, TOML)) -> TomlState a
TomlState ((Maybe b -> Maybe a) -> (Maybe b, TOML) -> (Maybe a, TOML)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((b -> a) -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> b -> a
forall a b. a -> b -> a
const a
a)) ((Maybe b, TOML) -> (Maybe a, TOML))
-> (TOML -> (Maybe b, TOML)) -> TOML -> (Maybe a, TOML)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TOML -> (Maybe b, TOML)
unTomlState)
    {-# INLINE (<$) #-}

-- | @since 1.3.0.0
instance Applicative TomlState where
    pure :: a -> TomlState a
    pure :: a -> TomlState a
pure a :: a
a = (TOML -> (Maybe a, TOML)) -> TomlState a
forall a. (TOML -> (Maybe a, TOML)) -> TomlState a
TomlState (a -> Maybe a
forall a. a -> Maybe a
Just a
a,)
    {-# INLINE pure #-}

    (<*>) :: TomlState (a -> b) -> TomlState a -> TomlState b
    tsF :: TomlState (a -> b)
tsF <*> :: TomlState (a -> b) -> TomlState a -> TomlState b
<*> tsA :: TomlState a
tsA = (TOML -> (Maybe b, TOML)) -> TomlState b
forall a. (TOML -> (Maybe a, TOML)) -> TomlState a
TomlState ((TOML -> (Maybe b, TOML)) -> TomlState b)
-> (TOML -> (Maybe b, TOML)) -> TomlState b
forall a b. (a -> b) -> a -> b
$ \t :: TOML
t ->
        let (mF :: Maybe (a -> b)
mF, tF :: TOML
tF) = TomlState (a -> b) -> TOML -> (Maybe (a -> b), TOML)
forall a. TomlState a -> TOML -> (Maybe a, TOML)
unTomlState TomlState (a -> b)
tsF TOML
t
            (mA :: Maybe a
mA, tA :: TOML
tA) = TomlState a -> TOML -> (Maybe a, TOML)
forall a. TomlState a -> TOML -> (Maybe a, TOML)
unTomlState TomlState a
tsA TOML
tF
        in (Maybe (a -> b)
mF Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe a
mA , TOML
tA)
    {-# INLINE (<*>) #-}

-- | @since 1.3.0.0
instance Alternative TomlState where
    empty :: TomlState a
    empty :: TomlState a
empty = (TOML -> (Maybe a, TOML)) -> TomlState a
forall a. (TOML -> (Maybe a, TOML)) -> TomlState a
TomlState (Maybe a
forall a. Maybe a
Nothing,)
    {-# INLINE empty #-}

    (<|>) :: TomlState a -> TomlState a -> TomlState a
    ts1 :: TomlState a
ts1 <|> :: TomlState a -> TomlState a -> TomlState a
<|> ts2 :: TomlState a
ts2 = (TOML -> (Maybe a, TOML)) -> TomlState a
forall a. (TOML -> (Maybe a, TOML)) -> TomlState a
TomlState ((TOML -> (Maybe a, TOML)) -> TomlState a)
-> (TOML -> (Maybe a, TOML)) -> TomlState a
forall a b. (a -> b) -> a -> b
$ \t :: TOML
t -> let (m1 :: Maybe a
m1, t1 :: TOML
t1) = TomlState a -> TOML -> (Maybe a, TOML)
forall a. TomlState a -> TOML -> (Maybe a, TOML)
unTomlState TomlState a
ts1 TOML
t in case Maybe a
m1 of
        Nothing -> TomlState a -> TOML -> (Maybe a, TOML)
forall a. TomlState a -> TOML -> (Maybe a, TOML)
unTomlState TomlState a
ts2 TOML
t
        Just _  -> (Maybe a
m1, TOML
t1)
    {-# INLINE (<|>) #-}

-- | @since 1.3.0.0
instance Monad TomlState where
    return :: a -> TomlState a
    return :: a -> TomlState a
return = a -> TomlState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    {-# INLINE return #-}

    (>>=) :: TomlState a -> (a -> TomlState b) -> TomlState b
    tsA :: TomlState a
tsA >>= :: TomlState a -> (a -> TomlState b) -> TomlState b
>>= f :: a -> TomlState b
f = (TOML -> (Maybe b, TOML)) -> TomlState b
forall a. (TOML -> (Maybe a, TOML)) -> TomlState a
TomlState ((TOML -> (Maybe b, TOML)) -> TomlState b)
-> (TOML -> (Maybe b, TOML)) -> TomlState b
forall a b. (a -> b) -> a -> b
$ \t :: TOML
t -> let (mA :: Maybe a
mA, newT :: TOML
newT) = TomlState a -> TOML -> (Maybe a, TOML)
forall a. TomlState a -> TOML -> (Maybe a, TOML)
unTomlState TomlState a
tsA TOML
t in case Maybe a
mA of
        Nothing -> (Maybe b
forall a. Maybe a
Nothing, TOML
newT)
        Just a :: a
a  -> TomlState b -> TOML -> (Maybe b, TOML)
forall a. TomlState a -> TOML -> (Maybe a, TOML)
unTomlState (a -> TomlState b
f a
a) TOML
newT
    {-# INLINE (>>=) #-}

-- | @since 1.3.0.0
instance (s ~ TOML) => MonadState s TomlState where
    state :: (TOML -> (a, TOML)) -> TomlState a
    state :: (TOML -> (a, TOML)) -> TomlState a
state f :: TOML -> (a, TOML)
f = (TOML -> (Maybe a, TOML)) -> TomlState a
forall a. (TOML -> (Maybe a, TOML)) -> TomlState a
TomlState ((a -> Maybe a) -> (a, TOML) -> (Maybe a, TOML)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a -> Maybe a
forall a. a -> Maybe a
Just ((a, TOML) -> (Maybe a, TOML))
-> (TOML -> (a, TOML)) -> TOML -> (Maybe a, TOML)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TOML -> (a, TOML)
f)
    {-# INLINE state #-}

    get :: TomlState TOML
    get :: TomlState TOML
get = (TOML -> (Maybe TOML, TOML)) -> TomlState TOML
forall a. (TOML -> (Maybe a, TOML)) -> TomlState a
TomlState (\t :: TOML
t -> (TOML -> Maybe TOML
forall a. a -> Maybe a
Just TOML
t, TOML
t))
    {-# INLINE get #-}

    put :: TOML -> TomlState ()
    put :: TOML -> TomlState ()
put t :: TOML
t = (TOML -> (Maybe (), TOML)) -> TomlState ()
forall a. (TOML -> (Maybe a, TOML)) -> TomlState a
TomlState (\_ -> (() -> Maybe ()
forall a. a -> Maybe a
Just (), TOML
t))
    {-# INLINE put #-}

{- | Transform 'Either' into 'TomlState'.

@since 1.3.0.0
-}
eitherToTomlState :: Either e a -> TomlState a
eitherToTomlState :: Either e a -> TomlState a
eitherToTomlState e :: Either e a
e = (TOML -> (Maybe a, TOML)) -> TomlState a
forall a. (TOML -> (Maybe a, TOML)) -> TomlState a
TomlState ((e -> Maybe a) -> (a -> Maybe a) -> Either e a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> e -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just Either e a
e,)