{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE Rank2Types          #-}

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

Implementation of /Tagged Partial Bidirectional Isomorphism/.
This module contains the 'BiMap' type that represents conversion between
two types with the possibility of failure.

See "Toml.Codec.BiMap.Conversion" for examples of 'BiMap' with
specific types. The 'BiMap' concept is general and is not specific to
TOML, but in this package most usages of 'BiMap' are between TOML
values and Haskell values.
-}

module Toml.Codec.BiMap
    ( -- * 'BiMap' concept
      BiMap (..)
    , invert
    , iso
    , prism

      -- * TOML 'BiMap'
      -- ** Type
    , TomlBiMap
      -- ** Error
    , TomlBiMapError (..)
    , wrongConstructor
    , prettyBiMapError
      -- ** Smart constructors
    , mkAnyValueBiMap
      -- ** Internals
    , 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


{- | Partial bidirectional isomorphism. @BiMap a b@ contains two function:

1. @a -> Either e b@
2. @b -> Either e a@

If you think of types as sets then this data type can be illustrated by the
following picture:

![bimap-type](https://user-images.githubusercontent.com/4276606/50770531-b6a36000-1298-11e9-9528-caae87951d2a.png)

'BiMap' also implements 'Cat.Category' typeclass. And this instance can be described
clearly by this illustration:

![bimap-cat](https://user-images.githubusercontent.com/4276606/50771234-13a01580-129b-11e9-93da-6c5dd0f7f160.png)

@since 0.4.0
-}
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
    }

-- | @since 0.4.0
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 (.) #-}

{- | Inverts bidirectional mapping.

@since 0.4.0
-}
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 #-}

{- | Creates 'BiMap' from isomorphism. Can be used in the following way:

@
__newtype__ Even = Even Integer
__newtype__ Odd  = Odd  Integer

succEven :: Even -> Odd
succEven (Even n) = Odd (n + 1)

predOdd :: Odd -> Even
predOdd (Odd n) = Even (n - 1)

_EvenOdd :: 'BiMap' e Even Odd
_EvenOdd = 'iso' succEven predOdd
@

@since 0.4.0
-}
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 #-}

{- | Creates 'BiMap' from prism-like pair of functions. This combinator can be
used to create 'BiMap' for custom sum types like this:

@
__data__ User
    = Admin  Integer  -- id of admin
    | Client Text     -- name of the client
    __deriving__ (Show)

_Admin :: 'TomlBiMap' User Integer
_Admin = Toml.'prism' Admin $ \\__case__
    Admin i -> Right i
    other   -> Toml.'wrongConstructor' \"Admin\" other

_Client :: 'TomlBiMap' User Text
_Client = Toml.'prism' Client $ \\__case__
    Client n -> Right n
    other    -> Toml.'wrongConstructor' \"Client\" other
@

@since 0.4.0
-}
prism
    :: (field -> object)
    -- ^ Constructor
    -> (object -> Either error field)
    -- ^ Match object to either error or 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 #-}

----------------------------------------------------------------------------
-- TOML BiMap
----------------------------------------------------------------------------

{- | 'BiMap' specialized to TOML error.

@since 1.0.0
-}
type TomlBiMap = BiMap TomlBiMapError

{- | Type of errors for TOML 'BiMap'.

@since 1.0.0
-}
data TomlBiMapError
    = WrongConstructor -- ^ Error for cases with wrong constructors. For
                       -- example, you're trying to convert 'Left' but
                       -- bidirectional converter expects 'Right'.
        !Text          -- ^ Expected constructor name
        !Text          -- ^ Actual value
    | WrongValue       -- ^ Error for cases with wrong values
        !MatchError    -- ^ Information about failed matching
    | ArbitraryError   -- ^ Arbitrary textual error
        !Text          -- ^ Error message
    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)

{- | Converts 'TomlBiMapError' into pretty human-readable text.

@since 1.0.0
-}
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

{- | Helper to construct WrongConstuctor error.

@since 1.0.0
-}
wrongConstructor
    :: Show a
    => Text  -- ^ Name of the expected constructor
    -> a     -- ^ Actual value
    -> 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 #-}

----------------------------------------------------------------------------
--  BiMaps for value
----------------------------------------------------------------------------

{- | Smart constructor for 'BiMap' from a Haskell value (some
primitive like 'Int' or 'Text') to 'AnyValue'.

@since 0.4.0
-}
mkAnyValueBiMap
    :: forall a (tag :: TValue)
    .  (forall (t :: TValue) . Value t -> Either MatchError a)
    -- ^ Haskell type exctractor from 'Value'
    -> (a -> Value tag)
    -- ^ Convert Haskell type back to 'Value'
    -> 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