Extras.hs

module Data.Yaml.Pretty.Extras
  ( module Data.Yaml
  , module Data.Yaml.Pretty
  , ToPrettyYaml(..)
  , encodeFilePretty
  , displayPrettyYaml
  , PrettyYamlException(..)
  , decodeFileThrow
  , decodeFileThrowLogged
  , encodeFilePrettyLogged
  )
where

import           Control.Error.Safe
import           Control.Monad.Except
import           Data.Typeable
import           Data.Yaml
import           Data.Yaml.Pretty
import           RIO                     hiding ( tryJust )
import qualified RIO.ByteString                as BS
import           RIO.List

data PrettyYamlException = FieldNotListed Text [Text]
  deriving (Typeable)

instance Show PrettyYamlException where
  show (FieldNotListed x as) = "Could not find field " ++ show x ++ "in " ++ show as

exceptElemIndex x as = tryJust (FieldNotListed x as) (elemIndex x as)

listElemCmp as x y = either (error . show) id $ runExcept $ liftA2
  compare
  (exceptElemIndex x as)
  (exceptElemIndex 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