pretty printer: detect escape character from AST

- Add escape character detection logic to the pretty printer
- Replace the escape character on demand for printing
- Add tests ensuring correct default behaviour
- Version bump to 10.0.0 due to API change

When pretty printing, look ahead into the AST to be printed to determine
which escape character to choose. Then use that character during
printing.
This is possibly a major breaking change in the API, because `Arguments
Text` is no longer an instance of `Pretty`. Instead the pretty printer
expects all instructions to be of type `Instruction Text` and not
`Instruction args`. This allows the arguments to the instructions to be
printed with the correct escape character.

language-docker.cabal

@@ -4,10 +4,10 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 4c166335e4f8bb1979bf3b9b406bb34b47d9c7f6a89f165a58ba5c696e84e54e
+-- hash: 2c9caaab990151b5cf17795136674a3655d2422f22f1e4c84806741c1309e5bd
 
 name:           language-docker
-version:        9.4.0
+version:        10.0.0
 synopsis:       Dockerfile parser, pretty-printer and embedded DSL
 description:    All functions for parsing and pretty-printing Dockerfiles are exported through @Language.Docker@. For more fine-grained operations look for specific modules that implement a certain functionality.
                 See the <https://github.com/hadolint/language-docker GitHub project> for the source-code and examples.
@@ -79,7 +79,7 @@ test-suite hspec
       Paths_language_docker
   hs-source-dirs:
       test
-  default-extensions: OverloadedStrings OverloadedStrings OverloadedLists
+  default-extensions: OverloadedStrings ImplicitParams Rank2Types OverloadedLists
   build-depends:
       HUnit >=1.2
     , QuickCheck

package.yaml

@@ -1,5 +1,5 @@
 name: language-docker
-version: '9.4.0'
+version: '10.0.0'
 synopsis: Dockerfile parser, pretty-printer and embedded DSL
 description: 'All functions for parsing and pretty-printing Dockerfiles are
   exported through @Language.Docker@. For more fine-grained operations look for
@@ -26,6 +26,8 @@ extra-source-files:
   - test/fixtures/2.Dockerfile
 default-extensions:
   - OverloadedStrings
+  - ImplicitParams
+  - Rank2Types
 
 dependencies:
   - base >=4.8 && <5
@@ -48,9 +50,6 @@ library:
   - -Wredundant-constraints
   - -fno-warn-unused-do-bind
   - -fno-warn-orphans
-  default-extensions:
-    - ImplicitParams
-    - Rank2Types
   exposed-modules:
   - Language.Docker
   - Language.Docker.Parser
@@ -62,7 +61,6 @@ tests:
     main: Spec.hs
     source-dirs: test
     default-extensions:
-      - OverloadedStrings
       - OverloadedLists
     dependencies:
     - hspec

src/Language/Docker/Parser.hs

@@ -68,6 +68,3 @@ doParse path txt = do
 -- | Changes crlf line endings to simple line endings
 dos2unix :: T.Text -> T.Text
 dos2unix = T.replace "\r\n" "\n"
-
-defaultEsc :: Char
-defaultEsc = '\\'

src/Language/Docker/PrettyPrint.hs

@@ -27,22 +27,29 @@ data EscapeAccum
         escaping :: !Bool
       }
 
-instance Pretty (Arguments Text) where
-  pretty = prettyPrintArguments
-
 -- | Pretty print a 'Dockerfile' to a 'Text'
 prettyPrint :: Dockerfile -> L.Text
 prettyPrint = renderLazy . layoutPretty opts . prettyPrintDockerfile
   where
     opts = LayoutOptions Unbounded
 
-prettyPrintDockerfile :: Pretty (Arguments args) => [InstructionPos args] -> Doc ann
+prettyPrintDockerfile :: [InstructionPos Text] -> Doc ann
 prettyPrintDockerfile instr = doPrint instr <> "\n"
   where
-    doPrint = vsep . fmap prettyPrintInstructionPos
+    doPrint ips =
+      let ?esc = findEscapeChar ips
+       in (vsep . fmap prettyPrintInstructionPos ) ips
+
+findEscapeChar ::  [InstructionPos args] -> Char
+findEscapeChar [] = defaultEsc
+findEscapeChar (i:is) =
+  case i of
+    InstructionPos {instruction = (Pragma (Escape (EscapeChar c)))} -> c
+    InstructionPos {instruction = (Pragma _)} -> findEscapeChar is
+    _ -> defaultEsc
 
 -- | Pretty print a 'InstructionPos' to a 'Doc'
-prettyPrintInstructionPos :: Pretty (Arguments args) => InstructionPos args -> Doc ann
+prettyPrintInstructionPos :: (?esc :: Char) => InstructionPos Text -> Doc ann
 prettyPrintInstructionPos (InstructionPos i _ _) = prettyPrintInstruction i
 
 prettyPrintImage :: Image -> Doc ann
@@ -75,42 +82,41 @@ prettyPrintBaseImage BaseImage {..} = do
         Nothing -> mempty
         Just (Digest d) -> "@" <> pretty d
 
-prettyPrintPairs :: Pairs -> Doc ann
+prettyPrintPairs :: (?esc :: Char) => Pairs -> Doc ann
 prettyPrintPairs ps = align $ sepLine $ fmap prettyPrintPair ps
   where
-    sepLine = concatWith (\x y -> x <> " \\" <> line <> y)
+    sepLine = concatWith (\x y -> x <> " " <> pretty ?esc <> line <> y)
 
-prettyPrintPair :: (Text, Text) -> Doc ann
+prettyPrintPair :: (?esc :: Char) => (Text, Text) -> Doc ann
 prettyPrintPair (k, v) = pretty k <> pretty '=' <> doubleQoute v
 
-prettyPrintArguments :: Arguments Text -> Doc ann
+prettyPrintArguments :: (?esc :: Char) => Arguments Text -> Doc ann
 prettyPrintArguments (ArgumentsList as) = prettyPrintJSON (Text.words as)
 prettyPrintArguments (ArgumentsText as) = hsep (fmap helper (Text.words as))
   where
-    helper "&&" = "\\\n &&"
+    helper "&&" = pretty ?esc <> "\n &&"
     helper a = pretty a
 
-prettyPrintJSON :: [Text] -> Doc ann
+prettyPrintJSON :: (?esc :: Char) => [Text] -> Doc ann
 prettyPrintJSON args = list (fmap doubleQoute args)
 
-doubleQoute :: Text -> Doc ann
+doubleQoute :: (?esc :: Char) => Text -> Doc ann
 doubleQoute w = enclose dquote dquote (pretty (escapeQuotes w))
 
-escapeQuotes :: Text -> L.Text
+escapeQuotes :: (?esc :: Char) => Text -> L.Text
 escapeQuotes text =
   case Text.foldr accumulate (EscapeAccum mempty 0 False) text of
     EscapeAccum buffer _ False -> B.toLazyText buffer
     EscapeAccum buffer count True ->
       case count `mod` 2 of
-        0 -> B.toLazyText (B.singleton '\\' <> buffer)
+        0 -> B.toLazyText (B.singleton ?esc <> buffer)
         _ -> B.toLazyText buffer
   where
     accumulate '"' EscapeAccum {buffer, escaping = False} =
       EscapeAccum (B.singleton '"' <> buffer) 0 True
-    accumulate '\\' EscapeAccum {buffer, escaping = True, count} =
-      EscapeAccum (B.singleton '\\' <> buffer) (count + 1) True
     accumulate c EscapeAccum {buffer, escaping = True, count}
-      | even count = EscapeAccum (B.singleton c <> B.singleton '\\' <> buffer) 0 False
+      | c == ?esc = EscapeAccum (B.singleton ?esc <> buffer) (count + 1) True
+      | even count = EscapeAccum (B.singleton c <> B.singleton ?esc <> buffer) 0 False
       | otherwise = EscapeAccum (B.singleton c <> buffer) 0 False -- It was already escaped
     accumulate c EscapeAccum {buffer, escaping = False} =
       EscapeAccum (B.singleton c <> buffer) 0 False
@@ -159,7 +165,7 @@ prettyPrintRetries = maybe mempty pp
   where
     pp (Retries r) = "--retries=" <> pretty r
 
-prettyPrintRunMount :: Maybe RunMount -> Doc ann
+prettyPrintRunMount :: (?esc :: Char) => Maybe RunMount -> Doc ann
 prettyPrintRunMount Nothing = mempty
 prettyPrintRunMount (Just mount) = "--mount="
   <> case mount of
@@ -235,7 +241,7 @@ prettyPrintPragma :: PragmaDirective -> Doc ann
 prettyPrintPragma (Escape (EscapeChar esc)) = "escape = " <> pretty esc
 prettyPrintPragma (Syntax (SyntaxImage img)) = "syntax = " <> prettyPrintImage img
 
-prettyPrintInstruction :: Pretty (Arguments args) => Instruction args -> Doc ann
+prettyPrintInstruction :: (?esc :: Char) => Instruction Text -> Doc ann
 prettyPrintInstruction i =
   case i of
     Maintainer m -> do
@@ -249,7 +255,7 @@ prettyPrintInstruction i =
       pretty k <> "=" <> pretty v
     Entrypoint e -> do
       "ENTRYPOINT"
-      pretty e
+      prettyPrintArguments e
     Stopsignal s -> do
       "STOPSIGNAL"
       pretty s
@@ -267,7 +273,7 @@ prettyPrintInstruction i =
       prettyPrintRunMount mount
       prettyPrintRunNetwork network
       prettyPrintRunSecurity security
-      pretty c
+      prettyPrintArguments c
     Copy CopyArgs {sourcePaths, targetPath, chownFlag, chmodFlag, sourceFlag} -> do
       "COPY"
       prettyPrintChown chownFlag
@@ -276,7 +282,7 @@ prettyPrintInstruction i =
       prettyPrintFileList sourcePaths targetPath
     Cmd c -> do
       "CMD"
-      pretty c
+      prettyPrintArguments c
     Label l -> do
       "LABEL"
       prettyPrintPairs l
@@ -305,7 +311,7 @@ prettyPrintInstruction i =
       prettyPrintFileList sourcePaths targetPath
     Shell args -> do
       "SHELL"
-      pretty args
+      prettyPrintArguments args
     Healthcheck NoCheck -> "HEALTHCHECK NONE"
     Healthcheck (Check CheckArgs {..}) -> do
       "HEALTHCHECK"
@@ -314,7 +320,7 @@ prettyPrintInstruction i =
       prettyPrintDuration "--start-period=" startPeriod
       prettyPrintRetries retries
       "CMD"
-      pretty checkCommand
+      prettyPrintArguments checkCommand
   where
     (>>) = spaceCat
 

src/Language/Docker/Syntax.hs

@@ -371,3 +371,6 @@ data InstructionPos args
         lineNumber :: !Linenumber
       }
   deriving (Eq, Ord, Show, Functor)
+
+defaultEsc :: Char
+defaultEsc = '\\'

test/Language/Docker/IntegrationSpec.hs

@@ -4,7 +4,7 @@ import qualified Data.Text as Text
 import qualified Data.Text.IO
 import qualified Data.Text.Lazy.IO as L
 import Language.Docker.Parser
-import Language.Docker.PrettyPrint (prettyPrint)
+import Language.Docker.PrettyPrint (prettyPrint, prettyPrintDockerfile)
 import Test.HUnit hiding (Label)
 import Test.Hspec
 import Text.Megaparsec hiding (Label)
@@ -42,6 +42,34 @@ spec = do
         Right a -> L.putStr $ prettyPrint a
         Left err -> assertFailure $ errorBundlePretty err
 
+  describe "escape character detection logic" $ do
+    it "ensure the pretty printer respects escape pragmas" $ do
+      fromDisk <- Data.Text.IO.readFile "test/fixtures/6.Dockerfile"
+      let ast = parseText fromDisk
+       in case ast of
+          Right a ->
+             let fromAst = prettyPrintDockerfile a
+              in assertEqual "error" fromDisk (Text.pack . show $ fromAst)
+          Left err -> assertFailure $ errorBundlePretty err
+
+    it "ensure escape character '\\' is used as default" $ do
+      fromDisk <- Data.Text.IO.readFile "test/fixtures/7.Dockerfile"
+      let ast = parseText fromDisk
+       in case ast of
+          Right a ->
+             let fromAst = prettyPrintDockerfile a
+              in assertEqual "error" fromDisk (Text.pack . show $ fromAst)
+          Left err -> assertFailure $ errorBundlePretty err
+
+    it "ensure the printer ignores escape pragmas in the wrong place" $ do
+      fromDisk <- Data.Text.IO.readFile "test/fixtures/8.Dockerfile"
+      let ast = parseText fromDisk
+       in case ast of
+          Right a ->
+             let fromAst = prettyPrintDockerfile a
+              in assertEqual "error" fromDisk (Text.pack . show $ fromAst)
+          Left err -> assertFailure $ errorBundlePretty err
+
   describe "parse text" $ do
     it "1.Dockerfile" $ do
       contents <- Data.Text.IO.readFile "test/fixtures/1.Dockerfile"

test/Language/Docker/PrettyPrintSpec.hs

@@ -145,4 +145,7 @@ assertPretty expected instruction = assertEqual
 
 prettyPrintStrict :: Instruction Text.Text -> Text.Text
 prettyPrintStrict =
-  renderStrict . layoutPretty (LayoutOptions Unbounded) . prettyPrintInstruction
+  let ?esc = defaultEsc
+   in renderStrict
+      . layoutPretty (LayoutOptions Unbounded)
+      . prettyPrintInstruction

test/fixtures/6.Dockerfile

@@ -0,0 +1,3 @@
+# escape = `
+RUN cmd a `
+ && cmd b

test/fixtures/7.Dockerfile

@@ -0,0 +1,3 @@
+FROM debian:buster
+RUN cmd a \
+ && cmd b

test/fixtures/8.Dockerfile

@@ -0,0 +1,4 @@
+FROM debian:buster
+# escape = `
+RUN cmd a \
+ && cmd b