From 11668e467465f518fca3473555cb14b2371ed7ea Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Sat, 2 Apr 2022 16:16:12 -0700 Subject: [PATCH 1/2] Return 'TomlState ()' in codecWrite --- src/Toml/Codec/Combinator/Common.hs | 4 ++-- src/Toml/Codec/Combinator/List.hs | 10 +++++----- src/Toml/Codec/Combinator/Map.hs | 8 ++++---- src/Toml/Codec/Combinator/Table.hs | 4 ++-- src/Toml/Codec/Di.hs | 7 ++++--- src/Toml/Codec/Types.hs | 15 +++++---------- 6 files changed, 22 insertions(+), 26 deletions(-) diff --git a/src/Toml/Codec/Combinator/Common.hs b/src/Toml/Codec/Combinator/Common.hs index 070c3960..99b93d76 100644 --- a/src/Toml/Codec/Combinator/Common.hs +++ b/src/Toml/Codec/Combinator/Common.hs @@ -60,10 +60,10 @@ match BiMap{..} key = Codec input output Nothing -> Failure [KeyNotFound key] Just anyVal -> whenLeftBiMapError key (backward anyVal) pure - output :: a -> TomlState a + output :: a -> TomlState () output a = do anyVal <- eitherToTomlState $ forward a - a <$ modify (insertKeyAnyVal key anyVal) + modify (insertKeyAnyVal key anyVal) {- | Throw error on 'Left', or perform a given action with 'Right'. diff --git a/src/Toml/Codec/Combinator/List.hs b/src/Toml/Codec/Combinator/List.hs index 57914648..a784d442 100644 --- a/src/Toml/Codec/Combinator/List.hs +++ b/src/Toml/Codec/Combinator/List.hs @@ -65,6 +65,7 @@ module Toml.Codec.Combinator.List ) where import Control.Monad.State (gets, modify) +import Data.Foldable (traverse_) import Data.List.NonEmpty (NonEmpty (..), toList) import Validation (Validation (..)) @@ -80,6 +81,7 @@ import Toml.Type.Key (Key) import Toml.Type.TOML (TOML (..), insertTableArrays) import qualified Data.HashMap.Strict as HashMap +import qualified Data.List.NonEmpty as NonEmpty {- | Codec for list of values. Takes converter for single value and @@ -159,9 +161,7 @@ list codec key = Codec Failure [TableArrayNotFound errKey] | errKey == key -> pure [] Failure errs -> Failure errs - , codecWrite = \case - [] -> pure [] - l@(x:xs) -> l <$ codecWrite nonEmptyCodec (x :| xs) + , codecWrite = traverse_ (codecWrite nonEmptyCodec) . NonEmpty.nonEmpty } where nonEmptyCodec :: TomlCodec (NonEmpty a) @@ -213,7 +213,7 @@ nonEmpty codec key = Codec input output -- adds all TOML objects to the existing list if there are some - output :: NonEmpty a -> TomlState (NonEmpty a) + output :: NonEmpty a -> TomlState () output as = do let tomls = fmap (execTomlCodec codec) as mTables <- gets $ HashMap.lookup key . tomlTableArrays @@ -222,4 +222,4 @@ nonEmpty codec key = Codec input output Nothing -> tomls Just oldTomls -> oldTomls <> tomls - as <$ modify (insertTableArrays key newTomls) + modify (insertTableArrays key newTomls) diff --git a/src/Toml/Codec/Combinator/Map.hs b/src/Toml/Codec/Combinator/Map.hs index 17598526..eb97e914 100644 --- a/src/Toml/Codec/Combinator/Map.hs +++ b/src/Toml/Codec/Combinator/Map.hs @@ -347,7 +347,7 @@ internalMap emptyMap toListMap fromListMap keyCodec valCodec key = Codec input o v <- codecRead valCodec toml pure (k, v) - output :: map -> TomlState map + output :: map -> TomlState () output dict = do let tomls = fmap (\(k, v) -> execTomlCodec keyCodec k <> execTomlCodec valCodec v) @@ -363,7 +363,7 @@ internalMap emptyMap toListMap fromListMap keyCodec valCodec key = Codec input o Just (t :| ts) -> insertTableArrays key $ t :| (ts ++ tomls) - dict <$ modify updateAction + modify updateAction internalTableMap :: forall map k v @@ -391,12 +391,12 @@ internalTableMap emptyMap toListMap fromListMap keyBiMap valCodec tableName = whenLeftBiMapError key (forward keyBiMap key) $ \k -> (k,) <$> codecRead (valCodec key) toml - output :: map -> TomlState map + output :: map -> TomlState () output m = do mTable <- gets $ Prefix.lookup tableName . tomlTables let toml = fromMaybe mempty mTable let (_, newToml) = unTomlState updateMapTable toml - m <$ modify (insertTable tableName newToml) + modify (insertTable tableName newToml) where updateMapTable :: TomlState () updateMapTable = forM_ (toListMap m) $ \(k, v) -> case backward keyBiMap k of diff --git a/src/Toml/Codec/Combinator/Table.hs b/src/Toml/Codec/Combinator/Table.hs index f8219c7b..6dc30eb1 100644 --- a/src/Toml/Codec/Combinator/Table.hs +++ b/src/Toml/Codec/Combinator/Table.hs @@ -87,9 +87,9 @@ table codec key = Codec input output Nothing -> Failure [TableNotFound key] Just toml -> handleTableErrors codec key toml - output :: a -> TomlState a + output :: a -> TomlState () output a = do mTable <- gets $ Prefix.lookup key . tomlTables let toml = fromMaybe mempty mTable let (_, newToml) = unTomlState (codecWrite codec a) toml - a <$ modify (insertTable key newToml) + modify (insertTable key newToml) diff --git a/src/Toml/Codec/Di.hs b/src/Toml/Codec/Di.hs index e0bd7eb6..ba3027f6 100644 --- a/src/Toml/Codec/Di.hs +++ b/src/Toml/Codec/Di.hs @@ -21,6 +21,7 @@ module Toml.Codec.Di import Control.Applicative (Alternative (..)) import Data.Coerce (Coercible, coerce) +import Data.Foldable (traverse_) import Toml.Codec.Types (Codec (..), TomlCodec, ()) @@ -78,7 +79,7 @@ dimap -> TomlCodec b -- ^ Target 'Codec' object dimap f g codec = Codec { codecRead = fmap g . codecRead codec - , codecWrite = fmap g . codecWrite codec . f + , codecWrite = codecWrite codec . f } {-# INLINE dimap #-} @@ -108,7 +109,7 @@ dioptional -> TomlCodec (Maybe a) dioptional Codec{..} = Codec { codecRead = fmap Just . codecRead \_ -> pure Nothing - , codecWrite = traverse codecWrite + , codecWrite = traverse_ codecWrite } {-# INLINE dioptional #-} @@ -184,7 +185,7 @@ dimatch match ctor codec = Codec { codecRead = fmap ctor . codecRead codec , codecWrite = \c -> case match c of Nothing -> empty - Just d -> ctor <$> codecWrite codec d + Just d -> codecWrite codec d } {-# INLINE dimatch #-} diff --git a/src/Toml/Codec/Types.hs b/src/Toml/Codec/Types.hs index d5048398..62b0d212 100644 --- a/src/Toml/Codec/Types.hs +++ b/src/Toml/Codec/Types.hs @@ -82,13 +82,8 @@ described in more details in related blog post: data Codec i o = Codec { -- | Extract value of type @o@ from monadic context 'TomlEnv'. codecRead :: TomlEnv o - - {- | Store value of type @i@ inside monadic context 'TomlState' and - returning value of type @o@. Type of this function actually should be - @o -> TomlState ()@ but with such type it's impossible to have 'Monad' - and other instances. - -} - , codecWrite :: i -> TomlState o + -- | Store value of type @i@ inside monadic context 'TomlState'. + , codecWrite :: i -> TomlState () } -- | @since 0.0.0 @@ -96,7 +91,7 @@ instance Functor (Codec i) where fmap :: (oA -> oB) -> Codec i oA -> Codec i oB fmap f codec = Codec { codecRead = fmap f . codecRead codec - , codecWrite = fmap f . codecWrite codec + , codecWrite = codecWrite codec } {-# INLINE fmap #-} @@ -105,14 +100,14 @@ instance Applicative (Codec i) where pure :: o -> Codec i o pure a = Codec { codecRead = \_ -> Success a - , codecWrite = \_ -> pure a + , codecWrite = \_ -> pure () } {-# INLINE pure #-} (<*>) :: Codec i (oA -> oB) -> Codec i oA -> Codec i oB codecf <*> codeca = Codec { codecRead = liftA2 (<*>) (codecRead codecf) (codecRead codeca) - , codecWrite = \c -> codecWrite codecf c <*> codecWrite codeca c + , codecWrite = \c -> codecWrite codecf c *> codecWrite codeca c } {-# INLINE (<*>) #-} From 396c6776a932ab956a33aba3eaa9185af9b45a42 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Sat, 2 Apr 2022 16:27:26 -0700 Subject: [PATCH 2/2] Fix typos + clarify docs --- src/Toml/Codec/Types.hs | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Toml/Codec/Types.hs b/src/Toml/Codec/Types.hs index 62b0d212..9a89939a 100644 --- a/src/Toml/Codec/Types.hs +++ b/src/Toml/Codec/Types.hs @@ -49,22 +49,21 @@ import Toml.Type (TOML (..)) type TomlEnv a = TOML -> Validation [TomlDecodeError] a -{- | Specialied 'Codec' type alias for bidirectional TOML serialization. Keeps +{- | Specialized 'Codec' type alias for bidirectional TOML serialization. Keeps 'TOML' object as both environment and state. @since 0.5.0 -} type TomlCodec a = Codec a a -{- | Monad for bidirectional conversion. Contains pair of functions: +{- | Monad for bidirectional conversion. Contains a pair of functions: -1. How to read value of type @o@ (out) from immutable environment context +1. How to read a value of type @o@ (out) from an immutable environment context ('TomlEnv')? -2. How to store a value of type @i@ (in) in stateful context ('TomlState') and -return a value of type @o@? +2. How to store a value of type @i@ (in) in a stateful context ('TomlState')? -This approach with the bunch of utility functions allows to -have single description for from/to @TOML@ conversion. +This approach, along with a bunch of utility functions, allows us to +have a single description for @TOML@ serialization + deserialization. In practice this type will always be used in the following way: @@ -72,9 +71,11 @@ In practice this type will always be used in the following way: type 'TomlCodec' a = 'Codec' a a @ -Type parameter @i@ if fictional. Here some trick is used. This trick is -implemented in the [codec](http://hackage.haskell.org/package/codec) package and -described in more details in related blog post: +However, we need to represent @i@ separately from @o@ in order to implement +instances like 'Alternative', which requires the type parameter to be covariant, +but @i@ is contravariant. This trick is inspired by the +[codec](http://hackage.haskell.org/package/codec) package and +described in more details in this blog post: . @since 0.0.0 @@ -133,8 +134,8 @@ f g = \a -> f a <|> g a {-# INLINE () #-} {- | Mutable context for TOML conversion. -We are introducing our own implemetation of state with 'MonadState' instance due -to some limitation in the design connected to the usage of State. +We are introducing our own implementation of state with 'MonadState' instance due +to some limitations in the design connected to the usage of State. This newtype is equivalent to the following transformer: @@ -142,7 +143,6 @@ This newtype is equivalent to the following transformer: MaybeT (State TOML) @ - @since 1.3.0.0 -} newtype TomlState a = TomlState