{-# 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 = forall e a b. (a -> Either e b) -> (b -> Either e a) -> BiMap e a b
BiMap forall a b. b -> Either a b
Right 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  =  forall e a b. BiMap e a b -> a -> Either e b
forward BiMap e a b
ab forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m 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 = forall e a b. BiMap e a b -> b -> Either e a
backward BiMap e b c
bc forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> 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) = 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 = forall e a b. (a -> Either e b) -> (b -> Either e a) -> BiMap e a b
BiMap (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) (forall a b. b -> Either a b
Right 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 = forall e a b. (a -> Either e b) -> (b -> Either e a) -> BiMap e a b
BiMap object -> Either error field
preview (forall a b. b -> Either a b
Right 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TomlBiMapError -> TomlBiMapError -> Bool
$c/= :: TomlBiMapError -> TomlBiMapError -> Bool
== :: TomlBiMapError -> TomlBiMapError -> Bool
$c== :: TomlBiMapError -> TomlBiMapError -> Bool
Eq, Int -> TomlBiMapError -> ShowS
[TomlBiMapError] -> ShowS
TomlBiMapError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TomlBiMapError] -> ShowS
$cshowList :: [TomlBiMapError] -> ShowS
show :: TomlBiMapError -> String
$cshow :: TomlBiMapError -> String
showsPrec :: Int -> TomlBiMapError -> ShowS
$cshowsPrec :: Int -> TomlBiMapError -> ShowS
Show, 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
$cto :: forall x. Rep TomlBiMapError x -> TomlBiMapError
$cfrom :: forall x. TomlBiMapError -> Rep TomlBiMapError x
Generic)
    deriving anyclass (TomlBiMapError -> ()
forall a. (a -> ()) -> NFData a
rnf :: TomlBiMapError -> ()
$crnf :: 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: " forall a. Semigroup a => a -> a -> a
<> Text
expected
        , Text
"  * Actual:   " forall a. Semigroup a => a -> a -> a
<> Text
actual
        ]
    WrongValue (MatchError TValue
expected AnyValue
actual) -> [Text] -> Text
T.unlines
        [ Text
"Invalid constructor"
        , Text
"  * Expected: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tShow TValue
expected
        , Text
"  * Actual:   " forall a. Semigroup a => a -> a -> a
<> 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 = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> Text -> TomlBiMapError
WrongConstructor Text
constructor (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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  = forall a b. b -> Either a b
Right 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 = forall (t :: TValue). Value t -> AnyValue
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) = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first MatchError -> TomlBiMapError
WrongValue forall a b. (a -> b) -> a -> b
$ forall (t :: TValue). Value t -> Either MatchError a
matchValue Value t
value