yaml-pretty-extras 0.0.1.2 → 0.0.1.3
raw patch · 4 files changed
+94/−40 lines, 4 files
Files
- ChangeLog.md +5/−0
- src/Data/Yaml/Pretty/Extras.hs +76/−24
- test/Spec.hs +9/−14
- yaml-pretty-extras.cabal +4/−2
ChangeLog.md view
@@ -1,5 +1,10 @@ # Changelog for yaml-pretty-extras +## v0.0.1.3++Add decodeFileThrow, decodeFileThrowLogged and encodeFilePrettyLogged functions+for use with RIO+ ## v0.0.1.2 Base on RIO
src/Data/Yaml/Pretty/Extras.hs view
@@ -1,35 +1,37 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.Yaml.Pretty.Extras (-- module Data.Yaml,- module Data.Yaml.Pretty,-- ToPrettyYaml(..),- encodeFilePretty,- displayPrettyYaml,- PrettyYamlException(..)--) where+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.Yaml-import Data.Yaml.Pretty-import RIO hiding (tryJust)-import qualified RIO.ByteString as BS-import RIO.List+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)+ 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)+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]@@ -40,8 +42,58 @@ toPrettyYaml :: a -> BS.ByteString toPrettyYaml = encodePretty =<< liftM2 setConfDropNull dropNull (flip setConfCompare defConfig . listElemCmp . fieldOrder) -encodeFilePretty :: ToPrettyYaml a => FilePath -> a -> IO ()+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
test/Spec.hs view
@@ -1,14 +1,11 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveAnyClass #-}+import Data.Yaml.Pretty.Extras+import GHC.Generics+import RIO+import qualified RIO.ByteString as BS+import Test.Hspec -import Data.Text-import Data.Yaml.Pretty.Extras-import GHC.Generics-import Test.Hspec -import qualified Data.ByteString as BS- data Person = Person { mood :: Text, job :: Text@@ -24,8 +21,6 @@ fieldOrder = const ["name", "kind", "people", "mood", "job"] main :: IO ()-main = hspec $ do- describe "Data.Yaml.Pretty.Extras" $ do- it "prints correctly" $ do- Just x <- either (error . show) id <$> decodeFileEither "test/mock.yaml" :: IO (Maybe Conf)- BS.readFile "test/mock.yaml" `shouldReturn` (toPrettyYaml x)+main = hspec $ describe "Data.Yaml.Pretty.Extras" $ it "prints correctly" $ do+ Just x <- decodeFileThrow "test/mock.yaml" :: IO (Maybe Conf)+ BS.readFile "test/mock.yaml" `shouldReturn` toPrettyYaml x
yaml-pretty-extras.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: cb8076c3936b0152125b8f51768620c7909fb2fa0dd869e45a6e842abc03e4a3+-- hash: 02fcaf6c7200aae215dad66d520b577e59eee386c8f339577cae1535d75f6775 name: yaml-pretty-extras-version: 0.0.1.2+version: 0.0.1.3 synopsis: Extra functionality for pretty printing Yaml documents. description: Extra functionality for pretty printing Yaml documents. Allows precise field ordering. category: Data@@ -31,6 +31,7 @@ Paths_yaml_pretty_extras hs-source-dirs: src+ default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeSynonymInstances ViewPatterns build-depends: base >=4.7 && <5 , bytestring@@ -48,6 +49,7 @@ Paths_yaml_pretty_extras hs-source-dirs: test+ default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeSynonymInstances ViewPatterns ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5