{-# LANGUAGE DeriveAnyClass #-}
module Toml.Bi.Code
(
TomlCodec
, Env
, St
, DecodeException (..)
, LoadTomlException (..)
, prettyException
, decode
, decodeFile
, runTomlCodec
, encode
, execTomlCodec
) where
import Control.DeepSeq (NFData)
import Control.Exception (Exception, throwIO)
import Control.Monad.Except (ExceptT, runExceptT)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Reader (Reader, runReader)
import Control.Monad.State (State, execState)
import Control.Monad.Trans.Maybe (MaybeT (..))
import Data.Bifunctor (first)
import Data.Foldable (toList)
import Data.Semigroup (Semigroup (..))
import Data.Text (Text)
import GHC.Generics (Generic)
import Toml.Bi.Map (TomlBiMapError, prettyBiMapError)
import Toml.Bi.Monad (BiCodec, Codec (..))
import Toml.Parser (ParseException (..), parse)
import Toml.PrefixTree (Key (..), unPiece)
import Toml.Printer (pretty)
import Toml.Type (TOML (..), TValue, showType)
import qualified Data.Text as Text
import qualified Data.Text.IO as TIO
data DecodeException
= TrivialError
| BiMapError !TomlBiMapError
| KeyNotFound !Key
| TableNotFound !Key
| TypeMismatch !Key !Text !TValue
| ParseError !ParseException
deriving stock (DecodeException -> DecodeException -> Bool
(DecodeException -> DecodeException -> Bool)
-> (DecodeException -> DecodeException -> Bool)
-> Eq DecodeException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DecodeException -> DecodeException -> Bool
$c/= :: DecodeException -> DecodeException -> Bool
== :: DecodeException -> DecodeException -> Bool
$c== :: DecodeException -> DecodeException -> Bool
Eq, (forall x. DecodeException -> Rep DecodeException x)
-> (forall x. Rep DecodeException x -> DecodeException)
-> Generic DecodeException
forall x. Rep DecodeException x -> DecodeException
forall x. DecodeException -> Rep DecodeException x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DecodeException x -> DecodeException
$cfrom :: forall x. DecodeException -> Rep DecodeException x
Generic)
deriving anyclass (DecodeException -> ()
(DecodeException -> ()) -> NFData DecodeException
forall a. (a -> ()) -> NFData a
rnf :: DecodeException -> ()
$crnf :: DecodeException -> ()
NFData)
instance Show DecodeException where
show :: DecodeException -> String
show = Text -> String
Text.unpack (Text -> String)
-> (DecodeException -> Text) -> DecodeException -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecodeException -> Text
prettyException
instance Semigroup DecodeException where
TrivialError <> :: DecodeException -> DecodeException -> DecodeException
<> e :: DecodeException
e = DecodeException
e
e :: DecodeException
e <> _ = DecodeException
e
instance Monoid DecodeException where
mempty :: DecodeException
mempty = DecodeException
TrivialError
mappend :: DecodeException -> DecodeException -> DecodeException
mappend = DecodeException -> DecodeException -> DecodeException
forall a. Semigroup a => a -> a -> a
(<>)
prettyException :: DecodeException -> Text
prettyException :: DecodeException -> Text
prettyException de :: DecodeException
de = "tomland decode error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> case DecodeException
de of
TrivialError -> "'empty' parser from 'Alternative' is used"
BiMapError biError :: TomlBiMapError
biError -> TomlBiMapError -> Text
prettyBiMapError TomlBiMapError
biError
KeyNotFound name :: Key
name -> "Key " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Key -> Text
joinKey Key
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " is not found"
TableNotFound name :: Key
name -> "Table [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Key -> Text
joinKey Key
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "] is not found"
TypeMismatch name :: Key
name expected :: Text
expected actual :: TValue
actual -> "Type for key " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Key -> Text
joinKey Key
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " doesn't match."
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n Expected: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
expected
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n Actual: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (TValue -> String
showType TValue
actual)
ParseError (ParseException msg :: Text
msg) -> "Parse error during conversion from TOML to custom user type: \n " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
where
joinKey :: Key -> Text
joinKey :: Key -> Text
joinKey = Text -> [Text] -> Text
Text.intercalate "." ([Text] -> Text) -> (Key -> [Text]) -> Key -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Piece -> Text) -> [Piece] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Piece -> Text
unPiece ([Piece] -> [Text]) -> (Key -> [Piece]) -> Key -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Piece -> [Piece]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty Piece -> [Piece])
-> (Key -> NonEmpty Piece) -> Key -> [Piece]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> NonEmpty Piece
unKey
type Env = ExceptT DecodeException (Reader TOML)
type St = MaybeT (State TOML)
type TomlCodec a = BiCodec Env St a
decode :: TomlCodec a -> Text -> Either DecodeException a
decode :: TomlCodec a -> Text -> Either DecodeException a
decode codec :: TomlCodec a
codec text :: Text
text = do
TOML
toml <- (ParseException -> DecodeException)
-> Either ParseException TOML -> Either DecodeException TOML
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseException -> DecodeException
ParseError (Text -> Either ParseException TOML
parse Text
text)
TomlCodec a -> TOML -> Either DecodeException a
forall a. TomlCodec a -> TOML -> Either DecodeException a
runTomlCodec TomlCodec a
codec TOML
toml
runTomlCodec :: TomlCodec a -> TOML -> Either DecodeException a
runTomlCodec :: TomlCodec a -> TOML -> Either DecodeException a
runTomlCodec codec :: TomlCodec a
codec = Reader TOML (Either DecodeException a)
-> TOML -> Either DecodeException a
forall r a. Reader r a -> r -> a
runReader (ExceptT DecodeException (Reader TOML) a
-> Reader TOML (Either DecodeException a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT DecodeException (Reader TOML) a
-> Reader TOML (Either DecodeException a))
-> ExceptT DecodeException (Reader TOML) a
-> Reader TOML (Either DecodeException a)
forall a b. (a -> b) -> a -> b
$ TomlCodec a -> ExceptT DecodeException (Reader TOML) a
forall (r :: * -> *) (w :: * -> *) c a. Codec r w c a -> r a
codecRead TomlCodec a
codec)
encode :: TomlCodec a -> a -> Text
encode :: TomlCodec a -> a -> Text
encode codec :: TomlCodec a
codec obj :: a
obj = TOML -> Text
pretty (TOML -> Text) -> TOML -> Text
forall a b. (a -> b) -> a -> b
$ TomlCodec a -> a -> TOML
forall a. TomlCodec a -> a -> TOML
execTomlCodec TomlCodec a
codec a
obj
execTomlCodec :: TomlCodec a -> a -> TOML
execTomlCodec :: TomlCodec a -> a -> TOML
execTomlCodec codec :: TomlCodec a
codec obj :: a
obj = State TOML (Maybe a) -> TOML -> TOML
forall s a. State s a -> s -> s
execState (MaybeT (State TOML) a -> State TOML (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (State TOML) a -> State TOML (Maybe a))
-> MaybeT (State TOML) a -> State TOML (Maybe a)
forall a b. (a -> b) -> a -> b
$ TomlCodec a -> a -> MaybeT (State TOML) a
forall (r :: * -> *) (w :: * -> *) c a. Codec r w c a -> c -> w a
codecWrite TomlCodec a
codec a
obj) TOML
forall a. Monoid a => a
mempty
data LoadTomlException = LoadTomlException !FilePath !Text
instance Show LoadTomlException where
show :: LoadTomlException -> String
show (LoadTomlException filePath :: String
filePath msg :: Text
msg) = "Couldnt parse file " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
filePath String -> ShowS
forall a. [a] -> [a] -> [a]
++ ": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
msg
instance Exception LoadTomlException
decodeFile :: (MonadIO m) => TomlCodec a -> FilePath -> m a
decodeFile :: TomlCodec a -> String -> m a
decodeFile codec :: TomlCodec a
codec filePath :: String
filePath = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$
(TomlCodec a -> Text -> Either DecodeException a
forall a. TomlCodec a -> Text -> Either DecodeException a
decode TomlCodec a
codec (Text -> Either DecodeException a)
-> IO Text -> IO (Either DecodeException a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
TIO.readFile String
filePath) IO (Either DecodeException a)
-> (Either DecodeException a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either DecodeException a -> IO a
forall a. Either DecodeException a -> IO a
errorWhenLeft
where
errorWhenLeft :: Either DecodeException a -> IO a
errorWhenLeft :: Either DecodeException a -> IO a
errorWhenLeft (Left e :: DecodeException
e) = LoadTomlException -> IO a
forall e a. Exception e => e -> IO a
throwIO (LoadTomlException -> IO a) -> LoadTomlException -> IO a
forall a b. (a -> b) -> a -> b
$ String -> Text -> LoadTomlException
LoadTomlException String
filePath (Text -> LoadTomlException) -> Text -> LoadTomlException
forall a b. (a -> b) -> a -> b
$ DecodeException -> Text
prettyException DecodeException
e
errorWhenLeft (Right pc :: a
pc) = a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
pc