module Data.Yaml.Pretty.Extras
( module Data.Yaml
, module Data.Yaml.Pretty
, ToPrettyYaml(..)
, encodeFilePretty
, decodeFileThrow
, displayPrettyYaml
, decodeFileThrowLogged
, encodeFilePrettyLogged
)
where
import Data.Typeable
import Data.Yaml
import Data.Yaml.Pretty
import RIO
import qualified RIO.ByteString as BS
import RIO.List
listElemCmp as x y =
fromMaybe LT $ liftA2 compare (elemIndex x as) (elemIndex y as)
class ToJSON a => ToPrettyYaml a where
fieldOrder :: a -> [Text]
dropNull :: a -> Bool
dropNull = const True
toPrettyYaml :: a -> BS.ByteString
toPrettyYaml = encodePretty =<< liftM2 setConfDropNull dropNull (flip setConfCompare defConfig . listElemCmp . fieldOrder)
encodeFilePretty :: (MonadIO m) => ToPrettyYaml a => FilePath -> a -> m ()
encodeFilePretty f x = BS.writeFile f (toPrettyYaml x)
displayPrettyYaml :: ToPrettyYaml a => a -> Utf8Builder
displayPrettyYaml = displayBytesUtf8 . toPrettyYaml
decodeFileThrow :: (MonadIO m, FromJSON c, MonadThrow m) => FilePath -> m c
decodeFileThrow = liftIO . decodeFileEither >=> either throwM return
decodeFileThrowLogged
:: ( MonadReader env m
, MonadThrow m
, MonadIO m
, HasLogFunc env
, FromJSON b
, ToPrettyYaml b
, Typeable b
)
=> FilePath
-> m b
decodeFileThrowLogged x = do
logInfo $ "Loading " <> displayShow x
(t :: b) <- decodeFileThrow x
logInfo $ mconcat
[ "Loaded "
, displayShow x
, " as "
, displayShow (typeOf t)
, " with contents\n"
, displayPrettyYaml t
]
return t
encodeFilePrettyLogged
:: ( MonadReader env m
, MonadThrow m
, MonadIO m
, HasLogFunc env
, ToPrettyYaml b
, Typeable b
)
=> FilePath
-> b
-> m ()
encodeFilePrettyLogged x d = do
logInfo $ mconcat
[ "Saving "
, displayShow (typeOf d)
, " with contents:\n"
, displayPrettyYaml d
, " to "
, displayShow x
]
encodeFilePretty x d
logInfo $ "Saved " <> displayShow x