{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap oA -> oB
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i o. Codec i o -> TomlEnv o
codecRead Codec i oA
codec
, codecWrite :: i -> TomlState oB
codecWrite = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap oA -> oB
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
_ -> forall e a. a -> Validation e a
Success o
a
, codecWrite :: i -> TomlState o
codecWrite = \i
_ -> 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 = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) (forall i o. Codec i o -> TomlEnv o
codecRead Codec i (oA -> oB)
codecf) (forall i o. Codec i o -> TomlEnv o
codecRead Codec i oA
codeca)
, codecWrite :: i -> TomlState oB
codecWrite = \i
c -> forall i o. Codec i o -> i -> TomlState o
codecWrite Codec i (oA -> oB)
codecf i
c forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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
_ -> forall (f :: * -> *) a. Alternative f => f a
empty
, codecWrite :: i -> TomlState o
codecWrite = \i
_ -> 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 = forall i o. Codec i o -> TomlEnv o
codecRead Codec i o
codec1 forall (f :: * -> *) a x.
Alternative f =>
(a -> f x) -> (a -> f x) -> a -> f x
<!> forall i o. Codec i o -> TomlEnv o
codecRead Codec i o
codec2
, codecWrite :: i -> TomlState o
codecWrite = \i
c -> forall i o. Codec i o -> i -> TomlState o
codecWrite Codec i o
codec1 i
c forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> 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 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 :: TOML -> (Maybe a, TOML)
unTomlState :: forall a. TomlState a -> TOML -> (Maybe a, TOML)
..} = forall a. (TOML -> (Maybe a, TOML)) -> TomlState a
TomlState (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) 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 :: TOML -> (Maybe b, TOML)
unTomlState :: forall a. TomlState a -> TOML -> (Maybe a, TOML)
..} = forall a. (TOML -> (Maybe a, TOML)) -> TomlState a
TomlState (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const a
a)) 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 = forall a. (TOML -> (Maybe a, TOML)) -> TomlState a
TomlState (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 = forall a. (TOML -> (Maybe a, TOML)) -> TomlState a
TomlState forall a b. (a -> b) -> a -> b
$ \TOML
t ->
let (Maybe (a -> b)
mF, TOML
tF) = forall a. TomlState a -> TOML -> (Maybe a, TOML)
unTomlState TomlState (a -> b)
tsF TOML
t
(Maybe a
mA, TOML
tA) = forall a. TomlState a -> TOML -> (Maybe a, TOML)
unTomlState TomlState a
tsA TOML
tF
in (Maybe (a -> b)
mF 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 = forall a. (TOML -> (Maybe a, TOML)) -> TomlState a
TomlState (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 = forall a. (TOML -> (Maybe a, TOML)) -> TomlState a
TomlState forall a b. (a -> b) -> a -> b
$ \TOML
t -> let (Maybe a
m1, TOML
t1) = forall a. TomlState a -> TOML -> (Maybe a, TOML)
unTomlState TomlState a
ts1 TOML
t in case Maybe a
m1 of
Maybe a
Nothing -> 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 = 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 = forall a. (TOML -> (Maybe a, TOML)) -> TomlState a
TomlState forall a b. (a -> b) -> a -> b
$ \TOML
t -> let (Maybe a
mA, TOML
newT) = forall a. TomlState a -> TOML -> (Maybe a, TOML)
unTomlState TomlState a
tsA TOML
t in case Maybe a
mA of
Maybe a
Nothing -> (forall a. Maybe a
Nothing, TOML
newT)
Just a
a -> 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 = forall a. (TOML -> (Maybe a, TOML)) -> TomlState a
TomlState (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. TOML -> (a, TOML)
f)
{-# INLINE state #-}
get :: TomlState TOML
get :: TomlState TOML
get = forall a. (TOML -> (Maybe a, TOML)) -> TomlState a
TomlState (\TOML
t -> (forall a. a -> Maybe a
Just TOML
t, TOML
t))
{-# INLINE get #-}
put :: TOML -> TomlState ()
put :: TOML -> TomlState ()
put TOML
t = forall a. (TOML -> (Maybe a, TOML)) -> TomlState a
TomlState (\TOML
_ -> (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 = forall a. (TOML -> (Maybe a, TOML)) -> TomlState a
TomlState (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just Either e a
e,)