{-# LANGUAGE DeriveAnyClass #-}

{- | Coding functions like 'decode' and 'encode'. Also contains specialization of 'Codec' for TOML.
-}

module Toml.Bi.Code
       ( -- * Types
         TomlCodec
       , Env
       , St

         -- * Exceptions
       , DecodeException (..)
       , LoadTomlException (..)
       , prettyException

         -- * Encode/Decode
       , 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


-- | Type of exception for converting from TOML to user custom data type.
data DecodeException
    = TrivialError
    | BiMapError !TomlBiMapError
    | KeyNotFound !Key  -- ^ No such key
    | TableNotFound !Key  -- ^ No such table
    | TypeMismatch !Key !Text !TValue  -- ^ Expected type vs actual type
    | ParseError !ParseException  -- ^ Exception during parsing
    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
(<>)

-- | Converts 'DecodeException' into pretty human-readable text.
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

-- | Immutable environment for TOML conversion.
-- This is @r@ type variable in 'Codec' data type.
type Env = ExceptT DecodeException (Reader TOML)

{- | Mutable context for TOML conversion.
This is @w@ type variable in 'Codec' data type.

@
MaybeT (State TOML) a
    = State TOML (Maybe a)
    = TOML -> (Maybe a, TOML)
@
-}
type St = MaybeT (State TOML)

{- | Specialied 'BiCodec' type alias for bidirectional TOML serialization. Keeps
'TOML' object as both environment and state.
-}
type TomlCodec a = BiCodec Env St a

-- | Convert textual representation of toml into user data type.
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

-- | Convert toml into user data type.
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)

-- | Convert object to textual representation.
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

-- | Runs 'codecWrite' of 'TomlCodec' and returns intermediate TOML AST.
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

-- | File loading error data type.
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

-- | Decode a value from a file. In case of parse errors, throws '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