dhall-format now can output multi-line strings

dhall.cabal

@@ -81,6 +81,7 @@ Extra-Source-Files:
     Prelude/Text/concatMap
     Prelude/Text/concatMapSep
     Prelude/Text/concatSep
+    tests/format/*.dhall
     tests/parser/*.dhall
     tests/regression/*.dhall
     tests/tutorial/*.dhall
@@ -173,6 +174,7 @@ Test-Suite test
     GHC-Options: -Wall
     Other-Modules:
         Examples
+        Format
         Normalization
         Parser
         Regression

src/Dhall/Core.hs

@@ -611,8 +611,32 @@ prettyDouble = Pretty.pretty
 
 prettyChunks :: Pretty a => Chunks s a -> Doc ann
 prettyChunks (Chunks a b) =
-    "\"" <> foldMap prettyChunk a <> prettyText b <> "\""
+    if any (\(builder, _) -> hasNewLine builder) a || hasNewLine b
+    then
+        Pretty.align
+        (   "''" <> Pretty.hardline
+        <>  Pretty.align
+            (foldMap prettyMultilineChunk a <> prettyMultilineBuilder b)
+        <>  "''"
+        )
+    else "\"" <> foldMap prettyChunk a <> prettyText b <> "\""
   where
+    hasNewLine builder = Text.any (== '\n') lazyText
+      where
+        lazyText = Builder.toLazyText builder
+
+    prettyMultilineChunk (c, d) =
+      prettyMultilineBuilder c <> "${" <> prettyExprA d <> "}"
+
+    prettyMultilineBuilder builder = mconcat docs
+      where
+        lazyText = Builder.toLazyText (escapeSingleQuotedText builder)
+
+        lazyLines = Text.splitOn "\n" lazyText
+
+        docs =
+            Data.List.intersperse Pretty.hardline (fmap Pretty.pretty lazyLines)
+
     prettyChunk (c, d) = prettyText c <> "${" <> prettyExprA d <> "}"
 
     prettyText t = Pretty.pretty (Builder.toLazyText (escapeText t))
@@ -1114,6 +1138,19 @@ buildChunks (Chunks a b) = "\"" <> foldMap buildChunk a <> escapeText b <> "\""
   where
     buildChunk (c, d) = escapeText c <> "${" <> buildExprA d <> "}"
 
+-- | Escape a `Builder` literal using Dhall's escaping rules for single-quoted
+--   @Text@
+escapeSingleQuotedText :: Builder -> Builder
+escapeSingleQuotedText inputBuilder = outputBuilder
+  where
+    inputText = Builder.toLazyText inputBuilder
+
+    outputText = substitute "${" "''${" (substitute "''" "'''" inputText)
+
+    outputBuilder = Builder.fromLazyText outputText
+
+    substitute before after = Text.intercalate after . Text.splitOn before
+
 -- | Escape a `Builder` literal using Dhall's escaping rules
 --
 -- Note that the result does not include surrounding quotes
@@ -1122,7 +1159,11 @@ escapeText a = Builder.fromLazyText (Text.concatMap adapt text)
   where
     adapt c
         | '\x20' <= c && c <= '\x21' = Text.singleton c
-        | '\x23' <= c && c <= '\x5B' = Text.singleton c
+        -- '\x22' == '"'
+        | '\x23' == c                = Text.singleton c
+        -- '\x24' == '$'
+        | '\x25' <= c && c <= '\x5B' = Text.singleton c
+        -- '\x5C' == '\\'
         | '\x5D' <= c && c <= '\x7F' = Text.singleton c
         | c == '"'                   = "\\\""
         | c == '$'                   = "\\$"

tests/Format.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Format where
+
+import Data.Monoid (mempty, (<>))
+import Data.Text (Text)
+import Test.Tasty (TestTree)
+
+import qualified Control.Exception
+import qualified Data.Text
+import qualified Data.Text.Lazy.IO
+import qualified Data.Text.Prettyprint.Doc
+import qualified Data.Text.Prettyprint.Doc.Render.Text
+import qualified Dhall.Parser
+import qualified Test.Tasty
+import qualified Test.Tasty.HUnit
+
+formatTests :: TestTree
+formatTests =
+    Test.Tasty.testGroup "format tests"
+        [ should
+            "prefer multi-line strings when newlines present"
+            "multiline"
+        , should
+            "escape ${ for single-quoted strings"
+            "escapeSingleQuotedOpenInterpolation"
+        ]
+
+opts :: Data.Text.Prettyprint.Doc.LayoutOptions
+opts =
+    Data.Text.Prettyprint.Doc.defaultLayoutOptions
+        { Data.Text.Prettyprint.Doc.layoutPageWidth =
+            Data.Text.Prettyprint.Doc.AvailablePerLine 80 1.0
+        }
+
+should :: Text -> Text -> TestTree
+should name basename =
+    Test.Tasty.HUnit.testCase (Data.Text.unpack name) $ do
+        let inputFile =
+                Data.Text.unpack ("./tests/format/" <> basename <> "A.dhall")
+        let outputFile =
+                Data.Text.unpack ("./tests/format/" <> basename <> "B.dhall")
+        inputText <- Data.Text.Lazy.IO.readFile inputFile
+
+        expr <- case Dhall.Parser.exprFromText mempty inputText of
+            Left  err  -> Control.Exception.throwIO err
+            Right expr -> return expr
+
+        let doc        = Data.Text.Prettyprint.Doc.pretty expr
+        let docStream  = Data.Text.Prettyprint.Doc.layoutSmart opts doc
+        let actualText = Data.Text.Prettyprint.Doc.Render.Text.renderLazy docStream
+
+        expectedText <- Data.Text.Lazy.IO.readFile outputFile
+
+        let message =
+                "The formatted expression did not match the expected output"
+        Test.Tasty.HUnit.assertEqual message expectedText actualText

tests/Regression.hs

@@ -83,7 +83,7 @@ issue126 = Test.Tasty.HUnit.testCase "Issue #126" (do
         \  foo\n\
         \  bar\n\
         \''"
-    Util.normalize' e @?= "\"foo\\nbar\\n\"" )
+    Util.normalize' e @?= "''\nfoo\nbar\n''" )
 
 issue151 :: TestTree
 issue151 = Test.Tasty.HUnit.testCase "Issue #151" (do

tests/Tests.hs

@@ -5,6 +5,7 @@ import Examples (exampleTests)
 import Parser (parserTests)
 import Regression (regressionTests)
 import Tutorial (tutorialTests)
+import Format (formatTests)
 import Test.Tasty
 
 allTests :: TestTree
@@ -15,6 +16,7 @@ allTests =
         , parserTests
         , regressionTests
         , tutorialTests
+        , formatTests
         ]
 
 main :: IO ()

tests/format/escapeSingleQuotedOpenInterpolationA.dhall

@@ -0,0 +1 @@
+"\${\n"

tests/format/escapeSingleQuotedOpenInterpolationB.dhall

@@ -0,0 +1,3 @@
+''
+''${
+''

tests/format/multilineA.dhall

@@ -0,0 +1 @@
+"ABC\nDEF"

tests/format/multilineB.dhall

@@ -0,0 +1,3 @@
+''
+ABC
+DEF''