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)
  , displayPrettyYaml
  , decodeFileThrowLogged
  , encodeFilePrettyLogged

  -- Transformers and Lenses

  , transformFile
  , inplace
  , sanitizeFile
  , overFile
  , traverseOfFile

  )
where

import           Data.Typeable
import           Data.Yaml
import           Data.Yaml.Pretty
import           Lens.Micro.Platform
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

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

-- | Run a function over a decoded file f and save the result to g, passthrough the new value.

transformFile
  :: (MonadIO m, FromJSON a1, ToPrettyYaml a2) =>
      FilePath -> FilePath -> (a1 -> a2) -> m a2
transformFile f g l = do
  (x :: a1) <- decodeFileThrow f
  encodeFilePretty g (l x)
  return (l x)

-- | Performs a file operation in place

inplace :: (FilePath -> FilePath -> a) -> FilePath -> a
inplace = join

-- | Perform a roundtrip decode/encode on a file to rearrange field order. Doesn't change the type.

sanitizeFile
  :: (MonadIO m, FromJSON a, ToPrettyYaml a) =>
     FilePath -> m a
sanitizeFile = flip (inplace transformFile) id

-- | Uses a lens over to modify a file, passthrough the new value.

overFile
  :: (MonadIO m, FromJSON a1, ToPrettyYaml a2) =>
     FilePath -> FilePath -> ASetter a1 a2 a b -> (a -> b) -> m a2
overFile f g l a = transformFile f g (over l a)

-- | Use a lens traverseOf to modify a file, passthrough the new value.

traverseOfFile
  :: (MonadIO m, FromJSON a1, ToPrettyYaml a2) =>
     FilePath -> FilePath -> LensLike m a1 a2 b1 b2 -> (b1 -> m b2) -> m a2
traverseOfFile f g l a = do
  (x :: a1) <- decodeFileThrow f
  y <- traverseOf l a x
  encodeFilePretty g y
  return y