Extras.hs

-----------------------------------------------------------------------------
-- |
-- Module     : Data.Yaml.Pretty.Extras
-- Copyright  : (c) Daniel Firth 2018
-- License    : BSD3
-- Maintainer : locallycompact@gmail.com
-- Stability  : experimental
--
-- This file defines yaml pretty printers with additional MonadThrow helpers
-- and RIO display functionality.
--
-----------------------------------------------------------------------------
module Data.Yaml.Pretty.Extras
  ( module Data.Yaml
  , module Data.Yaml.Pretty

  -- * Yaml Pretty Printers
  , ToPrettyYaml(..)
  , encodeFilePretty

  -- * RIO Helpers (Codecs and Logging)
  , 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)

{- | Augments ToJSON by allowing specification of a fieldOrder for printing.

   >  data Person = { name :: Text, age :: Int, job :: Text }
   >    deriving (Eq, FromJSON, Generic, Show, ToJSON)
   >
   >  instance ToPrettyYaml Person where
   >   fieldOrder = const ["name", "age", "job"]

-}

class ToJSON a => ToPrettyYaml a where
  -- | The order that detected fields should be printed in, fields that aren't found in this function
  -- will be printed non-deterministically.
  fieldOrder :: a -> [Text]

  -- | Whether to drop null elements on this type.
  dropNull :: a -> Bool
  dropNull = const True

  -- | Prints a Yaml ByteString according to specified fieldOrder.
  toPrettyYaml :: a -> BS.ByteString
  toPrettyYaml = encodePretty =<< liftM2 setConfDropNull dropNull (flip setConfCompare defConfig . listElemCmp . fieldOrder)

-- | A version of Data.Yaml's encodeFile using `toPrettyYaml` instead of `toJSON`
encodeFilePretty :: (MonadIO m) => ToPrettyYaml a => FilePath -> a -> m ()
encodeFilePretty f x = BS.writeFile f (toPrettyYaml x)

-- | Displays a ToPrettyYaml instance as Utf8, for use with RIO log functions
displayPrettyYaml :: ToPrettyYaml a => a -> Utf8Builder
displayPrettyYaml = displayBytesUtf8 . toPrettyYaml

-- | A version of Data.Yaml's decodeFileEither lifted to MonadThrow
decodeFileThrow :: (MonadIO m, FromJSON c, MonadThrow m) => FilePath -> m c
decodeFileThrow = liftIO . decodeFileEither >=> either throwM return

-- | decodeFileThrow with info logging, reports what was parsed via RIO's logInfo
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

-- | encodeFilePretty with info logging, reports what was saved to disk via RIO's logInfo
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