{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Toml.Codec.Types
(
TomlCodec
, TomlEnv
, TomlState (..)
, eitherToTomlState
, Codec (..)
, (<!>)
) 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 (..))
type TomlEnv a = TOML -> Validation [TomlDecodeError] a
type TomlCodec a = Codec a a
data Codec i o = Codec
{
forall i o. Codec i o -> TomlEnv o
codecRead :: TomlEnv o
, forall i o. Codec i o -> i -> TomlState o
codecWrite :: i -> TomlState o
}
instance Functor (Codec i) where
fmap :: (oA -> oB) -> Codec i oA -> Codec i oB
fmap :: forall a b. (a -> b) -> Codec i a -> Codec i b
fmap oA -> oB
f Codec i oA
codec = Codec
{ codecRead :: TomlEnv oB
codecRead = (oA -> oB)
-> Validation [TomlDecodeError] oA
-> Validation [TomlDecodeError] oB
forall a b.
(a -> b)
-> Validation [TomlDecodeError] a -> Validation [TomlDecodeError] b
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 a b. (a -> b) -> TomlState a -> TomlState b
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 #-}
instance Applicative (Codec i) where
pure :: o -> Codec i o
pure :: forall a. a -> Codec i a
pure o
a = Codec
{ codecRead :: TomlEnv o
codecRead = \TOML
_ -> o -> Validation [TomlDecodeError] o
forall e a. a -> Validation e a
Success o
a
, codecWrite :: i -> TomlState o
codecWrite = \i
_ -> o -> TomlState o
forall a. a -> TomlState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure o
a
}
{-# INLINE pure #-}
(<*>) :: Codec i (oA -> oB) -> Codec i oA -> Codec i oB
Codec i (oA -> oB)
codecf <*> :: forall a b. Codec i (a -> b) -> Codec i a -> Codec i b
<*> Codec i oA
codeca = 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 a b c.
(a -> b -> c) -> (TOML -> a) -> (TOML -> b) -> TOML -> c
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 a b.
Validation [TomlDecodeError] (a -> b)
-> Validation [TomlDecodeError] a -> Validation [TomlDecodeError] b
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 = \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 a b. TomlState (a -> b) -> TomlState a -> TomlState b
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 :: forall a. Codec i a
empty = Codec
{ codecRead :: TomlEnv o
codecRead = \TOML
_ -> Validation [TomlDecodeError] o
forall a. Validation [TomlDecodeError] a
forall (f :: * -> *) a. Alternative f => f a
empty
, codecWrite :: i -> TomlState o
codecWrite = \i
_ -> TomlState o
forall a. TomlState a
forall (f :: * -> *) a. Alternative f => f a
empty
}
{-# INLINE empty #-}
(<|>) :: Codec i o -> Codec i o -> Codec i o
Codec i o
codec1 <|> :: forall a. Codec i a -> Codec i a -> Codec i a
<|> Codec i o
codec2 = 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 = \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 a. TomlState a -> TomlState a -> TomlState a
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 (<|>) #-}
infixl 3 <!>
(<!>) :: Alternative f => (a -> f x) -> (a -> f x) -> (a -> f x)
a -> f x
f <!> :: forall (f :: * -> *) a x.
Alternative f =>
(a -> f x) -> (a -> f x) -> a -> f x
<!> a -> f x
g = \a
a -> a -> f x
f a
a f x -> f x -> f x
forall a. f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> f x
g a
a
{-# INLINE (<!>) #-}
newtype TomlState a = TomlState
{ forall a. TomlState a -> TOML -> (Maybe a, TOML)
unTomlState :: TOML -> (Maybe a, TOML)
}
instance Functor TomlState where
fmap :: (a -> b) -> TomlState a -> TomlState b
fmap :: forall a b. (a -> b) -> TomlState a -> TomlState b
fmap a -> b
f TomlState{TOML -> (Maybe a, TOML)
unTomlState :: forall a. TomlState a -> TOML -> (Maybe a, TOML)
unTomlState :: TOML -> (Maybe a, TOML)
..} = (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 a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((a -> b) -> Maybe a -> Maybe b
forall a b. (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 <$ :: forall a b. a -> TomlState b -> TomlState a
<$ TomlState{TOML -> (Maybe b, TOML)
unTomlState :: forall a. TomlState a -> TOML -> (Maybe a, TOML)
unTomlState :: TOML -> (Maybe b, TOML)
..} = (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 a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((b -> a) -> Maybe b -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
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 (<$) #-}
instance Applicative TomlState where
pure :: a -> TomlState a
pure :: forall a. a -> TomlState a
pure 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
TomlState (a -> b)
tsF <*> :: forall a b. TomlState (a -> b) -> TomlState a -> TomlState b
<*> 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
$ \TOML
t ->
let (Maybe (a -> b)
mF, 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
(Maybe a
mA, 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 a b. 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 (<*>) #-}
instance Alternative TomlState where
empty :: TomlState a
empty :: forall a. 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
TomlState a
ts1 <|> :: forall a. TomlState a -> TomlState a -> TomlState a
<|> 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
$ \TOML
t -> let (Maybe a
m1, 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
Maybe a
Nothing -> TomlState a -> TOML -> (Maybe a, TOML)
forall a. TomlState a -> TOML -> (Maybe a, TOML)
unTomlState TomlState a
ts2 TOML
t
Just a
_ -> (Maybe a
m1, TOML
t1)
{-# INLINE (<|>) #-}
instance Monad TomlState where
return :: a -> TomlState a
return :: forall a. a -> TomlState a
return = a -> TomlState a
forall a. a -> TomlState a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE return #-}
(>>=) :: TomlState a -> (a -> TomlState b) -> TomlState b
TomlState a
tsA >>= :: forall a b. TomlState a -> (a -> TomlState b) -> TomlState b
>>= 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
$ \TOML
t -> let (Maybe a
mA, 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
Maybe a
Nothing -> (Maybe b
forall a. Maybe a
Nothing, TOML
newT)
Just 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 (>>=) #-}
instance (s ~ TOML) => MonadState s TomlState where
state :: (TOML -> (a, TOML)) -> TomlState a
state :: forall a. (TOML -> (a, TOML)) -> TomlState a
state 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 a b c. (a -> b) -> (a, c) -> (b, c)
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 (\TOML
t -> (TOML -> Maybe TOML
forall a. a -> Maybe a
Just TOML
t, TOML
t))
{-# INLINE get #-}
put :: TOML -> TomlState ()
put :: TOML -> TomlState ()
put TOML
t = (TOML -> (Maybe (), TOML)) -> TomlState ()
forall a. (TOML -> (Maybe a, TOML)) -> TomlState a
TomlState (\TOML
_ -> (() -> Maybe ()
forall a. a -> Maybe a
Just (), TOML
t))
{-# INLINE put #-}
eitherToTomlState :: Either e a -> TomlState a
eitherToTomlState :: forall e a. Either e a -> TomlState a
eitherToTomlState 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,)