{-# LANGUAGE ApplicativeDo #-}

{- |
Copyright: (c) 2020 Kowainik
SPDX-License-Identifier: MPL-2.0
Maintainer: Kowainik <xrom.xkov@gmail.com>

Trial helpers for @tomland@.
-}

module Trial.Tomland
    ( trialCodec
    , trialStrCodec
    , trialMaybeCodec
    , taggedTrialCodec
    , taggedTrialStrCodec
    , taggedTrialMaybeCodec
    , taggedTrialListCodec
    ) where

import Control.Monad (join)
import Data.String (IsString (..))
import Toml (Key, TomlCodec)
import Trial (TaggedTrial, Trial (..), fiasco, maybeToTrial, trialToMaybe, unTag, withTag)

import qualified Data.Text as Text
import qualified Toml


{- | 'TomlCodec' for 'Trial' that adds a given event @e@ if a given
codec fails.

@since 0.0.0.0
-}
trialCodec :: e -> TomlCodec a -> TomlCodec (Trial e a)
trialCodec :: e -> TomlCodec a -> TomlCodec (Trial e a)
trialCodec e :: e
e = (Trial e a -> Maybe a)
-> (Maybe a -> Trial e a)
-> TomlCodec (Maybe a)
-> TomlCodec (Trial e a)
forall b a. (b -> a) -> (a -> b) -> TomlCodec a -> TomlCodec b
Toml.dimap Trial e a -> Maybe a
forall e a. Trial e a -> Maybe a
trialToMaybe (e -> Maybe a -> Trial e a
forall e a. e -> Maybe a -> Trial e a
maybeToTrial e
e) (TomlCodec (Maybe a) -> TomlCodec (Trial e a))
-> (TomlCodec a -> TomlCodec (Maybe a))
-> TomlCodec a
-> TomlCodec (Trial e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TomlCodec a -> TomlCodec (Maybe a)
forall a. TomlCodec a -> TomlCodec (Maybe a)
Toml.dioptional

{- | 'TomlCodec' for 'Trial' that adds an informative message if a
given codec fails.

@since 0.0.0.0
-}
trialStrCodec
    :: forall e a
    .  (IsString e, Semigroup e)
    => (Key -> TomlCodec a)
    -> Key
    -> TomlCodec (Trial e a)
trialStrCodec :: (Key -> TomlCodec a) -> Key -> TomlCodec (Trial e a)
trialStrCodec codecA :: Key -> TomlCodec a
codecA key :: Key
key =
    (Trial e a -> TaggedTrial e a)
-> (TaggedTrial e a -> Trial e a)
-> TomlCodec (TaggedTrial e a)
-> TomlCodec (Trial e a)
forall b a. (b -> a) -> (a -> b) -> TomlCodec a -> TomlCodec b
Toml.dimap (e -> Trial e a -> TaggedTrial e a
forall tag a. tag -> Trial tag a -> TaggedTrial tag a
withTag "TOML") TaggedTrial e a -> Trial e a
forall tag a. TaggedTrial tag a -> Trial tag a
unTag (TomlCodec (TaggedTrial e a) -> TomlCodec (Trial e a))
-> TomlCodec (TaggedTrial e a) -> TomlCodec (Trial e a)
forall a b. (a -> b) -> a -> b
$ (Key -> TomlCodec a) -> Key -> TomlCodec (TaggedTrial e a)
forall tag a.
(IsString tag, Semigroup tag) =>
(Key -> TomlCodec a) -> Key -> TomlCodec (TaggedTrial tag a)
taggedTrialStrCodec Key -> TomlCodec a
codecA Key
key

{- | 'TomlCodec' for 'Maybe' inside 'Trial'. Never fails,
doesn't change history of events.

@since 0.0.0.0
-}
trialMaybeCodec :: TomlCodec a -> TomlCodec (Trial e (Maybe a))
trialMaybeCodec :: TomlCodec a -> TomlCodec (Trial e (Maybe a))
trialMaybeCodec = (Trial e (Maybe a) -> Maybe a)
-> (Maybe a -> Trial e (Maybe a))
-> TomlCodec (Maybe a)
-> TomlCodec (Trial e (Maybe a))
forall b a. (b -> a) -> (a -> b) -> TomlCodec a -> TomlCodec b
Toml.dimap (Maybe (Maybe a) -> Maybe a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe a) -> Maybe a)
-> (Trial e (Maybe a) -> Maybe (Maybe a))
-> Trial e (Maybe a)
-> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trial e (Maybe a) -> Maybe (Maybe a)
forall e a. Trial e a -> Maybe a
trialToMaybe) Maybe a -> Trial e (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TomlCodec (Maybe a) -> TomlCodec (Trial e (Maybe a)))
-> (TomlCodec a -> TomlCodec (Maybe a))
-> TomlCodec a
-> TomlCodec (Trial e (Maybe a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TomlCodec a -> TomlCodec (Maybe a)
forall a. TomlCodec a -> TomlCodec (Maybe a)
Toml.dioptional

{- | 'TomlCodec' for 'TaggedTrial' that uses given @tag@ in a 'Fiasco'
if a given codec fails, and also adds @tag@ to the result.

@since 0.0.0.0
-}
taggedTrialCodec
    :: forall tag a
    .  tag
    -> (Key -> TomlCodec a)
    -> Key
    -> TomlCodec (TaggedTrial tag a)
taggedTrialCodec :: tag -> (Key -> TomlCodec a) -> Key -> TomlCodec (TaggedTrial tag a)
taggedTrialCodec tag :: tag
tag codecA :: Key -> TomlCodec a
codecA key :: Key
key =
    (TaggedTrial tag a -> Maybe a)
-> (Maybe a -> TaggedTrial tag a)
-> TomlCodec (Maybe a)
-> TomlCodec (TaggedTrial tag a)
forall b a. (b -> a) -> (a -> b) -> TomlCodec a -> TomlCodec b
Toml.dimap (((tag, a) -> a) -> Maybe (tag, a) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (tag, a) -> a
forall a b. (a, b) -> b
snd (Maybe (tag, a) -> Maybe a)
-> (TaggedTrial tag a -> Maybe (tag, a))
-> TaggedTrial tag a
-> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TaggedTrial tag a -> Maybe (tag, a)
forall e a. Trial e a -> Maybe a
trialToMaybe) Maybe a -> TaggedTrial tag a
handleMaybe
    (TomlCodec (Maybe a) -> TomlCodec (TaggedTrial tag a))
-> TomlCodec (Maybe a) -> TomlCodec (TaggedTrial tag a)
forall a b. (a -> b) -> a -> b
$ TomlCodec a -> TomlCodec (Maybe a)
forall a. TomlCodec a -> TomlCodec (Maybe a)
Toml.dioptional (Key -> TomlCodec a
codecA Key
key)
  where
    handleMaybe :: Maybe a -> TaggedTrial tag a
    handleMaybe :: Maybe a -> TaggedTrial tag a
handleMaybe = \case
        Nothing -> tag -> TaggedTrial tag a
forall e a. e -> Trial e a
fiasco tag
tag
        Just a :: a
a  -> tag -> Trial tag a -> TaggedTrial tag a
forall tag a. tag -> Trial tag a -> TaggedTrial tag a
withTag tag
tag (Trial tag a -> TaggedTrial tag a)
-> Trial tag a -> TaggedTrial tag a
forall a b. (a -> b) -> a -> b
$ a -> Trial tag a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

{- | 'TomlCodec' for 'TaggedTrial' that adds an informative message if
a given codec fails, and also adds a tag where the field comes from.

@since 0.0.0.0
-}
taggedTrialStrCodec
    :: forall tag a
    .  (IsString tag, Semigroup tag)
    => (Key -> TomlCodec a)
    -> Key
    -> TomlCodec (TaggedTrial tag a)
taggedTrialStrCodec :: (Key -> TomlCodec a) -> Key -> TomlCodec (TaggedTrial tag a)
taggedTrialStrCodec codecA :: Key -> TomlCodec a
codecA key :: Key
key =
    (TaggedTrial tag a -> Maybe a)
-> (Maybe a -> TaggedTrial tag a)
-> TomlCodec (Maybe a)
-> TomlCodec (TaggedTrial tag a)
forall b a. (b -> a) -> (a -> b) -> TomlCodec a -> TomlCodec b
Toml.dimap (((tag, a) -> a) -> Maybe (tag, a) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (tag, a) -> a
forall a b. (a, b) -> b
snd (Maybe (tag, a) -> Maybe a)
-> (TaggedTrial tag a -> Maybe (tag, a))
-> TaggedTrial tag a
-> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TaggedTrial tag a -> Maybe (tag, a)
forall e a. Trial e a -> Maybe a
trialToMaybe) Maybe a -> TaggedTrial tag a
handleMaybe
    (TomlCodec (Maybe a) -> TomlCodec (TaggedTrial tag a))
-> TomlCodec (Maybe a) -> TomlCodec (TaggedTrial tag a)
forall a b. (a -> b) -> a -> b
$ TomlCodec a -> TomlCodec (Maybe a)
forall a. TomlCodec a -> TomlCodec (Maybe a)
Toml.dioptional (Key -> TomlCodec a
codecA Key
key)
  where
    keyS :: tag
    keyS :: tag
keyS = String -> tag
forall a. IsString a => String -> a
fromString (String -> tag) -> String -> tag
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Key -> Text
Toml.prettyKey Key
key

    handleMaybe :: Maybe a -> TaggedTrial tag a
    handleMaybe :: Maybe a -> TaggedTrial tag a
handleMaybe = \case
        Nothing -> tag -> TaggedTrial tag a
forall e a. e -> Trial e a
fiasco (tag -> TaggedTrial tag a) -> tag -> TaggedTrial tag a
forall a b. (a -> b) -> a -> b
$ "No TOML option specified for key: " tag -> tag -> tag
forall a. Semigroup a => a -> a -> a
<> tag
keyS
        Just a :: a
a  -> tag -> Trial tag a -> TaggedTrial tag a
forall tag a. tag -> Trial tag a -> TaggedTrial tag a
withTag "TOML" (Trial tag a -> TaggedTrial tag a)
-> Trial tag a -> TaggedTrial tag a
forall a b. (a -> b) -> a -> b
$ a -> Trial tag a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

{- | 'TomlCodec' for 'Maybe' inside 'TaggedTrial'. Never fails,
doesn't change history of events, and adds a tag.

@since 0.0.0.0
-}
taggedTrialMaybeCodec :: IsString e => TomlCodec a -> TomlCodec (TaggedTrial e (Maybe a))
taggedTrialMaybeCodec :: TomlCodec a -> TomlCodec (TaggedTrial e (Maybe a))
taggedTrialMaybeCodec =
    (TaggedTrial e (Maybe a) -> Maybe a)
-> (Maybe a -> TaggedTrial e (Maybe a))
-> TomlCodec (Maybe a)
-> TomlCodec (TaggedTrial e (Maybe a))
forall b a. (b -> a) -> (a -> b) -> TomlCodec a -> TomlCodec b
Toml.dimap TaggedTrial e (Maybe a) -> Maybe a
forall e a. TaggedTrial e (Maybe a) -> Maybe a
taggedTrialToMaybe (e -> Trial e (Maybe a) -> TaggedTrial e (Maybe a)
forall tag a. tag -> Trial tag a -> TaggedTrial tag a
withTag "TOML" (Trial e (Maybe a) -> TaggedTrial e (Maybe a))
-> (Maybe a -> Trial e (Maybe a))
-> Maybe a
-> TaggedTrial e (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> Trial e (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (TomlCodec (Maybe a) -> TomlCodec (TaggedTrial e (Maybe a)))
-> (TomlCodec a -> TomlCodec (Maybe a))
-> TomlCodec a
-> TomlCodec (TaggedTrial e (Maybe a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TomlCodec a -> TomlCodec (Maybe a)
forall a. TomlCodec a -> TomlCodec (Maybe a)
Toml.dioptional
  where
    taggedTrialToMaybe :: TaggedTrial e (Maybe a) -> Maybe a
    taggedTrialToMaybe :: TaggedTrial e (Maybe a) -> Maybe a
taggedTrialToMaybe = Maybe (Maybe a) -> Maybe a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe a) -> Maybe a)
-> (TaggedTrial e (Maybe a) -> Maybe (Maybe a))
-> TaggedTrial e (Maybe a)
-> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((e, Maybe a) -> Maybe a) -> Maybe (e, Maybe a) -> Maybe (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (e, Maybe a) -> Maybe a
forall a b. (a, b) -> b
snd (Maybe (e, Maybe a) -> Maybe (Maybe a))
-> (TaggedTrial e (Maybe a) -> Maybe (e, Maybe a))
-> TaggedTrial e (Maybe a)
-> Maybe (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TaggedTrial e (Maybe a) -> Maybe (e, Maybe a)
forall e a. Trial e a -> Maybe a
trialToMaybe

{- | 'TomlCodec' that decodes with 'Toml.list' and adds 'fiasco' to
the result if the resulting list is empty. It's helpful to handle the
case when the list is not specified at all.

@since 0.0.0.0
-}
taggedTrialListCodec
    :: forall e a
    .  (IsString e, Semigroup e)
    => Key
    -> TomlCodec a
    -> TomlCodec (TaggedTrial e [a])
taggedTrialListCodec :: Key -> TomlCodec a -> TomlCodec (TaggedTrial e [a])
taggedTrialListCodec key :: Key
key aCodec :: TomlCodec a
aCodec = do
    TaggedTrial e [a]
res <- (Key -> TomlCodec [a]) -> Key -> TomlCodec (TaggedTrial e [a])
forall tag a.
(IsString tag, Semigroup tag) =>
(Key -> TomlCodec a) -> Key -> TomlCodec (TaggedTrial tag a)
taggedTrialStrCodec (TomlCodec a -> Key -> TomlCodec [a]
forall a. TomlCodec a -> Key -> TomlCodec [a]
Toml.list TomlCodec a
aCodec) Key
key
    pure $ case TaggedTrial e [a]
res of
        Result _ (_, []) ->
            TaggedTrial e [a]
res TaggedTrial e [a] -> TaggedTrial e [a] -> TaggedTrial e [a]
forall a. Semigroup a => a -> a -> a
<> e -> TaggedTrial e [a]
forall e a. e -> Trial e a
fiasco ("No TOML value is specified for key: " e -> e -> e
forall a. Semigroup a => a -> a -> a
<> Key -> e
keyToStr Key
key)
        Result _ _ -> TaggedTrial e [a]
res
        Fiasco _ -> TaggedTrial e [a]
res
  where
    keyToStr :: Key -> e
    keyToStr :: Key -> e
keyToStr = String -> e
forall a. IsString a => String -> a
fromString (String -> e) -> (Key -> String) -> Key -> e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack (Text -> String) -> (Key -> Text) -> Key -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
Toml.prettyKey