packages feed

language-docker 9.3.0 → 10.0.0

raw patch · 19 files changed

+487/−187 lines, 19 files

Files

language-docker.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 16d9c4402444a128ff719c0f88b1de7b2465020a9f4a721a18aeebf3ef5f276d+-- hash: 2c9caaab990151b5cf17795136674a3655d2422f22f1e4c84806741c1309e5bd  name:           language-docker-version:        9.3.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.@@ -53,6 +53,7 @@       Paths_language_docker   hs-source-dirs:       src+  default-extensions: OverloadedStrings ImplicitParams Rank2Types   ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-unused-do-bind -fno-warn-orphans   build-depends:       base >=4.8 && <5@@ -71,11 +72,14 @@   main-is: Spec.hs   other-modules:       Language.Docker.IntegrationSpec+      Language.Docker.ParsePragmaSpec       Language.Docker.ParserSpec       Language.Docker.PrettyPrintSpec+      TestHelper       Paths_language_docker   hs-source-dirs:       test+  default-extensions: OverloadedStrings ImplicitParams Rank2Types OverloadedLists   build-depends:       HUnit >=1.2     , QuickCheck
src/Language/Docker/Parser.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- module Language.Docker.Parser   ( parseText,     parseFile,@@ -14,18 +12,18 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding.Error as E-import Language.Docker.Parser.Instruction (parseInstruction)+import Language.Docker.Parser.Instruction (parseInstruction, parseComment) import Language.Docker.Parser.Prelude import Language.Docker.Syntax  contents :: Parser a -> Parser a contents p = do-  void $ takeWhileP Nothing (\c -> c == '\r' || c == '\n' || c == ' ' || c == '\t')+  void onlyWhitespaces   r <- p   eof   return r -dockerfile :: Parser Dockerfile+dockerfile :: (?esc :: Char) => Parser Dockerfile dockerfile =   many $ do     pos <- getSourcePos@@ -34,18 +32,38 @@     return $ InstructionPos i (T.pack . sourceName $ pos) (unPos . sourceLine $ pos)  parseText :: Text -> Either Error Dockerfile-parseText = parse (contents dockerfile) "<string>" . dos2unix+parseText txt = do+  let ?esc = findEscapePragma (T.lines (dos2unix txt))+   in parse (contents dockerfile) "<string>" (dos2unix txt)  parseFile :: FilePath -> IO (Either Error Dockerfile)-parseFile file = doParse <$> B.readFile file-  where-    doParse = parse (contents dockerfile) file . dos2unix . E.decodeUtf8With E.lenientDecode+parseFile file = doParse file <$> B.readFile file  -- | Reads the standard input until the end and parses the contents as a Dockerfile parseStdin :: IO (Either Error Dockerfile)-parseStdin = doParse <$> B.getContents+parseStdin = doParse "/dev/stdin" <$> B.getContents++-- | Parses a list of lines from a dockerfile one by one until either the escape+-- | pragma has been found, or pragmas are no longer expected.+-- | Pragmas can occur only until a comment, an empty line or another+-- | instruction occurs (i.e. they have to be the first lines of a Dockerfile).+findEscapePragma :: [Text] -> Char+findEscapePragma [] = defaultEsc+findEscapePragma (l:ls) =+  case parse (contents parseComment) "<line>" l of+    Left _ -> defaultEsc+    Right (Pragma (Escape (EscapeChar c))) -> c+    Right (Pragma _) -> findEscapePragma ls+    Right _ -> defaultEsc   where-    doParse = parse (contents dockerfile) "/dev/stdin" . dos2unix . E.decodeUtf8With E.lenientDecode+    ?esc = defaultEsc++doParse :: FilePath -> B.ByteString -> Either Error Dockerfile+doParse path txt = do+  let ?esc = findEscapePragma (T.lines src)+   in parse (contents dockerfile) path src+  where+    src = dos2unix (E.decodeUtf8With E.lenientDecode txt)  -- | Changes crlf line endings to simple line endings dos2unix :: T.Text -> T.Text
src/Language/Docker/Parser/Arguments.hs view
@@ -8,16 +8,16 @@ import Language.Docker.Syntax  -- Parse arguments of a command in the exec form-argumentsExec :: Parser (Arguments Text)+argumentsExec :: (?esc :: Char) => Parser (Arguments Text) argumentsExec = do   args <- brackets $ commaSep stringLiteral   return $ ArgumentsList (T.unwords args)  -- Parse arguments of a command in the shell form-argumentsShell :: Parser (Arguments Text)+argumentsShell :: (?esc :: Char) => Parser (Arguments Text) argumentsShell = ArgumentsText <$> toEnd   where     toEnd = untilEol "the shell arguments" -arguments :: Parser (Arguments Text)+arguments :: (?esc :: Char) => Parser (Arguments Text) arguments = try argumentsExec <|> try argumentsShell
src/Language/Docker/Parser/Cmd.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- module Language.Docker.Parser.Cmd   ( parseCmd,   )@@ -9,7 +7,7 @@ import Language.Docker.Parser.Prelude import Language.Docker.Syntax -parseCmd :: Parser (Instruction Text)+parseCmd :: (?esc :: Char) => Parser (Instruction Text) parseCmd = do   reserved "CMD"   Cmd <$> arguments
src/Language/Docker/Parser/Copy.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- module Language.Docker.Parser.Copy   ( parseCopy,     parseAdd,@@ -17,7 +15,7 @@   | FlagSource CopySource   | FlagInvalid (Text, Text) -parseCopy :: Parser (Instruction Text)+parseCopy :: (?esc :: Char) => Parser (Instruction Text) parseCopy = do   reserved "COPY"   flags <- copyFlag `sepEndBy` requiredWhitespace@@ -46,7 +44,7 @@               f : _ -> f       fileList "COPY" (\src dest -> Copy (CopyArgs src dest cho chm fr)) -parseAdd :: Parser (Instruction Text)+parseAdd :: (?esc :: Char) => Parser (Instruction Text) parseAdd = do   reserved "ADD"   flags <- copyFlag `sepEndBy` requiredWhitespace@@ -68,7 +66,9 @@                   c : _ -> c       fileList "ADD" (\src dest -> Add (AddArgs src dest cho chm)) -fileList :: Text -> (NonEmpty SourcePath -> TargetPath -> Instruction Text) -> Parser (Instruction Text)+fileList :: (?esc :: Char) => Text ->+            (NonEmpty SourcePath -> TargetPath -> Instruction Text) ->+            Parser (Instruction Text) fileList name constr = do   paths <-     (try stringList <?> "an array of strings [\"src_file\", \"dest_file\"]")@@ -85,32 +85,32 @@ unexpectedFlag name "" = customFailure $ NoValueFlagError (T.unpack name) unexpectedFlag name _ = customFailure $ InvalidFlagError (T.unpack name) -copyFlag :: Parser CopyFlag+copyFlag :: (?esc :: Char) => Parser CopyFlag copyFlag =   (FlagChown <$> try chown <?> "only one --chown")     <|> (FlagChmod <$> try chmod <?> "only one --chmod")     <|> (FlagSource <$> try copySource <?> "only one --from")     <|> (FlagInvalid <$> try anyFlag <?> "no other flags") -chown :: Parser Chown+chown :: (?esc :: Char) => Parser Chown chown = do   void $ string "--chown="   cho <- someUnless "the user and group for chown" (== ' ')   return $ Chown cho -chmod :: Parser Chmod+chmod :: (?esc :: Char) => Parser Chmod chmod = do   void $ string "--chmod="   chm <- someUnless "the mode for chmod" (== ' ')   return $ Chmod chm -copySource :: Parser CopySource+copySource :: (?esc :: Char) => Parser CopySource copySource = do   void $ string "--from="   src <- someUnless "the copy source path" isNl   return $ CopySource src -anyFlag :: Parser (Text, Text)+anyFlag :: (?esc :: Char) => Parser (Text, Text) anyFlag = do   void $ string "--"   name <- someUnless "the flag value" (== '=')
src/Language/Docker/Parser/Expose.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- module Language.Docker.Parser.Expose   ( parseExpose,   )@@ -9,19 +7,19 @@ import Language.Docker.Parser.Prelude import Language.Docker.Syntax -parseExpose :: Parser (Instruction Text)+parseExpose :: (?esc :: Char) => Parser (Instruction Text) parseExpose = do   reserved "EXPOSE"   Expose <$> ports -port :: Parser Port+port :: (?esc :: Char) => Parser Port port =   (try portVariable <?> "a variable")     <|> (try portRange <?> "a port range optionally followed by the protocol (udp/tcp)") -- There a many valid representations of ports     <|> (try portWithProtocol <?> "a port with its protocol (udp/tcp)")     <|> (try portInt <?> "a valid port number") -ports :: Parser Ports+ports :: (?esc :: Char) => Parser Ports ports = Ports <$> port `sepEndBy` requiredWhitespace  portRange :: Parser Port@@ -51,7 +49,7 @@   portNumber <- natural   Port (fromIntegral portNumber) <$> protocol -portVariable :: Parser Port+portVariable :: (?esc :: Char) => Parser Port portVariable = do   void (char '$')   variable <- someUnless "the variable name" (== '$')
src/Language/Docker/Parser/From.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- module Language.Docker.Parser.From   ( parseFrom,   )@@ -9,7 +7,7 @@ import Language.Docker.Parser.Prelude import Language.Docker.Syntax -parseRegistry :: Parser Registry+parseRegistry :: (?esc :: Char) => Parser Registry parseRegistry = do   domain <- someUnless "a domain name" (== '.')   void $ char '.'@@ -17,14 +15,14 @@   void $ char '/'   return $ Registry (domain <> "." <> tld) -parsePlatform :: Parser Platform+parsePlatform :: (?esc :: Char) => Parser Platform parsePlatform = do   void $ string "--platform="   p <- someUnless "the platform for the FROM image" (== ' ')   requiredWhitespace   return p -parseBaseImage :: (Text -> Parser (Maybe Tag)) -> Parser BaseImage+parseBaseImage :: (?esc :: Char) => (Text -> Parser (Maybe Tag)) -> Parser BaseImage parseBaseImage tagParser = do   maybePlatform <- (Just <$> try parsePlatform) <|> return Nothing   notFollowedBy (string "--")@@ -35,7 +33,7 @@   maybeAlias <- (Just <$> try (requiredWhitespace *> imageAlias)) <|> return Nothing   return $ BaseImage (Image regName name) maybeTag maybeDigest maybeAlias maybePlatform -taggedImage :: Parser BaseImage+taggedImage :: (?esc :: Char) => Parser BaseImage taggedImage = parseBaseImage tagParser   where     tagParser _ = do@@ -43,13 +41,13 @@       t <- someUnless "the image tag" (\c -> c == '@' || c == ':')       return (Just . Tag $ t) -parseDigest :: Parser Digest+parseDigest :: (?esc :: Char) => Parser Digest parseDigest = do   void $ char '@'   d <- someUnless "the image digest" (== '@')   return $ Digest d -untaggedImage :: Parser BaseImage+untaggedImage :: (?esc :: Char) => Parser BaseImage untaggedImage = parseBaseImage notInvalidTag   where     notInvalidTag :: Text -> Parser (Maybe Tag)@@ -59,16 +57,16 @@         ++ ":valid-tag)"       return Nothing -imageAlias :: Parser ImageAlias+imageAlias :: (?esc :: Char) => Parser ImageAlias imageAlias = do   void (try (reserved "AS") <?> "'AS' followed by the image alias")   aka <- someUnless "the image alias" (== '\n')   return $ ImageAlias aka -baseImage :: Parser BaseImage+baseImage :: (?esc :: Char) => Parser BaseImage baseImage = try taggedImage <|> untaggedImage -parseFrom :: Parser (Instruction Text)+parseFrom :: (?esc :: Char) => Parser (Instruction Text) parseFrom = do   reserved "FROM"   From <$> baseImage
src/Language/Docker/Parser/Healthcheck.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}  module Language.Docker.Parser.Healthcheck@@ -20,7 +19,7 @@   | FlagRetries Retries   | CFlagInvalid (Text, Text) -parseHealthcheck :: Parser (Instruction Text)+parseHealthcheck :: (?esc :: Char) => Parser (Instruction Text) parseHealthcheck = do   reserved "HEALTHCHECK"   Healthcheck <$> (fullCheck <|> noCheck)@@ -60,7 +59,7 @@           let retries = listToMaybe retriesD           return $ Check CheckArgs {..} -checkFlag :: Parser CheckFlag+checkFlag :: (?esc :: Char) => Parser CheckFlag checkFlag =   (FlagInterval <$> durationFlag "--interval=" <?> "--interval")     <|> (FlagTimeout <$> durationFlag "--timeout=" <?> "--timeout")@@ -85,7 +84,7 @@   n <- try natural <?> "the number of retries"   return $ Retries (fromIntegral n) -anyFlag :: Parser (Text, Text)+anyFlag :: (?esc :: Char) => Parser (Text, Text) anyFlag = do   void $ string "--"   name <- someUnless "the flag value" (== '=')
src/Language/Docker/Parser/Instruction.hs view
@@ -1,17 +1,18 @@-{-# LANGUAGE OverloadedStrings #-}- module Language.Docker.Parser.Instruction-  ( parseInstruction,+  ( parseArg,+    parseComment,+    parseEntryPoint,+    parseEscapePragma,+    parseInstruction,+    parseMaintainer,+    parseOnbuild,+    parsePragma,     parseShell,     parseStopSignal,-    parseArg,+    parseSyntaxPragma,     parseUser,-    parseWorkdir,     parseVolume,-    parseEntryPoint,-    parseMaintainer,-    parseOnbuild,-    parseComment,+    parseWorkdir,   ) where @@ -26,18 +27,18 @@ import Language.Docker.Parser.Run (parseRun) import Language.Docker.Syntax -parseShell :: Parser (Instruction Text)+parseShell :: (?esc :: Char) => Parser (Instruction Text) parseShell = do   reserved "SHELL"   Shell <$> arguments -parseStopSignal :: Parser (Instruction Text)+parseStopSignal :: (?esc :: Char) => Parser (Instruction Text) parseStopSignal = do   reserved "STOPSIGNAL"   args <- untilEol "the stop signal"   return $ Stopsignal args -parseArg :: Parser (Instruction Text)+parseArg :: (?esc :: Char) => Parser (Instruction Text) parseArg = do   reserved "ARG"   (try nameWithDefault <?> "the arg name")@@ -54,44 +55,74 @@       df <- untilEol "the argument value"       return $ Arg name (Just df) -parseUser :: Parser (Instruction Text)+parseUser :: (?esc :: Char) => Parser (Instruction Text) parseUser = do   reserved "USER"   username <- untilEol "the user"   return $ User username -parseWorkdir :: Parser (Instruction Text)+parseWorkdir :: (?esc :: Char) => Parser (Instruction Text) parseWorkdir = do   reserved "WORKDIR"   directory <- untilEol "the workdir path"   return $ Workdir directory -parseVolume :: Parser (Instruction Text)+parseVolume :: (?esc :: Char) => Parser (Instruction Text) parseVolume = do   reserved "VOLUME"   directory <- untilEol "the volume path"   return $ Volume directory -parseMaintainer :: Parser (Instruction Text)+parseMaintainer :: (?esc :: Char) => Parser (Instruction Text) parseMaintainer = do   reserved "MAINTAINER"   name <- untilEol "the maintainer name"   return $ Maintainer name -parseEntryPoint :: Parser (Instruction Text)+parseEntryPoint :: (?esc :: Char) => Parser (Instruction Text) parseEntryPoint = do   reserved "ENTRYPOINT"   Entrypoint <$> arguments -parseOnbuild :: Parser (Instruction Text)+parseOnbuild :: (?esc :: Char) => Parser (Instruction Text) parseOnbuild = do   reserved "ONBUILD"   OnBuild <$> parseInstruction -parseComment :: Parser (Instruction Text)-parseComment = Comment <$> comment+parsePragma :: (?esc :: Char) => Parser (Instruction Text)+parsePragma = do+  void $ lexeme' (char '#')+  choice+    [ parseEscapePragma <?> "an escape",+      parseSyntaxPragma <?> "a syntax"+    ] -parseInstruction :: Parser (Instruction Text)+parseEscapePragma :: Parser (Instruction Text)+parseEscapePragma = do+  void $ lexeme' (string "escape")+  void $ lexeme' (string "=")+  Pragma . Escape . EscapeChar <$> charLiteral++parseSyntaxPragma :: (?esc :: Char) => Parser (Instruction Text)+parseSyntaxPragma = do+  void $ lexeme' (string "syntax")+  void $ lexeme' (string "=")+  img <- untilEol "the syntax"+  return $ Pragma+      ( Syntax+          ( SyntaxImage+              ( Image+                  { registryName = Nothing,+                    imageName = img+                  }+              )+          )+      )++parseComment :: (?esc :: Char) => Parser (Instruction Text)+parseComment = (try parsePragma <?> "a pragma") <|> Comment <$> comment++parseInstruction :: (?esc :: Char) => Parser (Instruction Text) parseInstruction =   choice     [ parseOnbuild,
src/Language/Docker/Parser/Pairs.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- module Language.Docker.Parser.Pairs   ( parseEnv,     parseLabel,@@ -12,13 +10,13 @@  -- We cannot use string literal because it swallows space -- and therefore have to implement quoted values by ourselves-doubleQuotedValue :: Parser Text+doubleQuotedValue :: (?esc :: Char) => Parser Text doubleQuotedValue = between (string "\"") (string "\"") (stringWithEscaped ['"'] Nothing) -singleQuotedValue :: Parser Text+singleQuotedValue :: (?esc :: Char) => Parser Text singleQuotedValue = between (string "'") (string "'") (stringWithEscaped ['\''] Nothing) -unquotedString :: (Char -> Bool) -> Parser Text+unquotedString :: (?esc :: Char) => (Char -> Bool) -> Parser Text unquotedString acceptCondition = do   str <- stringWithEscaped [' ', '\t'] (Just (\c -> acceptCondition c && c /= '"' && c /= '\''))   checkFaults str@@ -29,7 +27,7 @@       | T.head str == '\"' = customError $ QuoteError "double" (T.unpack str)       | otherwise = return str -singleValue :: (Char -> Bool) -> Parser Text+singleValue :: (?esc :: Char) => (Char -> Bool) -> Parser Text singleValue acceptCondition = mconcat <$> variants   where     variants =@@ -40,7 +38,7 @@             unquotedString acceptCondition <?> "a string with no quotes"           ] -pair :: Parser (Text, Text)+pair :: (?esc :: Char) => Parser (Text, Text) pair = do   key <- singleValue (/= '=')   value <- withEqualSign <|> withoutEqualSign@@ -53,15 +51,15 @@       requiredWhitespace       untilEol "value" -pairs :: Parser Pairs+pairs :: (?esc :: Char) => Parser Pairs pairs = (pair <?> "a key value pair (key=value)") `sepEndBy1` requiredWhitespace -parseLabel :: Parser (Instruction Text)+parseLabel :: (?esc :: Char) => Parser (Instruction Text) parseLabel = do   reserved "LABEL"   Label <$> pairs -parseEnv :: Parser (Instruction Text)+parseEnv :: (?esc :: Char) => Parser (Instruction Text) parseEnv = do   reserved "ENV"   Env <$> pairs
src/Language/Docker/Parser/Prelude.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}  module Language.Docker.Parser.Prelude   ( customError,@@ -14,9 +13,12 @@     requiredWhitespace,     untilEol,     symbol,+    onlySpaces,+    onlyWhitespaces,     caseInsensitiveString,     stringWithEscaped,     lexeme,+    lexeme',     isNl,     isSpaceNl,     anyUnless,@@ -26,6 +28,7 @@     DockerfileError (..),     module Megaparsec,     char,+    L.charLiteral,     string,     void,     when,@@ -103,20 +106,24 @@ castToSpace FoundWhitespace = " " castToSpace MissingWhitespace = "" -eol :: Parser ()+eol :: (?esc :: Char) => Parser () eol = void ws <?> "end of line"   where     ws =       some $-        choice [void onlySpaces1, void $ takeWhile1P Nothing (== '\n'), void escapedLineBreaks]+        choice+          [ void onlySpaces1,+            void $ takeWhile1P Nothing (== '\n'),+            void escapedLineBreaks+          ] -reserved :: Text -> Parser ()+reserved :: (?esc :: Char) => Text -> Parser () reserved name = void (lexeme (string' name) <?> T.unpack name)  natural :: Parser Integer natural = L.decimal <?> "positive number" -commaSep :: Parser a -> Parser [a]+commaSep :: (?esc :: Char) => Parser a -> Parser [a] commaSep p = sepBy (p <* whitespace) (symbol ",")  stringLiteral :: Parser Text@@ -125,7 +132,7 @@   lit <- manyTill L.charLiteral (char '"')   return (T.pack lit) -brackets :: Parser a -> Parser a+brackets :: (?esc :: Char) => Parser a -> Parser a brackets = between (symbol "[" *> whitespace) (whitespace *> symbol "]")  onlySpaces :: Parser Text@@ -134,27 +141,32 @@ onlySpaces1 :: Parser Text onlySpaces1 = takeWhile1P (Just "at least one space") (\c -> c == ' ' || c == '\t') -escapedLineBreaks :: Parser FoundWhitespace+onlyWhitespaces :: Parser Text+onlyWhitespaces = takeWhileP+    (Just "whitespaces")+    (\c -> c == ' ' || c == '\t' || c == '\n' || c == '\r')++escapedLineBreaks :: (?esc :: Char) => Parser FoundWhitespace escapedLineBreaks = mconcat <$> breaks   where     breaks =       some $ do-        try (char '\\' *> onlySpaces *> newlines)+        try (char ?esc *> onlySpaces *> newlines)         skipMany . try $ onlySpaces *> comment *> newlines         -- Spaces before the next '\' have a special significance         -- so we remembeer the fact that we found some         FoundWhitespace <$ onlySpaces1 <|> pure MissingWhitespace     newlines = takeWhile1P Nothing isNl -foundWhitespace :: Parser FoundWhitespace+foundWhitespace :: (?esc :: Char) => Parser FoundWhitespace foundWhitespace = mconcat <$> found   where     found = many $ choice [FoundWhitespace <$ onlySpaces1, escapedLineBreaks] -whitespace :: Parser ()+whitespace :: (?esc :: Char) => Parser () whitespace = void foundWhitespace -requiredWhitespace :: Parser ()+requiredWhitespace :: (?esc :: Char) => Parser () requiredWhitespace = do   ws <- foundWhitespace   case ws of@@ -163,7 +175,7 @@  -- Parse value until end of line is reached -- after consuming all escaped newlines-untilEol :: String -> Parser Text+untilEol :: (?esc :: Char) => String -> Parser Text untilEol name = do   res <- mconcat <$> predicate   when (res == "") $ fail ("expecting " ++ name)@@ -173,11 +185,11 @@       many $         choice           [ castToSpace <$> escapedLineBreaks,-            takeWhile1P (Just name) (\c -> c /= '\n' && c /= '\\'),-            takeWhile1P Nothing (== '\\') <* notFollowedBy (char '\n')+            takeWhile1P (Just name) (\c -> c /= '\n' && c /= ?esc),+            takeWhile1P Nothing (== ?esc) <* notFollowedBy (char '\n')           ] -symbol :: Text -> Parser Text+symbol :: (?esc :: Char) => Text -> Parser Text symbol name = do   x <- string name   whitespace@@ -186,15 +198,15 @@ caseInsensitiveString :: Text -> Parser Text caseInsensitiveString = string' -stringWithEscaped :: [Char] -> Maybe (Char -> Bool) -> Parser Text+stringWithEscaped :: (?esc :: Char) => [Char] -> Maybe (Char -> Bool) -> Parser Text stringWithEscaped quoteChars maybeAcceptCondition = mconcat <$> sequences   where     sequences =       many $         choice           [ mconcat <$> inner,-            try $ takeWhile1P Nothing (== '\\') <* notFollowedBy quoteParser,-            string "\\" *> quoteParser+            try $ takeWhile1P Nothing (== ?esc) <* notFollowedBy quoteParser,+            string (T.singleton ?esc) *> quoteParser           ]     inner =       some $@@ -202,27 +214,33 @@           [ castToSpace <$> escapedLineBreaks,             takeWhile1P               Nothing-              (\c -> c /= '\\' && c /= '\n' && c `notElem` quoteChars && acceptCondition c)+              (\c -> c /= ?esc && c /= '\n' && c `notElem` quoteChars && acceptCondition c)           ]     quoteParser = T.singleton <$> choice (fmap char quoteChars)     acceptCondition = fromMaybe (const True) maybeAcceptCondition -lexeme :: Parser a -> Parser a+lexeme :: (?esc :: Char) => Parser a -> Parser a lexeme p = do   x <- p   requiredWhitespace   return x +lexeme' :: Parser a -> Parser a+lexeme' p = do+  x <- p+  void onlySpaces+  return x+ isNl :: Char -> Bool isNl c = c == '\n' -isSpaceNl :: Char -> Bool-isSpaceNl c = c == ' ' || c == '\t' || c == '\n' || c == '\\'+isSpaceNl :: (?esc :: Char) => Char -> Bool+isSpaceNl c = c == ' ' || c == '\t' || c == '\n' || c == ?esc -anyUnless :: (Char -> Bool) -> Parser Text+anyUnless :: (?esc :: Char) => (Char -> Bool) -> Parser Text anyUnless predicate = someUnless "" predicate <|> pure "" -someUnless :: String -> (Char -> Bool) -> Parser Text+someUnless :: (?esc :: Char) => String -> (Char -> Bool) -> Parser Text someUnless name predicate = do   res <- applyPredicate   case res of@@ -234,7 +252,7 @@         choice           [ castToSpace <$> escapedLineBreaks,             takeWhile1P (Just name) (\c -> not (isSpaceNl c || predicate c)),-            takeWhile1P Nothing (\c -> c == '\\' && not (predicate c))+            takeWhile1P Nothing (\c -> c == ?esc && not (predicate c))               <* notFollowedBy (char '\n')           ]
src/Language/Docker/Parser/Run.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE OverloadedStrings #-}  module Language.Docker.Parser.Run   ( parseRun,@@ -40,18 +39,18 @@   | Secret   | Ssh -parseRun :: Parser (Instruction Text)+parseRun :: (?esc :: Char) => Parser (Instruction Text) parseRun = do   reserved "RUN"   Run <$> runArguments -runArguments :: Parser (RunArgs Text)+runArguments :: (?esc :: Char) => Parser (RunArgs Text) runArguments = do   presentFlags <- choice [runFlags <* requiredWhitespace, pure (RunFlags Nothing Nothing Nothing)]   args <- arguments   return $ RunArgs args presentFlags -runFlags :: Parser RunFlags+runFlags :: (?esc :: Char) => Parser RunFlags runFlags = do   flags <- runFlag `sepBy` flagSeparator   return $ foldr toRunFlags emptyFlags flags@@ -62,10 +61,13 @@     toRunFlags (RunFlagNetwork n) rf = rf {network = Just n}     toRunFlags (RunFlagSecurity s) rf = rf {security = Just s} -runFlag :: Parser RunFlag+runFlag :: (?esc :: Char) => Parser RunFlag runFlag =   choice-    [RunFlagMount <$> runFlagMount, RunFlagSecurity <$> runFlagSecurity, RunFlagNetwork <$> runFlagNetwork]+    [ RunFlagMount <$> runFlagMount,+      RunFlagSecurity <$> runFlagSecurity,+      RunFlagNetwork <$> runFlagNetwork+    ]  runFlagSecurity :: Parser RunSecurity runFlagSecurity = do@@ -77,7 +79,7 @@   void $ string "--network="   choice [NetworkNone <$ string "none", NetworkHost <$ string "host", NetworkDefault <$ string "default"] -runFlagMount :: Parser RunMount+runFlagMount :: (?esc :: Char) => Parser RunMount runFlagMount = do   void $ string "--mount="   maybeType <-@@ -104,7 +106,7 @@     Secret -> SecretMount <$> (secretMount =<< args)     Ssh -> SshMount <$> (secretMount =<< args) -argsParser :: MountType -> Parser [RunMountArg]+argsParser :: (?esc :: Char) => MountType -> Parser [RunMountArg] argsParser mountType = mountChoices mountType `sepBy1` string ","  bindMount :: [RunMountArg] -> Parser BindOpts@@ -192,7 +194,7 @@             (_, True) -> (Left (DuplicateArgument name), seen)             (True, False) -> (Right (a : as), Set.insert name seen) -mountChoices :: MountType -> Parser RunMountArg+mountChoices :: (?esc :: Char) => MountType -> Parser RunMountArg mountChoices mountType =   choice $     case mountType of@@ -226,7 +228,7 @@           mountArgGid         ] -stringArg :: Parser Text+stringArg :: (?esc :: Char) => Parser Text stringArg = choice [stringLiteral, someUnless "a string" (== ',')]  key :: Text -> Parser a -> Parser a@@ -236,16 +238,16 @@ cacheSharing =   choice [Private <$ string "private", Shared <$ string "shared", Locked <$ string "locked"] -mountArgFromImage :: Parser RunMountArg+mountArgFromImage :: (?esc :: Char) => Parser RunMountArg mountArgFromImage = MountArgFromImage <$> key "from" stringArg  mountArgGid :: Parser RunMountArg mountArgGid = MountArgGid <$> key "gid" natural -mountArgId :: Parser RunMountArg+mountArgId :: (?esc :: Char) => Parser RunMountArg mountArgId = MountArgId <$> key "id" stringArg -mountArgMode :: Parser RunMountArg+mountArgMode :: (?esc :: Char) => Parser RunMountArg mountArgMode = MountArgMode <$> key "mode" stringArg  mountArgReadOnly :: Parser RunMountArg@@ -268,12 +270,12 @@ mountArgSharing :: Parser RunMountArg mountArgSharing = MountArgSharing <$> key "sharing" cacheSharing -mountArgSource :: Parser RunMountArg+mountArgSource :: (?esc :: Char) => Parser RunMountArg mountArgSource = do   label "source=" $ choice [string "source=", string "src="]   MountArgSource . SourcePath <$> stringArg -mountArgTarget :: Parser RunMountArg+mountArgTarget :: (?esc :: Char) => Parser RunMountArg mountArgTarget = do   label "target=" $ choice [string "target=", string "dst=", string "destination="]   MountArgTarget . TargetPath <$> stringArg
src/Language/Docker/PrettyPrint.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoMonomorphismRestriction #-}@@ -28,22 +27,29 @@         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@@ -76,42 +82,41 @@         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@@ -160,7 +165,7 @@   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@@ -232,7 +237,11 @@ prettyPrintRunSecurity (Just Sandbox) = "--security=sandbox" prettyPrintRunSecurity (Just Insecure) = "--security=insecure" -prettyPrintInstruction :: Pretty (Arguments args) => Instruction args -> Doc ann+prettyPrintPragma :: PragmaDirective -> Doc ann+prettyPrintPragma (Escape (EscapeChar esc)) = "escape = " <> pretty esc+prettyPrintPragma (Syntax (SyntaxImage img)) = "syntax = " <> prettyPrintImage img++prettyPrintInstruction :: (?esc :: Char) => Instruction Text -> Doc ann prettyPrintInstruction i =   case i of     Maintainer m -> do@@ -246,7 +255,7 @@       pretty k <> "=" <> pretty v     Entrypoint e -> do       "ENTRYPOINT"-      pretty e+      prettyPrintArguments e     Stopsignal s -> do       "STOPSIGNAL"       pretty s@@ -264,7 +273,7 @@       prettyPrintRunMount mount       prettyPrintRunNetwork network       prettyPrintRunSecurity security-      pretty c+      prettyPrintArguments c     Copy CopyArgs {sourcePaths, targetPath, chownFlag, chmodFlag, sourceFlag} -> do       "COPY"       prettyPrintChown chownFlag@@ -273,7 +282,7 @@       prettyPrintFileList sourcePaths targetPath     Cmd c -> do       "CMD"-      pretty c+      prettyPrintArguments c     Label l -> do       "LABEL"       prettyPrintPairs l@@ -283,6 +292,9 @@     User u -> do       "USER"       pretty u+    Pragma p -> do+      pretty '#'+      prettyPrintPragma p     Comment s -> do       pretty '#'       pretty s@@ -299,7 +311,7 @@       prettyPrintFileList sourcePaths targetPath     Shell args -> do       "SHELL"-      pretty args+      prettyPrintArguments args     Healthcheck NoCheck -> "HEALTHCHECK NONE"     Healthcheck (Check CheckArgs {..}) -> do       "HEALTHCHECK"@@ -308,7 +320,7 @@       prettyPrintDuration "--start-period=" startPeriod       prettyPrintRetries retries       "CMD"-      pretty checkCommand+      prettyPrintArguments checkCommand   where     (>>) = spaceCat
src/Language/Docker/Syntax.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}  module Language.Docker.Syntax where@@ -16,6 +15,7 @@ import qualified Data.Text as Text import Data.Time.Clock (DiffTime) import GHC.Exts (IsList (..))+import Text.Printf  data Image   = Image@@ -310,6 +310,28 @@           mount = Nothing         } +newtype EscapeChar+  = EscapeChar+      { escape :: Char+      }+  deriving (Show, Eq, Ord)++instance IsChar EscapeChar where+  fromChar c =+    EscapeChar {escape = c}+  toChar e = escape e++newtype SyntaxImage+  = SyntaxImage+      { syntax :: Image+      }+  deriving (Show, Eq, Ord)++data PragmaDirective+  = Escape !EscapeChar+  | Syntax !SyntaxImage+  deriving (Show, Eq, Ord)+ -- | All commands available in Dockerfiles data Instruction args   = From !BaseImage@@ -331,6 +353,7 @@       !Text       !(Maybe Text)   | Healthcheck !(Check args)+  | Pragma !PragmaDirective   | Comment !Text   | OnBuild !(Instruction args)   deriving (Eq, Ord, Show, Functor)@@ -348,3 +371,6 @@         lineNumber :: !Linenumber       }   deriving (Eq, Ord, Show, Functor)++defaultEsc :: Char+defaultEsc = '\\'
test/Language/Docker/IntegrationSpec.hs view
@@ -1,43 +1,132 @@-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE OverloadedStrings #-}- module Language.Docker.IntegrationSpec where  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)  spec :: Spec spec = do-  describe "first" $ do-    it "no erors" $ do+  describe "parse file" $ do+    it "1.Dockerfile" $ do       parsed <- parseFile "test/fixtures/1.Dockerfile"       case parsed of         Right a -> L.putStr $ prettyPrint a         Left err -> assertFailure $ errorBundlePretty err -  describe "second" $ do-    it "no erors" $ do+    it "2.Dockerfile" $ do       parsed <- parseFile "test/fixtures/2.Dockerfile"       case parsed of         Right a -> L.putStr $ prettyPrint a         Left err -> assertFailure $ errorBundlePretty err -  describe "first clrf" $ do-    it "no erors" $ do+    it "3.Dockerfile" $ do+      parsed <- parseFile "test/fixtures/3.Dockerfile"+      case parsed of+        Right a -> L.putStr $ prettyPrint a+        Left err -> assertFailure $ errorBundlePretty err++    it "4.Dockerfile" $ do+      parsed <- parseFile "test/fixtures/4.Dockerfile"+      case parsed of+        Right a -> L.putStr $ prettyPrint a+        Left err -> assertFailure $ errorBundlePretty err++    it "5.Dockerfile" $ do+      parsed <- parseFile "test/fixtures/5.Dockerfile"+      case parsed of+        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"       case parseText (Text.replace "\n" "\r\n" contents) of         Right _ -> return ()         Left err -> assertFailure $ errorBundlePretty err -  describe "second clrf" $ do-    it "no erors" $ do+    it "2.Dockerfile" $ do       contents <- Data.Text.IO.readFile "test/fixtures/2.Dockerfile"+      case parseText contents of+        Right _ -> return ()+        Left err -> assertFailure $ errorBundlePretty err++    it "3.Dockerfile" $ do+      contents <- Data.Text.IO.readFile "test/fixtures/3.Dockerfile"+      case parseText contents of+        Right _ -> return ()+        Left err -> assertFailure $ errorBundlePretty err++    it "4.Dockerfile" $ do+      contents <- Data.Text.IO.readFile "test/fixtures/4.Dockerfile"+      case parseText contents of+        Right _ -> return ()+        Left err -> assertFailure $ errorBundlePretty err++    it "5.Dockerfile" $ do+      contents <- Data.Text.IO.readFile "test/fixtures/5.Dockerfile"+      case parseText contents of+        Right _ -> return ()+        Left err -> assertFailure $ errorBundlePretty err++    it "1.Dockerfile crlf" $ do+      contents <- Data.Text.IO.readFile "test/fixtures/1.Dockerfile"+      case parseText contents of+        Right _ -> return ()+        Left err -> assertFailure $ errorBundlePretty err++    it "2.Dockerfile crlf" $ do+      contents <- Data.Text.IO.readFile "test/fixtures/2.Dockerfile"+      case parseText (Text.replace "\n" "\r\n" contents) of+        Right _ -> return ()+        Left err -> assertFailure $ errorBundlePretty err++    it "3.Dockerfile crlf" $ do+      contents <- Data.Text.IO.readFile "test/fixtures/3.Dockerfile"+      case parseText (Text.replace "\n" "\r\n" contents) of+        Right _ -> return ()+        Left err -> assertFailure $ errorBundlePretty err++    it "4.Dockerfile crlf" $ do+      contents <- Data.Text.IO.readFile "test/fixtures/4.Dockerfile"+      case parseText (Text.replace "\n" "\r\n" contents) of+        Right _ -> return ()+        Left err -> assertFailure $ errorBundlePretty err++    it "5.Dockerfile crlf" $ do+      contents <- Data.Text.IO.readFile "test/fixtures/5.Dockerfile"       case parseText (Text.replace "\n" "\r\n" contents) of         Right _ -> return ()         Left err -> assertFailure $ errorBundlePretty err
+ test/Language/Docker/ParsePragmaSpec.hs view
@@ -0,0 +1,73 @@+module Language.Docker.ParsePragmaSpec where++import qualified Data.Text as Text+import Language.Docker.Parser+import Language.Docker.Syntax+import TestHelper+import Test.HUnit hiding (Label)+import Test.Hspec+++spec :: Spec+spec = do+  describe "parse # pragma" $ do+    it "# escape = \\" $+      let dockerfile = Text.unlines ["# escape = \\\\"]  -- this need double escaping for some reason.+       in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '\\'})]+    it "#escape=`" $+      let dockerfile = Text.unlines ["#escape=`"]+       in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})]+    it "# escape=`" $+      let dockerfile = Text.unlines ["# escape=`"]+       in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})]+    it "#escape =`" $+      let dockerfile = Text.unlines ["#escape =`"]+       in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})]+    it "#escape= `" $+      let dockerfile = Text.unlines ["#escape= `"]+       in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})]+    it "# escape =`" $+      let dockerfile = Text.unlines ["# escape =`"]+       in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})]+    it "#escape = `" $+      let dockerfile = Text.unlines ["#escape = `"]+       in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})]+    it "# escape = `" $+      let dockerfile = Text.unlines ["# escape = `"]+       in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})]+    it "# Escape = `" $+      let dockerfile = Text.unlines ["# escape = `"]+       in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})]+    it "# ESCAPE = `" $+      let dockerfile = Text.unlines ["# escape = `"]+       in assertAst dockerfile [Pragma (Escape EscapeChar {escape = '`'})]+    it "#syntax=docker/dockerfile:1.0" $+      let dockerfile = Text.unlines ["#syntax=docker/dockerfile:1.0"]+       in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})]+    it "# syntax=docker/dockerfile:1.0" $+      let dockerfile = Text.unlines ["# syntax=docker/dockerfile:1.0"]+       in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})]+    it "#syntax =docker/dockerfile:1.0" $+      let dockerfile = Text.unlines ["#syntax =docker/dockerfile:1.0"]+       in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})]+    it "#syntax= docker/dockerfile:1.0" $+      let dockerfile = Text.unlines ["#syntax= docker/dockerfile:1.0"]+       in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})]+    it "# syntax =docker/dockerfile:1.0" $+      let dockerfile = Text.unlines ["# syntax =docker/dockerfile:1.0"]+       in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})]+    it "#syntax = docker/dockerfile:1.0" $+      let dockerfile = Text.unlines ["#syntax = docker/dockerfile:1.0"]+       in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})]+    it "# syntax= docker/dockerfile:1.0" $+      let dockerfile = Text.unlines ["# syntax= docker/dockerfile:1.0"]+       in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})]+    it "# syntax = docker/dockerfile:1.0" $+      let dockerfile = Text.unlines ["# syntax = docker/dockerfile:1.0"]+       in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})]+    it "# Syntax = docker/dockerfile:1.0" $+      let dockerfile = Text.unlines ["# syntax = docker/dockerfile:1.0"]+       in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})]+    it "# SYNTAX = docker/dockerfile:1.0" $+      let dockerfile = Text.unlines ["# syntax = docker/dockerfile:1.0"]+       in assertAst dockerfile [Pragma (Syntax SyntaxImage {syntax = "docker/dockerfile:1.0"})]
test/Language/Docker/ParserSpec.hs view
@@ -1,31 +1,15 @@-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE OverloadedStrings #-}- module Language.Docker.ParserSpec where  import Data.Default.Class (def) import qualified Data.Text as Text import Language.Docker.Parser import Language.Docker.Syntax+import TestHelper import Test.HUnit hiding (Label) import Test.Hspec import Text.Megaparsec hiding (Label) -untaggedImage :: Image -> BaseImage-untaggedImage n = BaseImage n Nothing Nothing Nothing Nothing -taggedImage :: Image -> Tag -> BaseImage-taggedImage n t = BaseImage n (Just t) Nothing Nothing Nothing--withDigest :: BaseImage -> Digest -> BaseImage-withDigest i d = i {digest = Just d}--withAlias :: BaseImage -> ImageAlias -> BaseImage-withAlias i a = i {alias = Just a}--withPlatform :: BaseImage -> Platform -> BaseImage-withPlatform i p = i {platform = Just p}- spec :: Spec spec = do   describe "parse ARG" $ do@@ -731,9 +715,3 @@             file             [ Run $ RunArgs (ArgumentsText "echo foo") flags             ]--assertAst :: HasCallStack => Text.Text -> [Instruction Text.Text] -> Assertion-assertAst s ast =-  case parseText s of-    Left err -> assertFailure $ errorBundlePretty err-    Right dockerfile -> assertEqual "ASTs are not equal" ast $ map instruction dockerfile
test/Language/Docker/PrettyPrintSpec.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE OverloadedStrings #-}  module Language.Docker.PrettyPrintSpec where @@ -118,7 +116,26 @@                       (CopySource "baseimage")                   )        in assertPretty "COPY --chown=root:root --chmod=751 --from=baseimage foo bar" copy-+  describe "pretty print # escape" $ do+    it "# escape = \\" $ do+      let esc = Pragma (Escape (EscapeChar '\\'))+       in assertPretty "# escape = \\" esc+    it "# escape = `" $ do+      let esc = Pragma (Escape (EscapeChar '`'))+       in assertPretty "# escape = `" esc+  describe "pretty print # syntax" $ do+    it "# syntax = docker/dockerfile:1.0" $ do+      let img = Pragma+                  ( Syntax+                    ( SyntaxImage+                        ( Image+                            { registryName = Nothing,+                              imageName = "docker/dockerfile:1.0"+                            }+                        )+                    )+                  )+       in assertPretty "# syntax = docker/dockerfile:1.0" img  assertPretty :: Text.Text -> Instruction Text.Text -> Assertion assertPretty expected instruction = assertEqual@@ -128,4 +145,7 @@  prettyPrintStrict :: Instruction Text.Text -> Text.Text prettyPrintStrict =-  renderStrict . layoutPretty (LayoutOptions Unbounded) . prettyPrintInstruction+  let ?esc = defaultEsc+   in renderStrict+      . layoutPretty (LayoutOptions Unbounded)+      . prettyPrintInstruction
+ test/TestHelper.hs view
@@ -0,0 +1,38 @@+module TestHelper+  ( assertAst,+    taggedImage,+    withAlias,+    withDigest,+    withPlatform,+    untaggedImage+  )+  where++import qualified Data.Text as Text+import Language.Docker.Parser+import Language.Docker.Syntax+import Test.HUnit hiding (Label)+import Test.Hspec+import Text.Megaparsec hiding (Label)+++untaggedImage :: Image -> BaseImage+untaggedImage n = BaseImage n Nothing Nothing Nothing Nothing++taggedImage :: Image -> Tag -> BaseImage+taggedImage n t = BaseImage n (Just t) Nothing Nothing Nothing++withDigest :: BaseImage -> Digest -> BaseImage+withDigest i d = i {digest = Just d}++withAlias :: BaseImage -> ImageAlias -> BaseImage+withAlias i a = i {alias = Just a}++withPlatform :: BaseImage -> Platform -> BaseImage+withPlatform i p = i {platform = Just p}++assertAst :: HasCallStack => Text.Text -> [Instruction Text.Text] -> Assertion+assertAst s ast =+  case parseText s of+    Left err -> assertFailure $ errorBundlePretty err+    Right dockerfile -> assertEqual "ASTs are not equal" ast $ map instruction dockerfile