{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.Docker.Parser.Prelude
( customError,
comment,
eol,
reserved,
natural,
commaSep,
stringLiteral,
brackets,
whitespace,
requiredWhitespace,
untilEol,
symbol,
caseInsensitiveString,
stringWithEscaped,
lexeme,
isNl,
isSpaceNl,
anyUnless,
someUnless,
Parser,
Error,
DockerfileError (..),
module Megaparsec,
char,
string,
void,
when,
Text,
module Data.Default.Class
)
where
import Control.Monad (void, when)
import Data.Data
import Data.Maybe (fromMaybe)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Text.Megaparsec as Megaparsec hiding (Label)
import Text.Megaparsec.Char hiding (eol)
import qualified Text.Megaparsec.Char.Lexer as L
import Data.Default.Class (Default(def))
data DockerfileError
= DuplicateFlagError String
| NoValueFlagError String
| InvalidFlagError String
| FileListError String
| MissingArgument [Text]
| DuplicateArgument Text
| UnexpectedArgument Text Text
| QuoteError
String
String
deriving (Eq, Data, Typeable, Ord, Read, Show)
type Parser = Parsec DockerfileError Text
type Error = ParseErrorBundle Text DockerfileError
instance ShowErrorComponent DockerfileError where
showErrorComponent (DuplicateFlagError f) = "duplicate flag: " ++ f
showErrorComponent (FileListError f) =
"unexpected end of line. At least two arguments are required for " ++ f
showErrorComponent (NoValueFlagError f) = "unexpected flag " ++ f ++ " with no value"
showErrorComponent (InvalidFlagError f) = "invalid flag: " ++ f
showErrorComponent (MissingArgument f) = "missing required argument(s) for mount flag: " ++ show f
showErrorComponent (DuplicateArgument f) = "duplicate argument for mount flag: " ++ T.unpack f
showErrorComponent (UnexpectedArgument a b) = "unexpected argument '" ++ T.unpack a ++ "' for mount of type '" ++ T.unpack b ++ "'"
showErrorComponent (QuoteError t str) =
"unexpected end of " ++ t ++ " quoted string " ++ str ++ " (unmatched quote)"
data FoundWhitespace
= FoundWhitespace
| MissingWhitespace
deriving (Eq, Show)
instance Semigroup FoundWhitespace where
FoundWhitespace <> _ = FoundWhitespace
_ <> a = a
instance Monoid FoundWhitespace where
mempty = MissingWhitespace
customError :: DockerfileError -> Parser a
customError = fancyFailure . S.singleton . ErrorCustom
castToSpace :: FoundWhitespace -> Text
castToSpace FoundWhitespace = " "
castToSpace MissingWhitespace = ""
eol :: Parser ()
eol = void ws <?> "end of line"
where
ws =
some $
choice [void onlySpaces1, void $ takeWhile1P Nothing (== '\n'), void escapedLineBreaks]
reserved :: 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 p = sepBy (p <* whitespace) (symbol ",")
stringLiteral :: Parser Text
stringLiteral = do
void (char '"')
lit <- manyTill L.charLiteral (char '"')
return (T.pack lit)
brackets :: Parser a -> Parser a
brackets = between (symbol "[" *> whitespace) (whitespace *> symbol "]")
onlySpaces :: Parser Text
onlySpaces = takeWhileP (Just "spaces") (\c -> c == ' ' || c == '\t')
onlySpaces1 :: Parser Text
onlySpaces1 = takeWhile1P (Just "at least one space") (\c -> c == ' ' || c == '\t')
escapedLineBreaks :: Parser FoundWhitespace
escapedLineBreaks = mconcat <$> breaks
where
breaks =
some $ do
try (char '\\' *> onlySpaces *> newlines)
skipMany . try $ onlySpaces *> comment *> newlines
FoundWhitespace <$ onlySpaces1 <|> pure MissingWhitespace
newlines = takeWhile1P Nothing isNl
foundWhitespace :: Parser FoundWhitespace
foundWhitespace = mconcat <$> found
where
found = many $ choice [FoundWhitespace <$ onlySpaces1, escapedLineBreaks]
whitespace :: Parser ()
whitespace = void foundWhitespace
requiredWhitespace :: Parser ()
requiredWhitespace = do
ws <- foundWhitespace
case ws of
FoundWhitespace -> pure ()
MissingWhitespace -> fail "missing whitespace"
untilEol :: String -> Parser Text
untilEol name = do
res <- mconcat <$> predicate
when (res == "") $ fail ("expecting " ++ name)
pure res
where
predicate =
many $
choice
[ castToSpace <$> escapedLineBreaks,
takeWhile1P (Just name) (\c -> c /= '\n' && c /= '\\'),
takeWhile1P Nothing (== '\\') <* notFollowedBy (char '\n')
]
symbol :: Text -> Parser Text
symbol name = do
x <- string name
whitespace
return x
caseInsensitiveString :: Text -> Parser Text
caseInsensitiveString = string'
stringWithEscaped :: [Char] -> Maybe (Char -> Bool) -> Parser Text
stringWithEscaped quoteChars maybeAcceptCondition = mconcat <$> sequences
where
sequences =
many $
choice
[ mconcat <$> inner,
try $ takeWhile1P Nothing (== '\\') <* notFollowedBy quoteParser,
string "\\" *> quoteParser
]
inner =
some $
choice
[ castToSpace <$> escapedLineBreaks,
takeWhile1P
Nothing
(\c -> c /= '\\' && 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 p = do
x <- p
requiredWhitespace
return x
isNl :: Char -> Bool
isNl c = c == '\n'
isSpaceNl :: Char -> Bool
isSpaceNl c = c == ' ' || c == '\t' || c == '\n' || c == '\\'
anyUnless :: (Char -> Bool) -> Parser Text
anyUnless predicate = someUnless "" predicate <|> pure ""
someUnless :: String -> (Char -> Bool) -> Parser Text
someUnless name predicate = do
res <- applyPredicate
case res of
[] -> fail ("expecting " ++ name)
_ -> pure (mconcat res)
where
applyPredicate =
many $
choice
[ castToSpace <$> escapedLineBreaks,
takeWhile1P (Just name) (\c -> not (isSpaceNl c || predicate c)),
takeWhile1P Nothing (\c -> c == '\\' && not (predicate c))
<* notFollowedBy (char '\n')
]
comment :: Parser Text
comment = do
void $ char '#'
takeWhileP Nothing (not . isNl)