toml-parser 1.3.0.0 → 1.3.1.0
raw patch · 15 files changed
+479/−151 lines, 15 filesdep ~template-haskell
Dependency ranges changed: template-haskell
Files
- ChangeLog.md +5/−0
- README.lhs +104/−54
- README.md +104/−54
- src/Toml.hs +3/−7
- src/Toml/FromValue.hs +0/−1
- src/Toml/Lexer.x +3/−0
- src/Toml/Lexer/Utils.hs +11/−4
- src/Toml/Pretty.hs +72/−16
- src/Toml/Semantics/Ordered.hs +113/−0
- test/DecodeSpec.hs +2/−3
- test/FromValueSpec.hs +1/−1
- test/HieDemoSpec.hs +1/−2
- test/LexerSpec.hs +11/−1
- test/PrettySpec.hs +33/−2
- toml-parser.cabal +16/−6
ChangeLog.md view
@@ -1,5 +1,10 @@ # Revision history for toml-parser +## 1.3.1.0++* Added `Toml.Semantics.Ordered` for preserving input TOML orderings+* Added support for pretty-printing multi-line strings+ ## 1.3.0.0 -- 2023-07-16 * Make more structured error messages available in the low-level modules.
README.lhs view
@@ -41,19 +41,28 @@ to ensure that its code typechecks and stays in sync with the rest of the package. ```haskell-import Toml (parse, decode, Value(..))-import Toml.FromValue (FromValue(fromValue), parseTableFromValue, reqKey, optKey)+import GHC.Generics (Generic)+import QuoteStr (quoteStr)+import Test.Hspec (Spec, hspec, it, shouldBe)+import Toml (parse, decode, encode, Value(..))+import Toml.FromValue (Result(Success), FromValue(fromValue), parseTableFromValue, reqKey) import Toml.FromValue.Generic (genericParseTable)-import Toml.ToValue (ToValue(toValue), ToTable(toTable), defaultTableToValue)+import Toml.ToValue (ToValue(toValue), ToTable(toTable), defaultTableToValue, table, (.=)) import Toml.ToValue.Generic (genericToTable)-import GHC.Generics (Generic)-main = pure ()++main :: IO ()+main = hspec (parses >> decodes >> encodes) ``` ### Using the raw parser -Consider this sample TOML text from the specification.+Consider this sample TOML text from the TOML specification. +```haskell+fruitStr :: String+fruitStr = [quoteStr|+```+ ```toml [[fruits]] name = "apple"@@ -76,52 +85,58 @@ name = "plantain" ``` +```haskell+|]+```+ Parsing using this package generates the following value -```haskell ignore->>> parse fruitStr-Right (fromList [- ("fruits",Array [- Table (fromList [- ("name",String "apple"),- ("physical",Table (fromList [- ("color",String "red"),- ("shape",String "round")])),- ("varieties",Array [- Table (fromList [("name",String "red delicious")]),- Table (fromList [("name",String "granny smith")])])]),- Table (fromList [- ("name",String "banana"),- ("varieties",Array [- Table (fromList [("name",String "plantain")])])])])])+```haskell+parses :: Spec+parses = it "parses" $+ parse fruitStr+ `shouldBe`+ Right (table [+ ("fruits", Array [+ Table (table [+ ("name", String "apple"),+ ("physical", Table (table [+ ("color", String "red"),+ ("shape", String "round")])),+ ("varieties", Array [+ Table (table [("name", String "red delicious")]),+ Table (table [("name", String "granny smith")])])]),+ Table (table [+ ("name", String "banana"),+ ("varieties", Array [+ Table (table [("name", String "plantain")])])])])]) ``` -We can render this parsed value back to TOML text using `prettyToml fruitToml`.-In this case the input was already sorted, so the generated text will happen-to match almost exactly.- ### Using decoding classes Here's an example of defining datatypes and deserializers for the TOML above.+The `FromValue` typeclass is used to encode each datatype into a TOML value.+Instances can be derived for simple record types. More complex examples can+be manually derived. ```haskell-newtype Fruits = Fruits [Fruit]- deriving (Eq, Show)+newtype Fruits = Fruits { fruits :: [Fruit] }+ deriving (Eq, Show, Generic) -data Fruit = Fruit String (Maybe Physical) [Variety]- deriving (Eq, Show)+data Fruit = Fruit { name :: String, physical :: Maybe Physical, varieties :: [Variety] }+ deriving (Eq, Show, Generic) -data Physical = Physical String String- deriving (Eq, Show)+data Physical = Physical { color :: String, shape :: String }+ deriving (Eq, Show, Generic) newtype Variety = Variety String- deriving (Eq, Show)+ deriving (Eq, Show, Generic) instance FromValue Fruits where- fromValue = parseTableFromValue (Fruits <$> reqKey "fruits")+ fromValue = parseTableFromValue genericParseTable instance FromValue Fruit where- fromValue = parseTableFromValue (Fruit <$> reqKey "name" <*> optKey "physical" <*> reqKey "varieties")+ fromValue = parseTableFromValue genericParseTable instance FromValue Physical where fromValue = parseTableFromValue (Physical <$> reqKey "color" <*> reqKey "shape")@@ -132,32 +147,67 @@ We can run this example on the original value to deserialize it into domain-specific datatypes. -```haskell ignore->>> decode fruitStr :: Result Fruits-Success [] (Fruits [- Fruit "apple" (Just (Physical "red" "round")) [Variety "red delicious", Variety "granny smith"],- Fruit "banana" Nothing [Variety "plantain"]])+```haskell+decodes :: Spec+decodes = it "decodes" $+ decode fruitStr+ `shouldBe`+ Success [] (Fruits [+ Fruit+ "apple"+ (Just (Physical "red" "round"))+ [Variety "red delicious", Variety "granny smith"],+ Fruit "banana" Nothing [Variety "plantain"]]) ``` -### Generics+### Using encoding classes -Code for generating and matching tables to records can be derived-using GHC.Generics. This will generate tables using the field names-as table keys.+The `ToValue` class is for all datatypes that can be encoded into TOML.+The more specialized `ToTable` class is for datatypes that encode into+tables and are thus elligible to be top-level types (all TOML documents+are tables at the top-level). +Generics can be used to derive `ToTable` for simple record types.+Manually defined instances are available for the more complex cases.+ ```haskell-data ExampleRecord = ExampleRecord {- exString :: String,- exList :: [Int],- exOpt :: Maybe Bool}- deriving (Show, Generic, Eq)+instance ToValue Fruits where toValue = defaultTableToValue+instance ToValue Fruit where toValue = defaultTableToValue+instance ToValue Physical where toValue = defaultTableToValue+instance ToValue Variety where toValue = defaultTableToValue -instance FromValue ExampleRecord where fromValue = parseTableFromValue genericParseTable-instance ToTable ExampleRecord where toTable = genericToTable-instance ToValue ExampleRecord where toValue = defaultTableToValue+instance ToTable Fruits where toTable = genericToTable+instance ToTable Fruit where toTable = genericToTable+instance ToTable Physical where toTable x = table ["color" .= color x, "shape" .= shape x]+instance ToTable Variety where toTable (Variety x) = table ["name" .= x]++encodes :: Spec+encodes = it "encodes" $+ show (encode (Fruits [Fruit+ "apple"+ (Just (Physical "red" "round"))+ [Variety "red delicious", Variety "granny smith"]]))+ `shouldBe` [quoteStr|+ [[fruits]]+ name = "apple"++ [fruits.physical]+ color = "red"+ shape = "round"++ [[fruits.varieties]]+ name = "red delicious"++ [[fruits.varieties]]+ name = "granny smith"|] ``` -### Larger Example+## More Examples A demonstration of using this package at a more realistic scale-can be found in [HieDemoSpec](test/HieDemoSpec.hs).+can be found in [HieDemoSpec](test/HieDemoSpec.hs). The various unit+test files demonstrate what you can do with this library and what+outputs you can expect.++See the low-level operations used to build a TOML syntax highlighter+in [TomlHighlighter](test-drivers/highlighter/Main.hs).
README.md view
@@ -41,19 +41,28 @@ to ensure that its code typechecks and stays in sync with the rest of the package. ```haskell-import Toml (parse, decode, Value(..))-import Toml.FromValue (FromValue(fromValue), parseTableFromValue, reqKey, optKey)+import GHC.Generics (Generic)+import QuoteStr (quoteStr)+import Test.Hspec (Spec, hspec, it, shouldBe)+import Toml (parse, decode, encode, Value(..))+import Toml.FromValue (Result(Success), FromValue(fromValue), parseTableFromValue, reqKey) import Toml.FromValue.Generic (genericParseTable)-import Toml.ToValue (ToValue(toValue), ToTable(toTable), defaultTableToValue)+import Toml.ToValue (ToValue(toValue), ToTable(toTable), defaultTableToValue, table, (.=)) import Toml.ToValue.Generic (genericToTable)-import GHC.Generics (Generic)-main = pure ()++main :: IO ()+main = hspec (parses >> decodes >> encodes) ``` ### Using the raw parser -Consider this sample TOML text from the specification.+Consider this sample TOML text from the TOML specification. +```haskell+fruitStr :: String+fruitStr = [quoteStr|+```+ ```toml [[fruits]] name = "apple"@@ -76,52 +85,58 @@ name = "plantain" ``` +```haskell+|]+```+ Parsing using this package generates the following value -```haskell ignore->>> parse fruitStr-Right (fromList [- ("fruits",Array [- Table (fromList [- ("name",String "apple"),- ("physical",Table (fromList [- ("color",String "red"),- ("shape",String "round")])),- ("varieties",Array [- Table (fromList [("name",String "red delicious")]),- Table (fromList [("name",String "granny smith")])])]),- Table (fromList [- ("name",String "banana"),- ("varieties",Array [- Table (fromList [("name",String "plantain")])])])])])+```haskell+parses :: Spec+parses = it "parses" $+ parse fruitStr+ `shouldBe`+ Right (table [+ ("fruits", Array [+ Table (table [+ ("name", String "apple"),+ ("physical", Table (table [+ ("color", String "red"),+ ("shape", String "round")])),+ ("varieties", Array [+ Table (table [("name", String "red delicious")]),+ Table (table [("name", String "granny smith")])])]),+ Table (table [+ ("name", String "banana"),+ ("varieties", Array [+ Table (table [("name", String "plantain")])])])])]) ``` -We can render this parsed value back to TOML text using `prettyToml fruitToml`.-In this case the input was already sorted, so the generated text will happen-to match almost exactly.- ### Using decoding classes Here's an example of defining datatypes and deserializers for the TOML above.+The `FromValue` typeclass is used to encode each datatype into a TOML value.+Instances can be derived for simple record types. More complex examples can+be manually derived. ```haskell-newtype Fruits = Fruits [Fruit]- deriving (Eq, Show)+newtype Fruits = Fruits { fruits :: [Fruit] }+ deriving (Eq, Show, Generic) -data Fruit = Fruit String (Maybe Physical) [Variety]- deriving (Eq, Show)+data Fruit = Fruit { name :: String, physical :: Maybe Physical, varieties :: [Variety] }+ deriving (Eq, Show, Generic) -data Physical = Physical String String- deriving (Eq, Show)+data Physical = Physical { color :: String, shape :: String }+ deriving (Eq, Show, Generic) newtype Variety = Variety String- deriving (Eq, Show)+ deriving (Eq, Show, Generic) instance FromValue Fruits where- fromValue = parseTableFromValue (Fruits <$> reqKey "fruits")+ fromValue = parseTableFromValue genericParseTable instance FromValue Fruit where- fromValue = parseTableFromValue (Fruit <$> reqKey "name" <*> optKey "physical" <*> reqKey "varieties")+ fromValue = parseTableFromValue genericParseTable instance FromValue Physical where fromValue = parseTableFromValue (Physical <$> reqKey "color" <*> reqKey "shape")@@ -132,32 +147,67 @@ We can run this example on the original value to deserialize it into domain-specific datatypes. -```haskell ignore->>> decode fruitStr :: Result Fruits-Success [] (Fruits [- Fruit "apple" (Just (Physical "red" "round")) [Variety "red delicious", Variety "granny smith"],- Fruit "banana" Nothing [Variety "plantain"]])+```haskell+decodes :: Spec+decodes = it "decodes" $+ decode fruitStr+ `shouldBe`+ Success [] (Fruits [+ Fruit+ "apple"+ (Just (Physical "red" "round"))+ [Variety "red delicious", Variety "granny smith"],+ Fruit "banana" Nothing [Variety "plantain"]]) ``` -### Generics+### Using encoding classes -Code for generating and matching tables to records can be derived-using GHC.Generics. This will generate tables using the field names-as table keys.+The `ToValue` class is for all datatypes that can be encoded into TOML.+The more specialized `ToTable` class is for datatypes that encode into+tables and are thus elligible to be top-level types (all TOML documents+are tables at the top-level). +Generics can be used to derive `ToTable` for simple record types.+Manually defined instances are available for the more complex cases.+ ```haskell-data ExampleRecord = ExampleRecord {- exString :: String,- exList :: [Int],- exOpt :: Maybe Bool}- deriving (Show, Generic, Eq)+instance ToValue Fruits where toValue = defaultTableToValue+instance ToValue Fruit where toValue = defaultTableToValue+instance ToValue Physical where toValue = defaultTableToValue+instance ToValue Variety where toValue = defaultTableToValue -instance FromValue ExampleRecord where fromValue = parseTableFromValue genericParseTable-instance ToTable ExampleRecord where toTable = genericToTable-instance ToValue ExampleRecord where toValue = defaultTableToValue+instance ToTable Fruits where toTable = genericToTable+instance ToTable Fruit where toTable = genericToTable+instance ToTable Physical where toTable x = table ["color" .= color x, "shape" .= shape x]+instance ToTable Variety where toTable (Variety x) = table ["name" .= x]++encodes :: Spec+encodes = it "encodes" $+ show (encode (Fruits [Fruit+ "apple"+ (Just (Physical "red" "round"))+ [Variety "red delicious", Variety "granny smith"]]))+ `shouldBe` [quoteStr|+ [[fruits]]+ name = "apple"++ [fruits.physical]+ color = "red"+ shape = "round"++ [[fruits.varieties]]+ name = "red delicious"++ [[fruits.varieties]]+ name = "granny smith"|] ``` -### Larger Example+## More Examples A demonstration of using this package at a more realistic scale-can be found in [HieDemoSpec](test/HieDemoSpec.hs).+can be found in [HieDemoSpec](test/HieDemoSpec.hs). The various unit+test files demonstrate what you can do with this library and what+outputs you can expect.++See the low-level operations used to build a TOML syntax highlighter+in [TomlHighlighter](test-drivers/highlighter/Main.hs).
src/Toml.hs view
@@ -32,13 +32,10 @@ Result(..), ) where -import Text.Printf (printf) import Toml.FromValue (FromValue (fromValue), Result(..)) import Toml.FromValue.Matcher (runMatcher)-import Toml.Located (Located(Located)) import Toml.Parser (parseRawToml)-import Toml.Position (Position(posColumn, posLine))-import Toml.Pretty (TomlDoc, DocClass(..), prettyToml, prettySemanticError, prettyMatchMessage)+import Toml.Pretty (TomlDoc, DocClass(..), prettyToml, prettySemanticError, prettyMatchMessage, prettyLocated) import Toml.Semantics (semantics) import Toml.ToValue (ToTable (toTable)) import Toml.Value (Table, Value(..))@@ -47,11 +44,10 @@ parse :: String -> Either String Table parse str = case parseRawToml str of- Left (Located p e) -> Left (printf "%d:%d: %s" (posLine p) (posColumn p) e)+ Left e -> Left (prettyLocated e) Right exprs -> case semantics exprs of- Left (Located p e) ->- Left (printf "%d:%d: %s" (posLine p) (posColumn p) (prettySemanticError e))+ Left e -> Left (prettyLocated (prettySemanticError <$> e)) Right tab -> Right tab -- | Use the 'FromValue' instance to decode a value from a TOML string.
src/Toml/FromValue.hs view
@@ -60,7 +60,6 @@ import Data.Ratio (Ratio) import Data.Sequence (Seq) import Data.Sequence qualified as Seq-import Data.String (IsString (fromString)) import Data.Text qualified import Data.Text.Lazy qualified import Data.Time (ZonedTime, LocalTime, Day, TimeOfDay)
src/Toml/Lexer.x view
@@ -37,6 +37,7 @@ $hexdig = [ $digit A-F a-f ] $basic_unescaped = [ $wschar \x21 \x23-\x5B \x5D-\x7E $non_ascii ] $comment_start_symbol = \#+$control = [\x00-\x1F \x7F] @barekey = [0-9 A-Z a-z \- _]+ @@ -89,6 +90,7 @@ toml :- + <val> { @bad_dec_int { failure "leading zero prohibited" }@@ -170,6 +172,7 @@ \\ b { strFrag . ("\b" <$) } \\ \\ { strFrag . ("\\" <$) } \\ \" { strFrag . ("\"" <$) }+ $control # [\t\r\n] { recommendEscape } } {
src/Toml/Lexer/Utils.hs view
@@ -40,18 +40,19 @@ startLstr, endStr, unicodeEscape,+ recommendEscape, mkError, ) where -import Data.Char (ord, chr, isAscii)+import Data.Char (ord, chr, isAscii, isControl) import Data.Foldable (asum) import Data.Time.Format (parseTimeM, defaultTimeLocale, ParseTime) import Numeric (readHex)-+import Text.Printf (printf)+import Toml.Lexer.Token (Token(..)) import Toml.Located (Located(..)) import Toml.Position (move, Position)-import Toml.Lexer.Token (Token(..)) -- | Type of actions associated with lexer patterns type Action = Located String -> Context -> Outcome@@ -115,6 +116,10 @@ | otherwise -> strFrag (Located p [chr n]) ctx _ -> error "unicodeEscape: panic" +recommendEscape :: Action+recommendEscape (Located p x) _ =+ LexerError (Located p (printf "control characters must be escaped, use: \\u%04X" (ord (head x))))+ -- | Emit a token ignoring the current lexeme token_ :: Token -> Action token_ t x _ = EmitToken (t <$ x)@@ -167,4 +172,6 @@ mkError "" = "unexpected end-of-input" mkError ('\n':_) = "unexpected end-of-line" mkError ('\r':'\n':_) = "unexpected end-of-line"-mkError (x:_) = "unexpected " ++ show x+mkError (x:_)+ | isControl x = "control characters prohibited"+ | otherwise = "unexpected " ++ show x
src/Toml/Pretty.hs view
@@ -36,12 +36,13 @@ -- * Pretty errors prettySemanticError, prettyMatchMessage,+ prettyLocated, ) where import Data.Char (ord, isAsciiLower, isAsciiUpper, isDigit, isPrint) import Data.Foldable (fold) import Data.List (partition, sortOn)-import Data.List.NonEmpty (NonEmpty((:|)))+import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty import Data.Map qualified as Map import Data.String (fromString)@@ -51,7 +52,9 @@ import Text.Printf (printf) import Toml.FromValue.Matcher (MatchMessage(..), Scope (..)) import Toml.Lexer (Token(..))+import Toml.Located (Located(..)) import Toml.Parser.Types (SectionKind(..))+import Toml.Position (Position(..)) import Toml.Semantics (SemanticError (..), SemanticErrorKind (..)) import Toml.Value (Value(..), Table) @@ -102,6 +105,25 @@ | x <= '\xffff' -> printf "\\u%04X%s" (ord x) (go xs) | otherwise -> printf "\\U%08X%s" (ord x) (go xs) +-- | Quote a string using basic string literal syntax.+quoteMlString :: String -> String+quoteMlString = ("\"\"\"\n"++) . go+ where+ go = \case+ "" -> "\"\"\"" -- terminator+ '"' : '"' : '"' : xs -> "\"\"\\\"" ++ go xs+ '\\' : xs -> '\\' : '\\' : go xs+ '\b' : xs -> '\\' : 'b' : go xs+ '\f' : xs -> '\\' : 'f' : go xs+ '\t' : xs -> '\\' : 't' : go xs+ '\n' : xs -> '\n' : go xs+ '\r' : '\n' : xs -> '\r' : '\n' : go xs+ '\r' : xs -> '\\' : 'r' : go xs+ x : xs+ | isPrint x -> x : go xs+ | x <= '\xffff' -> printf "\\u%04X%s" (ord x) (go xs)+ | otherwise -> printf "\\U%08X%s" (ord x) (go xs)+ -- | Pretty-print a section heading. The result is annotated as a 'TableClass'. prettySectionKind :: SectionKind -> NonEmpty String -> TomlDoc prettySectionKind TableKind key =@@ -155,7 +177,7 @@ Table t -> lbrace <> concatWith (surround ", ") [prettyAssignment k v | (k,v) <- Map.assocs t] <> rbrace Bool True -> annotate BoolClass "true" Bool False -> annotate BoolClass "false"- String str -> annotate StringClass (fromString (quoteString str))+ String str -> prettySmartString str TimeOfDay tod -> annotate DateClass (fromString (formatTime defaultTimeLocale "%H:%M:%S%Q" tod)) ZonedTime zt | timeZoneMinutes (zonedTimeZone zt) == 0 ->@@ -164,8 +186,39 @@ LocalTime lt -> annotate DateClass (fromString (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q" lt)) Day d -> annotate DateClass (fromString (formatTime defaultTimeLocale "%Y-%m-%d" d)) --- | Predicate for values that should be completely rendered on the+prettySmartString :: String -> TomlDoc+prettySmartString str+ | '\n' `elem` str =+ column \i ->+ pageWidth \case+ AvailablePerLine n _ | length str > n - i ->+ prettyMlString str+ _ -> prettyString str+ | otherwise = prettyString str++prettyMlString :: String -> TomlDoc+prettyMlString str = annotate StringClass (column \i -> hang (-i) (fromString (quoteMlString str)))++prettyString :: String -> TomlDoc+prettyString str = annotate StringClass (fromString (quoteString str))++-- | Predicate for values that CAN rendered on the -- righthand-side of an @=@.+isSimple :: Value -> Bool+isSimple = \case+ Integer _ -> True+ Float _ -> True+ Bool _ -> True+ String _ -> True+ TimeOfDay _ -> True+ ZonedTime _ -> True+ LocalTime _ -> True+ Day _ -> True+ Table x -> isSingularTable x -- differs from isAlwaysSimple+ Array x -> null x || not (all isTable x)++-- | Predicate for values that can be MUST rendered on the+-- righthand-side of an @=@. isAlwaysSimple :: Value -> Bool isAlwaysSimple = \case Integer _ -> True@@ -176,7 +229,7 @@ ZonedTime _ -> True LocalTime _ -> True Day _ -> True- Table x -> isSingularTable x+ Table _ -> False -- differs from isSimple Array x -> null x || not (all isTable x) -- | Predicate for table values.@@ -188,7 +241,7 @@ -- These can be collapsed using dotted-key notation on the lefthand-side -- of a @=@. isSingularTable :: Table -> Bool-isSingularTable (Map.elems -> [v]) = isAlwaysSimple v+isSingularTable (Map.elems -> [v]) = isSimple v isSingularTable _ = False -- | Render a complete TOML document using top-level table and array of@@ -259,31 +312,31 @@ NoProjection -> id KeyProjection f -> sortOn (f prefix . fst) - (simple, sections) = partition (isAlwaysSimple . snd) (order (Map.assocs t))+ kvs = order (Map.assocs t) + -- this table will require no subsequent tables to be defined+ simpleToml = all isSimple t++ (simple, sections) = partition (isAlwaysSimple . snd) kvs+ topLines = [fold topElts | let topElts = headers ++ assignments, not (null topElts)] headers = case NonEmpty.nonEmpty prefix of- Just key | not (null simple) || null sections || kind == ArrayTableKind ->+ Just key | simpleToml || not (null simple) || null sections || kind == ArrayTableKind -> [prettySectionKind kind key <> hardline] _ -> [] - assignments = [prettyAssignment k v <> hardline | (k,v) <- simple]+ assignments = [prettyAssignment k v <> hardline | (k,v) <- if simpleToml then kvs else simple] - subtables = [prettySection (prefix `snoc` k) v | (k,v) <- sections]+ subtables = [prettySection (prefix ++ [k]) v | not simpleToml, (k,v) <- sections] prettySection key (Table tab) =- prettyToml_ mbKeyProj TableKind (NonEmpty.toList key) tab+ prettyToml_ mbKeyProj TableKind key tab prettySection key (Array a) =- vcat [prettyToml_ mbKeyProj ArrayTableKind (NonEmpty.toList key) tab | Table tab <- a]+ vcat [prettyToml_ mbKeyProj ArrayTableKind key tab | Table tab <- a] prettySection _ _ = error "prettySection applied to simple value" --- | Create a 'NonEmpty' with a given prefix and last element.-snoc :: [a] -> a -> NonEmpty a-snoc [] y = y :| []-snoc (x : xs) y = x :| xs ++ [y]- -- | Render a semantic TOML error in a human-readable string. -- -- @since 1.3.0.0@@ -304,3 +357,6 @@ where f (ScopeIndex i) = ('[' :) . shows i . (']':) f (ScopeKey key) = ('.' :) . shows (prettySimpleKey key)++prettyLocated :: Located String -> String+prettyLocated (Located p s) = printf "%d:%d: %s" (posLine p) (posColumn p) s
+ src/Toml/Semantics/Ordered.hs view
@@ -0,0 +1,113 @@+{-|+Module : Toml.Semantics.Ordered+Description : Tool for extracting an ordering from an existing TOML file+Copyright : (c) Eric Mertens, 2023+License : ISC+Maintainer : emertens@gmail.com++This module can help build a key ordering projection given an existing+TOML file. This could be useful for applying a transformation to a TOML+file before pretty-printing it back in something very close to the+original order.++When using the computed order, table keys will be remembered in the order+they appeared in the source file. Any key additional keys added to the+tables will be ordered alphabetically after all the known keys.++@+demo =+ do txt <- 'readFile' \"demo.toml\"+ let Right exprs = 'Toml.Parser.parseRawToml' txt+ to = 'extractTableOrder' exprs+ Right toml = 'Toml.Semantics.semantics' exprs+ projection = 'projectKey' to+ 'print' ('Toml.Pretty.prettyTomlOrdered' projection toml)+@++@since 1.3.1.0++-}+module Toml.Semantics.Ordered (+ TableOrder,+ extractTableOrder,+ projectKey,+ ProjectedKey,+ debugTableOrder,+ ) where++import Data.Foldable (foldl', toList)+import Data.List (sortOn)+import Data.Map (Map)+import Data.Map qualified as Map+import Toml.Located (Located(locThing))+import Toml.Parser.Types (Expr(..), Key, Val(ValTable, ValArray))++-- | Summary of the order of the keys in a TOML document.+newtype TableOrder = TO (Map String KeyOrder)++data KeyOrder = KeyOrder !Int TableOrder++newtype ProjectedKey = PK (Either Int String)+ deriving (Eq, Ord)++-- | Generate a projection function for use with 'Toml.Pretty.prettyTomlOrdered'+projectKey ::+ TableOrder {- ^ table order -} ->+ [String] {- ^ table path -} ->+ String {- ^ key -} ->+ ProjectedKey {- ^ type suitable for ordering table keys -}+projectKey (TO to) [] = \k ->+ case Map.lookup k to of+ Just (KeyOrder i _) -> PK (Left i)+ Nothing -> PK (Right k)+projectKey (TO to) (p:ps) =+ case Map.lookup p to of+ Just (KeyOrder _ to') -> projectKey to' ps+ Nothing -> PK . Right++emptyOrder :: TableOrder+emptyOrder = TO Map.empty++-- | Extract a 'TableOrder' from the output of 'Toml.Parser.parseRawToml'+-- to be later used with 'projectKey'.+extractTableOrder :: [Expr] -> TableOrder+extractTableOrder = snd . foldl' addExpr ([], emptyOrder)++addExpr :: ([String], TableOrder) -> Expr -> ([String], TableOrder)+addExpr (prefix, to) = \case+ TableExpr k -> let k' = keyPath k in (k', addKey to k')+ ArrayTableExpr k -> let k' = keyPath k in (k', addKey to k')+ KeyValExpr k v -> (prefix, addVal prefix (addKey to (prefix ++ keyPath k)) v)++addVal :: [String] -> TableOrder -> Val -> TableOrder+addVal prefix to = \case+ ValArray xs -> foldl' (addVal prefix) to xs+ ValTable kvs -> foldl' (\acc (k,v) ->+ let k' = prefix ++ keyPath k in+ addVal k' (addKey acc k') v) to kvs+ _ -> to++addKey :: TableOrder -> [String] -> TableOrder+addKey to [] = to+addKey (TO to) (x:xs) = TO (Map.alter f x to)+ where+ f Nothing = Just (KeyOrder (Map.size to) (addKey emptyOrder xs))+ f (Just (KeyOrder i m)) = Just (KeyOrder i (addKey m xs))++keyPath :: Key -> [String]+keyPath = map locThing . toList++-- | Render a white-space nested representation of the key ordering extracted+-- by 'extractTableOrder'. This is provided for debugging and understandability.+debugTableOrder :: TableOrder -> String+debugTableOrder to = unlines (go 0 to [])+ where+ go i (TO m) z =+ foldr (go1 i) z+ (sortOn p (Map.assocs m))++ go1 i (k, KeyOrder _ v) z =+ (replicate (4*i) ' ' ++ k) :+ go (i+1) v z++ p (_, KeyOrder i _) = i
test/DecodeSpec.hs view
@@ -1,13 +1,12 @@ {-# Language DuplicateRecordFields #-} module DecodeSpec (spec) where -import Data.Map qualified as Map import Data.Maybe (fromMaybe) import GHC.Generics (Generic) import QuoteStr (quoteStr) import Test.Hspec (it, shouldBe, Spec)-import Toml (decode, Result(Success), encode)-import Toml.FromValue (FromValue(..), runParseTable, reqKey, optKey)+import Toml (decode, Result, encode)+import Toml.FromValue (FromValue(..), reqKey, optKey) import Toml.FromValue.Generic (genericParseTable) import Toml.ToValue (ToTable(..), ToValue(toValue), table, (.=), defaultTableToValue) import Toml.ToValue.Generic (genericToTable)
test/FromValueSpec.hs view
@@ -12,7 +12,7 @@ import Control.Monad (when) import Test.Hspec (it, shouldBe, Spec) import Toml (Result(..), Value(..))-import Toml.FromValue (Result(..), FromValue(fromValue), optKey, parseTableFromValue, reqKey, warnTable, pickKey, runParseTable)+import Toml.FromValue (FromValue(fromValue), optKey, reqKey, warnTable, pickKey, runParseTable) import Toml.FromValue.Matcher (Matcher, runMatcher) import Toml.FromValue.ParseTable (KeyAlt(..)) import Toml.Pretty (prettyMatchMessage)
test/HieDemoSpec.hs view
@@ -15,11 +15,10 @@ -} module HieDemoSpec where -import Control.Applicative (optional) import GHC.Generics ( Generic ) import QuoteStr (quoteStr) import Test.Hspec (Spec, it, shouldBe)-import Toml (Value(Table, Array), Table, Result(..), decode)+import Toml (Value(Table, Array), Table, decode) import Toml.FromValue import Toml.FromValue.Generic (genericParseTable)
test/LexerSpec.hs view
@@ -9,7 +9,17 @@ do it "handles special cased control character" $ parse "x = '\SOH'" `shouldBe`- Left "1:6: lexical error: unexpected '\\SOH'"+ Left "1:6: lexical error: control characters prohibited"++ it "recommends escapes for control characters (1)" $+ parse "x = \"\SOH\""+ `shouldBe`+ Left "1:6: lexical error: control characters must be escaped, use: \\u0001"++ it "recommends escapes for control characters (2)" $+ parse "x = \"\DEL\""+ `shouldBe`+ Left "1:6: lexical error: control characters must be escaped, use: \\u007F" -- These seem boring, but they provide test coverage of an error case in the state machine it "handles unexpected '}'" $
test/PrettySpec.hs view
@@ -29,9 +29,10 @@ it "renders empty tables" $ fmap tomlString (parse "x.y.z={}\nz.y.w=false") `shouldBe` Right [quoteStr|- z.y.w = false+ [x.y.z] - [x.y.z]|]+ [z]+ y.w = false|] it "renders empty tables in array of tables" $ fmap tomlString (parse "ex=[{},{},{a=9}]")@@ -59,6 +60,24 @@ `shouldBe` Right [quoteStr| a = "\\\b\t\r\n\f\"\u007F\U0001000C"|] + it "renders multiline strings" $+ fmap tomlString (parse [quoteStr|+ Everything-I-Touch = "Everything I touch\nwith tenderness, alas,\npricks like a bramble."+ Two-More = [+ "The west wind whispered,\nAnd touched the eyelids of spring:\nHer eyes, Primroses.",+ "Plum flower temple:\nVoices rise\nFrom the foothills",+ ]|])+ `shouldBe` Right [quoteStr|+ Everything-I-Touch = """+ Everything I touch+ with tenderness, alas,+ pricks like a bramble."""+ Two-More = [ """+ The west wind whispered,+ And touched the eyelids of spring:+ Her eyes, Primroses."""+ , "Plum flower temple:\nVoices rise\nFrom the foothills" ]|]+ it "renders floats" $ fmap tomlString (parse "a=0.0\nb=-0.1\nc=0.1\nd=3.141592653589793\ne=4e123") `shouldBe` Right [quoteStr|@@ -106,3 +125,15 @@ `shouldBe` Right [quoteStr| x = [ [ {a = "this is a longer example", b = "and it will linewrap"} , {c = "all on its own"} ] ]|]++ it "factors out unique table prefixes in leaf tables" $+ fmap tomlString (parse [quoteStr|+ [x]+ i = 1+ p.q = "a"+ y.z = "c"|])+ `shouldBe` Right [quoteStr|+ [x]+ i = 1+ p.q = "a"+ y.z = "c"|]
toml-parser.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: toml-parser-version: 1.3.0.0+version: 1.3.1.0 synopsis: TOML 1.0.0 parser description: TOML parser using generated lexers and parsers with@@ -13,7 +13,7 @@ copyright: 2023 Eric Mertens category: Text build-type: Simple-tested-with: GHC == {8.10.7, 9.0.2, 9.2.8, 9.4.5, 9.6.2}+tested-with: GHC == {8.10.7, 9.0.2, 9.2.8, 9.4.7, 9.6.3} extra-doc-files: ChangeLog.md@@ -60,6 +60,7 @@ Toml.Position Toml.Pretty Toml.Semantics+ Toml.Semantics.Ordered Toml.ToValue Toml.ToValue.Generic Toml.Value@@ -68,8 +69,8 @@ Toml.Parser.Utils build-depends: array ^>= 0.5,- base ^>= {4.14, 4.15, 4.16, 4.17, 4.18},- containers ^>= {0.5, 0.6},+ base ^>= {4.14, 4.15, 4.16, 4.17, 4.18, 4.19},+ containers ^>= {0.5, 0.6, 0.7}, prettyprinter ^>= 1.7, text >= 0.2 && < 3, time ^>= {1.9, 1.10, 1.11, 1.12},@@ -91,7 +92,7 @@ base, containers, hspec ^>= {2.10, 2.11},- template-haskell ^>= {2.16, 2.17, 2.18, 2.19, 2.20},+ template-haskell ^>= {2.16, 2.17, 2.18, 2.19, 2.20, 2.21}, time, toml-parser, other-modules:@@ -108,9 +109,18 @@ import: extensions type: exitcode-stdio-1.0 main-is: README.lhs- ghc-options: -pgmL markdown-unlit+ ghc-options: -pgmL markdown-unlit -optL "haskell toml"+ default-extensions:+ QuasiQuotes+ other-modules:+ QuoteStr+ hs-source-dirs:+ .+ test build-depends: base, toml-parser,+ hspec ^>= {2.10, 2.11},+ template-haskell ^>= {2.16, 2.17, 2.18, 2.19, 2.20, 2.21}, build-tool-depends: markdown-unlit:markdown-unlit ^>= {0.5.1, 0.6.0},