[POC] Add 'quoted' option (#941)

Allow to generare quoted scalars if needed via providing a custom encode
options to Data.Yaml.encodeWith. So far two corner cases from yaml
itself (an empty scalar, and special strings) are omitted in the
implementation.

appveyor.yml

@@ -12,7 +12,7 @@ environment:
   # Override the temp directory to avoid sed escaping issues
   # See https://github.com/haskell/cabal/issues/5386
   TMP: c:\tmp
-  
+
   matrix:
     # Commenting out for now default stack (lts-13) cause
     # compilations times are reaching appveyor default build timeout
@@ -35,21 +35,44 @@ cache:
   - dhall-bash\.stack-work -> '%STACK_YAML%'
   - dhall-lsp-server\.stack-work -> '%STACK_YAML%'
 
-build_script:
-  - stack build
-  - stack install --local-bin-path bin
-  - if /I "%APPVEYOR_REPO_TAG%" EQU "true" (set DEPLOY_TAG=%APPVEYOR_REPO_TAG_NAME%) else (set DEPLOY_TAG=%APPVEYOR_REPO_COMMIT:~0,5%)
-  - set DEPLOY_SUFFIX=%DEPLOY_TAG%-x86_64-windows.zip
-  - 7z a "bin\dhall-%DEPLOY_SUFFIX%" "%APPVEYOR_BUILD_FOLDER%\bin\dhall.exe"
-  - 7z a "bin\dhall-json-%DEPLOY_SUFFIX%" "%APPVEYOR_BUILD_FOLDER%\bin\dhall-to-json.exe"
-  - 7z a "bin\dhall-json-%DEPLOY_SUFFIX%" "%APPVEYOR_BUILD_FOLDER%\bin\dhall-to-yaml.exe"
-  - 7z a "bin\dhall-json-%DEPLOY_SUFFIX%" "%APPVEYOR_BUILD_FOLDER%\bin\json-to-dhall.exe"
-  - 7z a "bin\dhall-text-%DEPLOY_SUFFIX%" "%APPVEYOR_BUILD_FOLDER%\bin\dhall-to-text.exe"
-  - 7z a "bin\dhall-bash-%DEPLOY_SUFFIX%" "%APPVEYOR_BUILD_FOLDER%\bin\dhall-to-bash.exe"
-  # dhall-lsp-server can't be built with lts-6
-  - if exist "%APPVEYOR_BUILD_FOLDER%\bin\dhall-lsp-server.exe" ( 7z a "bin\dhall-lsp-server-%DEPLOY_SUFFIX%" "%APPVEYOR_BUILD_FOLDER%\bin\dhall-lsp-server.exe" )
-  
 for:
+-
+  matrix:
+    except:
+      # dhall-json is not supported for LTS 6
+      - STACK_YAML: stack-lts-6.yaml
+
+  build_script:
+    - stack build
+    - stack install --local-bin-path bin
+    - if /I "%APPVEYOR_REPO_TAG%" EQU "true" (set DEPLOY_TAG=%APPVEYOR_REPO_TAG_NAME%) else (set DEPLOY_TAG=%APPVEYOR_REPO_COMMIT:~0,5%)
+    - set DEPLOY_SUFFIX=%DEPLOY_TAG%-x86_64-windows.zip
+    - 7z a "bin\dhall-%DEPLOY_SUFFIX%" "%APPVEYOR_BUILD_FOLDER%\bin\dhall.exe"
+    - 7z a "bin\dhall-json-%DEPLOY_SUFFIX%" "%APPVEYOR_BUILD_FOLDER%\bin\dhall-to-json.exe"
+    - 7z a "bin\dhall-json-%DEPLOY_SUFFIX%" "%APPVEYOR_BUILD_FOLDER%\bin\dhall-to-yaml.exe"
+    - 7z a "bin\dhall-json-%DEPLOY_SUFFIX%" "%APPVEYOR_BUILD_FOLDER%\bin\json-to-dhall.exe"
+    - 7z a "bin\dhall-text-%DEPLOY_SUFFIX%" "%APPVEYOR_BUILD_FOLDER%\bin\dhall-to-text.exe"
+    - 7z a "bin\dhall-bash-%DEPLOY_SUFFIX%" "%APPVEYOR_BUILD_FOLDER%\bin\dhall-to-bash.exe"
+    # dhall-lsp-server can't be built with lts-6
+    - if exist "%APPVEYOR_BUILD_FOLDER%\bin\dhall-lsp-server.exe" ( 7z a "bin\dhall-lsp-server-%DEPLOY_SUFFIX%" "%APPVEYOR_BUILD_FOLDER%\bin\dhall-lsp-server.exe" )
+-
+  matrix:
+    only:
+      - STACK_YAML: stack-lts-6.yaml
+
+  build_script:
+    - stack build
+    - stack install --local-bin-path bin
+    - if /I "%APPVEYOR_REPO_TAG%" EQU "true" (set DEPLOY_TAG=%APPVEYOR_REPO_TAG_NAME%) else (set DEPLOY_TAG=%APPVEYOR_REPO_COMMIT:~0,5%)
+    - set DEPLOY_SUFFIX=%DEPLOY_TAG%-x86_64-windows.zip
+    # dhall-json is not supported for LTS 6, so do not try to copy the
+    # corresponding binaries
+    - 7z a "bin\dhall-%DEPLOY_SUFFIX%" "%APPVEYOR_BUILD_FOLDER%\bin\dhall.exe"
+    - 7z a "bin\dhall-text-%DEPLOY_SUFFIX%" "%APPVEYOR_BUILD_FOLDER%\bin\dhall-to-text.exe"
+    - 7z a "bin\dhall-bash-%DEPLOY_SUFFIX%" "%APPVEYOR_BUILD_FOLDER%\bin\dhall-to-bash.exe"
+    # dhall-lsp-server can't be built with lts-6
+    - if exist "%APPVEYOR_BUILD_FOLDER%\bin\dhall-lsp-server.exe" ( 7z a "bin\dhall-lsp-server-%DEPLOY_SUFFIX%" "%APPVEYOR_BUILD_FOLDER%\bin\dhall-lsp-server.exe" )
+
 -
   matrix:
     except:
@@ -74,7 +97,7 @@ artifacts:
     name: dhall-bash
   - path: bin\dhall-lsp-server-%DEPLOY_SUFFIX%
     name: dhall-lsp-server
-    
+
 deploy:
   - provider: GitHub
     auth_token:

dhall-json/dhall-json.cabal

@@ -35,10 +35,13 @@ Library
     Build-Depends:
         base                      >= 4.8.0.0  && < 5   ,
         aeson                     >= 1.0.0.0  && < 1.5 ,
+        bytestring                               < 0.11,
         dhall                     >= 1.22.0   && < 1.24,
         optparse-applicative      >= 0.14.0.0 && < 0.15,
         text                      >= 0.11.1.0 && < 1.3 ,
-        unordered-containers                     < 0.3
+        unordered-containers                     < 0.3 ,
+        vector                                         ,
+        yaml                      >= 0.5.0    && < 0.12
     Exposed-Modules: Dhall.JSON
     GHC-Options: -Wall
 
@@ -68,8 +71,6 @@ Executable dhall-to-yaml
         dhall                                  ,
         dhall-json                             ,
         optparse-applicative                   ,
-        yaml                 >= 0.5.0 && < 0.12,
-        vector                                 ,
         text
     GHC-Options: -Wall
 

dhall-json/dhall-to-yaml/Main.hs

@@ -12,8 +12,6 @@ import Options.Applicative (Parser, ParserInfo)
 import qualified Control.Exception
 import qualified Data.ByteString
 import qualified Data.Text.IO
-import qualified Data.Vector
-import qualified Data.Yaml
 import qualified Dhall
 import qualified Dhall.JSON
 import qualified GHC.IO.Encoding
@@ -25,6 +23,7 @@ data Options = Options
     { explain    :: Bool
     , omission   :: Value -> Value
     , documents  :: Bool
+    , quoted     :: Bool
     , conversion :: Conversion
     }
 
@@ -34,6 +33,7 @@ parseOptions =
     <$> parseExplain
     <*> Dhall.JSON.parseOmission
     <*> parseDocuments
+    <*> parseQuoted
     <*> Dhall.JSON.parseConversion
   where
     parseExplain =
@@ -48,6 +48,12 @@ parseOptions =
             <>  Options.Applicative.help "If given a Dhall list, output a document for every element"
             )
 
+    parseQuoted =
+        Options.Applicative.switch
+            (   Options.Applicative.long "quoted"
+            <>  Options.Applicative.help "Prevent from generating not quoted scalars"
+            )
+
 parserInfo :: ParserInfo Options
 parserInfo =
     Options.Applicative.info
@@ -69,12 +75,7 @@ main = do
 
         json <- omission <$> explaining (Dhall.JSON.codeToValue conversion "(stdin)" stdin)
 
-        let yaml = case (documents, json) of
+        let yaml = Dhall.JSON.jsonToYaml json documents quoted
-              (True, Data.Yaml.Array elems)
-                -> Data.ByteString.intercalate "\n---\n"
-                   $ fmap Data.Yaml.encode
-                   $ Data.Vector.toList elems
-              _ -> Data.Yaml.encode json
 
         Data.ByteString.putStr yaml
 

dhall-json/src/Dhall/JSON.hs

@@ -166,6 +166,7 @@ module Dhall.JSON (
     , convertToHomogeneousMaps
     , parseConversion
     , codeToValue
+    , jsonToYaml
 
     -- * Exceptions
     , CompileError(..)
@@ -182,17 +183,21 @@ import Dhall.TypeCheck (X)
 import Dhall.Map (Map)
 import Options.Applicative (Parser)
 
+import qualified Data.ByteString
 import qualified Data.Foldable
 import qualified Data.HashMap.Strict
 import qualified Data.List
 import qualified Data.Ord
 import qualified Data.Text
+import qualified Data.Vector
+import qualified Data.Yaml
 import qualified Dhall.Core
 import qualified Dhall.Import
 import qualified Dhall.Map
 import qualified Dhall.Parser
 import qualified Dhall.TypeCheck
 import qualified Options.Applicative
+import qualified Text.Libyaml
 
 {-| This is the exception type for errors that might arise when translating
     Dhall to JSON
@@ -821,3 +826,34 @@ codeToValue conversion name code = do
     case dhallToJSON convertedExpression of
       Left  err  -> Control.Exception.throwIO err
       Right json -> return json
+
+-- | Transform json representation into yaml
+jsonToYaml
+    :: Value
+    -> Bool
+    -> Bool
+    -> Data.ByteString.ByteString
+jsonToYaml json documents quoted = case (documents, json) of
+  (True, Data.Yaml.Array elems)
+    -> Data.ByteString.intercalate "\n---\n"
+       $ fmap (encodeYaml encodeOptions)
+       $ Data.Vector.toList elems
+  _ -> encodeYaml encodeOptions json
+  where
+    encodeYaml = Data.Yaml.encodeWith
+
+    customStyle = \s -> case () of
+        ()
+            | "\n" `Data.Text.isInfixOf` s -> ( noTag, literal )
+            | otherwise -> ( noTag, Text.Libyaml.SingleQuoted )
+        where
+            noTag = Text.Libyaml.NoTag
+            literal = Text.Libyaml.Literal
+
+    quotedOptions = Data.Yaml.setStringStyle
+                        customStyle
+                        Data.Yaml.defaultEncodeOptions
+
+    encodeOptions = if quoted
+        then quotedOptions
+        else Data.Yaml.defaultEncodeOptions

dhall-json/tasty/Main.hs

@@ -23,6 +23,8 @@ testTree :: TestTree
 testTree =
     Test.Tasty.testGroup "dhall-json"
         [ issue48
+        , yamlQuotedStrings
+        , yaml
         ]
 
 issue48 :: TestTree
@@ -60,3 +62,59 @@ issue48 = Test.Tasty.HUnit.testCase "Issue #48" assertion
                 "Conversion to homogeneous maps did not generate the expected JSON output"
 
         Test.Tasty.HUnit.assertEqual message expectedValue actualValue
+
+yamlQuotedStrings :: TestTree
+yamlQuotedStrings = Test.Tasty.HUnit.testCase "Yaml: quoted string style" assertion
+  where
+    assertion = do
+        let file = "./tasty/data/yaml.dhall"
+
+        code <- Data.Text.IO.readFile file
+
+        parsedExpression <- case Dhall.Parser.exprFromText file code of
+            Left  exception        -> Control.Exception.throwIO exception
+            Right parsedExpression -> return parsedExpression
+
+        resolvedExpression <- Dhall.Import.load parsedExpression
+
+        jsonValue <- case Dhall.JSON.dhallToJSON resolvedExpression of
+            Left  exception   -> Control.Exception.throwIO exception
+            Right jsonValue -> return jsonValue
+
+        let actualValue = Dhall.JSON.jsonToYaml jsonValue False True
+
+        bytes <- Data.ByteString.Lazy.readFile "./tasty/data/quoted.yaml"
+        let expectedValue = Data.ByteString.Lazy.toStrict bytes
+
+        let message =
+                "Conversion to quoted yaml did not generate the expected output"
+
+        Test.Tasty.HUnit.assertEqual message expectedValue actualValue
+
+yaml :: TestTree
+yaml = Test.Tasty.HUnit.testCase "Yaml: normal string style" assertion
+  where
+    assertion = do
+        let file = "./tasty/data/yaml.dhall"
+
+        code <- Data.Text.IO.readFile file
+
+        parsedExpression <- case Dhall.Parser.exprFromText file code of
+            Left  exception        -> Control.Exception.throwIO exception
+            Right parsedExpression -> return parsedExpression
+
+        resolvedExpression <- Dhall.Import.load parsedExpression
+
+        jsonValue <- case Dhall.JSON.dhallToJSON resolvedExpression of
+            Left  exception   -> Control.Exception.throwIO exception
+            Right jsonValue -> return jsonValue
+
+        let actualValue = Dhall.JSON.jsonToYaml jsonValue False False
+
+        bytes <- Data.ByteString.Lazy.readFile "./tasty/data/normal.yaml"
+        let expectedValue = Data.ByteString.Lazy.toStrict bytes
+
+        let message =
+                "Conversion to normal yaml did not generate the expected output"
+
+        Test.Tasty.HUnit.assertEqual message expectedValue actualValue

dhall-json/tasty/data/normal.yaml

@@ -0,0 +1,5 @@
+bool_value: true
+text: |
+  Plain text
+string_value: 2000-01-01
+int_value: 1

dhall-json/tasty/data/quoted.yaml

@@ -0,0 +1,5 @@
+'bool_value': true
+'text': |
+  Plain text
+'string_value': '2000-01-01'
+'int_value': 1

dhall-json/tasty/data/yaml.dhall

@@ -0,0 +1,5 @@
+{ string_value = "2000-01-01"
+, text = ./tasty/data/yaml.txt as Text
+, int_value = 1
+, bool_value = True
+}

dhall-json/tasty/data/yaml.txt

@@ -0,0 +1 @@
+Plain text

stack-lts-12.yaml

@@ -17,6 +17,7 @@ extra-deps:
   - haskell-lsp-types-0.8.0.1
   - turtle-1.5.14
   - transformers-compat-0.6.4
+  - yaml-0.10.4.0
 flags:
   transformers-compat:
     five-three: true

stack-lts-6.yaml

@@ -2,7 +2,6 @@ resolver: lts-6.27
 packages:
   - dhall
   - dhall-bash
-  - dhall-json
   - dhall-text
 extra-deps:
 - ansi-terminal-0.7.1.1
@@ -38,6 +37,7 @@ extra-deps:
 - resourcet-1.1.11
 - turtle-1.5.14
 - unliftio-core-0.1.2.0
+- yaml-0.10.4.0
 flags:
   transformers-compat:
     four: true

stack.yaml

@@ -7,6 +7,7 @@ packages:
   - dhall-lsp-server
 extra-deps:
   - repline-0.2.1.0
+  - yaml-0.10.4.0
 nix:
   packages:
     - ncurses