{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE Rank2Types #-}
module Toml.Codec.BiMap
(
BiMap (..)
, invert
, iso
, prism
, TomlBiMap
, TomlBiMapError (..)
, wrongConstructor
, prettyBiMapError
, mkAnyValueBiMap
, tShow
) where
import Control.DeepSeq (NFData)
import Control.Monad ((>=>))
import Data.Bifunctor (first)
import Data.Text (Text)
import GHC.Generics (Generic)
import Toml.Type.AnyValue (AnyValue (..), MatchError (..))
import Toml.Type.Value (TValue (..), Value (..))
import qualified Control.Category as Cat
import qualified Data.Text as T
data BiMap e a b = BiMap
{ forall e a b. BiMap e a b -> a -> Either e b
forward :: a -> Either e b
, forall e a b. BiMap e a b -> b -> Either e a
backward :: b -> Either e a
}
instance Cat.Category (BiMap e) where
id :: BiMap e a a
id :: forall a. BiMap e a a
id = (a -> Either e a) -> (a -> Either e a) -> BiMap e a a
forall e a b. (a -> Either e b) -> (b -> Either e a) -> BiMap e a b
BiMap a -> Either e a
forall a b. b -> Either a b
Right a -> Either e a
forall a b. b -> Either a b
Right
{-# INLINE id #-}
(.) :: BiMap e b c -> BiMap e a b -> BiMap e a c
BiMap e b c
bc . :: forall b c a. BiMap e b c -> BiMap e a b -> BiMap e a c
. BiMap e a b
ab = BiMap
{ forward :: a -> Either e c
forward = BiMap e a b -> a -> Either e b
forall e a b. BiMap e a b -> a -> Either e b
forward BiMap e a b
ab (a -> Either e b) -> (b -> Either e c) -> a -> Either e c
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> BiMap e b c -> b -> Either e c
forall e a b. BiMap e a b -> a -> Either e b
forward BiMap e b c
bc
, backward :: c -> Either e a
backward = BiMap e b c -> c -> Either e b
forall e a b. BiMap e a b -> b -> Either e a
backward BiMap e b c
bc (c -> Either e b) -> (b -> Either e a) -> c -> Either e a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> BiMap e a b -> b -> Either e a
forall e a b. BiMap e a b -> b -> Either e a
backward BiMap e a b
ab
}
{-# INLINE (.) #-}
invert :: BiMap e a b -> BiMap e b a
invert :: forall e a b. BiMap e a b -> BiMap e b a
invert (BiMap a -> Either e b
f b -> Either e a
g) = (b -> Either e a) -> (a -> Either e b) -> BiMap e b a
forall e a b. (a -> Either e b) -> (b -> Either e a) -> BiMap e a b
BiMap b -> Either e a
g a -> Either e b
f
{-# INLINE invert #-}
iso :: (a -> b) -> (b -> a) -> BiMap e a b
iso :: forall a b e. (a -> b) -> (b -> a) -> BiMap e a b
iso a -> b
f b -> a
g = (a -> Either e b) -> (b -> Either e a) -> BiMap e a b
forall e a b. (a -> Either e b) -> (b -> Either e a) -> BiMap e a b
BiMap (b -> Either e b
forall a b. b -> Either a b
Right (b -> Either e b) -> (a -> b) -> a -> Either e b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) (a -> Either e a
forall a b. b -> Either a b
Right (a -> Either e a) -> (b -> a) -> b -> Either e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
g)
{-# INLINE iso #-}
prism
:: (field -> object)
-> (object -> Either error field)
-> BiMap error object field
prism :: forall field object error.
(field -> object)
-> (object -> Either error field) -> BiMap error object field
prism field -> object
review object -> Either error field
preview = (object -> Either error field)
-> (field -> Either error object) -> BiMap error object field
forall e a b. (a -> Either e b) -> (b -> Either e a) -> BiMap e a b
BiMap object -> Either error field
preview (object -> Either error object
forall a b. b -> Either a b
Right (object -> Either error object)
-> (field -> object) -> field -> Either error object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. field -> object
review)
{-# INLINE prism #-}
type TomlBiMap = BiMap TomlBiMapError
data TomlBiMapError
= WrongConstructor
!Text
!Text
| WrongValue
!MatchError
| ArbitraryError
!Text
deriving stock (TomlBiMapError -> TomlBiMapError -> Bool
(TomlBiMapError -> TomlBiMapError -> Bool)
-> (TomlBiMapError -> TomlBiMapError -> Bool) -> Eq TomlBiMapError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TomlBiMapError -> TomlBiMapError -> Bool
== :: TomlBiMapError -> TomlBiMapError -> Bool
$c/= :: TomlBiMapError -> TomlBiMapError -> Bool
/= :: TomlBiMapError -> TomlBiMapError -> Bool
Eq, Int -> TomlBiMapError -> ShowS
[TomlBiMapError] -> ShowS
TomlBiMapError -> String
(Int -> TomlBiMapError -> ShowS)
-> (TomlBiMapError -> String)
-> ([TomlBiMapError] -> ShowS)
-> Show TomlBiMapError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TomlBiMapError -> ShowS
showsPrec :: Int -> TomlBiMapError -> ShowS
$cshow :: TomlBiMapError -> String
show :: TomlBiMapError -> String
$cshowList :: [TomlBiMapError] -> ShowS
showList :: [TomlBiMapError] -> ShowS
Show, (forall x. TomlBiMapError -> Rep TomlBiMapError x)
-> (forall x. Rep TomlBiMapError x -> TomlBiMapError)
-> Generic TomlBiMapError
forall x. Rep TomlBiMapError x -> TomlBiMapError
forall x. TomlBiMapError -> Rep TomlBiMapError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TomlBiMapError -> Rep TomlBiMapError x
from :: forall x. TomlBiMapError -> Rep TomlBiMapError x
$cto :: forall x. Rep TomlBiMapError x -> TomlBiMapError
to :: forall x. Rep TomlBiMapError x -> TomlBiMapError
Generic)
deriving anyclass (TomlBiMapError -> ()
(TomlBiMapError -> ()) -> NFData TomlBiMapError
forall a. (a -> ()) -> NFData a
$crnf :: TomlBiMapError -> ()
rnf :: TomlBiMapError -> ()
NFData)
prettyBiMapError :: TomlBiMapError -> Text
prettyBiMapError :: TomlBiMapError -> Text
prettyBiMapError = \case
WrongConstructor Text
expected Text
actual -> [Text] -> Text
T.unlines
[ Text
"Invalid constructor"
, Text
" * Expected: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
expected
, Text
" * Actual: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
actual
]
WrongValue (MatchError TValue
expected AnyValue
actual) -> [Text] -> Text
T.unlines
[ Text
"Invalid constructor"
, Text
" * Expected: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TValue -> Text
forall a. Show a => a -> Text
tShow TValue
expected
, Text
" * Actual: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AnyValue -> Text
forall a. Show a => a -> Text
tShow AnyValue
actual
]
ArbitraryError Text
text -> Text
text
wrongConstructor
:: Show a
=> Text
-> a
-> Either TomlBiMapError b
wrongConstructor :: forall a b. Show a => Text -> a -> Either TomlBiMapError b
wrongConstructor Text
constructor a
x = TomlBiMapError -> Either TomlBiMapError b
forall a b. a -> Either a b
Left (TomlBiMapError -> Either TomlBiMapError b)
-> TomlBiMapError -> Either TomlBiMapError b
forall a b. (a -> b) -> a -> b
$ Text -> Text -> TomlBiMapError
WrongConstructor Text
constructor (a -> Text
forall a. Show a => a -> Text
tShow a
x)
tShow :: Show a => a -> Text
tShow :: forall a. Show a => a -> Text
tShow = String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show
{-# INLINE tShow #-}
mkAnyValueBiMap
:: forall a (tag :: TValue)
. (forall (t :: TValue) . Value t -> Either MatchError a)
-> (a -> Value tag)
-> TomlBiMap a AnyValue
mkAnyValueBiMap :: forall a (tag :: TValue).
(forall (t :: TValue). Value t -> Either MatchError a)
-> (a -> Value tag) -> TomlBiMap a AnyValue
mkAnyValueBiMap forall (t :: TValue). Value t -> Either MatchError a
matchValue a -> Value tag
toValue = BiMap
{ forward :: a -> Either TomlBiMapError AnyValue
forward = AnyValue -> Either TomlBiMapError AnyValue
forall a b. b -> Either a b
Right (AnyValue -> Either TomlBiMapError AnyValue)
-> (a -> AnyValue) -> a -> Either TomlBiMapError AnyValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> AnyValue
toAnyValue
, backward :: AnyValue -> Either TomlBiMapError a
backward = AnyValue -> Either TomlBiMapError a
fromAnyValue
}
where
toAnyValue :: a -> AnyValue
toAnyValue :: a -> AnyValue
toAnyValue = Value tag -> AnyValue
forall (t :: TValue). Value t -> AnyValue
AnyValue (Value tag -> AnyValue) -> (a -> Value tag) -> a -> AnyValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value tag
toValue
fromAnyValue :: AnyValue -> Either TomlBiMapError a
fromAnyValue :: AnyValue -> Either TomlBiMapError a
fromAnyValue (AnyValue Value t
value) = (MatchError -> TomlBiMapError)
-> Either MatchError a -> Either TomlBiMapError a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first MatchError -> TomlBiMapError
WrongValue (Either MatchError a -> Either TomlBiMapError a)
-> Either MatchError a -> Either TomlBiMapError a
forall a b. (a -> b) -> a -> b
$ Value t -> Either MatchError a
forall (t :: TValue). Value t -> Either MatchError a
matchValue Value t
value