tomland-1.3.2.0: src/Toml/Codec/BiMap.hs
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE Rank2Types #-}
{- |
Module : Toml.Codec.BiMap
Copyright : (c) 2018-2021 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' also implements 'Cat.Category' typeclass. And this instance can be described
clearly by this illustration:
@since 0.4.0
-}
data BiMap e a b = BiMap
{ forward :: a -> Either e b
, backward :: b -> Either e a
}
-- | @since 0.4.0
instance Cat.Category (BiMap e) where
id :: BiMap e a a
id = BiMap Right Right
{-# INLINE id #-}
(.) :: BiMap e b c -> BiMap e a b -> BiMap e a c
bc . ab = BiMap
{ forward = forward ab >=> forward bc
, backward = backward bc >=> backward ab
}
{-# INLINE (.) #-}
{- | Inverts bidirectional mapping.
@since 0.4.0
-}
invert :: BiMap e a b -> BiMap e b a
invert (BiMap f g) = BiMap g 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 f g = BiMap (Right . f) (Right . 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 review preview = BiMap preview (Right . 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 (Eq, Show, Generic)
deriving anyclass (NFData)
{- | Converts 'TomlBiMapError' into pretty human-readable text.
@since 1.0.0
-}
prettyBiMapError :: TomlBiMapError -> Text
prettyBiMapError = \case
WrongConstructor expected actual -> T.unlines
[ "Invalid constructor"
, " * Expected: " <> expected
, " * Actual: " <> actual
]
WrongValue (MatchError expected actual) -> T.unlines
[ "Invalid constructor"
, " * Expected: " <> tShow expected
, " * Actual: " <> tShow actual
]
ArbitraryError 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 constructor x = Left $ WrongConstructor constructor (tShow x)
tShow :: Show a => a -> Text
tShow = T.pack . 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 matchValue toValue = BiMap
{ forward = Right . toAnyValue
, backward = fromAnyValue
}
where
toAnyValue :: a -> AnyValue
toAnyValue = AnyValue . toValue
fromAnyValue :: AnyValue -> Either TomlBiMapError a
fromAnyValue (AnyValue value) = first WrongValue $ matchValue value