Extras.hs

{-# LANGUAGE OverloadedStrings #-}

module Data.Yaml.Pretty.Extras (

  module Data.Yaml,
  module Data.Yaml.Pretty,

  ToPrettyYaml(..),
  encodeFilePretty,
  PrettyYamlException(..)

) where

import Control.Applicative
import Control.Error.Safe
import Control.Monad.Except
import qualified Data.ByteString as BS
import Data.List
import Data.Typeable
import Data.Text
import Data.Yaml
import Data.Yaml.Pretty

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 :: ToPrettyYaml a => FilePath -> a -> IO ()
encodeFilePretty f x = BS.writeFile f (toPrettyYaml x)