Merge pull request #66 from phadej/pretty

Pretty, resolve #65

.gitignore

@@ -3,3 +3,4 @@ dist
 cabal-dev/
 .cabal-sandbox/
 cabal.sandbox.config
+.stack-work/

Data/Yaml.hs

@@ -144,22 +144,6 @@ pairToEvents (k, v) rest =
     EventScalar (encodeUtf8 k) StrTag PlainNoTag Nothing
   : objToEvents' v rest
 
--- | Strings which must be escaped so as not to be treated as non-string scalars.
-specialStrings :: HashSet.HashSet Text
-specialStrings = HashSet.fromList $ T.words
-    "y Y yes Yes YES n N no No NO true True TRUE false False FALSE on On ON off Off OFF null Null NULL ~"
-
-isNumeric :: Text -> Bool
-isNumeric =
-    T.all isNumeric'
-  where
-    isNumeric' c = ('0' <= c && c <= '9')
-                || c == 'e'
-                || c == 'E'
-                || c == '.'
-                || c == '-'
-                || c == '+'
-
 decode :: FromJSON a
        => ByteString
        -> Maybe a

Data/Yaml/Builder.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
 -- | NOTE: This module is a highly experimental preview release. It may change
 -- drastically, or be entirely removed, in a future release.
 module Data.Yaml.Builder
@@ -7,6 +9,10 @@ module Data.Yaml.Builder
     , mapping
     , array
     , string
+    , bool
+    , null
+    , scientific
+    , number
     , toByteString
     , writeYamlFile
     , (.=)
@@ -15,12 +21,26 @@ module Data.Yaml.Builder
 import Data.Conduit
 import Data.ByteString (ByteString)
 import Text.Libyaml
+import Data.Yaml.Internal
 import Data.Text (Text)
+import Data.Scientific (Scientific)
+import Data.Aeson.Types (Value(..))
+import qualified Data.HashSet as HashSet
+import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import System.IO.Unsafe (unsafePerformIO)
 import Control.Arrow (second)
 import qualified Data.ByteString.Char8 as S8
 import Control.Monad.Trans.Resource (runResourceT)
+#if MIN_VERSION_aeson(0, 7, 0)
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.Lazy as TL
+import Data.Text.Lazy.Builder (toLazyText)
+import Data.Aeson.Encode (encodeToTextBuilder)
+#else
+import qualified Data.ByteString.Char8 as S8
+#endif
+import Prelude hiding (null)
 
 (.=) :: ToYaml a => Text -> a -> (Text, YamlBuilder)
 k .= v = (k, toYaml v)
@@ -55,7 +75,37 @@ array bs =
     go (YamlBuilder b) rest = b rest
 
 string :: Text -> YamlBuilder
-string t = YamlBuilder (EventScalar (encodeUtf8 t) StrTag PlainNoTag Nothing:)
+-- Empty strings need special handling to ensure they get quoted. This avoids:
+-- https://github.com/snoyberg/yaml/issues/24
+string ""  = YamlBuilder (EventScalar "" NoTag SingleQuoted Nothing :)
+string s   =
+    YamlBuilder (event :)
+  where
+    event
+        -- Make sure that special strings are encoded as strings properly.
+        -- See: https://github.com/snoyberg/yaml/issues/31
+        | s `HashSet.member` specialStrings || isNumeric s = EventScalar (encodeUtf8 s) NoTag SingleQuoted Nothing
+        | otherwise = EventScalar (encodeUtf8 s) StrTag PlainNoTag Nothing
+
+-- Use aeson's implementation which gets rid of annoying decimal points
+scientific :: Scientific -> YamlBuilder
+scientific n = YamlBuilder (EventScalar (TE.encodeUtf8 $ TL.toStrict $ toLazyText $ encodeToTextBuilder (Number n)) IntTag PlainNoTag Nothing :)
+
+{-# DEPRECATED number "Use scientific" #-}
+#if MIN_VERSION_aeson(0,7,0)
+number :: Scientific -> YamlBuilder
+number = scientific
+#else
+number :: Number -> YamlBuilder
+number n rest = YamlBuilder (EventScalar (S8.pack $ show n) IntTag PlainNoTag Nothing :)
+#endif
+
+bool :: Bool -> YamlBuilder
+bool True   = YamlBuilder (EventScalar "true" BoolTag PlainNoTag Nothing :)
+bool False  = YamlBuilder (EventScalar "false" BoolTag PlainNoTag Nothing :)
+
+null :: YamlBuilder
+null = YamlBuilder (EventScalar "null" NullTag PlainNoTag Nothing :)
 
 toEvents :: YamlBuilder -> [Event]
 toEvents (YamlBuilder front) =

Data/Yaml/Internal.hs

@@ -9,6 +9,8 @@ module Data.Yaml.Internal
     , parse
     , decodeHelper
     , decodeHelper_
+    , specialStrings
+    , isNumeric
     ) where
 
 import qualified Text.Libyaml as Y
@@ -41,6 +43,7 @@ import Data.Scientific (fromFloatDigits)
 import Data.Attoparsec.Number
 #endif
 import Control.Monad.Trans.Resource (ResourceT, runResourceT)
+import qualified Data.HashSet as HashSet
 
 data ParseException = NonScalarKey
                     | UnknownAlias { _anchorName :: Y.AnchorName }
@@ -257,3 +260,19 @@ decodeHelper_ src = do
             (Left . AesonException)
             Right
             (parseEither parseJSON y)
+
+-- | Strings which must be escaped so as not to be treated as non-string scalars.
+specialStrings :: HashSet.HashSet Text
+specialStrings = HashSet.fromList $ T.words
+    "y Y yes Yes YES n N no No NO true True TRUE false False FALSE on On ON off Off OFF null Null NULL ~"
+
+isNumeric :: Text -> Bool
+isNumeric =
+    T.all isNumeric'
+  where
+    isNumeric' c = ('0' <= c && c <= '9')
+                || c == 'e'
+                || c == 'E'
+                || c == '.'
+                || c == '-'
+                || c == '+'

Data/Yaml/Pretty.hs

@@ -0,0 +1,46 @@
+-- | Prettier YAML encoding.
+module Data.Yaml.Pretty
+    ( encodePretty
+    , Config
+    , getConfCompare
+    , setConfCompare
+    , defConfig
+    ) where
+
+import Data.Yaml.Builder
+import Data.Aeson.Types
+import Data.Text (Text)
+import Data.Monoid
+import qualified Data.Vector as V
+import qualified Data.HashMap.Strict as HM
+import Data.Function (on)
+import Data.List (sortBy)
+import Data.ByteString (ByteString)
+import Prelude hiding (null)
+
+data Config = Config
+  { confCompare :: Text -> Text -> Ordering -- ^ Function used to sort keys in objects
+  }
+
+-- | The default configuration: do not sort objects.
+defConfig :: Config
+defConfig = Config mempty
+
+getConfCompare :: Config -> Text -> Text -> Ordering
+getConfCompare = confCompare
+
+setConfCompare :: (Text -> Text -> Ordering) -> Config -> Config
+setConfCompare cmp c = c { confCompare = cmp }
+
+pretty :: Config -> Value -> YamlBuilder
+pretty cfg = go
+  where go (Object o) = mapping (sortBy (confCompare cfg `on` fst) $ HM.toList $ HM.map go o)
+        go (Array a)  = array (fmap go $ V.toList a)
+        go Null       = null
+        go (String s) = string s
+        go (Number n) = number n
+        go (Bool b)   = bool b
+
+-- | Configurable 'encode'.
+encodePretty :: ToJSON a => Config -> a -> ByteString
+encodePretty cfg = toByteString . pretty cfg . toJSON

stack.yaml

@@ -0,0 +1,9 @@
+flags:
+  yaml:
+    no-exe: false
+    system-libyaml: false
+    no-unicode: false
+packages:
+- '.'
+extra-deps: []
+resolver: lts-2.22

test/Data/YamlSpec.hs

@@ -22,6 +22,7 @@ import Data.Either.Compat
 import Test.Mockery.Directory
 
 import qualified Data.Yaml as D
+import qualified Data.Yaml.Pretty as Pretty
 import Data.Yaml (object, array, (.=))
 import Data.Maybe
 import qualified Data.HashMap.Strict as M
@@ -65,6 +66,10 @@ spec = do
         it "encode/decode strings" caseEncodeDecodeStrings
         it "decode invalid file" caseDecodeInvalid
         it "processes datatypes" caseDataTypes
+    describe "Data.Yaml.Pretty" $ do
+        it "encode/decode" caseEncodeDecodeDataPretty
+        it "encode/decode strings" caseEncodeDecodeStringsPretty
+        it "processes datatypes" caseDataTypesPretty
     describe "Data.Yaml aliases" $ do
         it "simple scalar alias" caseSimpleScalarAlias
         it "simple sequence alias" caseSimpleSequenceAlias
@@ -299,6 +304,11 @@ caseEncodeDecodeData = do
     let out = D.decode $ D.encode sample
     out @?= Just sample
 
+caseEncodeDecodeDataPretty :: Assertion
+caseEncodeDecodeDataPretty = do
+    let out = D.decode $ Pretty.encodePretty Pretty.defConfig sample
+    out @?= Just sample
+
 caseEncodeDecodeFileData :: Assertion
 caseEncodeDecodeFileData = withFile "" $ \fp -> do
     D.encodeFile fp sample
@@ -310,6 +320,11 @@ caseEncodeDecodeStrings = do
     let out = D.decode $ D.encode sample
     out @?= Just sample
 
+caseEncodeDecodeStringsPretty :: Assertion
+caseEncodeDecodeStringsPretty = do
+    let out = D.decode $ Pretty.encodePretty Pretty.defConfig sample
+    out @?= Just sample
+
 caseDecodeInvalid :: Assertion
 caseDecodeInvalid = do
     let invalid = B8.pack "\tthis is 'not' valid :-)"
@@ -391,6 +406,18 @@ caseDataTypes =
         , ("null", D.Null)
         ]
 
+caseDataTypesPretty :: Assertion
+caseDataTypesPretty =
+    D.decode (Pretty.encodePretty Pretty.defConfig val) @?= Just val
+  where
+    val = object
+        [ ("string", D.String "foo")
+        , ("int", D.Number 5)
+        , ("float", D.Number 4.3)
+        , ("true", D.Bool True)
+        , ("false", D.Bool False)
+        , ("null", D.Null)
+        ]
 caseQuotedNumber, caseUnquotedNumber, caseAttribNumber, caseIntegerDecimals :: Assertion
 caseQuotedNumber = D.decode "foo: \"1234\"" @?= Just (object [("foo", D.String "1234")])
 caseUnquotedNumber = D.decode "foo: 1234" @?= Just (object [("foo", D.Number 1234)])

yaml.cabal

@@ -57,6 +57,7 @@ library
                      Data.Yaml
                      Data.Yaml.Aeson
                      Data.Yaml.Builder
+                     Data.Yaml.Pretty
                      Data.Yaml.Parser
                      Data.Yaml.Include
     other-modules: