diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,16 @@ +## v1.0.0 + +* Implement KDL v2 parser +* Implement `KDL.render`, which is format-preserving +* Improve rendering parse errors +* Include filepath in error messages when `decodeFileWith` fails +* Support adding span information + +API changes: +* Rename `Text` constructor to `String` in `ValueData` +* Overhauled `*Format` data types +* Removed selector functions (e.g. `nodeName` => `(.name)` or `Node{name}`) + ## v0.2.1 * Add `KDL.Applicative` diff --git a/kdl-hs.cabal b/kdl-hs.cabal --- a/kdl-hs.cabal +++ b/kdl-hs.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: kdl-hs -version: 0.2.1 +version: 1.0.0 synopsis: KDL language parser and API description: KDL language parser and API. homepage: https://github.com/brandonchinn178/kdl-hs#readme @@ -15,6 +15,9 @@ extra-source-files: README.md CHANGELOG.md + test/KDL/__snapshots__/DecoderSpec.snap.md + test/KDL/__snapshots__/ParserSpec.snap.md + test/KDL/__snapshots__/RenderSpec.snap.md source-repository head type: git @@ -34,17 +37,13 @@ KDL.Decoder.Monad KDL.Decoder.Schema KDL.Parser + KDL.Parser.Internal KDL.Render KDL.Types - other-modules: - KDL.Parser.Hustle - KDL.Parser.Hustle.Formatter - KDL.Parser.Hustle.Internal - KDL.Parser.Hustle.Parser - KDL.Parser.Hustle.Types build-depends: base < 5 , containers + , data-default , megaparsec , prettyprinter >= 1.7.0 , scientific @@ -53,21 +52,45 @@ default-language: GHC2021 ghc-options: -Wall -Wcompat +executable kdl-hs-test-decoder + main-is: test/kdl-hs-test-decoder.hs + build-depends: + base < 5 + , aeson + , bytestring + , containers + , kdl-hs + , scientific + , text + default-language: GHC2021 + ghc-options: -Wall -Wcompat + test-suite kdl-tests type: exitcode-stdio-1.0 ghc-options: -F -pgmF=skeletest-preprocessor - build-tool-depends: skeletest:skeletest-preprocessor + build-tool-depends: + , skeletest:skeletest-preprocessor + , kdl-hs:kdl-hs-test-decoder hs-source-dirs: test main-is: Main.hs other-modules: KDL.ApplicativeSpec - KDL.ParserSpec + KDL.DecoderSpec KDL.Decoder.ArrowSpec KDL.Decoder.MonadSpec + KDL.ParserSpec + KDL.RenderSpec + KDL.TestUtils.AST + KDL.TestUtils.Error build-depends: base , containers + , directory + , filepath , kdl-hs + , pretty-show + , process + , scientific , skeletest , temporary , text diff --git a/src/KDL/Applicative.hs b/src/KDL/Applicative.hs --- a/src/KDL/Applicative.hs +++ b/src/KDL/Applicative.hs @@ -75,8 +75,7 @@ -- -- It seems like QualifiedDo still needs a definition for this, even with -- ApplicativeDo enabled. - -- - -- https://discourse.haskell.org/t/qualifieddo-applicativedo-still-requires/13491 + -- https://gitlab.haskell.org/ghc/ghc/-/issues/26723 (>>=) :: a instance (GHC.Unsatisfiable (GHC.Text ">>= is not allowed in a KDL.do block")) => NoBind a where (>>=) = GHC.unsatisfiable diff --git a/src/KDL/Decoder/Arrow.hs b/src/KDL/Decoder/Arrow.hs --- a/src/KDL/Decoder/Arrow.hs +++ b/src/KDL/Decoder/Arrow.hs @@ -92,6 +92,7 @@ import Control.Monad.Trans.Class qualified as Trans import Control.Monad.Trans.State.Strict (StateT) import Control.Monad.Trans.State.Strict qualified as StateT +import Data.Bifunctor (first) import Data.Bits (finiteBitSize) import Data.Int (Int64) import Data.List (partition) @@ -127,6 +128,7 @@ NodeList (..), Value (..), ValueData (..), + def, ) import Numeric.Natural (Natural) import Prelude hiding (any, fail, null) @@ -134,11 +136,11 @@ -- | Decode the given KDL configuration with the given decoder. decodeWith :: DocumentDecoder a -> Text -> Either DecodeError a -decodeWith decoder = decodeFromParseResult decoder . parse +decodeWith decoder = decodeFromParseResult decoder Nothing . parse -- | Read KDL configuration from the given file path and decode it with the given decoder. decodeFileWith :: DocumentDecoder a -> FilePath -> IO (Either DecodeError a) -decodeFileWith decoder = fmap (decodeFromParseResult decoder) . parseFile +decodeFileWith decoder fp = decodeFromParseResult decoder (Just fp) <$> parseFile fp -- | Decode an already-parsed 'Document' with the given decoder. decodeDocWith :: DocumentDecoder a -> Document -> Either DecodeError a @@ -146,10 +148,15 @@ runDecodeM . runDecodeStateM doc emptyDecodeHistory $ decoder.run () -decodeFromParseResult :: DocumentDecoder a -> Either Text Document -> Either DecodeError a -decodeFromParseResult decoder = \case - Left e -> runDecodeM . decodeThrow $ DecodeError_ParseError e - Right doc -> decodeDocWith decoder doc +decodeFromParseResult :: + DocumentDecoder a -> + Maybe FilePath -> + Either Text Document -> + Either DecodeError a +decodeFromParseResult decoder mPath = + first (\e -> e{filepath = mPath}) . \case + Left e -> runDecodeM . decodeThrow $ DecodeError_ParseError e + Right doc -> decodeDocWith decoder doc {----- Decoder -----} @@ -621,7 +628,7 @@ , name = name , entries = [] , children = Nothing - , format = Nothing + , ext = def } -- | Decode an argument in the node. @@ -843,7 +850,7 @@ } pure b where - emptyNodeList = NodeList{nodes = [], format = Nothing} + emptyNodeList = NodeList{nodes = [], ext = def} {----- Decoding ValueData -----} @@ -1014,7 +1021,7 @@ -- | Decode a KDL text value. text :: DecodeArrow Value a Text text = valueDataDecoderPrim (SchemaOne TextSchema) $ \case - Value{data_ = Text s} -> pure s + Value{data_ = String s} -> pure s v -> decodeThrow DecodeError_ValueDecodeFail{expectedType = "text", value = v} -- | Decode a KDL number value. diff --git a/src/KDL/Decoder/Internal/DecodeM.hs b/src/KDL/Decoder/Internal/DecodeM.hs --- a/src/KDL/Decoder/Internal/DecodeM.hs +++ b/src/KDL/Decoder/Internal/DecodeM.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoFieldSelectors #-} @@ -70,7 +71,7 @@ -- This error is non-fatal and can be handled by '<|>'. See 'makeFatal' -- for more information. decodeThrow :: BaseDecodeError -> DecodeM a -decodeThrow e = DecodeM $ \_ onFail _ -> onFail $ DecodeError [([], e)] +decodeThrow e = DecodeM $ \_ onFail _ -> onFail $ DecodeError Nothing [([], e)] -- | Throw a 'DecodeError_Custom' error. failM :: Text -> DecodeM a @@ -91,4 +92,4 @@ addContext :: ContextItem -> DecodeM a -> DecodeM a addContext ctxItem (DecodeM f) = DecodeM $ \onFatal onFail onSuccess -> f (onFatal . addCtx) (onFail . addCtx) onSuccess where - addCtx (DecodeError es) = DecodeError [(ctxItem : ctx, msg) | (ctx, msg) <- es] + addCtx e = e{errors = [(ctxItem : ctx, msg) | (ctx, msg) <- e.errors]} diff --git a/src/KDL/Decoder/Internal/Error.hs b/src/KDL/Decoder/Internal/Error.hs --- a/src/KDL/Decoder/Internal/Error.hs +++ b/src/KDL/Decoder/Internal/Error.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoFieldSelectors #-} @@ -12,6 +13,7 @@ renderDecodeError, ) where +import Control.Applicative ((<|>)) import Data.Map qualified as Map import Data.Text (Text) import Data.Text qualified as Text @@ -24,12 +26,15 @@ Value, ) -data DecodeError = DecodeError [(Context, BaseDecodeError)] +data DecodeError = DecodeError + { filepath :: Maybe FilePath + , errors :: [(Context, BaseDecodeError)] + } deriving (Show, Eq) instance Semigroup DecodeError where - DecodeError e1 <> DecodeError e2 = DecodeError (e1 <> e2) + DecodeError fp1 e1 <> DecodeError fp2 e2 = DecodeError (fp1 <|> fp2) (e1 <> e2) instance Monoid DecodeError where - mempty = DecodeError [] + mempty = DecodeError Nothing [] type Context = [ContextItem] @@ -60,13 +65,24 @@ deriving (Show, Eq) renderDecodeError :: DecodeError -> Text -renderDecodeError = Text.intercalate "\n" . map renderCtxErrors . groupCtxErrors +renderDecodeError decodeError = + Text.intercalate "\n" + . concatMap renderCtxErrors + . groupCtxErrors + $ decodeError.errors where -- Group errors with the same contexts together - groupCtxErrors (DecodeError es) = Map.toAscList $ Map.fromListWith (<>) [(ctx, [e]) | (ctx, e) <- es] + groupCtxErrors es = Map.toAscList $ Map.fromListWith (<>) [(ctx, [e]) | (ctx, e) <- es] - renderCtxErrors (ctx, errs) = - Text.intercalate "\n" $ ("At: " <> renderCtxItems ctx) : renderErrors errs + addPath = + case decodeError.filepath of + Nothing -> id + Just fp -> let msg = "Failed to decode " <> Text.pack fp <> ":" in (msg :) + + renderCtxErrors = \case + -- Special case parse errors, which shouldn't have a context + (_, [DecodeError_ParseError msg]) -> [msg] + (ctx, errs) -> addPath $ ("At: " <> renderCtxItems ctx) : renderErrors errs renderCtxItems items | null items = "" diff --git a/src/KDL/Parser.hs b/src/KDL/Parser.hs --- a/src/KDL/Parser.hs +++ b/src/KDL/Parser.hs @@ -1,91 +1,44 @@ +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-| +Implement the v2 parser specified at: https://kdl.dev/spec/#name-full-grammar +-} module KDL.Parser ( parse, parseFile, + + -- * Configurable parsing + ParseConfig (..), + parseWith, + parseFileWith, ) where -import Data.Map qualified as Map +import Data.Bifunctor (first) +import Data.Default (def) import Data.Text (Text) import Data.Text qualified as Text import Data.Text.IO qualified as Text -import KDL.Parser.Hustle qualified as Hustle -import KDL.Types ( - Ann (..), - Document, - Entry (..), - Identifier (..), - Node (..), - NodeList (..), - Value (..), - ValueData (..), - ValueFormat (..), +import KDL.Parser.Internal ( + ParseConfig (..), + p_document, + runParser, ) +import KDL.Types (Document) +import Text.Megaparsec qualified as Megaparsec --- TODO: Implement our own parser that implements the v2.0.0 spec + preserves formatting and comments parse :: Text -> Either Text Document -parse input = - case Hustle.parse Hustle.document "" input of - Left e -> Left . Text.strip . Text.pack . Hustle.errorBundlePretty $ e - Right (Hustle.Document nodes) -> Right $ fromNodes nodes - where - fromNodes nodes = - NodeList - { nodes = map fromNode nodes - , format = Nothing - } - - fromAnn identifier = - Ann - { identifier = fromIdentifier identifier - , format = Nothing - } - - fromNode Hustle.Node{..} = - Node - { ann = fromAnn <$> nodeAnn - , name = fromIdentifier nodeName - , entries = map fromArgEntry nodeArgs <> map fromPropEntry (Map.toList nodeProps) - , children = Just $ fromNodes nodeChildren - , format = Nothing - } - - fromArgEntry v = - Entry - { name = Nothing - , value = fromValue v - , format = Nothing - } - - fromPropEntry (name, v) = - Entry - { name = Just $ fromIdentifier name - , value = fromValue v - , format = Nothing - } +parse = parseWith def - fromValue Hustle.Value{..} = - Value - { ann = fromAnn <$> valueAnn - , data_ = - case valueExp of - Hustle.StringValue s -> Text s - Hustle.IntegerValue x -> Number (fromInteger x) - Hustle.SciValue x -> Number x - Hustle.BooleanValue x -> Bool x - Hustle.NullValue -> Null - , format = - case valueExp of - Hustle.IntegerValue x -> Just ValueFormat{repr = Text.pack $ show x} - _ -> Nothing - } +parseFile :: FilePath -> IO (Either Text Document) +parseFile = parseFileWith def - fromIdentifier (Hustle.Identifier s) = - Identifier - { value = s - , format = Nothing - } +parseWith :: ParseConfig -> Text -> Either Text Document +parseWith config input = + first (Text.strip . Text.pack . Megaparsec.errorBundlePretty) $ + runParser config p_document input -parseFile :: FilePath -> IO (Either Text Document) -parseFile = fmap parse . Text.readFile +parseFileWith :: ParseConfig -> FilePath -> IO (Either Text Document) +parseFileWith config0 fp = parseWith config <$> Text.readFile fp + where + config = config0{filepath = fp} diff --git a/src/KDL/Parser/Hustle.hs b/src/KDL/Parser/Hustle.hs deleted file mode 100644 --- a/src/KDL/Parser/Hustle.hs +++ /dev/null @@ -1,28 +0,0 @@ -{- FOURMOLU_DISABLE -} - -{- | Vendered from https://github.com/fuzzypixelz/hustle -} -module KDL.Parser.Hustle - ( Parser - , Document(..) - , Node(..) - , Value(..) - , ValueType(..) - , Identifier(..) - , pretty - , document - , parse - , errorBundlePretty - ) where - -import KDL.Parser.Hustle.Formatter ( Pretty(pretty) ) -import KDL.Parser.Hustle.Parser ( document ) -import KDL.Parser.Hustle.Types ( Document(..) - , Identifier(..) - , Node(..) - , Parser - , Value(..) - , ValueType(..) - ) -import Text.Megaparsec ( errorBundlePretty - , parse - ) diff --git a/src/KDL/Parser/Hustle/Formatter.hs b/src/KDL/Parser/Hustle/Formatter.hs deleted file mode 100644 --- a/src/KDL/Parser/Hustle/Formatter.hs +++ /dev/null @@ -1,83 +0,0 @@ -{- FOURMOLU_DISABLE -} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -{- | Vendered from https://github.com/fuzzypixelz/hustle -} -module KDL.Parser.Hustle.Formatter - ( Pretty(pretty) - ) where - -import Data.Map ( Map ) -import qualified Data.Map.Strict as Map -import Data.Maybe ( catMaybes ) -import Data.Scientific ( Scientific ) -import qualified Data.Text as T -import KDL.Parser.Hustle.Internal ( escChar - , match - ) -import KDL.Parser.Hustle.Parser ( identifier ) -import KDL.Parser.Hustle.Types -import Prettyprinter ( Pretty(pretty) - , braces - , dquotes - , enclose - , hsep - , nest - , parens - , viaShow - , vsep - ) - -instance Pretty Scientific where - pretty = viaShow - -instance Pretty Identifier where - pretty (Identifier i) = - if match identifier i then pretty i else dquotes (pretty i) - -instance Pretty Value where - pretty v = vann <> vexp - where - vann = case valueAnn v of - Nothing -> "" - Just a -> parens (pretty a) - vexp = case valueExp v of - StringValue s -> dquotes . pretty $ T.concatMap escChar s - IntegerValue i -> pretty i - SciValue s -> pretty s - BooleanValue b -> if b then "true" else "false" - NullValue -> "null" - -instance Pretty (Map Identifier Value) where - pretty ps = hsep . Map.elems $ Map.mapWithKey prop ps - where prop i v = pretty i <> "=" <> pretty v - -instance Pretty Node where - pretty n = hsep . catMaybes $ [nname, nargs, nprops, nchildren] - where - nann = case nodeAnn n of - Nothing -> "" - Just a -> parens (pretty a) - nname = Just $ nann <> pretty (nodeName n) - nargs = case nodeArgs n of - [] -> Nothing - nas -> Just . hsep . map pretty $ nas - nprops | nodeProps n == Map.empty = Nothing - | otherwise = Just (pretty (nodeProps n)) - nchildren = case nodeChildren n of - [] -> Nothing - ncs -> - Just - . nest 4 - . braces - . enclose "\n" (nest (-4) "\n") - . vsep - . map pretty - $ ncs - -instance Pretty Document where - pretty d = vsep (map pretty (docNodes d)) <> "\n" - -instance Show Document where - show d = show (pretty d) diff --git a/src/KDL/Parser/Hustle/Internal.hs b/src/KDL/Parser/Hustle/Internal.hs deleted file mode 100644 --- a/src/KDL/Parser/Hustle/Internal.hs +++ /dev/null @@ -1,96 +0,0 @@ -{- FOURMOLU_DISABLE -} -{-# LANGUAGE OverloadedStrings #-} - -{- | Vendered from https://github.com/fuzzypixelz/hustle -} -module KDL.Parser.Hustle.Internal where - -import Control.Monad ( void ) -import Data.Char ( digitToInt - , isDigit - ) -import Data.Either ( isRight ) -import Data.Scientific ( Scientific ) -import qualified Data.Scientific as Sci -import Data.Text ( Text ) -import qualified Data.Text as T -import KDL.Parser.Hustle.Types ( Parser ) -import Text.Megaparsec ( (<|>) - , MonadParsec - ( eof - , takeWhileP - , try - ) - , option - , runParser - , satisfy - ) -import Text.Megaparsec.Char ( char - , char' - , digitChar - , newline - ) -import qualified Text.Megaparsec.Char.Lexer as L - -signed :: Num a => Parser a -> Parser a -signed p = option id sign <*> p - where sign = (id <$ char '+') <|> (negate <$ char '-') - -lineComment :: Parser () -lineComment = L.skipLineComment "//" >> (void newline <|> eof) - -blockComment :: Parser () -blockComment = L.skipBlockCommentNested "/*" "*/" - -isBinDigit :: Char -> Bool -isBinDigit c = c `elem` ['0', '1'] - -data SP = SP Integer Int - -number :: Integer -> (Char -> Bool) -> Parser Integer -number b isNumDigit = mkNum . T.filter (/= '_') <$> digits - where - mkNum = T.foldl' step 0 - step a c = a * b + fromIntegral (digitToInt c) - digits = T.cons <$> satisfy isNumDigit <*> takeWhileP - (Just "digit") - (\c -> isNumDigit c || c == '_') - -decimal_ :: Parser Integer -decimal_ = number 10 isDigit - -scientific_ :: Parser Scientific -scientific_ = do - c' <- decimal_ - SP c e' <- dotDecimal_ c' - e <- option e' (try $ exponent_ e') - return (Sci.scientific c e) - -dotDecimal_ :: Integer -> Parser SP -dotDecimal_ c' = do - void (char '.') - let digits = T.cons <$> digitChar <*> takeWhileP - (Just "digit") - (\c -> isDigit c || c == '_') - let mkNum = T.foldl' step (SP c' 0) - step (SP a e') c = SP (a * 10 + fromIntegral (digitToInt c)) (e' - 1) - mkNum . T.filter (/= '_') <$> digits - -exponent_ :: Int -> Parser Int -exponent_ e' = do - void (char' 'e') - (+ e') <$> L.signed (return ()) (fromIntegral <$> decimal_) - -match :: Parser a -> Text -> Bool -match p t = isRight $ runParser (p >> eof) "" t - -escChar :: Char -> Text -escChar c = case c of - '\x08' -> "\\b" - '\x09' -> "\\t" - '\x0A' -> "\\n" - '\x0C' -> "\\f" - '\x0D' -> "\\r" - '\x22' -> "\\\"" - '\x2F' -> "\\/" - '\x5C' -> "\\\\" - _ -> T.singleton c diff --git a/src/KDL/Parser/Hustle/Parser.hs b/src/KDL/Parser/Hustle/Parser.hs deleted file mode 100644 --- a/src/KDL/Parser/Hustle/Parser.hs +++ /dev/null @@ -1,310 +0,0 @@ -{- FOURMOLU_DISABLE -} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -{- | Vendered from https://github.com/fuzzypixelz/hustle -} -module KDL.Parser.Hustle.Parser where - -import KDL.Parser.Hustle.Internal -import KDL.Parser.Hustle.Types - -import Control.Monad ( void ) -import Data.Char ( chr - , isHexDigit - , isOctDigit - , isDigit - , isSpace - ) -import qualified Data.Map.Strict as Map -import Data.Maybe ( catMaybes - , fromMaybe - , mapMaybe - , maybeToList - ) -import Data.Scientific ( Scientific ) -import Data.Text ( Text ) -import qualified Data.Text as T -import Text.Megaparsec ( () - , (<|>) - , MonadParsec(eof, label, try) - , anySingle - , between - , choice - , many - , manyTill - , noneOf - , optional - , satisfy - , some - ) -import Text.Megaparsec.Char ( char - , char' - , crlf - , newline - , string - ) - --- WHITESPACE - -escline :: Parser () -escline = - char '\\' >> many ws >> (try linebreak <|> lineComment) "Escape Line" - -linespace :: Parser () -linespace = try linebreak <|> try ws <|> try lineComment "Line Space" - -linebreak :: Parser () -linebreak = label "Newline" $ do - choice $ void crlf : map - void - [ char '\r' "carriage return" - , char '\n' "newline" - , char '\x85' "next line" - , char '\f' "form feed" - , char '\x2028' "line seperator" - , char '\x2029' "paragraph seperator" - ] - -ws :: Parser () -ws = bom <|> hspacechar <|> blockComment "Whitespace" - -bom :: Parser () -bom = void (char '\xFEFF') "BOM" - -hspacechar :: Parser () -hspacechar = label "Unicode Space" $ do - choice $ map - void - [ char '\x0009' "character tabulation" - , char '\x0020' "space" - , char '\x00A0' "bo-break space" - , char '\x1680' "ogham space mark" - , char '\x2000' "en quad" - , char '\x2001' "em quad" - , char '\x2002' "en space" - , char '\x2003' "em space" - , char '\x2004' "three-per-em space" - , char '\x2005' "four-per-em space" - , char '\x2006' "six-per-em space" - , char '\x2007' "figure space" - , char '\x2008' "punctuation space" - , char '\x2009' "thin space" - , char '\x200A' "hair space" - , char '\x202F' "narrow no-break space" - , char '\x205F' "medium mathmatical space" - , char '\x3000' "ideographic space" - ] - --- STRINGS - -anystring :: Parser Text -anystring = try unquotedstring <|> try rawstring <|> quotedstring - -unquotedstring :: Parser Text -unquotedstring = label "Unquoted String" $ do - c0 <- satisfy $ \c -> isValidChar c && not (isDigit c) && c /= '"' - rest <- many $ satisfy isValidChar - -- TODO: Forbid true, false, null, inf, -inf, nan, or "looks like a number" - pure $ T.pack (c0 : rest) - where - isValidChar c = not (isSpace c) && c `notElem` ("[]{}()\\/#\";=" :: [Char]) - -quotedstring :: Parser Text -quotedstring = label "Quoted String" $ do - T.concat <$> (char '"' *> manyTill character (char '"')) - -rawstring :: Parser Text -rawstring = label "Raw String" $ do - void (char 'r') - hs <- T.pack <$> many (char '#') - void (char '"') - s <- manyTill anySingle (string (T.cons '"' hs)) - return (T.pack s) - -character :: Parser Text -character = void (char '\\') *> escape <|> nonescape - -{- - As per the Haskell 2010 Language Report, - (https://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-200002.6) - The '\/' Solidus escape isn't defined, so if we try to parse it directly the - compiler throws a lexical error. Hence this terribleness. --} -escape :: Parser Text -escape = - do - e <- choice - [ '\x08' <$ char 'b' - , '\x09' <$ char 't' - , '\x0A' <$ char 'n' - , '\x0C' <$ char 'f' - , '\x0D' <$ char 'r' - , '\x22' <$ char '\"' - , '\x2F' <$ char '/' - , '\x5C' <$ char '\\' - ] - return (T.singleton e) - <|> uescape - -uescape :: Parser Text -uescape = do - void (string "u{") - u <- fromInteger <$> number 16 isHexDigit - if u >= 0x10ffff - then fail "Exceeded Unicode code point limit." - else do - void (char '}') - let c = chr u - return (T.singleton c) - -nonescape :: Parser Text -nonescape = do - c <- noneOf ("\\\"" :: [Char]) - return (T.singleton c) - --- NUMBERS - -binary :: Parser Integer -binary = signed $ char '0' >> char' 'b' >> number 2 isBinDigit - -octal :: Parser Integer -octal = signed $ char '0' >> char 'o' >> number 8 isOctDigit - -hexadecimal :: Parser Integer -hexadecimal = signed $ char '0' >> char 'x' >> number 16 isHexDigit - -integer :: Parser Integer -integer = signed decimal_ - -scientific :: Parser Scientific -scientific = signed scientific_ - --- CONTENT - -name :: Parser Identifier -name = Identifier <$> (try anystring <|> identifier) - -identifier :: Parser Text -identifier = label "Identifier" $ do - i <- satisfy iichar - is <- many (satisfy ichar) - let result = T.pack (i : is) - case result of - "true" -> fail "keyword true in identifier" - "false" -> fail "keyword false in identifier" - "null" -> fail "keyword null in identifier" - _ -> return result - where - ichar c = - (c > '\x20') - && (c <= '\x10FFFF') - && (c `notElem` ("\\/(){}<>;[]=,\"" :: [Char])) - && not (match linespace (T.singleton c)) - iichar c = ichar c && c `notElem` ['0' .. '9'] - -nullvalue :: Parser Text -nullvalue = string "#null" - -bool :: Parser Bool -bool = True <$ string "#true" <|> False <$ string "#false" - -property :: Parser (Identifier, Value) -property = label "Property" $ do - propKey <- name - void (char '=') - propValue <- value - return (propKey, propValue) - -value :: Parser Value -value = label "Value" $ do - valueAnn <- optional typeAnnotation - valueExp <- choice - [ IntegerValue <$> try binary "Binary" - , IntegerValue <$> try octal "Octal" - , IntegerValue <$> try hexadecimal "Hexadecimal" - , SciValue <$> try scientific "Decimal" - , IntegerValue <$> try integer "Integer" - , BooleanValue <$> try bool "Boolean" - , NullValue <$ try nullvalue "Null" - , StringValue <$> anystring "String" - ] - return Value { .. } - -typeAnnotation :: Parser Identifier -typeAnnotation = label "Type Annotation" $ do - void (char '(') - i <- name - void (char ')') - return i - --- NODES - -nodes :: Parser [Node] -nodes = between (many linespace) (many linespace) (fromMaybe [] <$> body) - where - body = optional $ do - n <- maybeToList <$> node - ns <- fromMaybe [] <$> optional nodes - return (n ++ ns) - -node :: Parser (Maybe Node) -node = label "Node" $ do - discard <- optional comment - nodeAnn <- optional typeAnnotation - nodeName <- name - nodeContent <- catMaybes <$> content - nodeChildren <- fromMaybe [] <$> optional children - _ <- many nodespace - _ <- terminator - let nodeArgs = mapMaybe isArg nodeContent - nodeProps = Map.fromList $ mapMaybe isProp nodeContent - case discard of - Just _ -> return Nothing - Nothing -> return $ Just Node { .. } - where - isArg c = case c of - NodeValue v -> Just v - _ -> Nothing - isProp c = case c of - NodeProperty p -> Just p - _ -> Nothing - -content :: Parser [Maybe Content] -content = many . try $ do - void (some nodespace) - discard <- optional $ comment <* many nodespace - c <- choice [NodeProperty <$> try property, NodeValue <$> try value] - case discard of - Just _ -> return Nothing - Nothing -> return $ Just c - -children :: Parser [Node] -children = label "Node Child" . try $ do - void (many nodespace) - discard <- optional comment - void (char '{') - ns <- nodes - void (char '}') - void (many ws) - case discard of - Just _ -> return [] - Nothing -> return ns - -comment :: Parser () -comment = label "/-Comment" . try $ do - void (string "/-") - void $ many nodespace - -nodespace :: Parser () -nodespace = label "Node Space" $ do - try (many ws *> escline <* many ws) <|> try (void $ some ws) - -terminator :: Parser () -terminator = label "Node Terminator" $ do - choice [try (void (char ';')), try (void newline), try lineComment, eof] - -document :: Parser Document -document = do - docNodes <- nodes - void eof - return Document { .. } diff --git a/src/KDL/Parser/Hustle/Types.hs b/src/KDL/Parser/Hustle/Types.hs deleted file mode 100644 --- a/src/KDL/Parser/Hustle/Types.hs +++ /dev/null @@ -1,73 +0,0 @@ -{- FOURMOLU_DISABLE -} -{- | Vendered from https://github.com/fuzzypixelz/hustle -} -module KDL.Parser.Hustle.Types - ( Parser - , Document(..) - , Content(..) - , Node(..) - , Value(..) - , ValueType(..) - , Identifier(..) - ) where - -import Data.Map ( Map ) -import Data.Scientific ( Scientific ) -import Data.Text ( Text ) -import Data.Void ( Void ) -import Text.Megaparsec ( Parsec ) - -{- - String has exactly one use, - and that’s showing Hello World in tutorials. - -- Albert Einstein --} -type Parser = Parsec Void Text - -newtype Document = Document - { docNodes :: [Node] - } - deriving (Eq) - -{- - This data type serves as an abstraction over Values - and Properties of a Node, in order simplify the the node - Parser, i.e group the two types together to - consume any number of them in any order. --} -data Content - = NodeValue { getValue :: Value } - | NodeProperty { getProp :: (Identifier, Value) } - deriving (Eq) - -data Node = Node - { nodeAnn :: Maybe Identifier - , nodeName :: Identifier - , nodeArgs :: [Value] - , nodeProps :: Map Identifier Value - , nodeChildren :: [Node] - } - deriving (Show, Eq) - -newtype Identifier = Identifier Text - deriving (Show, Eq) - -data Value = Value - { valueAnn :: Maybe Identifier - , valueExp :: ValueType - } - deriving (Show, Eq) - -data ValueType - = StringValue Text - | IntegerValue Integer - | SciValue Scientific - | BooleanValue Bool - | NullValue - deriving (Show, Eq) - -{- - This allows for querying properties in alphabetical order - upon printing out, the rest is handled automatically by Map. --} -instance Ord Identifier where - Identifier t1 `compare` Identifier t2 = t1 `compare` t2 diff --git a/src/KDL/Parser/Internal.hs b/src/KDL/Parser/Internal.hs new file mode 100644 --- /dev/null +++ b/src/KDL/Parser/Internal.hs @@ -0,0 +1,1331 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoFieldSelectors #-} + +{-| +Implement the v2 parser specified at: https://kdl.dev/spec/#name-full-grammar +-} +module KDL.Parser.Internal ( + Parser, + ParseConfig (..), + runParser, + + -- * (1) Compatibility + p_bom, + p_version, + + -- * (3.1) Document + p_document, + p_nodes, + p_line_space, + p_node_space, + + -- * (3.2) Node + p_node, + p_base_node, + p_node_prop_or_arg, + p_node_terminator, + + -- * (3.3) Line Continuation + p_escline, + + -- * (3.4) Property + p_prop, + + -- * (3.5) Argument + p_value'Entry, + + -- * (3.6) Children Block + p_node_children, + + -- * (3.7) Value + p_value, + p_keyword, + + -- * (3.8) Type Annotation + p_type, + + -- * (3.9) String + p_string'Identifier, + p_string, + + -- * (3.10) Identifier String + p_identifier_string, + isValidUnquotedString, + p_unambiguous_ident, + p_signed_ident, + disallowed_keyword_identifiers, + p_dotted_ident, + p_identifier_char, + + -- * (3.11) Quoted String + p_quoted_string, + p_single_line_string_body, + p_string_character, + p_hex_unicode, + p_ws_escape, + + -- * (3.12) Multi-line String + p_multi_line_string_body, + + -- * (3.13) Raw String + p_raw_string, + p_raw_string_quotes, + p_single_line_raw_string_body, + p_single_line_raw_string_char, + p_multi_line_raw_string_body, + + -- * (3.14) Number + p_number, + p_hex, + p_hex_digit, + p_octal, + p_binary, + p_decimal, + p_integer, + p_digits, + p_exponent, + p_sign, + p_keyword_number, + + -- * (3.15) Boolean + p_boolean, + + -- * (3.17) Whitespace + p_ws, + p_unicode_space, + p_single_line_comment, + p_multi_line_comment, + p_slashdash, + + -- * (3.18) Newline + p_newline, + + -- * (3.19) Disallowed Literal Code Points + is_disallowed_literal_code_points, + + -- * Unicode + p_unicode, + is_unicode_scalar_value, +) where + +import Control.Monad (guard, void, (>=>)) +import Control.Monad.Trans.Class qualified as Trans +import Control.Monad.Trans.Reader qualified as Reader +import Control.Monad.Trans.State.Strict (StateT, evalStateT) +import Control.Monad.Trans.State.Strict qualified as State +import Data.Bifunctor (bimap) +import Data.Bits (toIntegralSized) +import Data.Char ( + chr, + digitToInt, + isDigit, + isHexDigit, + isOctDigit, + isSpace, + ord, + ) +import Data.Default (Default (..)) +import Data.Either (isRight) +import Data.Foldable (foldlM, traverse_) +import Data.Foldable qualified as Seq (toList) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Maybe (catMaybes, fromMaybe, isJust) +import Data.Scientific (Scientific) +import Data.Scientific qualified as Scientific +import Data.Sequence qualified as Seq +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Void (Void) +import KDL.Types ( + Ann (..), + AnnExtension (..), + AnnFormat (..), + Document, + Entry (..), + EntryExtension (..), + EntryFormat (..), + Identifier (..), + IdentifierExtension (..), + IdentifierFormat (..), + Node (..), + NodeExtension (..), + NodeFormat (..), + NodeList (..), + NodeListExtension (..), + NodeListFormat (..), + Span (..), + Value (..), + ValueData (..), + ValueExtension (..), + ValueFormat (..), + ) +import KDL.Types qualified as AnnExtension (AnnExtension (..)) +import KDL.Types qualified as AnnFormat (AnnFormat (..)) +import KDL.Types qualified as EntryExtension (EntryExtension (..)) +import KDL.Types qualified as EntryFormat (EntryFormat (..)) +import KDL.Types qualified as Node (Node (..)) +import KDL.Types qualified as NodeExtension (NodeExtension (..)) +import KDL.Types qualified as NodeFormat (NodeFormat (..)) +import KDL.Types qualified as NodeListExtension (NodeListExtension (..)) +import KDL.Types qualified as NodeListFormat (NodeListFormat (..)) +import Text.Megaparsec hiding (runParser) +import Text.Megaparsec.Char +import Prelude hiding (span) + +#if !MIN_VERSION_base(4,20,0) +import Data.Foldable (foldl') +#endif + +data ParseConfig = ParseConfig + { filepath :: FilePath + , includeSpans :: Bool + } + +instance Default ParseConfig where + def = + ParseConfig + { filepath = "" + , includeSpans = False + } + +type Parser = ParsecT Void Text (Reader.Reader ParseConfig) + +runParser :: ParseConfig -> Parser a -> Text -> Either (ParseErrorBundle Text Void) a +runParser config p = (`Reader.runReader` config) . runParserT p config.filepath + +{----- (1) Compatibility -----} + +-- | ref: (1) +-- bom := '\u{FEFF}' +p_bom :: Parser () +p_bom = label "BOM" $ do + void $ string "\xFEFF" + +-- | ref: (1) +-- version := +-- '/-' unicode-space* 'kdl-version' unicode-space+ ('1' | '2') +-- unicode-space* newline +p_version :: Parser () +p_version = label "version" $ do + _ <- string "/-" + _ <- many p_unicode_space + _ <- string "kdl-version" + _ <- some p_unicode_space + _ <- oneOf ['1', '2'] + _ <- many p_unicode_space + _ <- p_newline + pure () + +{----- (3.1) Document -----} + +-- | ref: (3.1) +-- document := bom? version? nodes +p_document :: Parser Document +p_document = do + bom <- hidden . option "" . withSource_ $ p_bom + version <- hidden . option "" . withSource_ $ try p_version + nodes <- p_nodes + hidden eof + pure . prependLeading bom . prependLeading version $ nodes + +-- | ref: (3.1) +-- nodes := (line-space* node)* line-space* +p_nodes :: Parser NodeList +p_nodes = label "nodes" $ do + -- The grammar is left-associative, but we do right-associative to get + -- correct backtracking semantics + good parse errors + initialWS <- withSource_ $ many p_line_space + (results, span) <- withSpan . fmap concat . manyWhile $ do + (sdash, parseNode) <- p_node + (result, continue) <- + resolveSlashdash sdash parseNode >>= \case + Left src -> pure (Left src, True) + Right (node, hasTerminator) -> pure (Right node, hasTerminator) + trailing <- withSource_ $ many p_line_space + pure ([result, Left trailing], continue) + let (nodes, leftoverWS) = mergeLeadingWS initialWS results + -- If there are no nodes, all the whitespace should be considered leading + -- whitespace. Otherwise, the leftover whitespace (e.g. slashdashed nodes + -- at the end) are trailing whitespace. + let (leading, trailing) = + if null nodes + then (leftoverWS, "") + else ("", leftoverWS) + ext = + NodeListExtension + { format = Just NodeListFormat{..} + , span + } + pure NodeList{..} + where + manyWhile :: Parser (a, Bool) -> Parser [a] + manyWhile p = + optional p >>= \case + Nothing -> pure [] + Just (a, continue) -> fmap (a :) . option [] $ if continue then manyWhile p else empty + +-- | ref: (3.1) + (3.17) +-- // Whitespace where newlines are allowed. +-- line-space := node-space | newline | single-line-comment +p_line_space :: Parser () +p_line_space = hidden $ do + void . choice $ + [ p_node_space + , void p_newline + , void p_single_line_comment + ] + +-- | ref: (3.1) + (3.17) +-- // Whitespace within nodes, +-- // where newline-ish things must be esclined. +-- node-space := ws* escline ws* | ws+ +p_node_space :: Parser () +p_node_space = hidden $ do + void . choice . map try $ + [ many p_ws *> p_escline *> many p_ws + , some p_ws + ] + +{----- (3.2) Node -----} + +-- | ref: (3.2) +-- node := base-node node-terminator +-- final-node := base-node node-terminator? +p_node :: Parser (SlashdashResult, Parser (Node, Bool)) +p_node = label "node" $ do + (sdash, parseNode) <- p_base_node + pure . (sdash,) $ do + spanStart <- startSpan + node <- parseNode + mTerminator <- optional p_node_terminator + span <- finishSpan spanStart + let node' = + case mTerminator of + Just terminator -> + node + { Node.ext = + node.ext + { NodeExtension.format = setTerminator terminator <$> node.ext.format + , NodeExtension.span = span + } + } + Nothing -> node + pure (node', isJust mTerminator) + where + setTerminator terminator format = + format + { NodeFormat.beforeTerminator = format.trailing + , NodeFormat.terminator = terminator + , NodeFormat.trailing = "" + } + +-- | ref: (3.2) +-- base-node := slashdash? type? node-space* string +-- (node-space* (node-space | slashdash) node-prop-or-arg)* +-- // slashdashed node-children must always be after props and args. +-- (node-space* slashdash node-children)* +-- (node-space* node-children)? +-- (node-space* slashdash node-children)* +-- node-space* +p_base_node :: Parser (SlashdashResult, Parser Node) +p_base_node = label "base node" $ do + sdash <- option NoSlashdash p_slashdash + pure . (sdash,) $ do + spanStart <- startSpan + + -- node ann + initialAnn <- optional p_type + postAnnWS <- withSource_ $ many p_node_space + let (ann, leading) = + case initialAnn of + Just a -> (Just $ appendTrailing postAnnWS a, "") + Nothing -> (Nothing, postAnnWS) + + -- node name + name <- p_string'Identifier + + -- node entries + (entries, postEntriesWS) <- mergeLeadingWS "" <$> p_entries + + -- slashdashed node-children #1 + slashdashedChildren1 <- p_slashdashed_children + + -- node children + let unzipMaybe = maybe (Nothing, Nothing) (\(a, b) -> (Just a, Just b)) + (preChildrenWS, children) <- fmap unzipMaybe . optional $ do + -- Make sure a children block is coming up before we commit to consuming + -- the whitespace as pre-children whitespace + _ <- lookAhead $ try $ many p_node_space *> label "children block" (char '{') + (,) + <$> withSource_ (many p_node_space) + <*> p_node_children + let beforeChildren = postEntriesWS <> slashdashedChildren1 <> fromMaybe "" preChildrenWS + + span <- finishSpan spanStart + + -- slashdashed node-children #2 + slashdashedChildren2 <- p_slashdashed_children + + -- trailing space + postChildrenWS <- withSource_ $ many p_node_space + let trailing = slashdashedChildren2 <> postChildrenWS + + -- set by caller + let beforeTerminator = "" + terminator = "" + + let ext = + NodeExtension + { format = Just NodeFormat{..} + , span + } + + pure Node{..} + where + -- (node-space* (node-space | slashdash) node-prop-or-arg)* + p_entries = fmap concat . many . label "node prop or arg" $ do + -- make sure this is not the pre-children whitespace or post-node whitespace + -- so that we can commit to this being node-prop-or-arg whitespace + notFollowedBy $ do + _ <- many p_node_space + _ <- optional p_slashdash + choice + [ void (char '{') + , void (char '}') + , void p_node_terminator + ] + leading <- withSource_ $ many p_node_space + -- if there was no node-space, it _must_ be a slashdash + sdash <- (if Text.null leading then id else option NoSlashdash) p_slashdash + entry <- resolveSlashdash sdash p_node_prop_or_arg + pure [Left leading, entry] + + -- (node-space* slashdash node-children)* + p_slashdashed_children = + withSource_ . many . try $ do + _ <- many p_node_space + _ <- p_slashdash + _ <- p_node_children + pure () + +-- | ref: (3.2) +-- node-prop-or-arg := prop | value +p_node_prop_or_arg :: Parser Entry +p_node_prop_or_arg = label "node entry" $ do + try p_prop <|> p_value'Entry + +-- | ref: (3.2) +-- node-terminator := single-line-comment | newline | ';' | eof +p_node_terminator :: Parser Text +p_node_terminator = label "end of node" $ do + choice + [ p_single_line_comment + , p_newline + , string ";" + , p_eof + ] + +{----- (3.3) Line Continuation -----} + +-- | ref: (3.3) +-- escline := '\\' ws* (single-line-comment | newline | eof) +p_escline :: Parser () +p_escline = label "escline" $ do + _ <- string "\\" + _ <- many p_ws + _ <- p_single_line_comment <|> p_newline <|> p_eof + pure () + +{----- (3.4) Property -----} + +-- | ref: (3.4) +-- prop := string node-space* '=' node-space* value +p_prop :: Parser Entry +p_prop = label "property" $ do + spanStart <- startSpan + name <- p_string'Identifier + afterKey <- withSource_ $ many p_node_space + _ <- char '=' + afterEq <- withSource_ $ many p_node_space + (value, leading) <- p_value + span <- finishSpan spanStart + let format = + EntryFormat + { leading + , afterKey + , afterEq + , trailing = "" + } + ext = EntryExtension{format = Just format, span} + pure Entry{name = Just name, ..} + +{----- (3.5) Argument -----} + +-- | ref: (3.5) +p_value'Entry :: Parser Entry +p_value'Entry = label "argument" $ do + ((value, leading), span) <- withSpan p_value + let format = + EntryFormat + { leading + , afterKey = "" + , afterEq = "" + , trailing = "" + } + ext = + EntryExtension + { format = Just format + , span + } + pure Entry{name = Nothing, ..} + +{----- (3.6) Children Block -----} + +-- | ref: (3.6) +-- node-children := '{' nodes final-node? '}' +p_node_children :: Parser NodeList +p_node_children = label "children block" $ do + between (char '{') (char '}') $ do + p_nodes -- 'final-node?' logic is in p_nodes / p_node + +{----- (3.7) Value -----} + +-- | ref: (3.7) +-- value := type? node-space* (string | number | keyword) +p_value :: Parser (Value, Text) +p_value = label "value" $ do + spanStart <- startSpan + initialAnn <- optional p_type + postAnnWS <- withSource_ $ many p_node_space + let (ann, leading) = + case initialAnn of + Just a -> (Just $ appendTrailing postAnnWS a, "") + Nothing -> (Nothing, postAnnWS) + + (data_, repr_) <- + withSource . choice . map try $ + [ String <$> p_string + , p_number + , p_keyword + ] + let repr = Just repr_ + span <- finishSpan spanStart + + let ext = + ValueExtension + { format = Just ValueFormat{..} + , span + } + pure (Value{..}, leading) + +-- | ref: (3.7) +p_keyword :: Parser ValueData +p_keyword = label "value keyword" $ do + choice . map try $ + [ Bool <$> p_boolean + , Null <$ string "#null" + ] + +{----- (3.8) Type Annotation -----} + +-- | ref: (3.8) +-- type := '(' node-space* string node-space* ')' +p_type :: Parser Ann +p_type = label "type annotation" $ do + ((identifier, format), span) <- + withSpan . between (char '(') (char ')') $ do + beforeId <- withSource_ $ many p_node_space + identifier <- p_string'Identifier + afterId <- withSource_ $ many p_node_space + let format = Just AnnFormat{leading = "", trailing = "", ..} + pure (identifier, format) + + let ext = AnnExtension{format, span} + pure Ann{identifier, ext} + +{----- (3.9) String -----} + +-- | ref: (3.9) +p_string'Identifier :: Parser Identifier +p_string'Identifier = do + ((value, repr_), span) <- withSpan . withSource $ p_string + let repr = Just repr_ + let ext = IdentifierExtension{format = Just IdentifierFormat{..}, span} + pure Identifier{..} + +-- | ref: (3.9) +-- string := identifier-string | quoted-string | raw-string ¶ +p_string :: Parser Text +p_string = label "string" $ do + choice + [ p_identifier_string + , p_quoted_string + , p_raw_string + ] + +{----- (3.10) Identifier String -----} + +-- | ref: (3.10) +-- identifier-string := unambiguous-ident | signed-ident | dotted-ident +p_identifier_string :: Parser Text +p_identifier_string = label "unquoted string" $ do + choice . map try $ + [ p_unambiguous_ident + , p_signed_ident + , p_dotted_ident + ] + +isValidUnquotedString :: Text -> Bool +isValidUnquotedString = isRight . runParser def (p_identifier_string <* eof) + +-- | ref: (3.10) +-- unambiguous-ident := +-- ((identifier-char - digit - sign - '.') identifier-char*) +-- - disallowed-keyword-identifiers +p_unambiguous_ident :: Parser Text +p_unambiguous_ident = label "unquoted string" $ do + c <- p_identifier_char + guard $ not $ isDigit c || c `elem` ['-', '+', '.'] + cs <- many p_identifier_char + let s = Text.pack (c : cs) + guard $ s `Set.notMember` disallowed_keyword_identifiers + pure s + +-- | ref: (3.10) +-- signed-ident := +-- sign ((identifier-char - digit - '.') identifier-char*)? +p_signed_ident :: Parser Text +p_signed_ident = do + c0 <- p_sign + cs <- option "" $ do + c1 <- p_identifier_char + guard $ not $ isDigit c1 || c1 == '.' + cs <- many p_identifier_char + pure (c1 : cs) + pure $ Text.pack (c0 : cs) + +-- | ref: (3.10) +-- disallowed-keyword-identifiers := +-- 'true' | 'false' | 'null' | 'inf' | '-inf' | 'nan' +disallowed_keyword_identifiers :: Set Text +disallowed_keyword_identifiers = + Set.fromList + [ "true" + , "false" + , "null" + , "inf" + , "-inf" + , "nan" + ] + +-- | ref: (3.10) +-- dotted-ident := +-- sign? '.' ((identifier-char - digit) identifier-char*)? +p_dotted_ident :: Parser Text +p_dotted_ident = do + c0 <- option "" $ Text.singleton <$> p_sign + c1 <- single '.' + cs <- option "" $ do + c2 <- p_identifier_char + guard $ not $ isDigit c2 + cs <- many p_identifier_char + pure (c2 : cs) + pure $ c0 <> Text.pack (c1 : cs) + +-- | ref: (3.10.2) +-- identifier-char := +-- unicode - unicode-space - newline - [\\/(){};\[\]"#=] +-- - disallowed-literal-code-points +p_identifier_char :: Parser Char +p_identifier_char = do + satisfy $ \c -> Text.singleton c `Set.notMember` invalid && (not . is_disallowed_literal_code_points) c + where + invalid = + Set.unions + [ Set.map Text.singleton chars_unicode_space + , chars_newline + , Set.map Text.singleton $ Set.fromList "\\/(){};[]\"#=" + ] + +{----- (3.11) Quoted String -----} + +-- | ref: (3.11) + (3.12) +-- quoted-string := +-- '"' single-line-string-body '"' | +-- '"""' newline +-- (multi-line-string-body newline)? +-- (unicode-space | ws-escape)* '"""' +p_quoted_string :: Parser Text +p_quoted_string = label "quoted string" $ do + choice + [ between (string quotes3) (string quotes3) $ do + parseMultilineString + p_multi_line_string_body + ( repeat0 . choice $ + [ Text.singleton <$> p_unicode_space + , "" <$ p_ws_escape + ] + ) + , between (string quotes1) (string quotes1) $ do + p_single_line_string_body + ] + +-- | ref: (3.11) +-- single-line-string-body := (string-character - newline)* +p_single_line_string_body :: Parser Text +p_single_line_string_body = label "quoted string line" $ do + repeat0 $ p_string_character (Just p_newline) + +-- | ref: (3.11) +-- string-character := +-- '\\' (["\\bfnrts] | +-- 'u{' hex-unicode '}') | +-- ws-escape | +-- [^\\"] - disallowed-literal-code-points +p_string_character :: Maybe (Parser invalid) -> Parser Text +p_string_character invalid = label "string character" $ do + choice . map try $ + [ do + _ <- char '\\' + fmap Text.singleton . choice $ + [ char '"' + , char '\\' + , char 'b' *> pure '\b' + , char 'f' *> pure '\f' + , char 'n' *> pure '\n' + , char 'r' *> pure '\r' + , char 't' *> pure '\t' + , char 's' *> pure ' ' + , between (string "u{") (string "}") $ do + chr <$> p_hex_unicode + ] + , "" <$ p_ws_escape + , do + traverse_ notFollowedBy invalid + c <- satisfy (`notElem` ['\\', '"']) + guard $ not $ is_disallowed_literal_code_points c + pure $ Text.singleton c + ] + +-- | ref: (3.11.1) +-- hex-unicode := hex-digit{1, 6} - surrogate - above-max-scalar +-- surrogate := [0]{0, 2} [dD] [8-9a-fA-F] hex-digit{2} +-- // U+D800-DFFF: D 8 00 +-- // D F FF +-- above-max-scalar = [2-9a-fA-F] hex-digit{5} | +-- [1] [1-9a-fA-F] hex-digit{4} +p_hex_unicode :: Parser Int +p_hex_unicode = label "hex unicode" $ do + digits <- countBetween 1 6 p_hex_digit + guard $ (not . null) digits + let x = undigits 16 digits + guard $ is_unicode_scalar_value x + pure x + +-- | ref: (3.11.1.1) +-- ws-escape := '\\' (unicode-space | newline)+ +p_ws_escape :: Parser () +p_ws_escape = label "escaped Whitespace" $ do + char '\\' *> void (some $ void p_unicode_space <|> void p_newline) + +{----- (3.12) Multi-line String -----} + +-- | ref: (3.12) +-- multi-line-string-body := (('"' | '""')? string-character)* +-- +-- Requires some changes to the grammar: https://github.com/kdl-org/kdl/pull/552 +p_multi_line_string_body :: Parser end -> Parser MultilineChars +p_multi_line_string_body end = label "quoted multiline string body" $ do + manyTill (withSource validChar) (try . lookAhead $ end) + where + validChar = do + choice + [ string "\"\"" <* notFollowedBy (char '"') + , string "\"" <* notFollowedBy (char '"') + , p_string_character Nothing + ] + +-- | Characters in a multiline string. +-- +-- In simple cases, the input is effectively [(Char, Text)], containing +-- each character in the multiline string and its raw representation. This +-- distinguishes what the user actually wrote vs its semantic value; e.g. +-- '\s' is represented as (" ", "\s"). +-- +-- It needs to be (Text, Text) instead of (Char, Text) because some character +-- sequences are semantically an empty string (e.g. p_ws_escape) and a few can +-- return multiple characters (e.g. p_newline). +type MultilineChars = [(Text, Text)] + +type MultilineProcessorM a = StateT MultilineProcessorState Parser a +data MultilineProcessorState = MultilineProcessorState + { wsPrefix :: Text + , lineStartOffset :: Int + } + +-- | Parse a multiline string with the grammar: +-- +-- '"""' newline +-- ( newline)? +-- * '"""' +parseMultilineString :: + (forall end. Parser end -> Parser MultilineChars) -> + Parser Text -> + Parser Text +parseMultilineString parseBody parseEndSpace = do + _ <- p_newline -- Drop the first newline + State{stateOffset = startOffset} <- getParserState + mBody <- optional . try $ do + body <- parseBody (p_newline *> parseEndSpace *> string quotes3) + _ <- p_newline -- Drop the last newline + pure body + end <- parseEndSpace + case mBody of + Nothing -> pure "" + Just body -> do + let state = + MultilineProcessorState + { wsPrefix = end + , lineStartOffset = startOffset + } + body' <- flip evalStateT state $ mapLinesM processLine body + pure $ foldMap fst body' + where + processLine = rmPrefix . collapseWsOnlyLines + + collapseWsOnlyLines line = + let srcs = foldMap snd line + in if Text.all isSpace srcs + then [("", srcs)] + else line + + rmPrefix line0 = do + let go pre = \case + -- Consumed the full prefix, return the final line + line | Text.null pre -> pure line + -- The prefix starts with the source text; consume and continue matching the rest of the prefix + (_, src) : rest | Just pre' <- Text.stripPrefix src pre -> go pre' rest + -- Prefix did not match, return the initial line unchanged + _ -> do + offset <- State.gets (.lineStartOffset) + parseError . FancyError offset . Set.singleton $ + ErrorFail "Line does not have the correct indentation" + pre0 <- State.gets (.wsPrefix) + -- If the line is completely empty (e.g. after collapseWsOnlyLines), + -- there's no prefix to strip. + if all (Text.null . fst) line0 + then pure line0 + else go pre0 line0 + + mapLinesM :: + (MultilineChars -> MultilineProcessorM MultilineChars) -> + MultilineChars -> + MultilineProcessorM MultilineChars + mapLinesM f = + let resolveLine (buf, acc) = (acc <>) . Seq.fromList <$> f (Seq.toList buf) + go (buf, acc) (c, src) + -- If we're at a newline, `buf` contains the chars before the newline. + -- Apply the function and reset the buffer. The newline should be added + -- directly to the accumulator, since the newline isn't part of the line. + -- Per (3.12.1), newline characters are normalized to LF. + | c `Set.member` chars_newline = do + acc' <- resolveLine (buf, acc) + State.modify $ \s -> + let lineLen = sum . fmap Text.length $ fmap snd buf Seq.|> src + in s{lineStartOffset = s.lineStartOffset + lineLen} + pure (Seq.empty, acc' Seq.|> ("\n", src)) + -- Otherwise, append to the buffer and continue + | otherwise = do + pure (buf Seq.|> (c, src), acc) + in foldlM go (Seq.empty, Seq.empty) + -- Resolve line one last time to apply the function on the last line + >=> resolveLine + >=> (pure . Seq.toList) + +{----- (3.13) Raw String -----} + +-- | ref: (3.13) +-- raw-string := '#' raw-string-quotes '#' | '#' raw-string '#' +p_raw_string :: Parser Text +p_raw_string = label "raw string" $ do + -- For efficiency, we'll implement this slightly differently than the grammar + -- verbatim. Find all the hashes up front and use that to pass the closing + -- delimiter to the inner parsers. + delim <- withSource_ . some $ string "#" + s <- p_raw_string_quotes (string delim) + _ <- string delim + pure s + +-- | ref: (3.13) +-- raw-string-quotes := +-- '"' single-line-raw-string-body '"' | +-- '"""' newline +-- (multi-line-raw-string-body newline)? +-- unicode-space* '"""' +p_raw_string_quotes :: Parser end -> Parser Text +p_raw_string_quotes end = label "raw string quotes" $ do + choice + [ between (string quotes3) (string quotes3) $ do + parseMultilineString + p_multi_line_raw_string_body + (repeat0 $ Text.singleton <$> p_unicode_space) + , between (string quotes1) (string quotes1) . withSource_ $ do + p_single_line_raw_string_body (string quotes1 *> end) + ] + +-- | ref: (3.13) +-- single-line-raw-string-body := +-- '' | +-- (single-line-raw-string-char - '"') +-- single-line-raw-string-char*? | +-- '"' (single-line-raw-string-char - '"') +-- single-line-raw-string-char*? +p_single_line_raw_string_body :: Parser end -> Parser () +p_single_line_raw_string_body end = label "raw string single line" $ do + void . optional $ do + _ <- optional $ char '"' + c <- p_single_line_raw_string_char + guard $ c /= '"' + manyTill p_single_line_raw_string_char (try $ lookAhead end) + +-- | ref: (3.13) +-- single-line-raw-string-char := +-- unicode - newline - disallowed-literal-code-points +p_single_line_raw_string_char :: Parser Char +p_single_line_raw_string_char = label "raw string character" $ do + c <- p_unicode + guard $ Text.singleton c `Set.notMember` chars_newline + guard $ not $ is_disallowed_literal_code_points c + pure c + +-- | ref: (3.13) +-- multi-line-raw-string-body := +-- (unicode - disallowed-literal-code-points)*? +p_multi_line_raw_string_body :: Parser end -> Parser MultilineChars +p_multi_line_raw_string_body end = label "raw string multiline body" $ do + manyTill validChar (try . lookAhead $ end) + where + validChar = do + c <- p_unicode + guard $ not $ is_disallowed_literal_code_points c + let s = Text.singleton c + pure (s, s) + +{----- (3.14) Number -----} + +-- | ref: (3.14) +-- number := keyword-number | hex | octal | binary | decimal +p_number :: Parser ValueData +p_number = label "number" $ do + choice . map try $ + [ p_keyword_number + , Number <$> p_hex + , Number <$> p_octal + , Number <$> p_binary + , Number <$> p_decimal + ] + +-- | ref: (3.14) +-- hex := sign? '0x' hex-digit (hex-digit | '_')* +p_hex :: Parser Scientific +p_hex = label "hex" $ parseNumWith "0x" 16 isHexDigit + +-- | ref: (3.14) +-- hex-digit := [0-9a-fA-F] +p_hex_digit :: Parser Int +p_hex_digit = label "hex digit" $ do + digitToInt <$> satisfy isHexDigit + +-- | ref: (3.14) +-- octal := sign? '0o' [0-7] [0-7_]* +p_octal :: Parser Scientific +p_octal = label "octal" $ parseNumWith "0o" 8 isOctDigit + +-- | ref: (3.14) +-- binary := sign? '0b' ('0' | '1') ('0' | '1' | '_')* +p_binary :: Parser Scientific +p_binary = label "binary" $ parseNumWith "0b" 2 isBinDigit + where + isBinDigit c = c == '0' || c == '1' + +parseNumWith :: Text -> Integer -> (Char -> Bool) -> Parser Scientific +parseNumWith prefix base isValid = do + signed <- parseSigned + _ <- string prefix + (x, _) <- p_digits base isValid + pure . signed . fromInteger $ x + +-- | ref: (3.14) +-- decimal := sign? integer ('.' integer)? exponent? +p_decimal :: Parser Scientific +p_decimal = label "decimal number" $ do + signed <- parseSigned + (i, _) <- p_integer + (f, fdigits) <- option (0, 0) $ label "decimal point" (char '.') *> p_integer + e <- option 0 p_exponent + pure . signed $ Scientific.scientific (i * (10 ^ fdigits) + f) (e - fdigits) + +-- | ref: (3.14) +-- integer := digit (digit | '_')* +p_integer :: Parser (Integer, Int) +p_integer = label "integer" $ p_digits 10 isDigit + +p_digits :: Integer -> (Char -> Bool) -> Parser (Integer, Int) +p_digits base isValid = do + d <- p_digit + ds <- + fmap catMaybes . many . choice $ + [ Just <$> p_digit + , Nothing <$ hidden (char '_') + ] + let digits = map toInteger (d : ds) + pure (undigits base digits, length digits) + where + p_digit = digitToInt <$> satisfy isValid + +-- | ref: (3.14) +-- exponent := ('e' | 'E') sign? integer +p_exponent :: Parser Int +p_exponent = label "exponent" $ do + _ <- oneOf ['e', 'E'] + signed <- parseSigned + (x, _) <- p_integer + case toIntegralSized x of + Just x' -> pure $ signed x' + Nothing -> fail $ "Exponent is too large: " <> show x + +-- | ref: (3.14) +-- sign := '+' | '-' +p_sign :: Parser Char +p_sign = label "sign" $ do + oneOf ['-', '+'] + +parseSigned :: (Num a) => Parser (a -> a) +parseSigned = toSign <$> optional p_sign + where + toSign = \case + Just '-' -> negate + _ -> id + +-- | ref: (3.14.1) +-- keyword-number := '#inf' | '#-inf' | '#nan' +p_keyword_number :: Parser ValueData +p_keyword_number = do + choice + [ Inf <$ string "#inf" + , NegInf <$ string "#-inf" + , NaN <$ string "#nan" + ] + +{----- (3.15) Boolean -----} + +-- | ref: (3.15) +-- boolean := '#true' | '#false' +p_boolean :: Parser Bool +p_boolean = label "boolean" $ do + choice + [ True <$ string "#true" + , False <$ string "#false" + ] + +{----- (3.17) Whitespace -----} + +-- | ref: (3.17) +-- ws := unicode-space | multi-line-comment +p_ws :: Parser Text +p_ws = label "whitespace" $ do + (Text.singleton <$> p_unicode_space) <|> p_multi_line_comment + +-- | ref: (3.17) +-- unicode-space := See Table +-- (All White_Space unicode characters which are not `newline`) +p_unicode_space :: Parser Char +p_unicode_space = label "unicode space" $ do + choice + [ char c l + | (c, l) <- chars_unicode_space' + ] + +-- | ref: (3.17) +chars_unicode_space :: Set Char +chars_unicode_space = Set.fromList $ map fst chars_unicode_space' + +-- | ref: (3.17) +chars_unicode_space' :: [(Char, String)] +chars_unicode_space' = + [ ('\x0009', "character tabulation") + , ('\x0020', "space") + , ('\x00A0', "no-break space") + , ('\x1680', "ogham space mark") + , ('\x2000', "en quad") + , ('\x2001', "em quad") + , ('\x2002', "en space") + , ('\x2003', "em space") + , ('\x2004', "three-per-em space") + , ('\x2005', "four-per-em space") + , ('\x2006', "six-per-em space") + , ('\x2007', "figure space") + , ('\x2008', "punctuation space") + , ('\x2009', "thin space") + , ('\x200A', "hair space") + , ('\x202F', "narrow no-break space") + , ('\x205F', "medium mathmatical space") + , ('\x3000', "ideographic space") + ] + +-- | ref: (3.17.1) +-- single-line-comment := '//' ^newline* (newline | eof) +p_single_line_comment :: Parser Text +p_single_line_comment = label "single-line comment" $ do + withSource_ $ do + _ <- string "//" + _ <- takeWhileP Nothing (/= '\n') + _ <- p_newline <|> p_eof + pure () + +-- | ref: (3.17.2) +-- multi-line-comment := '/*' commented-block +p_multi_line_comment :: Parser Text +p_multi_line_comment = label "multi-line comment" . withSource_ $ do + string "/*" *> p_commented_block + +-- | ref: (3.17.2) +-- commented-block := +-- '*/' | (multi-line-comment | '*' | '/' | [^*/]+) commented-block +p_commented_block :: Parser () +p_commented_block = label "commented block" $ do + choice + [ void $ string "*/" + , do + choice + [ void p_multi_line_comment + , void $ char '*' + , void $ char '/' + , void $ takeWhileP Nothing (`notElem` ['*', '/']) + ] + p_commented_block + ] + +data SlashdashResult = Slashdash Text | NoSlashdash + +resolveSlashdash :: SlashdashResult -> Parser a -> Parser (Either Text a) +resolveSlashdash = \case + Slashdash sdash -> fmap (Left . (sdash <>)) . withSource_ + NoSlashdash -> fmap Right + +-- | ref: (3.17.3) +-- slashdash := '/-' line-space* +p_slashdash :: Parser SlashdashResult +p_slashdash = hidden $ do + sdash <- withSource_ $ string "/-" *> many p_line_space + pure $ Slashdash sdash + +{----- (3.18) Newline -----} + +-- | ref: (3.18) +-- newline := See Table (All Newline White_Space) +p_newline :: Parser Text +p_newline = label "newline" $ do + choice [string s l | (s, l) <- chars_newline'] + +-- | ref: (3.18) +chars_newline :: Set Text +chars_newline = Set.fromList $ map fst chars_newline' + +-- | ref: (3.18) +chars_newline' :: [(Text, String)] +chars_newline' = + [ ("\x000D\x000A", "CRLF") + , ("\x000D", "CR") + , ("\x000A", "LF") + , ("\x0085", "NEL") + , ("\x000B", "VT") + , ("\x000C", "FF") + , ("\x2028", "LS") + , ("\x2029", "PS") + ] + +{----- (3.19) Disallowed Literal Code Points -----} + +-- | ref: (3.19) +-- disallowed-literal-code-points := +-- See Table (Disallowed Literal Code Points) +is_disallowed_literal_code_points :: Char -> Bool +is_disallowed_literal_code_points c = + or + [ -- The codepoints U+0000-0008 or the codepoints U+000E-001F (various control characters). + or + [ '\x0000' <= c && c <= '\x0008' + , '\x000E' <= c && c <= '\x001F' + ] + , c == '\x007F' -- U+007F (the Delete control character). + , (not . is_unicode_scalar_value . ord) c -- Any codepoint that is not a Unicode Scalar Value (U+D800-DFFF). + , -- U+200E-200F, U+202A-202E, and U+2066-2069, the unicode "direction control" characters + or + [ '\x200E' <= c && c <= '\x200F' + , '\x202A' <= c && c <= '\x202E' + , '\x2066' <= c && c <= '\x2069' + ] + , -- U+FEFF, aka Zero-width Non-breaking Space (ZWNBSP)/Byte Order Mark (BOM), except as the first code point in a document. + c == '\xFEFF' + ] + +{----- Unicode -----} + +-- | unicode := Any Unicode Scalar Value +p_unicode :: Parser Char +p_unicode = label "unicode scalar value" $ do + satisfy (is_unicode_scalar_value . ord) + +-- | https://unicode.org/glossary/#unicode_scalar_value +is_unicode_scalar_value :: Int -> Bool +is_unicode_scalar_value x = + (0 <= x && x <= 0xD7FF) || (0xE000 <= x && x <= 0x10FFFF) + +{----- Utilities -----} + +withSource :: Parser a -> Parser (a, Text) +withSource p = do + s <- getParserState + a <- p + s' <- getParserState + let n = stateOffset s' - stateOffset s + pure (a, Text.take n (stateInput s)) + +withSource_ :: Parser a -> Parser Text +withSource_ = fmap snd . withSource + +newtype SpanStart = SpanStart (Maybe (State Text Void, SourcePos)) + +withSpan :: Parser a -> Parser (a, Span) +withSpan p = do + spanStart <- startSpan + a <- p + span <- finishSpan spanStart + pure (a, span) + +startSpan :: Parser SpanStart +startSpan = do + config <- Trans.lift Reader.ask + if not config.includeSpans + then pure . SpanStart $ Nothing + else do + start <- getSourcePos + startState <- getParserState + pure . SpanStart . Just $ (startState, start) + +finishSpan :: SpanStart -> Parser Span +finishSpan (SpanStart mStart) = + case mStart of + Nothing -> pure def + Just (startState, start) -> do + end <- getSourcePos + endState <- getParserState + let startLine = unPos start.sourceLine + startCol = unPos start.sourceColumn + (endLine, endCol) = + getEnd + startState + endState + startCol + (unPos end.sourceLine, unPos end.sourceColumn) + pure Span{..} + where + -- end.sourceColumn is off by 1, since the parser has already incremented + -- past the parsed element. So we need to simply subtract 1. However, if + -- end.sourceColumn == 1, it's at the start of a new line, and we need to + -- calculate the last column of the previous line. + getEnd startState endState startCol (endLine, endCol) = + if endCol > 1 + then (endLine, endCol - 1) + else + let len = endState.stateOffset - startState.stateOffset + source = Text.take len startState.stateInput + endCol' = case NonEmpty.nonEmpty $ Text.lines source of + -- source was empty, i.e. len == 0, so endCol := startCol + Nothing -> startCol + -- there were no newlines other than the last newline, so we're + -- offset from startCol + Just (line NonEmpty.:| []) -> startCol + Text.length line - 1 + -- source had multiple newlines, endCol is simply the length of the last line + Just sourceLines -> Text.length $ NonEmpty.last sourceLines + in (endLine - 1, endCol') + +repeat0 :: (Monoid a) => Parser a -> Parser a +repeat0 = fmap mconcat . many + +quotes1 :: Text +quotes1 = "\"" + +quotes3 :: Text +quotes3 = "\"\"\"" + +-- | Return a list whose length is in the range [lo, hi], inclusive. +countBetween :: Int -> Int -> Parser a -> Parser [a] +countBetween lo hi m = go 0 + where + go n + | n < lo = (:) <$> m <*> go (n + 1) + | n < hi = ((:) <$> m <*> go (n + 1)) <|> pure [] + | otherwise = pure [] + +p_eof :: Parser Text +p_eof = hidden $ "" <$ eof + +undigits :: (Num a) => a -> [a] -> a +undigits base = foldl' (\acc x -> acc * base + x) 0 + +-- | Group all 'Left' values and put it in the leading whitespace of the next +-- element. Return any leftover whitespace (i.e. the list ends with 'Left' +-- values). +mergeLeadingWS :: (HasWsFormat a) => Text -> [Either Text a] -> ([a], Text) +mergeLeadingWS initialLeading = + bimap Seq.toList toText . foldl' go (Seq.empty, Seq.singleton initialLeading) + where + toText = Text.concat . Seq.toList + go (nodes, buf) = \case + Left t -> (nodes, buf Seq.|> t) + Right node -> (nodes Seq.|> prependLeading (toText buf) node, Seq.empty) + +class HasFormat a where + type KdlFormat a + mapFormat :: (KdlFormat a -> KdlFormat a) -> a -> a +instance HasFormat NodeList where + type KdlFormat NodeList = NodeListFormat + mapFormat f NodeList{..} = NodeList{ext = ext{NodeListExtension.format = f <$> ext.format}, ..} +instance HasFormat Node where + type KdlFormat Node = NodeFormat + mapFormat f Node{..} = Node{ext = ext{NodeExtension.format = f <$> ext.format}, ..} +instance HasFormat Ann where + type KdlFormat Ann = AnnFormat + mapFormat f Ann{..} = Ann{ext = ext{AnnExtension.format = f <$> ext.format}, ..} +instance HasFormat Entry where + type KdlFormat Entry = EntryFormat + mapFormat f Entry{..} = Entry{ext = ext{EntryExtension.format = f <$> ext.format}, ..} + +class (HasFormat a) => HasWsFormat a where + mapLeading :: (Text -> Text) -> a -> a + mapTrailing :: (Text -> Text) -> a -> a + prependLeading :: Text -> a -> a + prependLeading s = mapLeading (s <>) + appendTrailing :: Text -> a -> a + appendTrailing s = mapTrailing (<> s) +instance HasWsFormat NodeList where + mapLeading f = mapFormat $ \format -> format{NodeListFormat.leading = f format.leading} + mapTrailing f = mapFormat $ \format -> format{NodeListFormat.trailing = f format.trailing} +instance HasWsFormat Node where + mapLeading f = mapFormat $ \format -> format{NodeFormat.leading = f format.leading} + mapTrailing f = mapFormat $ \format -> format{NodeFormat.trailing = f format.trailing} +instance HasWsFormat Ann where + mapLeading f = mapFormat $ \format -> format{AnnFormat.leading = f format.leading} + mapTrailing f = mapFormat $ \format -> format{AnnFormat.trailing = f format.trailing} +instance HasWsFormat Entry where + mapLeading f = mapFormat $ \format -> format{EntryFormat.leading = f format.leading} + mapTrailing f = mapFormat $ \format -> format{EntryFormat.trailing = f format.trailing} diff --git a/src/KDL/Render.hs b/src/KDL/Render.hs --- a/src/KDL/Render.hs +++ b/src/KDL/Render.hs @@ -7,54 +7,122 @@ render, -- * Rendering components - renderAnn, renderValue, renderValueData, renderIdentifier, ) where import Data.Char (isDigit) +import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as Text import KDL.Types ( Ann (..), + AnnExtension (..), AnnFormat (..), Document, + Entry (..), + EntryExtension (..), + EntryFormat (..), Identifier (..), + IdentifierExtension (..), IdentifierFormat (..), + Node (..), + NodeExtension (..), + NodeFormat (..), + NodeList (..), + NodeListExtension (..), + NodeListFormat (..), Value (..), ValueData (..), + ValueExtension (..), ValueFormat (..), ) --- TODO: Implement render after parsing Document with formatting information render :: Document -> Text -render = error "render is not implemented yet" +render = renderNodeList 0 +type IndentLevel = Int + +renderNodeList :: IndentLevel -> NodeList -> Text +renderNodeList lvl NodeList{..} = + Text.concat + [ maybe (if lvl > 0 then "\n" else "") (.leading) ext.format + , foldMap (renderNode lvl) nodes + , maybe (indent (lvl - 1)) (.trailing) ext.format + ] + +renderNode :: IndentLevel -> Node -> Text +renderNode lvl Node{..} = + Text.concat + [ maybe (indent lvl) (.leading) ext.format + , maybe "" renderAnn ann + , renderIdentifier name + , foldMap renderEntry entries + , let def_ = if children == Nothing then "" else " " + in maybe def_ (.beforeChildren) ext.format + , case children of + Nothing -> "" + Just nodes -> renderChildren lvl nodes + , maybe "" (.beforeTerminator) ext.format + , maybe "\n" (.terminator) ext.format + , maybe "" (.trailing) ext.format + ] + +renderChildren :: IndentLevel -> NodeList -> Text +renderChildren lvl nodeList = + case nodeList.ext.format of + -- Special case empty node list to render as "{}" + Nothing | null nodeList.nodes -> "{}" + _ -> "{" <> renderNodeList (lvl + 1) nodeList <> "}" + +indent :: IndentLevel -> Text +indent lvl = Text.replicate lvl " " + +renderEntry :: Entry -> Text +renderEntry Entry{..} = + Text.concat + [ maybe " " (.leading) ext.format + , case name of + Nothing -> renderValue value + Just nameId -> + Text.concat + [ renderIdentifier nameId + , maybe "" (.afterKey) ext.format + , "=" + , maybe "" (.afterEq) ext.format + , renderValue value + ] + , maybe "" (.trailing) ext.format + ] + renderAnn :: Ann -> Text renderAnn Ann{..} = Text.concat - [ maybe "" (.leading) format + [ maybe "" (.leading) ext.format , "(" - , maybe "" (.before_id) format + , maybe "" (.beforeId) ext.format , renderIdentifier identifier - , maybe "" (.after_id) format + , maybe "" (.afterId) ext.format , ")" - , maybe "" (.trailing) format + , maybe "" (.trailing) ext.format ] renderValue :: Value -> Text renderValue Value{..} = Text.concat [ maybe "" renderAnn ann - , maybe (renderValueData data_) (.repr) format + , fromMaybe (renderValueData data_) (ext.format >>= (.repr)) ] renderValueData :: ValueData -> Text renderValueData = \case - Text s -> renderString s + String s -> renderString s Number x -> (Text.pack . show) x Bool b -> if b then "#true" else "#false" + Inf -> "#inf" + NegInf -> "#-inf" + NaN -> "#nan" Null -> "#null" where renderString s = if isPlainIdent s then s else "\"" <> Text.concatMap escapeChar s <> "\"" @@ -129,4 +197,4 @@ c -> Text.singleton c renderIdentifier :: Identifier -> Text -renderIdentifier ident = maybe ident.value (.repr) ident.format +renderIdentifier ident = fromMaybe ident.value (ident.ext.format >>= (.repr)) diff --git a/src/KDL/Types.hs b/src/KDL/Types.hs --- a/src/KDL/Types.hs +++ b/src/KDL/Types.hs @@ -9,19 +9,17 @@ Defines the types that make up a KDL document. This module enables @-XNoFieldSelectors@, so none of the fields create implicit -selector functions. Instead, use @-XOverloadedRecordDot@, or the functions -provided by this module. +selector functions. Instead, use @-XOverloadedRecordDot@, +@-XNamedFieldPuns@/@-XRecordWildCards@, or explicitly pattern-match. -} module KDL.Types ( -- * Document Document, - docNodes, -- * NodeList NodeList (..), + NodeListExtension (..), NodeListFormat (..), - fromNodeList, - nodeListFormat, -- ** Helpers filterNodes, @@ -33,12 +31,8 @@ -- * Node Node (..), + NodeExtension (..), NodeFormat (..), - nodeAnn, - nodeName, - nodeEntries, - nodeChildren, - nodeFormat, -- ** Helpers getArgs, @@ -48,34 +42,36 @@ -- * Entry Entry (..), + EntryExtension (..), EntryFormat (..), - entryName, - entryValue, - entryFormat, -- * Value Value (..), + ValueExtension (..), ValueFormat (..), - valueAnn, - valueData, - valueFormat, ValueData (..), -- * Ann Ann (..), + AnnExtension (..), AnnFormat (..), - annIdentifier, - annFormat, -- * Identifier Identifier (..), + IdentifierExtension (..), IdentifierFormat (..), fromIdentifier, - identifierFormat, toIdentifier, + + -- * Span + Span (..), + + -- * Re-exports + def, ) where import Control.Monad ((<=<)) +import Data.Default (Default (..)) import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe (listToMaybe, mapMaybe) @@ -86,30 +82,40 @@ type Document = NodeList -docNodes :: Document -> [Node] -docNodes = fromNodeList - {----- NodeList -----} data NodeList = NodeList { nodes :: [Node] - , format :: Maybe NodeListFormat + , ext :: NodeListExtension } deriving (Show, Eq) +data NodeListExtension = NodeListExtension + { format :: Maybe NodeListFormat + , span :: Span + } + deriving (Show, Eq) + data NodeListFormat = NodeListFormat { leading :: Text - -- ^ Whitespace and comments preceding the document's first node. + -- ^ Whitespace and comments preceding the first node. , trailing :: Text - -- ^ Whitespace and comments following the document's last node. + -- ^ Whitespace and comments following the last node. } deriving (Show, Eq) -fromNodeList :: NodeList -> [Node] -fromNodeList = (.nodes) - -nodeListFormat :: NodeList -> Maybe NodeListFormat -nodeListFormat = (.format) +instance Default NodeListExtension where + def = + NodeListExtension + { format = def + , span = def + } +instance Default NodeListFormat where + def = + NodeListFormat + { leading = "" + , trailing = "" + } -- | A helper to get all nodes with the given name filterNodes :: Text -> NodeList -> [Node] @@ -191,33 +197,48 @@ -- mapM getArg (getDashNodesAt "foo" doc) == Just [Number 1, Number 2, Text "test"] -- @ getDashNodesAt :: Text -> NodeList -> [Node] -getDashNodesAt name = maybe [] (filterNodes "-") . (nodeChildren <=< lookupNode name) +getDashNodesAt name = maybe [] (filterNodes "-") . ((.children) <=< lookupNode name) {----- Ann -----} data Ann = Ann { identifier :: Identifier - , format :: Maybe AnnFormat + , ext :: AnnExtension } deriving (Show, Eq) +data AnnExtension = AnnExtension + { format :: Maybe AnnFormat + , span :: Span + } + deriving (Show, Eq) + data AnnFormat = AnnFormat { leading :: Text -- ^ Whitespace and comments preceding the annotation itself. - , before_id :: Text + , beforeId :: Text -- ^ Whitespace and comments between the opening `(` and the identifier. - , after_id :: Text + , afterId :: Text -- ^ Whitespace and comments between the identifier and the closing `)`. , trailing :: Text -- ^ Whitespace and comments following the annotation itself. } deriving (Show, Eq) -annIdentifier :: Ann -> Identifier -annIdentifier = (.identifier) - -annFormat :: Ann -> Maybe AnnFormat -annFormat = (.format) +instance Default AnnExtension where + def = + AnnExtension + { format = def + , span = def + } +instance Default AnnFormat where + def = + AnnFormat + { leading = "" + , beforeId = "" + , afterId = "" + , trailing = "" + } {----- Node -----} @@ -226,16 +247,22 @@ , name :: Identifier , entries :: [Entry] , children :: Maybe NodeList - , format :: Maybe NodeFormat + , ext :: NodeExtension } deriving (Show, Eq) +data NodeExtension = NodeExtension + { format :: Maybe NodeFormat + , span :: Span + } + deriving (Show, Eq) + data NodeFormat = NodeFormat { leading :: Text -- ^ Whitespace and comments preceding the node itself. - , before_children :: Text + , beforeChildren :: Text -- ^ Whitespace and comments preceding the node's children block. - , before_terminator :: Text + , beforeTerminator :: Text -- ^ Whitespace and comments right before the node's terminator. , terminator :: Text -- ^ The terminator for the node. @@ -244,20 +271,21 @@ } deriving (Show, Eq) -nodeAnn :: Node -> Maybe Ann -nodeAnn = (.ann) - -nodeName :: Node -> Identifier -nodeName = (.name) - -nodeEntries :: Node -> [Entry] -nodeEntries = (.entries) - -nodeChildren :: Node -> Maybe NodeList -nodeChildren = (.children) - -nodeFormat :: Node -> Maybe NodeFormat -nodeFormat = (.format) +instance Default NodeExtension where + def = + NodeExtension + { format = def + , span = def + } +instance Default NodeFormat where + def = + NodeFormat + { leading = "" + , beforeChildren = "" + , beforeTerminator = "" + , terminator = "" + , trailing = "" + } -- | Get all the positional arguments of the node. getArgs :: Node -> [Value] @@ -288,59 +316,83 @@ { name :: Maybe Identifier -- ^ The name of the entry, if it's a property, Nothing if it's a positional arg , value :: Value - , format :: Maybe EntryFormat + , ext :: EntryExtension } deriving (Show, Eq) +data EntryExtension = EntryExtension + { format :: Maybe EntryFormat + , span :: Span + } + deriving (Show, Eq) + data EntryFormat = EntryFormat { leading :: Text -- ^ Whitespace and comments preceding the entry itself. - , after_key :: Text + , afterKey :: Text -- ^ Whitespace and comments between an entry's key name and its equals sign. - , after_eq :: Text + , afterEq :: Text -- ^ Whitespace and comments between an entry's equals sign and its value. , trailing :: Text -- ^ Whitespace and comments following the entry itself. } deriving (Show, Eq) -entryName :: Entry -> Maybe Identifier -entryName = (.name) - -entryValue :: Entry -> Value -entryValue = (.value) - -entryFormat :: Entry -> Maybe EntryFormat -entryFormat = (.format) +instance Default EntryExtension where + def = + EntryExtension + { format = def + , span = def + } +instance Default EntryFormat where + def = + EntryFormat + { leading = "" + , afterKey = "" + , afterEq = "" + , trailing = "" + } {----- Value -----} data Value = Value { ann :: Maybe Ann , data_ :: ValueData - , format :: Maybe ValueFormat + , ext :: ValueExtension } deriving (Show, Eq) +data ValueExtension = ValueExtension + { format :: Maybe ValueFormat + , span :: Span + } + deriving (Show, Eq) + data ValueFormat = ValueFormat - { repr :: Text + { repr :: Maybe Text -- ^ The actual text representation of the value. } deriving (Show, Eq) -valueAnn :: Value -> Maybe Ann -valueAnn = (.ann) - -valueData :: Value -> ValueData -valueData = (.data_) - -valueFormat :: Value -> Maybe ValueFormat -valueFormat = (.format) +instance Default ValueExtension where + def = + ValueExtension + { format = def + , span = def + } +instance Default ValueFormat where + def = + ValueFormat + { repr = Nothing + } data ValueData - = Text Text + = String Text | Number Scientific | Bool Bool + | Inf + | NegInf + | NaN | Null deriving (Show, Eq) @@ -348,20 +400,56 @@ data Identifier = Identifier { value :: Text - , format :: Maybe IdentifierFormat + , ext :: IdentifierExtension } deriving (Show, Eq, Ord) +data IdentifierExtension = IdentifierExtension + { format :: Maybe IdentifierFormat + , span :: Span + } + deriving (Show, Eq, Ord) + data IdentifierFormat = IdentifierFormat - { repr :: Text + { repr :: Maybe Text } deriving (Show, Eq, Ord) +instance Default IdentifierExtension where + def = + IdentifierExtension + { format = def + , span = def + } +instance Default IdentifierFormat where + def = + IdentifierFormat + { repr = Nothing + } + fromIdentifier :: Identifier -> Text fromIdentifier = (.value) -identifierFormat :: Identifier -> Maybe IdentifierFormat -identifierFormat = (.format) - toIdentifier :: Text -> Identifier -toIdentifier value = Identifier{value = value, format = Nothing} +toIdentifier value = Identifier{value = value, ext = def} + +{----- Span -----} + +-- | The span of a KDL element, if parsed with 'includeSpans'. If 'includeSpans' +-- was not enabled, all fields are set to 0. +data Span = Span + { startLine :: Int + , startCol :: Int + , endLine :: Int + , endCol :: Int + } + deriving (Show, Eq, Ord) + +instance Default Span where + def = + Span + { startLine = 0 + , startCol = 0 + , endLine = 0 + , endCol = 0 + } diff --git a/test/KDL/Decoder/ArrowSpec.hs b/test/KDL/Decoder/ArrowSpec.hs --- a/test/KDL/Decoder/ArrowSpec.hs +++ b/test/KDL/Decoder/ArrowSpec.hs @@ -5,7 +5,7 @@ module KDL.Decoder.ArrowSpec (spec) where import Control.Arrow (returnA) -import Control.Monad (forM_, unless, when) +import Control.Monad (forM_, unless) import Data.Int (Int64) import Data.Map qualified as Map import Data.Proxy (Proxy (..)) @@ -13,6 +13,8 @@ import Data.Text qualified as Text import Data.Typeable (typeRep) import KDL.Arrow qualified as KDL +import KDL.TestUtils.AST (scrubFormat) +import KDL.TestUtils.Error (decodeErrorMsg) import KDL.Types ( Entry (..), Identifier (..), @@ -22,13 +24,7 @@ ValueData (..), ) import Skeletest -import Skeletest.Predicate qualified as P -decodeErrorMsg :: [Text] -> Predicate IO (Either KDL.DecodeError a) -decodeErrorMsg msgs = P.left (KDL.renderDecodeError P.>>> P.eq msg) - where - msg = Text.intercalate "\n" msgs - spec :: Spec spec = do apiSpec @@ -38,108 +34,65 @@ apiSpec :: Spec apiSpec = do - describe "decodeWith" $ do - it "fails with helpful error if parsing fails" $ do - let config = "foo hello= 123" - decoder = KDL.document $ KDL.node @Node "foo" - KDL.decodeWith decoder config - `shouldSatisfy` decodeErrorMsg - [ "At: " - , " 1:10:" - , " |" - , " 1 | foo hello= 123" - , " | ^^" - , " unexpected \"= \"" - , " expecting Node Child, Node Space, or Node Terminator" - ] - - it "fails with user-defined error" $ do - let config = "foo -1" - decoder = - KDL.document . KDL.argAtWith "foo" $ - KDL.withDecoder KDL.number $ \x -> do - when (x < 0) $ do - KDL.failM $ "Got negative number: " <> (Text.pack . show) x - pure x - KDL.decodeWith decoder config - `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > arg #0" - , " Got negative number: -1.0" - ] - - it "shows context in deeply nested error" $ do - let config = "foo; foo { bar { baz; baz; baz; baz a=1; }; }" - decoder = - KDL.document - . (KDL.many . KDL.nodeWith "foo" . KDL.children) - . (KDL.many . KDL.nodeWith "bar" . KDL.children) - . (KDL.many . KDL.nodeWith "baz") - $ KDL.optional (KDL.prop @Text "a") - KDL.decodeWith decoder config - `shouldSatisfy` decodeErrorMsg - [ "At: foo #1 > bar #0 > baz #3 > prop a" - , " Expected text, got: 1" - ] - describe "NodeListDecoder" $ do describe "node" $ do it "decodes a node" $ do let config = "foo 1.0" decoder = KDL.document $ proc () -> do - KDL.node "foo" -< () + scrubFormat <$> KDL.node "foo" -< () expected = Node { ann = Nothing - , name = Identifier{value = "foo", format = Nothing} + , name = Identifier{value = "foo", ext = KDL.def} , entries = [ Entry { name = Nothing - , value = Value{ann = Nothing, data_ = Number 1.0, format = Nothing} - , format = Nothing + , value = Value{ann = Nothing, data_ = Number 1.0, ext = KDL.def} + , ext = KDL.def } ] - , children = Just NodeList{nodes = [], format = Nothing} - , format = Nothing + , children = Nothing + , ext = KDL.def } KDL.decodeWith decoder config `shouldBe` Right expected it "decodes multiple nodes" $ do let config = "foo; foo" decoder = KDL.document $ proc () -> do - KDL.many $ KDL.node "foo" -< () + fmap (map scrubFormat) . KDL.many $ KDL.node "foo" -< () expected = [fooNode, fooNode] fooNode = Node { ann = Nothing - , name = Identifier{value = "foo", format = Nothing} + , name = Identifier{value = "foo", ext = KDL.def} , entries = [] - , children = Just NodeList{nodes = [], format = Nothing} - , format = Nothing + , children = Nothing + , ext = KDL.def } KDL.decodeWith decoder config `shouldBe` Right expected it "decodes nodes in any order" $ do let config = "foo; bar" decoder = KDL.document $ proc () -> do - bar <- KDL.node "bar" -< () - foo <- KDL.node "foo" -< () + bar <- scrubFormat <$> KDL.node "bar" -< () + foo <- scrubFormat <$> KDL.node "foo" -< () returnA -< (bar, foo) expected = (node "bar", node "foo") node name = Node { ann = Nothing - , name = Identifier{value = name, format = Nothing} + , name = Identifier{value = name, ext = KDL.def} , entries = [] - , children = Just NodeList{nodes = [], format = Nothing} - , format = Nothing + , children = Nothing + , ext = KDL.def } KDL.decodeWith decoder config `shouldBe` Right expected it "fails when not enough nodes" $ do let config = "foo" decoder = KDL.document $ proc () -> do - foo1 <- KDL.node @Node "foo" -< () - foo2 <- KDL.node @Node "foo" -< () + foo1 <- scrubFormat <$> KDL.node @Node "foo" -< () + foo2 <- scrubFormat <$> KDL.node @Node "foo" -< () returnA -< (foo1, foo2) KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg @@ -150,7 +103,7 @@ -- Most behaviors tested with `node` describe "nodeWith" $ do it "decodes a node" $ do - let config = "foo 1.0 { hello \"world\"; }" + let config = "foo 1.0 { hello world; }" decodeFoo = proc () -> do arg <- KDL.arg @Int -< () child <- KDL.children $ KDL.argAt @Text "hello" -< () @@ -212,7 +165,7 @@ let config = "foo 1.0; foo 2.0; bar" decoder = KDL.document $ proc () -> do _ <- KDL.node @Node "foo" -< () - KDL.remainingNodes -< () + fmap (map scrubFormat) <$> KDL.remainingNodes -< () expected = Map.fromList [ ("foo", [fooNode2]) @@ -221,24 +174,24 @@ fooNode2 = Node { ann = Nothing - , name = Identifier{value = "foo", format = Nothing} + , name = Identifier{value = "foo", ext = KDL.def} , entries = [ Entry { name = Nothing - , value = Value{ann = Nothing, data_ = Number 2.0, format = Nothing} - , format = Nothing + , value = Value{ann = Nothing, data_ = Number 2.0, ext = KDL.def} + , ext = KDL.def } ] - , children = Just NodeList{nodes = [], format = Nothing} - , format = Nothing + , children = Nothing + , ext = KDL.def } barNode = Node { ann = Nothing - , name = Identifier{value = "bar", format = Nothing} + , name = Identifier{value = "bar", ext = KDL.def} , entries = [] - , children = Just NodeList{nodes = [], format = Nothing} - , format = Nothing + , children = Nothing + , ext = KDL.def } KDL.decodeWith decoder config `shouldBe` Right expected @@ -259,7 +212,7 @@ KDL.decodeWith decoder config `shouldBe` Right expected it "fails when node fails to parse" $ do - let config = "foo 1; bar 1; bar \"hello\"" + let config = "foo 1; bar 1; bar hello" decodeNode = proc () -> do KDL.arg @Int -< () decoder = KDL.document $ proc () -> do @@ -310,7 +263,7 @@ describe "argAt" $ do it "gets argument at a node" $ do - let config = "foo \"bar\"; hello \"world\"" + let config = "foo bar; hello world" decoder = KDL.document $ proc () -> do hello <- KDL.argAt @Text "hello" -< () foo <- KDL.argAt @Text "foo" -< () @@ -411,7 +364,7 @@ KDL.decodeWith decoder config `shouldBe` Right [] it "fails if any arg fails to parse" $ do - let config = "foo 1 \"asdf\"" + let config = "foo 1 asdf" decoder = KDL.document $ proc () -> do KDL.argsAt @Int "foo" -< () KDL.decodeWith decoder config @@ -504,7 +457,7 @@ ] it "fails if any child fails to parse" $ do - let config = "foo { - 1; - \"asdf\"; }" + let config = "foo { - 1; - asdf; }" decoder = KDL.document $ proc () -> do KDL.dashChildrenAt @Int "foo" -< () KDL.decodeWith decoder config @@ -561,15 +514,18 @@ it "gets dash nodes at a node" $ do let config = "foo { - { bar; }; - { baz; }; }" decoder = KDL.document $ proc () -> do - KDL.dashNodesAt "foo" -< () + map scrubFormat <$> KDL.dashNodesAt "foo" -< () expected = [node "-" [node "bar" []], node "-" [node "baz" []]] node name children = Node { ann = Nothing - , name = Identifier{value = name, format = Nothing} + , name = Identifier{value = name, ext = KDL.def} , entries = [] - , children = Just NodeList{nodes = children, format = Nothing} - , format = Nothing + , children = + if null children + then Nothing + else Just NodeList{nodes = children, ext = KDL.def} + , ext = KDL.def } KDL.decodeWith decoder config `shouldBe` Right expected @@ -598,7 +554,7 @@ -- Most behaviors tested with `dashNodesAt` describe "dashNodesAtWith" $ do it "gets dash nodes at a node" $ do - let config = "foo { - 1 { bar \"hello\"; }; - 2 { bar \"world\"; }; }" + let config = "foo { - 1 { bar hello; }; - 2 { bar world; }; }" decodeChild = proc () -> do arg <- KDL.arg @Int -< () child <- KDL.children $ KDL.nodeWith "bar" $ KDL.arg @Text -< () @@ -608,7 +564,7 @@ KDL.decodeWith decoder config `shouldBe` Right [(1, "hello"), (2, "world")] it "fails if any child fails to parse" $ do - let config = "foo { - { bar 1; }; - { bar \"test\"; }; }" + let config = "foo { - { bar 1; }; - { bar test; }; }" decoder = KDL.document $ proc () -> do KDL.dashNodesAtWith "foo" $ KDL.children $ KDL.argAt @Int "bar" -< () KDL.decodeWith decoder config @@ -627,7 +583,7 @@ describe "arg" $ do it "decodes an argument" $ do - let config = "foo 1 \"bar\"" + let config = "foo 1 bar" decoder = proc () -> do arg1 <- KDL.arg @Int -< () arg2 <- KDL.arg @Text -< () @@ -651,7 +607,7 @@ ] it "fails if argument fails to parse" $ do - let config = "foo \"test\"" + let config = "foo test" decoder = proc () -> do KDL.arg @Int -< () decodeNode "foo" decoder config @@ -673,7 +629,7 @@ -- Most behaviors tested with `arg` describe "argWith" $ do it "decodes an argument" $ do - let config = "foo \"bar\"" + let config = "foo bar" decoder = proc () -> do KDL.argWith KDL.text -< () decodeNode "foo" decoder config `shouldBe` Right "bar" @@ -716,7 +672,7 @@ describe "prop" $ do it "decodes a prop" $ do - let config = "foo test1=1 test2=\"hello\"" + let config = "foo test1=1 test2=hello" decoder = proc () -> do prop1 <- KDL.prop @Text "test2" -< () prop2 <- KDL.prop @Int "test1" -< () @@ -890,20 +846,20 @@ it "decodes children" $ do let config = "foo { bar test; }" decoder = proc () -> do - KDL.children $ KDL.node @Node "bar" -< () + fmap scrubFormat . KDL.children $ KDL.node @Node "bar" -< () expected = Node { ann = Nothing - , name = Identifier{value = "bar", format = Nothing} + , name = Identifier{value = "bar", ext = KDL.def} , entries = [ Entry { name = Nothing - , value = Value{ann = Nothing, data_ = Text "test", format = Nothing} - , format = Nothing + , value = Value{ann = Nothing, data_ = String "test", ext = KDL.def} + , ext = KDL.def } ] - , children = Just NodeList{nodes = [], format = Nothing} - , format = Nothing + , children = Nothing + , ext = KDL.def } decodeNode "foo" decoder config `shouldBe` Right expected @@ -930,15 +886,15 @@ it "decodes any value" $ do let config = "foo 1.0 asdf #true" decoder = KDL.document $ proc () -> do - KDL.argsAtWith "foo" KDL.any -< () + map scrubFormat <$> KDL.argsAtWith "foo" KDL.any -< () val data_ = Value { ann = Nothing , data_ = data_ - , format = Nothing + , ext = KDL.def } KDL.decodeWith decoder config - `shouldBe` Right [val $ Number 1, val $ Text "asdf", val $ Bool True] + `shouldBe` Right [val $ Number 1, val $ String "asdf", val $ Bool True] describe "text" $ do it "decodes text value" $ do diff --git a/test/KDL/Decoder/MonadSpec.hs b/test/KDL/Decoder/MonadSpec.hs --- a/test/KDL/Decoder/MonadSpec.hs +++ b/test/KDL/Decoder/MonadSpec.hs @@ -3,11 +3,13 @@ module KDL.Decoder.MonadSpec (spec) where -import Control.Monad (forM_, unless, when) +import Control.Monad (forM_, unless) import Data.Map qualified as Map import Data.Text (Text) import Data.Text qualified as Text import KDL qualified +import KDL.TestUtils.AST (scrubFormat) +import KDL.TestUtils.Error (decodeErrorMsg) import KDL.Types ( Entry (..), Identifier (..), @@ -17,13 +19,7 @@ ValueData (..), ) import Skeletest -import Skeletest.Predicate qualified as P -decodeErrorMsg :: [Text] -> Predicate IO (Either KDL.DecodeError a) -decodeErrorMsg msgs = P.left (KDL.renderDecodeError P.>>> P.eq msg) - where - msg = Text.intercalate "\n" msgs - spec :: Spec spec = do apiSpec @@ -32,108 +28,65 @@ apiSpec :: Spec apiSpec = do - describe "decodeWith" $ do - it "fails with helpful error if parsing fails" $ do - let config = "foo hello= 123" - decoder = KDL.document $ KDL.node @Node "foo" - KDL.decodeWith decoder config - `shouldSatisfy` decodeErrorMsg - [ "At: " - , " 1:10:" - , " |" - , " 1 | foo hello= 123" - , " | ^^" - , " unexpected \"= \"" - , " expecting Node Child, Node Space, or Node Terminator" - ] - - it "fails with user-defined error" $ do - let config = "foo -1" - decoder = - KDL.document . KDL.argAtWith "foo" $ - KDL.withDecoder KDL.number $ \x -> do - when (x < 0) $ do - KDL.failM $ "Got negative number: " <> (Text.pack . show) x - pure x - KDL.decodeWith decoder config - `shouldSatisfy` decodeErrorMsg - [ "At: foo #0 > arg #0" - , " Got negative number: -1.0" - ] - - it "shows context in deeply nested error" $ do - let config = "foo; foo { bar { baz; baz; baz; baz a=1; }; }" - decoder = - KDL.document - . (KDL.many . KDL.nodeWith "foo" . KDL.children) - . (KDL.many . KDL.nodeWith "bar" . KDL.children) - . (KDL.many . KDL.nodeWith "baz") - $ KDL.optional (KDL.prop @Text "a") - KDL.decodeWith decoder config - `shouldSatisfy` decodeErrorMsg - [ "At: foo #1 > bar #0 > baz #3 > prop a" - , " Expected text, got: 1" - ] - describe "NodeListDecoder" $ do describe "node" $ do it "decodes a node" $ do let config = "foo 1.0" decoder = KDL.document $ do - KDL.node "foo" + scrubFormat <$> KDL.node "foo" expected = Node { ann = Nothing - , name = Identifier{value = "foo", format = Nothing} + , name = Identifier{value = "foo", ext = KDL.def} , entries = [ Entry { name = Nothing - , value = Value{ann = Nothing, data_ = Number 1.0, format = Nothing} - , format = Nothing + , value = Value{ann = Nothing, data_ = Number 1.0, ext = KDL.def} + , ext = KDL.def } ] - , children = Just NodeList{nodes = [], format = Nothing} - , format = Nothing + , children = Nothing + , ext = KDL.def } KDL.decodeWith decoder config `shouldBe` Right expected it "decodes multiple nodes" $ do let config = "foo; foo" decoder = KDL.document $ do - KDL.many $ KDL.node "foo" + fmap (map scrubFormat) . KDL.many $ KDL.node "foo" expected = [fooNode, fooNode] fooNode = Node { ann = Nothing - , name = Identifier{value = "foo", format = Nothing} + , name = Identifier{value = "foo", ext = KDL.def} , entries = [] - , children = Just NodeList{nodes = [], format = Nothing} - , format = Nothing + , children = Nothing + , ext = KDL.def } KDL.decodeWith decoder config `shouldBe` Right expected it "decodes nodes in any order" $ do let config = "foo; bar" decoder = KDL.document $ do - bar <- KDL.node "bar" - foo <- KDL.node "foo" + bar <- scrubFormat <$> KDL.node "bar" + foo <- scrubFormat <$> KDL.node "foo" pure (bar, foo) expected = (node "bar", node "foo") node name = Node { ann = Nothing - , name = Identifier{value = name, format = Nothing} + , name = Identifier{value = name, ext = KDL.def} , entries = [] - , children = Just NodeList{nodes = [], format = Nothing} - , format = Nothing + , children = Nothing + , ext = KDL.def } KDL.decodeWith decoder config `shouldBe` Right expected it "fails when not enough nodes" $ do let config = "foo" decoder = KDL.document $ do - foo1 <- KDL.node @Node "foo" - foo2 <- KDL.node @Node "foo" + foo1 <- scrubFormat <$> KDL.node @Node "foo" + foo2 <- scrubFormat <$> KDL.node @Node "foo" pure (foo1, foo2) KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsg @@ -144,7 +97,7 @@ -- Most behaviors tested with `node` describe "nodeWith" $ do it "decodes a node" $ do - let config = "foo 1.0 { hello \"world\"; }" + let config = "foo 1.0 { hello world; }" decodeFoo = do arg <- KDL.arg @Int child <- KDL.children $ KDL.argAt @Text "hello" @@ -206,7 +159,7 @@ let config = "foo 1.0; foo 2.0; bar" decoder = KDL.document $ do _ <- KDL.node @Node "foo" - KDL.remainingNodes + fmap (map scrubFormat) <$> KDL.remainingNodes expected = Map.fromList [ ("foo", [fooNode2]) @@ -215,24 +168,24 @@ fooNode2 = Node { ann = Nothing - , name = Identifier{value = "foo", format = Nothing} + , name = Identifier{value = "foo", ext = KDL.def} , entries = [ Entry { name = Nothing - , value = Value{ann = Nothing, data_ = Number 2.0, format = Nothing} - , format = Nothing + , value = Value{ann = Nothing, data_ = Number 2.0, ext = KDL.def} + , ext = KDL.def } ] - , children = Just NodeList{nodes = [], format = Nothing} - , format = Nothing + , children = Nothing + , ext = KDL.def } barNode = Node { ann = Nothing - , name = Identifier{value = "bar", format = Nothing} + , name = Identifier{value = "bar", ext = KDL.def} , entries = [] - , children = Just NodeList{nodes = [], format = Nothing} - , format = Nothing + , children = Nothing + , ext = KDL.def } KDL.decodeWith decoder config `shouldBe` Right expected @@ -253,7 +206,7 @@ KDL.decodeWith decoder config `shouldBe` Right expected it "fails when node fails to parse" $ do - let config = "foo 1; bar 1; bar \"hello\"" + let config = "foo 1; bar 1; bar hello" decodeNode = do KDL.arg @Int decoder = KDL.document $ do @@ -304,7 +257,7 @@ describe "argAt" $ do it "gets argument at a node" $ do - let config = "foo \"bar\"; hello \"world\"" + let config = "foo bar; hello world" decoder = KDL.document $ do hello <- KDL.argAt @Text "hello" foo <- KDL.argAt @Text "foo" @@ -405,7 +358,7 @@ KDL.decodeWith decoder config `shouldBe` Right [] it "fails if any arg fails to parse" $ do - let config = "foo 1 \"asdf\"" + let config = "foo 1 asdf" decoder = KDL.document $ do KDL.argsAt @Int "foo" KDL.decodeWith decoder config @@ -498,7 +451,7 @@ ] it "fails if any child fails to parse" $ do - let config = "foo { - 1; - \"asdf\"; }" + let config = "foo { - 1; - asdf; }" decoder = KDL.document $ do KDL.dashChildrenAt @Int "foo" KDL.decodeWith decoder config @@ -555,15 +508,18 @@ it "gets dash nodes at a node" $ do let config = "foo { - { bar; }; - { baz; }; }" decoder = KDL.document $ do - KDL.dashNodesAt "foo" + map scrubFormat <$> KDL.dashNodesAt "foo" expected = [node "-" [node "bar" []], node "-" [node "baz" []]] node name children = Node { ann = Nothing - , name = Identifier{value = name, format = Nothing} + , name = Identifier{value = name, ext = KDL.def} , entries = [] - , children = Just NodeList{nodes = children, format = Nothing} - , format = Nothing + , children = + if null children + then Nothing + else Just NodeList{nodes = children, ext = KDL.def} + , ext = KDL.def } KDL.decodeWith decoder config `shouldBe` Right expected @@ -592,7 +548,7 @@ -- Most behaviors tested with `dashNodesAt` describe "dashNodesAtWith" $ do it "gets dash nodes at a node" $ do - let config = "foo { - 1 { bar \"hello\"; }; - 2 { bar \"world\"; }; }" + let config = "foo { - 1 { bar hello; }; - 2 { bar world; }; }" decodeChild = do arg <- KDL.arg @Int child <- KDL.children $ KDL.nodeWith "bar" $ KDL.arg @Text @@ -602,7 +558,7 @@ KDL.decodeWith decoder config `shouldBe` Right [(1, "hello"), (2, "world")] it "fails if any child fails to parse" $ do - let config = "foo { - { bar 1; }; - { bar \"test\"; }; }" + let config = "foo { - { bar 1; }; - { bar test; }; }" decoder = KDL.document $ do KDL.dashNodesAtWith "foo" $ KDL.children $ KDL.argAt @Int "bar" KDL.decodeWith decoder config @@ -621,7 +577,7 @@ describe "arg" $ do it "decodes an argument" $ do - let config = "foo 1 \"bar\"" + let config = "foo 1 bar" decoder = do arg1 <- KDL.arg @Int arg2 <- KDL.arg @Text @@ -645,7 +601,7 @@ ] it "fails if argument fails to parse" $ do - let config = "foo \"test\"" + let config = "foo test" decoder = do KDL.arg @Int decodeNode "foo" decoder config @@ -667,7 +623,7 @@ -- Most behaviors tested with `arg` describe "argWith" $ do it "decodes an argument" $ do - let config = "foo \"bar\"" + let config = "foo bar" decoder = do KDL.argWith KDL.text decodeNode "foo" decoder config `shouldBe` Right "bar" @@ -710,7 +666,7 @@ describe "prop" $ do it "decodes a prop" $ do - let config = "foo test1=1 test2=\"hello\"" + let config = "foo test1=1 test2=hello" decoder = do prop1 <- KDL.prop @Text "test2" prop2 <- KDL.prop @Int "test1" @@ -884,20 +840,20 @@ it "decodes children" $ do let config = "foo { bar test; }" decoder = do - KDL.children $ KDL.node @Node "bar" + fmap scrubFormat . KDL.children $ KDL.node @Node "bar" expected = Node { ann = Nothing - , name = Identifier{value = "bar", format = Nothing} + , name = Identifier{value = "bar", ext = KDL.def} , entries = [ Entry { name = Nothing - , value = Value{ann = Nothing, data_ = Text "test", format = Nothing} - , format = Nothing + , value = Value{ann = Nothing, data_ = String "test", ext = KDL.def} + , ext = KDL.def } ] - , children = Just NodeList{nodes = [], format = Nothing} - , format = Nothing + , children = Nothing + , ext = KDL.def } decodeNode "foo" decoder config `shouldBe` Right expected @@ -924,15 +880,15 @@ it "decodes any value" $ do let config = "foo 1.0 asdf #true" decoder = KDL.document $ do - KDL.argsAtWith "foo" KDL.any + map scrubFormat <$> KDL.argsAtWith "foo" KDL.any val data_ = Value { ann = Nothing , data_ = data_ - , format = Nothing + , ext = KDL.def } KDL.decodeWith decoder config - `shouldBe` Right [val $ Number 1, val $ Text "asdf", val $ Bool True] + `shouldBe` Right [val $ Number 1, val $ String "asdf", val $ Bool True] describe "text" $ do it "decodes text value" $ do diff --git a/test/KDL/DecoderSpec.hs b/test/KDL/DecoderSpec.hs new file mode 100644 --- /dev/null +++ b/test/KDL/DecoderSpec.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +module KDL.DecoderSpec (spec) where + +import Control.Monad (when) +import Data.Text (Text) +import Data.Text qualified as Text +import KDL qualified +import KDL.Types (Node) +import Skeletest +import Skeletest.Predicate qualified as P +import System.FilePath (()) + +decodeErrorMsgSnapshot :: Maybe FilePath -> Predicate IO (Either KDL.DecodeError a) +decodeErrorMsgSnapshot mfile = P.left (KDL.renderDecodeError P.>>> sanitize P.>>> P.matchesSnapshot) + where + sanitize = + case mfile of + Nothing -> id + Just file -> Text.replace (Text.pack file) "test_config.kdl" + +spec :: Spec +spec = do + describe "decodeWith" $ do + it "fails with helpful error if parsing fails" $ do + let config = "foo 123=123" + decoder = KDL.document $ KDL.node @Node "foo" + KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsgSnapshot Nothing + + it "fails with user-defined error" $ do + let config = "foo -1" + decoder = + KDL.document . KDL.argAtWith "foo" $ + KDL.withDecoder KDL.number $ \x -> do + when (x < 0) $ do + KDL.failM $ "Got negative number: " <> (Text.pack . show) x + pure x + KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsgSnapshot Nothing + + it "shows context in deeply nested error" $ do + let config = "foo; foo { bar { baz; baz; baz; baz a=1; }; }" + decoder = + KDL.document + . (KDL.many . KDL.nodeWith "foo" . KDL.children) + . (KDL.many . KDL.nodeWith "bar" . KDL.children) + . (KDL.many . KDL.nodeWith "baz") + $ KDL.optional (KDL.prop @Text "a") + KDL.decodeWith decoder config `shouldSatisfy` decodeErrorMsgSnapshot Nothing + + describe "decodeFileWith" $ do + it "fails with helpful error if parsing fails" $ do + FixtureKdlFile file <- getFixture + writeFile file "foo 123=123" + let decoder = KDL.document $ KDL.node @Node "foo" + KDL.decodeFileWith decoder file `shouldSatisfy` P.returns (decodeErrorMsgSnapshot (Just file)) + + it "fails with user-defined error" $ do + FixtureKdlFile file <- getFixture + writeFile file "foo -1" + let decoder = + KDL.document . KDL.argAtWith "foo" $ + KDL.withDecoder KDL.number $ \x -> do + when (x < 0) $ do + KDL.failM $ "Got negative number: " <> (Text.pack . show) x + pure x + KDL.decodeFileWith decoder file `shouldSatisfy` P.returns (decodeErrorMsgSnapshot (Just file)) + + it "shows context in deeply nested error" $ do + FixtureKdlFile file <- getFixture + writeFile file "foo; foo { bar { baz; baz; baz; baz a=1; }; }" + let decoder = + KDL.document + . (KDL.many . KDL.nodeWith "foo" . KDL.children) + . (KDL.many . KDL.nodeWith "bar" . KDL.children) + . (KDL.many . KDL.nodeWith "baz") + $ KDL.optional (KDL.prop @Text "a") + KDL.decodeFileWith decoder file `shouldSatisfy` P.returns (decodeErrorMsgSnapshot (Just file)) + +newtype FixtureKdlFile = FixtureKdlFile FilePath + +instance Fixture FixtureKdlFile where + fixtureAction = do + FixtureTmpDir tmpdir <- getFixture + pure . noCleanup $ FixtureKdlFile (tmpdir "kdl-hs-test.kdl") diff --git a/test/KDL/ParserSpec.hs b/test/KDL/ParserSpec.hs --- a/test/KDL/ParserSpec.hs +++ b/test/KDL/ParserSpec.hs @@ -3,111 +3,58 @@ module KDL.ParserSpec (spec) where -import Data.Text (Text) -import Data.Text qualified as Text -import KDL.Parser -import KDL.Types ( - Entry (..), - Identifier (..), - Node (..), - NodeList (..), - Value (..), - ValueData (..), - ) +import Control.Monad (forM_) +import Data.Text.IO qualified as Text +import KDL qualified import Skeletest import Skeletest.Predicate qualified as P +import System.Directory (findExecutable, listDirectory) +import System.FilePath (takeExtension, ()) import System.IO.Temp (withSystemTempDirectory) +import System.Process (callProcess) spec :: Spec spec = do + let exampleConfig = "foo hello=world 1.0 { bar; }" + describe "parse" $ do it "parses a KDL document" $ do - let expected = - newNodeList - [ newNode - "foo" - [ newArg $ Number 1.0 - , newProp "hello" $ Text "world" - ] - ( Just - [ newNode "bar" [] (Just []) - ] - ) - ] - parse "foo hello=world 1.0 { bar; }" `shouldBe` Right expected + KDL.parse exampleConfig `shouldSatisfy` P.right P.matchesSnapshot - it "returns a textual error on parse failure" $ do - let msg = - Text.intercalate "\n" $ - [ "1:10:" - , " |" - , "1 | foo hello= 123" - , " | ^^" - , "unexpected \"= \"" - , "expecting Node Child, Node Space, or Node Terminator" - ] - parse "foo hello= 123" `shouldBe` Left msg + describe "error messages" $ do + let test msg input = do + it msg $ KDL.parse input `shouldSatisfy` P.left P.matchesSnapshot + -- TODO: add more + test "Unquoted numeric prop name" "foo 123=123" + + describe "parseWith" $ do + it "parses a KDL document with spans" $ do + KDL.parseWith KDL.def{KDL.includeSpans = True} "foo 1 2 {\n bar 3\n}" + `shouldSatisfy` P.right P.matchesSnapshot + + -- Most behavior tested in `parse` tests describe "parseFile" $ do it "parses a KDL document from a filepath" $ do withSystemTempDirectory "" $ \tmpdir -> do let file = tmpdir ++ "/test.kdl" - writeFile file "foo hello=world 1.0 { bar; }" - let expected = - newNodeList - [ newNode - "foo" - [ newArg $ Number 1.0 - , newProp "hello" $ Text "world" - ] - ( Just - [ newNode "bar" [] (Just []) - ] - ) - ] - parseFile file `shouldSatisfy` P.returns (P.right (P.eq expected)) - -{----- Helpers -----} - -newNodeList :: [Node] -> NodeList -newNodeList nodes = - NodeList - { nodes = nodes - , format = Nothing - } - -newNode :: Text -> [Entry] -> Maybe [Node] -> Node -newNode name entries children = - Node - { ann = Nothing - , name = newIdentifier name - , entries = entries - , children = newNodeList <$> children - , format = Nothing - } - -newArg :: ValueData -> Entry -newArg = newEntry Nothing - -newProp :: Text -> ValueData -> Entry -newProp = newEntry . Just + Text.writeFile file exampleConfig + Right actual <- KDL.parseFile file + Right expected <- pure $ KDL.parse exampleConfig + -- tested in `parse` + actual `shouldBe` expected -newEntry :: Maybe Text -> ValueData -> Entry -newEntry mName data_ = - Entry - { name = newIdentifier <$> mName - , value = - Value - { ann = Nothing - , data_ = data_ - , format = Nothing - } - , format = Nothing - } + describe "kdl-test examples" $ do + it "decodes correctly" $ do + decoder <- findExecutable "kdl-hs-test-decoder" >>= maybe (error "Could not find kdl-hs-test-decoder") pure + callProcess "scripts/kdl-test" ["run", "--decoder", decoder] -newIdentifier :: Text -> Identifier -newIdentifier value = - Identifier - { value = value - , format = Nothing - } + it "roundtrips successfully" $ do + FixtureTmpDir tmpdir <- getFixture + let dir = tmpdir "kdl-examples" + callProcess "scripts/kdl-test" ["extract", "--dir", dir] + files <- filter ((== ".kdl") . takeExtension) <$> listDirectory (dir "valid") + forM_ files $ \file -> do + context file $ do + content <- Text.readFile (dir "valid" file) + (fmap KDL.render . KDL.parse) content `shouldBe` Right content diff --git a/test/KDL/RenderSpec.hs b/test/KDL/RenderSpec.hs new file mode 100644 --- /dev/null +++ b/test/KDL/RenderSpec.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +module KDL.RenderSpec (spec) where + +import KDL qualified +import Skeletest +import Skeletest.Predicate qualified as P + +spec :: Spec +spec = do + describe "render" $ do + describe "default formatting" $ do + let ident s = KDL.Identifier{value = s, ext = KDL.def} + fooAnn = + KDL.Ann + { identifier = ident "Foo" + , ext = KDL.def + } + doc = + KDL.NodeList + { nodes = + [ KDL.Node + { ann = Just fooAnn + , name = ident "foo" + , entries = + [ KDL.Entry + { name = Nothing + , value = + KDL.Value + { ann = Just fooAnn + , data_ = KDL.Number 123 + , ext = KDL.def + } + , ext = KDL.def + } + , KDL.Entry + { name = Just $ ident "a" + , value = + KDL.Value + { ann = Just fooAnn + , data_ = KDL.Number 123 + , ext = KDL.def + } + , ext = KDL.def + } + , KDL.Entry + { name = Nothing + , value = + KDL.Value + { ann = Nothing + , data_ = KDL.String "test" + , ext = KDL.def + } + , ext = KDL.def + } + , KDL.Entry + { name = Just $ ident "b" + , value = + KDL.Value + { ann = Nothing + , data_ = KDL.String "test" + , ext = KDL.def + } + , ext = KDL.def + } + ] + , children = + Just + KDL.NodeList + { nodes = + [ KDL.Node + { ann = Nothing + , name = ident "bar" + , entries = [] + , children = + Just + KDL.NodeList + { nodes = + [ KDL.Node + { ann = Nothing + , name = ident "baz" + , entries = [] + , children = Nothing + , ext = KDL.def + } + ] + , ext = KDL.def + } + , ext = KDL.def + } + ] + , ext = KDL.def + } + , ext = KDL.def + } + , KDL.Node + { ann = Just fooAnn + , name = ident "foo" + , entries = [] + , children = + Just + KDL.NodeList + { nodes = [] + , ext = KDL.def + } + , ext = KDL.def + } + ] + , ext = KDL.def + } + + it "renders correctly" $ do + KDL.render doc `shouldSatisfy` P.matchesSnapshot + + it "can be parsed" $ do + (KDL.parse . KDL.render) doc `shouldSatisfy` P.right P.anything diff --git a/test/KDL/TestUtils/AST.hs b/test/KDL/TestUtils/AST.hs new file mode 100644 --- /dev/null +++ b/test/KDL/TestUtils/AST.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE RecordWildCards #-} + +module KDL.TestUtils.AST ( + scrubFormat, +) where + +import KDL.Types + +class ScrubFormat a where + scrubFormat :: a -> a +instance ScrubFormat NodeList where + scrubFormat NodeList{..} = + NodeList + { nodes = map scrubFormat nodes + , ext = def + } +instance ScrubFormat Node where + scrubFormat Node{..} = + Node + { ann = scrubFormat <$> ann + , name = scrubFormat name + , entries = map scrubFormat entries + , children = scrubFormat <$> children + , ext = def + } +instance ScrubFormat Entry where + scrubFormat Entry{..} = + Entry + { name = scrubFormat <$> name + , value = scrubFormat value + , ext = def + } +instance ScrubFormat Value where + scrubFormat Value{..} = + Value + { ann = scrubFormat <$> ann + , data_ = data_ + , ext = def + } +instance ScrubFormat Ann where + scrubFormat Ann{..} = + Ann + { identifier = scrubFormat identifier + , ext = def + } +instance ScrubFormat Identifier where + scrubFormat Identifier{..} = + Identifier + { value = value + , ext = def + } diff --git a/test/KDL/TestUtils/Error.hs b/test/KDL/TestUtils/Error.hs new file mode 100644 --- /dev/null +++ b/test/KDL/TestUtils/Error.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE OverloadedStrings #-} + +module KDL.TestUtils.Error ( + decodeErrorMsg, +) where + +import Data.Text (Text) +import Data.Text qualified as Text +import KDL qualified +import Skeletest +import Skeletest.Predicate qualified as P + +decodeErrorMsg :: [Text] -> Predicate IO (Either KDL.DecodeError a) +decodeErrorMsg msgs = P.left (KDL.renderDecodeError P.>>> P.eq msg) + where + msg = Text.intercalate "\n" msgs diff --git a/test/KDL/__snapshots__/DecoderSpec.snap.md b/test/KDL/__snapshots__/DecoderSpec.snap.md new file mode 100644 --- /dev/null +++ b/test/KDL/__snapshots__/DecoderSpec.snap.md @@ -0,0 +1,53 @@ +# test/KDL/DecoderSpec.hs + +## decodeFileWith / fails with helpful error if parsing fails + +``` +test_config.kdl:1:8: + | +1 | foo 123=123 + | ^ +unexpected '=' +expecting children block, decimal point, end of node, exponent, or node prop or arg +``` + +## decodeFileWith / fails with user-defined error + +``` +Failed to decode test_config.kdl: +At: foo #0 > arg #0 + Got negative number: -1.0 +``` + +## decodeFileWith / shows context in deeply nested error + +``` +Failed to decode test_config.kdl: +At: foo #1 > bar #0 > baz #3 > prop a + Expected text, got: 1 +``` + +## decodeWith / fails with helpful error if parsing fails + +``` +1:8: + | +1 | foo 123=123 + | ^ +unexpected '=' +expecting children block, decimal point, end of node, exponent, or node prop or arg +``` + +## decodeWith / fails with user-defined error + +``` +At: foo #0 > arg #0 + Got negative number: -1.0 +``` + +## decodeWith / shows context in deeply nested error + +``` +At: foo #1 > bar #0 > baz #3 > prop a + Expected text, got: 1 +``` diff --git a/test/KDL/__snapshots__/ParserSpec.snap.md b/test/KDL/__snapshots__/ParserSpec.snap.md new file mode 100644 --- /dev/null +++ b/test/KDL/__snapshots__/ParserSpec.snap.md @@ -0,0 +1,332 @@ +# test/KDL/ParserSpec.hs + +## parse / error messages / Unquoted numeric prop name + +``` +1:8: + | +1 | foo 123=123 + | ^ +unexpected '=' +expecting children block, decimal point, end of node, exponent, or node prop or arg +``` + +## parse / parses a KDL document + +```haskell +NodeList + { nodes = + [ Node + { ann = Nothing + , name = + Identifier + { value = "foo" + , ext = + IdentifierExtension + { format = Just IdentifierFormat { repr = Just "foo" } + , span = + Span { startLine = 0 , startCol = 0 , endLine = 0 , endCol = 0 } + } + } + , entries = + [ Entry + { name = + Just + Identifier + { value = "hello" + , ext = + IdentifierExtension + { format = Just IdentifierFormat { repr = Just "hello" } + , span = + Span { startLine = 0 , startCol = 0 , endLine = 0 , endCol = 0 } + } + } + , value = + Value + { ann = Nothing + , data_ = String "world" + , ext = + ValueExtension + { format = Just ValueFormat { repr = Just "world" } + , span = + Span { startLine = 0 , startCol = 0 , endLine = 0 , endCol = 0 } + } + } + , ext = + EntryExtension + { format = + Just + EntryFormat + { leading = " " , afterKey = "" , afterEq = "" , trailing = "" } + , span = + Span { startLine = 0 , startCol = 0 , endLine = 0 , endCol = 0 } + } + } + , Entry + { name = Nothing + , value = + Value + { ann = Nothing + , data_ = Number 1.0 + , ext = + ValueExtension + { format = Just ValueFormat { repr = Just "1.0" } + , span = + Span { startLine = 0 , startCol = 0 , endLine = 0 , endCol = 0 } + } + } + , ext = + EntryExtension + { format = + Just + EntryFormat + { leading = " " , afterKey = "" , afterEq = "" , trailing = "" } + , span = + Span { startLine = 0 , startCol = 0 , endLine = 0 , endCol = 0 } + } + } + ] + , children = + Just + NodeList + { nodes = + [ Node + { ann = Nothing + , name = + Identifier + { value = "bar" + , ext = + IdentifierExtension + { format = Just IdentifierFormat { repr = Just "bar" } + , span = + Span + { startLine = 0 + , startCol = 0 + , endLine = 0 + , endCol = 0 + } + } + } + , entries = [] + , children = Nothing + , ext = + NodeExtension + { format = + Just + NodeFormat + { leading = " " + , beforeChildren = "" + , beforeTerminator = "" + , terminator = ";" + , trailing = "" + } + , span = + Span { startLine = 0 , startCol = 0 , endLine = 0 , endCol = 0 } + } + } + ] + , ext = + NodeListExtension + { format = Just NodeListFormat { leading = "" , trailing = " " } + , span = + Span { startLine = 0 , startCol = 0 , endLine = 0 , endCol = 0 } + } + } + , ext = + NodeExtension + { format = + Just + NodeFormat + { leading = "" + , beforeChildren = " " + , beforeTerminator = "" + , terminator = "" + , trailing = "" + } + , span = + Span { startLine = 0 , startCol = 0 , endLine = 0 , endCol = 0 } + } + } + ] + , ext = + NodeListExtension + { format = Just NodeListFormat { leading = "" , trailing = "" } + , span = + Span { startLine = 0 , startCol = 0 , endLine = 0 , endCol = 0 } + } + } +``` + +## parseWith / parses a KDL document with spans + +```haskell +NodeList + { nodes = + [ Node + { ann = Nothing + , name = + Identifier + { value = "foo" + , ext = + IdentifierExtension + { format = Just IdentifierFormat { repr = Just "foo" } + , span = + Span { startLine = 1 , startCol = 1 , endLine = 1 , endCol = 3 } + } + } + , entries = + [ Entry + { name = Nothing + , value = + Value + { ann = Nothing + , data_ = Number 1.0 + , ext = + ValueExtension + { format = Just ValueFormat { repr = Just "1" } + , span = + Span { startLine = 1 , startCol = 5 , endLine = 1 , endCol = 5 } + } + } + , ext = + EntryExtension + { format = + Just + EntryFormat + { leading = " " , afterKey = "" , afterEq = "" , trailing = "" } + , span = + Span { startLine = 1 , startCol = 5 , endLine = 1 , endCol = 5 } + } + } + , Entry + { name = Nothing + , value = + Value + { ann = Nothing + , data_ = Number 2.0 + , ext = + ValueExtension + { format = Just ValueFormat { repr = Just "2" } + , span = + Span { startLine = 1 , startCol = 7 , endLine = 1 , endCol = 7 } + } + } + , ext = + EntryExtension + { format = + Just + EntryFormat + { leading = " " , afterKey = "" , afterEq = "" , trailing = "" } + , span = + Span { startLine = 1 , startCol = 7 , endLine = 1 , endCol = 7 } + } + } + ] + , children = + Just + NodeList + { nodes = + [ Node + { ann = Nothing + , name = + Identifier + { value = "bar" + , ext = + IdentifierExtension + { format = Just IdentifierFormat { repr = Just "bar" } + , span = + Span + { startLine = 2 + , startCol = 3 + , endLine = 2 + , endCol = 5 + } + } + } + , entries = + [ Entry + { name = Nothing + , value = + Value + { ann = Nothing + , data_ = Number 3.0 + , ext = + ValueExtension + { format = Just ValueFormat { repr = Just "3" } + , span = + Span + { startLine = 2 + , startCol = 7 + , endLine = 2 + , endCol = 7 + } + } + } + , ext = + EntryExtension + { format = + Just + EntryFormat + { leading = " " + , afterKey = "" + , afterEq = "" + , trailing = "" + } + , span = + Span + { startLine = 2 + , startCol = 7 + , endLine = 2 + , endCol = 7 + } + } + } + ] + , children = Nothing + , ext = + NodeExtension + { format = + Just + NodeFormat + { leading = "\n " + , beforeChildren = "" + , beforeTerminator = "" + , terminator = "\n" + , trailing = "" + } + , span = + Span { startLine = 2 , startCol = 3 , endLine = 2 , endCol = 7 } + } + } + ] + , ext = + NodeListExtension + { format = Just NodeListFormat { leading = "" , trailing = "" } + , span = + Span { startLine = 2 , startCol = 3 , endLine = 2 , endCol = 7 } + } + } + , ext = + NodeExtension + { format = + Just + NodeFormat + { leading = "" + , beforeChildren = " " + , beforeTerminator = "" + , terminator = "" + , trailing = "" + } + , span = + Span { startLine = 1 , startCol = 1 , endLine = 3 , endCol = 1 } + } + } + ] + , ext = + NodeListExtension + { format = Just NodeListFormat { leading = "" , trailing = "" } + , span = + Span { startLine = 1 , startCol = 1 , endLine = 3 , endCol = 1 } + } + } +``` diff --git a/test/KDL/__snapshots__/RenderSpec.snap.md b/test/KDL/__snapshots__/RenderSpec.snap.md new file mode 100644 --- /dev/null +++ b/test/KDL/__snapshots__/RenderSpec.snap.md @@ -0,0 +1,12 @@ +# test/KDL/RenderSpec.hs + +## render / default formatting / renders correctly + +``` +(Foo)foo (Foo)123.0 a=(Foo)123.0 test b=test { + bar { + baz + } +} +(Foo)foo {} +``` diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,1 +1,23 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedStrings #-} + +import Data.Text qualified as Text +import Data.Typeable (Typeable) +import KDL qualified import Skeletest.Main +import Text.Show.Pretty (ppShow) + +snapshotRenderers :: [SnapshotRenderer] +snapshotRenderers = + [ hsRender @KDL.NodeList + , hsRender @KDL.Node + , hsRender @KDL.Entry + , hsRender @KDL.Value + ] + where + hsRender :: forall a. (Show a, Typeable a) => SnapshotRenderer + hsRender = + SnapshotRenderer + { render = Text.pack . ppShow @a + , snapshotLang = Just "haskell" + } diff --git a/test/kdl-hs-test-decoder.hs b/test/kdl-hs-test-decoder.hs new file mode 100644 --- /dev/null +++ b/test/kdl-hs-test-decoder.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +import Data.Aeson ((.=)) +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy.Char8 qualified as ByteStringL +import Data.Either (partitionEithers) +import Data.Map qualified as Map +import Data.Scientific qualified as Scientific +import Data.Text qualified as Text +import Data.Text.IO qualified as Text +import KDL qualified +import System.Exit (exitFailure) +import System.IO (stderr) + +main :: IO () +main = do + input <- Text.getContents + doc <- + case KDL.parse input of + Right doc -> pure doc + Left e -> do + Text.hPutStrLn stderr e + exitFailure + ByteStringL.putStrLn . Aeson.encode $ encodeNodeList doc + +encodeNodeList :: KDL.NodeList -> Aeson.Value +encodeNodeList nodes = Aeson.toJSON . map encodeNode $ nodes.nodes + +encodeNode :: KDL.Node -> Aeson.Value +encodeNode node = + Aeson.object + [ "type" .= (encodeAnn <$> node.ann) + , "name" .= encodeIdentifier node.name + , "args" .= args + , "props" .= Map.fromList props + , "children" .= maybe (Aeson.Array mempty) encodeNodeList node.children + ] + where + (args, props) = + partitionEithers + [ case entry.name of + Nothing -> Left val + Just name -> Right (name.value, val) + | entry <- node.entries + , let val = encodeEntry entry + ] + +encodeEntry :: KDL.Entry -> Aeson.Value +encodeEntry entry = + Aeson.object + [ "type" .= (encodeAnn <$> entry.value.ann) + , "value" .= encodeValueData entry.value.data_ + ] + +encodeValueData :: KDL.ValueData -> Aeson.Value +encodeValueData = \case + KDL.String s -> val "string" (Text.unpack s) + KDL.Number x -> val "number" (Scientific.formatScientific Scientific.Fixed Nothing x) + KDL.Bool x -> val "boolean" (if x then "true" else "false") + KDL.Inf -> val "number" "inf" + KDL.NegInf -> val "number" "-inf" + KDL.NaN -> val "number" "nan" + KDL.Null -> Aeson.object ["type" .= Text.pack "null"] + where + val :: String -> String -> Aeson.Value + val ty v = Aeson.object ["type" .= ty, "value" .= v] + +encodeAnn :: KDL.Ann -> Aeson.Value +encodeAnn = encodeIdentifier . (.identifier) + +encodeIdentifier :: KDL.Identifier -> Aeson.Value +encodeIdentifier = Aeson.toJSON . (.value)