toml-parser-2.0.2.0/0000755000000000000000000000000007346545000012307 5ustar0000000000000000toml-parser-2.0.2.0/ChangeLog.md0000644000000000000000000000740207346545000014463 0ustar0000000000000000# Revision history for toml-parser ## 2.0.2.0 * Update for TOML 1.1.0 - Add \e and \x escapes - Allow omitting seconds in times - Allow newlines and trailing commas in inline tables ## 2.0.1.2 * Reject inputs with out-of-bounds time zone offsets in accordance with the toml-tests test suite. ## 2.0.1.1 * Fixes bug that prohibited non-ASCII characters in `'''` strings. ## 2.0.1.0 * Added `ToValue UTCTime` and `FromValue UTCTime`. These correspond to offset data-times with the timezone translated to UTC. ## 2.0.0.0 * Pervasive annotations on the values added to allow for detailed positional error reporting throughout parsing and validation. * Replace uses of String with Text in the Value type and throughout the API * Reorganized almost all of the modules to minimize imports that upstream packages will actually need. ## 1.3.3.0 * Added `IsString Value` instance. * Addded helpers for `runMatcher` for ignoring and failing on warning `runMatcherIgnoreWarn` and `runMatcherFatalWarn` ## 1.3.2.0 * Added `Toml.Generic` to make instances easily derivable via DerivingVia. * Added GHC.Generics support for switching between product types and TOML arrays. ## 1.3.1.3 * Bugfix: Previous fix admitted some invalid inline tables - these are now rejected ## 1.3.1.2 * Bugfix: In some cases overlapping keys in inline tables could throw an exception instead instead of returning the proper semantic error value. ## 1.3.1.1 * Ensure years are rendered zero-padded ## 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. Consumers of the `Toml` module can keep getting simple error strings and users interested in structured errors can run the different layers independently to get more detailed error reporting. * `FromValue` and `ToValue` instances for: `Ratio`, `NonEmpty`, `Seq` * Add `FromKey` and `ToKey` for allowing codecs for `Map` to use various key types. ## 1.2.1.0 -- 2023-07-12 * Added `Toml.Pretty.prettyTomlOrdered` to allow user-specified section ordering. * Added `FromValue` and `ToValue` instances for `Text` * Added `reqKeyOf` and `optKeyOf` for easier custom matching without `FromValue` instances. ## 1.2.0.0 -- 2023-07-09 * Remove `FromTable` class. This class existed for things that could be matched specifically from tables, which is what the top-level values always are. However `FromValue` already handles this, and both classes can fail, so having the extra level of checking doesn't avoid failure. It does, however, create a lot of noise generating instances. Note that `ToTable` continues to exist because `toTable` isn't allowed to fail, and when serializing to TOML syntax you can only serialize top-level tables. * Extracted `Toml.FromValue.Matcher` and `Toml.FromValue.ParseTable` into their own modules. * Add `pickKey`, `liftMatcher`, `inKey`, `inIndex`, `parseTableFromValue` to `Toml.FromValue` * Replace `genericFromTable` with `genericParseTable`. The intended way to derive a `FromValue` instance is now to write: ```haskell instance FromValue T where fromValue = parseTableFromValue genericParseTable ``` ## 1.1.1.0 -- 2023-07-03 * Add support for GHC 8.10.7 and 9.0.2 ## 1.1.0.0 -- 2023-07-03 * Add Toml.FromValue.Generic and Toml.ToValue.Generic * Add Alternative instance to Matcher and support multiple error messages in Result * Add Data and Generic instances for Value ## 1.0.1.0 -- 2023-07-01 * Add ToTable and ToValue instances for Map * Refine error messages * More test coverage ## 1.0.0.0 -- 2023-06-29 * Complete rewrite including 1.0.0 compliance and pretty-printing. ## 0.1.0.0 -- 2017-05-04 * First version. toml-parser-2.0.2.0/LICENSE0000644000000000000000000000133207346545000013313 0ustar0000000000000000Copyright (c) 2023 Eric Mertens Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. toml-parser-2.0.2.0/README.lhs0000644000000000000000000001365707346545000013770 0ustar0000000000000000# TOML Parser This package implements a validating parser for [TOML 1.1.0](https://toml.io/en/v1.1.0). This package uses an [alex](https://haskell-alex.readthedocs.io/en/latest/)-generated lexer and [happy](https://haskell-happy.readthedocs.io/en/latest/)-generated parser. It also provides a pair of classes for serializing into and out of TOML. ## Package Structure ```mermaid --- title: Package Structure --- stateDiagram-v2 classDef important font-weight:bold; TOML:::important --> ApplicationTypes:::important : decode ApplicationTypes --> TOML : encode TOML --> [Token]: Lexer [Token] --> [Expr]: Parser [Expr] --> Table : Semantics Table --> ApplicationTypes : FromValue ApplicationTypes --> Table : ToValue Table --> TOML : Pretty ``` Most users will only need to import **Toml** or **Toml.Schema**. Other top-level modules are for low-level hacking on the TOML format itself. All modules below these top-level modules are exposed to provide direct access to library implementation details. - **Toml** - Basic encoding and decoding TOML - **Toml.Schema** - TOML schemas for application types - **Toml.Semantics** - Low-level semantic operations on TOML syntax - **Toml.Syntax** - Low-level parsing of text into TOML raw syntax ## Examples This file uses [markdown-unlit](https://hackage.haskell.org/package/markdown-unlit) to ensure that its code typechecks and stays in sync with the rest of the package. ```haskell {-# Language OverloadedStrings #-} import Data.Text (Text) import GHC.Generics (Generic) import QuoteStr (quoteStr) import Test.Hspec (Spec, hspec, it, shouldBe) import Toml import Toml.Schema main :: IO () main = hspec (parses >> decodes >> encodes >> warns >> errors) ``` ### Using the raw parser Consider this sample TOML text from the TOML specification. ```haskell fruitStr :: Text fruitStr = [quoteStr| ``` ```toml [[fruits]] name = "apple" [fruits.physical] # subtable color = "red" shape = "round" [[fruits.varieties]] # nested array of tables name = "red delicious" [[fruits.varieties]] name = "granny smith" [[fruits]] name = "banana" [[fruits.varieties]] name = "plantain" ``` ```haskell |] ``` Parsing using this package generates the following unstructured value ```haskell parses :: Spec parses = it "parses" $ forgetTableAnns <$> parse fruitStr `shouldBe` Right (table [ ("fruits", List [ Table (table [ ("name", Text "apple"), ("physical", Table (table [ ("color", Text "red"), ("shape", Text "round")])), ("varieties", List [ Table (table [("name", Text "red delicious")]), Table (table [("name", Text "granny smith")])])]), Table (table [ ("name", Text "banana"), ("varieties", List [ Table (table [("name", Text "plantain")])])])])]) ``` ### Defining a schema We can define a schema for our TOML format in the form of instances of `FromValue`, `ToValue`, and `ToTable` in order to read TOML directly into structured data form. This example manually derives some of the instances as a demonstration. ```haskell newtype Fruits = Fruits { fruits :: [Fruit] } deriving (Eq, Show, Generic) deriving (ToTable, ToValue, FromValue) via GenericTomlTable Fruits data Fruit = Fruit { name :: String, physical :: Maybe Physical, varieties :: [Variety] } deriving (Eq, Show, Generic) deriving (ToTable, ToValue, FromValue) via GenericTomlTable Fruit data Physical = Physical { color :: String, shape :: String } deriving (Eq, Show, Generic) deriving (ToTable, ToValue, FromValue) via GenericTomlTable Physical newtype Variety = Variety String deriving (Eq, Show) instance FromValue Variety where fromValue = parseTableFromValue (Variety <$> reqKey "name") instance ToValue Variety where toValue = defaultTableToValue instance ToTable Variety where toTable (Variety x) = table ["name" .= x] ``` We can run this example on the original value to deserialize it into domain-specific datatypes. ```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"]]) 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"|] ``` ### Useful errors and warnings This package takes care to preserve source information as much as possible in order to provide useful feedback to users. These examples show a couple of the message that can be generated when things don't go perfectly. ```haskell warns :: Spec warns = it "warns" $ decode [quoteStr| name = "simulated" typo = 10|] `shouldBe` Success ["2:1: unexpected key: typo in "] -- warnings (Variety "simulated") errors :: Spec errors = it "errors" $ decode [quoteStr| # Physical characteristics table color = "blue" shape = []|] `shouldBe` (Failure ["3:9: expected string but got array in shape"] :: Result String Physical) ``` ## More Examples A demonstration of using this package at a more realistic scale 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). toml-parser-2.0.2.0/README.md0000644000000000000000000001365707346545000013602 0ustar0000000000000000# TOML Parser This package implements a validating parser for [TOML 1.1.0](https://toml.io/en/v1.1.0). This package uses an [alex](https://haskell-alex.readthedocs.io/en/latest/)-generated lexer and [happy](https://haskell-happy.readthedocs.io/en/latest/)-generated parser. It also provides a pair of classes for serializing into and out of TOML. ## Package Structure ```mermaid --- title: Package Structure --- stateDiagram-v2 classDef important font-weight:bold; TOML:::important --> ApplicationTypes:::important : decode ApplicationTypes --> TOML : encode TOML --> [Token]: Lexer [Token] --> [Expr]: Parser [Expr] --> Table : Semantics Table --> ApplicationTypes : FromValue ApplicationTypes --> Table : ToValue Table --> TOML : Pretty ``` Most users will only need to import **Toml** or **Toml.Schema**. Other top-level modules are for low-level hacking on the TOML format itself. All modules below these top-level modules are exposed to provide direct access to library implementation details. - **Toml** - Basic encoding and decoding TOML - **Toml.Schema** - TOML schemas for application types - **Toml.Semantics** - Low-level semantic operations on TOML syntax - **Toml.Syntax** - Low-level parsing of text into TOML raw syntax ## Examples This file uses [markdown-unlit](https://hackage.haskell.org/package/markdown-unlit) to ensure that its code typechecks and stays in sync with the rest of the package. ```haskell {-# Language OverloadedStrings #-} import Data.Text (Text) import GHC.Generics (Generic) import QuoteStr (quoteStr) import Test.Hspec (Spec, hspec, it, shouldBe) import Toml import Toml.Schema main :: IO () main = hspec (parses >> decodes >> encodes >> warns >> errors) ``` ### Using the raw parser Consider this sample TOML text from the TOML specification. ```haskell fruitStr :: Text fruitStr = [quoteStr| ``` ```toml [[fruits]] name = "apple" [fruits.physical] # subtable color = "red" shape = "round" [[fruits.varieties]] # nested array of tables name = "red delicious" [[fruits.varieties]] name = "granny smith" [[fruits]] name = "banana" [[fruits.varieties]] name = "plantain" ``` ```haskell |] ``` Parsing using this package generates the following unstructured value ```haskell parses :: Spec parses = it "parses" $ forgetTableAnns <$> parse fruitStr `shouldBe` Right (table [ ("fruits", List [ Table (table [ ("name", Text "apple"), ("physical", Table (table [ ("color", Text "red"), ("shape", Text "round")])), ("varieties", List [ Table (table [("name", Text "red delicious")]), Table (table [("name", Text "granny smith")])])]), Table (table [ ("name", Text "banana"), ("varieties", List [ Table (table [("name", Text "plantain")])])])])]) ``` ### Defining a schema We can define a schema for our TOML format in the form of instances of `FromValue`, `ToValue`, and `ToTable` in order to read TOML directly into structured data form. This example manually derives some of the instances as a demonstration. ```haskell newtype Fruits = Fruits { fruits :: [Fruit] } deriving (Eq, Show, Generic) deriving (ToTable, ToValue, FromValue) via GenericTomlTable Fruits data Fruit = Fruit { name :: String, physical :: Maybe Physical, varieties :: [Variety] } deriving (Eq, Show, Generic) deriving (ToTable, ToValue, FromValue) via GenericTomlTable Fruit data Physical = Physical { color :: String, shape :: String } deriving (Eq, Show, Generic) deriving (ToTable, ToValue, FromValue) via GenericTomlTable Physical newtype Variety = Variety String deriving (Eq, Show) instance FromValue Variety where fromValue = parseTableFromValue (Variety <$> reqKey "name") instance ToValue Variety where toValue = defaultTableToValue instance ToTable Variety where toTable (Variety x) = table ["name" .= x] ``` We can run this example on the original value to deserialize it into domain-specific datatypes. ```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"]]) 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"|] ``` ### Useful errors and warnings This package takes care to preserve source information as much as possible in order to provide useful feedback to users. These examples show a couple of the message that can be generated when things don't go perfectly. ```haskell warns :: Spec warns = it "warns" $ decode [quoteStr| name = "simulated" typo = 10|] `shouldBe` Success ["2:1: unexpected key: typo in "] -- warnings (Variety "simulated") errors :: Spec errors = it "errors" $ decode [quoteStr| # Physical characteristics table color = "blue" shape = []|] `shouldBe` (Failure ["3:9: expected string but got array in shape"] :: Result String Physical) ``` ## More Examples A demonstration of using this package at a more realistic scale 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). toml-parser-2.0.2.0/benchmarker/0000755000000000000000000000000007346545000014570 5ustar0000000000000000toml-parser-2.0.2.0/benchmarker/benchmarker.hs0000644000000000000000000000074407346545000017412 0ustar0000000000000000 import Control.Exception (evaluate) import qualified Data.Text.IO import Data.Time (diffUTCTime, getCurrentTime) import System.Environment (getArgs) import Toml (parse) main :: IO () main = do args <- getArgs filename <- case args of [filename] -> pure filename _ -> fail "Usage: benchmarker " txt <- Data.Text.IO.readFile filename start <- getCurrentTime evaluate (parse txt) stop <- getCurrentTime print (stop `diffUTCTime` start) toml-parser-2.0.2.0/src/0000755000000000000000000000000007346545000013076 5ustar0000000000000000toml-parser-2.0.2.0/src/Toml.hs0000644000000000000000000001157407346545000014355 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} {-| Module : Toml Description : TOML parsing, printing, and codecs Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com This is the high-level interface to the toml-parser library. It enables parsing, printing, and conversion into and out of application-specific representations. This parser implements TOML 1.1.0 as carefully as possible. Use "Toml.Schema" to implement functions mapping between TOML values and your application types. Use "Toml.Syntax" and "Toml.Semantics" for low-level TOML syntax processing and semantic validation. Most applications will not need to use these modules directly unless the application is about TOML itself. The types and functions of this package are parameterized over an annotation type in order to allow applications to provide detailed feedback messages tracked back to specific source locations in an original TOML file. While the default annotation is a simple file position, some applications might upgrade this annotation to track multiple file names or synthetically generated sources. Other applications won't need source location and can replace annotations with a simple unit type. -} module Toml ( -- * Types Table, Value, -- * Located types Located(..), Position(..), Table'(..), Value'(..), valueAnn, valueType, forgetTableAnns, forgetValueAnns, -- * Parsing decode', decode, parse, DecodeError, Result(..), -- * Printing encode, prettyToml, DocClass(..), -- * Error rendering prettyDecodeError, prettyLocated, prettyMatchMessage, prettySemanticError, ) where import Data.Text (Text) import Text.Printf (printf) import Toml.Pretty import Toml.Schema import Toml.Semantics import Toml.Syntax -- | Parse a TOML formatted 'String' or report a structured error message. parse' :: Text -> Either DecodeError (Table' Position) parse' str = case parseRawToml str of Left e -> Left (ErrSyntax e) Right exprs -> case semantics exprs of Left e -> Left (ErrSemantics e) Right tab -> Right tab -- | Parse a TOML formatted 'String' or report a human-readable error message. parse :: Text -> Either String (Table' Position) parse str = case parse' str of Left e -> Left (prettyDecodeError e) Right x -> Right x -- | Sum of errors that can occur during TOML decoding data DecodeError = ErrSyntax (Located String) -- ^ Error during the lexer/parser phase | ErrSemantics (SemanticError Position) -- ^ Error during TOML validation | ErrSchema (MatchMessage Position) -- ^ Error during schema matching -- | Decode TOML syntax into an application value. decode' :: FromValue a => Text -> Result DecodeError a decode' str = case parse' str of Left e -> Failure [e] Right tab -> case runMatcher (fromValue (Table' startPos tab)) of Failure es -> Failure (ErrSchema <$> es) Success ws x -> Success (ErrSchema <$> ws) x -- | Wrapper rending error and warning messages into human-readable strings. decode :: FromValue a => Text -> Result String a decode str = case decode' str of Failure e -> Failure (map prettyDecodeError e) Success w x -> Success (map prettyDecodeError w) x -- | Use the 'ToTable' instance to encode a value to a TOML string. encode :: ToTable a => a -> TomlDoc encode = prettyToml . toTable -- | Human-readable representation of a 'DecodeError' prettyDecodeError :: DecodeError -> String prettyDecodeError = \case ErrSyntax e -> prettyLocated e ErrSemantics e -> prettySemanticError e ErrSchema e -> prettyMatchMessage e -- | Render a TOML decoding error as a human-readable string. prettyMatchMessage :: MatchMessage Position -> String prettyMatchMessage (MatchMessage loc scope msg) = prefix ++ msg ++ " in " ++ path where prefix = case loc of Nothing -> "" Just l -> prettyPosition l ++ ": " path = case scope of [] -> "" ScopeKey key : scope' -> shows (prettySimpleKey key) (foldr f "" scope') ScopeIndex i : scope' -> foldr f "" (ScopeIndex i : scope') -- should be impossible f (ScopeIndex i) = showChar '[' . shows i . showChar ']' f (ScopeKey key) = showChar '.' . shows (prettySimpleKey key) -- | Render a semantic TOML error in a human-readable string. prettySemanticError :: SemanticError Position -> String prettySemanticError (SemanticError a key kind) = printf "%s: key error: %s %s" (prettyPosition a) (show (prettySimpleKey key)) case kind of AlreadyAssigned -> "is already assigned" :: String ClosedTable -> "is a closed table" ImplicitlyTable -> "is already implicitly defined to be a table" toml-parser-2.0.2.0/src/Toml/0000755000000000000000000000000007346545000014011 5ustar0000000000000000toml-parser-2.0.2.0/src/Toml/Pretty.hs0000644000000000000000000003160307346545000015637 0ustar0000000000000000{-# Language OverloadedStrings, GADTs #-} {-| Module : Toml.Pretty Description : Human-readable representations for error messages Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com This module provides human-readable renderers for types used in this package to assist error message production. The generated 'Doc' values are annotated with 'DocClass' values to assist in producing syntax-highlighted outputs. To extract a plain String representation, use 'show'. -} module Toml.Pretty ( -- * Types TomlDoc, DocClass(..), -- * Printing semantic values prettyToml, prettyTomlOrdered, prettyValue, -- * Printing syntactic components prettyToken, prettySectionKind, -- * Printing keys prettySimpleKey, prettyKey, -- * Locations prettyLocated, prettyPosition, ) 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 qualified as NonEmpty import Data.Map qualified as Map import Data.String (fromString) import Data.Text (Text) import Data.Text qualified as Text import Data.Time (ZonedTime(zonedTimeZone), TimeZone (timeZoneMinutes)) import Data.Time.Format (formatTime, defaultTimeLocale) import Prettyprinter import Text.Printf (printf) import Toml.Semantics import Toml.Syntax.Lexer (Token(..)) import Toml.Syntax.Position (Located(..), Position(..)) import Toml.Syntax.Types (SectionKind(..)) -- | Annotation used to enable styling pretty-printed TOML data DocClass = TableClass -- ^ top-level @[key]@ and @[[key]]@ | KeyClass -- ^ dotted keys, left-hand side of assignments | StringClass -- ^ string literals | NumberClass -- ^ number literals | DateClass -- ^ date and time literals | BoolClass -- ^ boolean literals deriving (Read, Show, Eq, Ord) -- | Pretty-printer document with TOML class attributes to aid -- in syntax-highlighting. type TomlDoc = Doc DocClass -- | Renders a dotted-key using quotes where necessary and annotated -- as a 'KeyClass'. prettyKey :: NonEmpty Text -> TomlDoc prettyKey = annotate KeyClass . fold . NonEmpty.intersperse dot . fmap prettySimpleKey -- | Renders a simple-key using quotes where necessary. prettySimpleKey :: Text -> Doc a prettySimpleKey str | not (Text.null str), Text.all isBareKey str = pretty str | otherwise = fromString (quoteString (Text.unpack str)) -- | Predicate for the character-class that is allowed in bare keys isBareKey :: Char -> Bool isBareKey x = isAsciiLower x || isAsciiUpper x || isDigit x || x == '-' || x == '_' -- | Quote a string using basic string literal syntax. quoteString :: String -> String quoteString = ('"':) . go where go = \case "" -> "\"" -- terminator '"' : xs -> '\\' : '"' : go xs '\\' : xs -> '\\' : '\\' : go xs '\b' : xs -> '\\' : 'b' : go xs '\ESC':xs -> '\\' : 'e' : go xs '\f' : xs -> '\\' : 'f' : go xs '\n' : xs -> '\\' : 'n' : go xs '\r' : xs -> '\\' : 'r' : go xs '\t' : xs -> '\\' : 't' : go xs x : xs | isPrint x -> x : go xs | x <= '\xff' -> printf "\\x%02X%s" (ord x) (go xs) | 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 '\ESC':xs -> '\\' : 'e' : 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 <= '\xff' -> printf "\\x%02X%s" (ord 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 Text -> TomlDoc prettySectionKind TableKind key = annotate TableClass (unAnnotate (lbracket <> prettyKey key <> rbracket)) prettySectionKind ArrayTableKind key = annotate TableClass (unAnnotate (lbracket <> lbracket <> prettyKey key <> rbracket <> rbracket)) -- | Render token for human-readable error messages. prettyToken :: Token -> String prettyToken = \case TokComma -> "','" TokEquals -> "'='" TokPeriod -> "'.'" TokSquareO -> "'['" TokSquareC -> "']'" Tok2SquareO -> "'[['" Tok2SquareC -> "']]'" TokCurlyO -> "'{'" TokCurlyC -> "'}'" TokNewline -> "end-of-line" TokBareKey _ -> "bare key" TokTrue -> "true literal" TokFalse -> "false literal" TokString _ -> "string" TokMlString _ -> "multi-line string" TokInteger _ -> "integer" TokFloat _ -> "float" TokOffsetDateTime _ -> "offset date-time" TokLocalDateTime _ -> "local date-time" TokLocalDate _ -> "local date" TokLocalTime _ -> "local time" TokEOF -> "end-of-input" prettyAssignment :: Text -> Value' l -> TomlDoc prettyAssignment = go . pure where go ks (Table' _ (MkTable (Map.assocs -> [(k,(_, v))]))) = go (NonEmpty.cons k ks) v go ks v = prettyKey (NonEmpty.reverse ks) <+> equals <+> prettyValue v -- | Render a value suitable for assignment on the right-hand side -- of an equals sign. This value will always use inline table and list -- syntax. prettyValue :: Value' l -> TomlDoc prettyValue = \case Integer' _ i -> annotate NumberClass (pretty i) Double' _ f | isNaN f -> annotate NumberClass "nan" | isInfinite f -> annotate NumberClass (if f > 0 then "inf" else "-inf") | otherwise -> annotate NumberClass (pretty f) List' _ a -> align (list [prettyValue v | v <- a]) Table' _ (MkTable t) -> lbrace <> concatWith (surround ", ") [prettyAssignment k v | (k,(_, v)) <- Map.assocs t] <> rbrace Bool' _ True -> annotate BoolClass "true" Bool' _ False -> annotate BoolClass "false" Text' _ str -> prettySmartString str TimeOfDay' _ tod -> annotate DateClass (fromString (formatTime defaultTimeLocale "%H:%M:%S%Q" tod)) ZonedTime' _ zt | timeZoneMinutes (zonedTimeZone zt) == 0 -> annotate DateClass (fromString (formatTime defaultTimeLocale "%0Y-%m-%dT%H:%M:%S%QZ" zt)) | otherwise -> annotate DateClass (fromString (formatTime defaultTimeLocale "%0Y-%m-%dT%H:%M:%S%Q%Ez" zt)) LocalTime' _ lt -> annotate DateClass (fromString (formatTime defaultTimeLocale "%0Y-%m-%dT%H:%M:%S%Q" lt)) Day' _ d -> annotate DateClass (fromString (formatTime defaultTimeLocale "%0Y-%m-%d" d)) prettySmartString :: Text -> TomlDoc prettySmartString str | '\n' `elem` Text.unpack str = -- Text.elem isn't in text-1.2 column \i -> pageWidth \case AvailablePerLine n _ | Text.length str > n - i -> prettyMlString str _ -> prettyString str | otherwise = prettyString str prettyMlString :: Text -> TomlDoc prettyMlString str = annotate StringClass (column \i -> hang (-i) (fromString (quoteMlString (Text.unpack str)))) prettyString :: Text -> TomlDoc prettyString str = annotate StringClass (fromString (quoteString (Text.unpack str))) -- | Predicate for values that CAN rendered on the -- right-hand side of an @=@. isSimple :: Value' l -> Bool isSimple = \case Integer' {} -> True Double' {} -> True Bool' {} -> True Text' {} -> True TimeOfDay' {} -> True ZonedTime' {} -> True LocalTime' {} -> True Day' {} -> True Table' _ x -> isSingularTable x -- differs from isAlwaysSimple List' _ x -> null x || not (all isTable x) -- | Predicate for values that can be MUST rendered on the -- right-hand side of an @=@. isAlwaysSimple :: Value' l -> Bool isAlwaysSimple = \case Integer' {} -> True Double' {} -> True Bool' {} -> True Text' {} -> True TimeOfDay' {} -> True ZonedTime' {} -> True LocalTime' {} -> True Day' {} -> True Table' {} -> False -- differs from isSimple List' _ x -> null x || not (all isTable x) -- | Predicate for table values. isTable :: Value' l -> Bool isTable Table'{} = True isTable _ = False -- | Predicate for tables that can be rendered with a single assignment. -- These can be collapsed using dotted-key notation on the left-hand side -- of a @=@. isSingularTable :: Table' l -> Bool isSingularTable (MkTable (Map.elems -> [(_, v)])) = isSimple v isSingularTable _ = False -- | Render a complete TOML document using top-level table and array of -- table sections where possible. -- -- Keys are sorted alphabetically. To provide a custom ordering, see -- 'prettyTomlOrdered'. prettyToml :: Table' a {- ^ table to print -} -> TomlDoc {- ^ TOML syntax -} prettyToml = prettyToml_ NoProjection TableKind [] -- | Render a complete TOML document like 'prettyToml' but use a -- custom key ordering. The comparison function has access to the -- complete key path. Note that only keys in the same table will -- every be compared. -- -- This operation allows you to render your TOML files with the -- most important sections first. A TOML file describing a package -- might desire to have the @[package]@ section first before any -- of the ancillary configuration sections. -- -- The /table path/ is the name of the table being sorted. This allows -- the projection to be aware of which table is being sorted. -- -- The /key/ is the key in the table being sorted. These are the -- keys that will be compared to each other. -- -- Here's a projection that puts the @package@ section first, the -- @secondary@ section second, and then all remaining cases are -- sorted alphabetically afterward. -- -- @ -- example :: [String] -> String -> Either Int String -- example [] "package" = Left 1 -- example [] "second" = Left 2 -- example _ other = Right other -- @ -- -- We could also put the tables in reverse-alphabetical order -- by leveraging an existing newtype. -- -- @ -- reverseOrderProj :: [String] -> String -> Down String -- reverseOrderProj _ = Down -- @ prettyTomlOrdered :: Ord a => ([Text] -> Text -> a) {- ^ table path -> key -> projection -} -> Table' l {- ^ table to print -} -> TomlDoc {- ^ TOML syntax -} prettyTomlOrdered proj = prettyToml_ (KeyProjection proj) TableKind [] -- | Optional projection used to order rendered tables data KeyProjection where -- | No projection provided; alphabetical order used NoProjection :: KeyProjection -- | Projection provided: table name and current key are available KeyProjection :: Ord a => ([Text] -> Text -> a) -> KeyProjection prettyToml_ :: KeyProjection -> SectionKind -> [Text] -> Table' l -> TomlDoc prettyToml_ mbKeyProj kind prefix (MkTable t) = vcat (topLines ++ subtables) where order = case mbKeyProj of NoProjection -> id KeyProjection f -> sortOn (f prefix . fst) kvs = order (Map.assocs t) -- this table will require no subsequent tables to be defined simpleToml = all (isSimple . snd) t (simple, sections) = partition (isAlwaysSimple . snd . snd) kvs topLines = [fold topElts | let topElts = headers ++ assignments, not (null topElts)] headers = case NonEmpty.nonEmpty prefix of Just key | simpleToml || not (null simple) || null sections || kind == ArrayTableKind -> [prettySectionKind kind key <> hardline] _ -> [] assignments = [prettyAssignment k v <> hardline | (k,(_, v)) <- if simpleToml then kvs else simple] subtables = [prettySection (prefix ++ [k]) v | not simpleToml, (k,(_, v)) <- sections] prettySection key (Table' _ tab) = prettyToml_ mbKeyProj TableKind key tab prettySection key (List' _ a) = vcat [prettyToml_ mbKeyProj ArrayTableKind key tab | Table' _ tab <- a] prettySection _ _ = error "prettySection applied to simple value" -- | Pretty-print as @line:col: message@ prettyLocated :: Located String -> String prettyLocated (Located p s) = printf "%s: %s" (prettyPosition p) s -- | Pretty-print as @line:col@ prettyPosition :: Position -> String prettyPosition p = printf "%d:%d" (posLine p) (posColumn p) toml-parser-2.0.2.0/src/Toml/Schema.hs0000644000000000000000000000230607346545000015546 0ustar0000000000000000{-| Module : Toml.Schema Description : Infrastructure for converting between TOML and application values Copyright : (c) Eric Mertens, 2024 License : ISC Maintainer : emertens@gmail.com -} module Toml.Schema ( -- * FromValue FromValue(..), mapOf, listOf, -- ** Matcher Matcher, runMatcher, runMatcherFatalWarn, runMatcherIgnoreWarn, Result(..), MatchMessage(..), Scope(..), parseTableFromValue, parseTable, getScope, warn, warnAt, failAt, getTable, setTable, -- ** Tables ParseTable, reqKey, optKey, reqKeyOf, optKeyOf, pickKey, KeyAlt(..), warnTable, warnTableAt, failTableAt, liftMatcher, -- * ToValue ToValue(..), ToTable(..), table, (.=), defaultTableToValue, -- * Types Value, Value'(..), Table, Table'(..), -- * Generics GenericTomlArray(..), GenericTomlTable(..), genericFromTable, genericFromArray, genericToArray, genericToTable, ) where import Toml.Schema.FromValue import Toml.Schema.Generic import Toml.Schema.ParseTable import Toml.Schema.Matcher import Toml.Schema.ToValue import Toml.Semantics toml-parser-2.0.2.0/src/Toml/Schema/0000755000000000000000000000000007346545000015211 5ustar0000000000000000toml-parser-2.0.2.0/src/Toml/Schema/FromValue.hs0000644000000000000000000002371507346545000017455 0ustar0000000000000000{-# Language TypeFamilies #-} {-| Module : Toml.Schema.FromValue Description : Automation for converting TOML values to application values. Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com Use 'FromValue' to define a transformation from some 'Value' to an application domain type. Use 'ParseTable' to help build 'FromValue' instances that match tables. It will make it easy to track which table keys have been used and which are left over. Warnings can be emitted using 'warn' and 'warnTable' (depending on what) context you're in. These warnings can provide useful feedback about problematic values or keys that might be unused now but were perhaps meaningful in an old version of a configuration file. "Toml.Schema.FromValue.Generic" can be used to derive instances of 'FromValue' automatically for record types. -} module Toml.Schema.FromValue ( -- * Deserialization classes FromValue(..), FromKey(..), -- * Containers mapOf, listOf, -- * Tables parseTableFromValue, reqKey, reqKeyOf, optKey, optKeyOf, -- * Errors typeError, ) where import Control.Monad (zipWithM, liftM2) import Data.Int (Int8, Int16, Int32, Int64) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty import Data.Map (Map) import Data.Map qualified as Map import Data.Ratio (Ratio) import Data.Sequence (Seq) import Data.Sequence qualified as Seq import Data.Text (Text) import Data.Text qualified as Text import Data.Text.Lazy qualified import Data.Time (ZonedTime, LocalTime, Day, TimeOfDay, UTCTime, zonedTimeToUTC) import Data.Word (Word8, Word16, Word32, Word64) import Numeric.Natural (Natural) import Toml.Schema.Matcher import Toml.Schema.ParseTable import Toml.Semantics -- | Table matching function used to help implement 'fromValue' for tables. -- Key matching function is given the annotation of the key for error reporting. -- Value matching function is given the key in case values can depend on their keys. mapOf :: Ord k => (l -> Text -> Matcher l k) {- ^ key matcher -} -> (Text -> Value' l -> Matcher l v) {- ^ value matcher -} -> Value' l -> Matcher l (Map k v) mapOf matchKey matchVal = \case Table' _ (MkTable t) -> Map.fromList <$> sequence kvs where kvs = [liftM2 (,) (matchKey l k) (inKey k (matchVal k v)) | (k, (l, v)) <- Map.assocs t] v -> typeError "table" v -- | List matching function used to help implemented 'fromValue' for arrays. -- The element matching function is given the list index in case values can -- depend on their index. listOf :: (Int -> Value' l -> Matcher l a) -> Value' l -> Matcher l [a] listOf matchElt = \case List' _ xs -> zipWithM (\i -> inIndex i . matchElt i) [0..] xs v -> typeError "array" v -- | Class for types that can be decoded from a TOML value. class FromValue a where -- | Convert a 'Value' or report an error message fromValue :: Value' l -> Matcher l a -- | Used to implement instance for @[]@. Most implementations rely on the default implementation. listFromValue :: Value' l -> Matcher l [a] listFromValue = listOf (const fromValue) instance (Ord k, FromKey k, FromValue v) => FromValue (Map k v) where fromValue = mapOf fromKey (const fromValue) instance FromValue Table where fromValue (Table' _ t) = pure (forgetTableAnns t) fromValue v = typeError "table" v -- | Convert from a table key class FromKey a where fromKey :: l -> Text -> Matcher l a -- | Matches all strings instance a ~ Char => FromKey [a] where fromKey _ = pure . Text.unpack -- | Matches all strings instance FromKey Text where fromKey _ = pure -- | Matches all strings instance FromKey Data.Text.Lazy.Text where fromKey _ = pure . Data.Text.Lazy.fromStrict -- | Report a type error typeError :: String {- ^ expected type -} -> Value' l {- ^ actual value -} -> Matcher l a typeError wanted got = failAt (valueAnn got) ("expected " ++ wanted ++ " but got " ++ valueType got) -- | Used to derive a 'fromValue' implementation from a 'ParseTable' matcher. parseTableFromValue :: ParseTable l a -> Value' l -> Matcher l a parseTableFromValue p (Table' l t) = parseTable p l t parseTableFromValue _ v = typeError "table" v -- | Matches integer values instance FromValue Integer where fromValue (Integer' _ x) = pure x fromValue v = typeError "integer" v -- | Matches non-negative integer values instance FromValue Natural where fromValue v = do i <- fromValue v if 0 <= i then pure (fromInteger i) else failAt (valueAnn v) "integer out of range for Natural" fromValueSized :: forall l a. (Bounded a, Integral a) => String -> Value' l -> Matcher l a fromValueSized name v = do i <- fromValue v if fromIntegral (minBound :: a) <= i && i <= fromIntegral (maxBound :: a) then pure (fromInteger i) else failAt (valueAnn v) ("integer out of range for " ++ name) instance FromValue Int where fromValue = fromValueSized "Int" instance FromValue Int8 where fromValue = fromValueSized "Int8" instance FromValue Int16 where fromValue = fromValueSized "Int16" instance FromValue Int32 where fromValue = fromValueSized "Int32" instance FromValue Int64 where fromValue = fromValueSized "Int64" instance FromValue Word where fromValue = fromValueSized "Word" instance FromValue Word8 where fromValue = fromValueSized "Word8" instance FromValue Word16 where fromValue = fromValueSized "Word16" instance FromValue Word32 where fromValue = fromValueSized "Word32" instance FromValue Word64 where fromValue = fromValueSized "Word64" -- | Matches single-character strings with 'fromValue' and arbitrary -- strings with 'listFromValue' to support 'Prelude.String' instance FromValue Char where fromValue (Text' l t) = case Text.uncons t of Just (c, t') | Text.null t' -> pure c _ -> failAt l "expected single character" fromValue v = typeError "string" v listFromValue (Text' _ t) = pure (Text.unpack t) listFromValue v = typeError "string" v -- | Matches string literals instance FromValue Text where fromValue (Text' _ t) = pure t fromValue v = typeError "string" v -- | Matches string literals instance FromValue Data.Text.Lazy.Text where fromValue v = Data.Text.Lazy.fromStrict <$> fromValue v -- | Matches floating-point and integer values instance FromValue Double where fromValue (Double' _ x) = pure x fromValue (Integer' _ x) = pure (fromInteger x) fromValue v = typeError "float" v -- | Matches floating-point and integer values instance FromValue Float where fromValue (Double' _ x) = pure (realToFrac x) fromValue (Integer' _ x) = pure (fromInteger x) fromValue v = typeError "float" v -- | Matches floating-point and integer values. -- -- TOML specifies @Floats should be implemented as IEEE 754 binary64 values.@ -- so note that the given 'Rational' will be converted from a double -- representation and will often be an approximation rather than the exact -- value. instance Integral a => FromValue (Ratio a) where fromValue (Double' a x) | isNaN x || isInfinite x = failAt a "finite float required" | otherwise = pure (realToFrac x) fromValue (Integer' _ x) = pure (fromInteger x) fromValue v = typeError "float" v -- | Matches non-empty arrays or reports an error. instance FromValue a => FromValue (NonEmpty a) where fromValue v = do xs <- fromValue v case NonEmpty.nonEmpty xs of Nothing -> failAt (valueAnn v) "non-empty list required" Just ne -> pure ne -- | Matches arrays instance FromValue a => FromValue (Seq a) where fromValue v = Seq.fromList <$> fromValue v -- | Matches @true@ and @false@ instance FromValue Bool where fromValue (Bool' _ x) = pure x fromValue v = typeError "boolean" v -- | Implemented in terms of 'listFromValue' instance FromValue a => FromValue [a] where fromValue = listFromValue -- | Matches local date literals instance FromValue Day where fromValue (Day' _ x) = pure x fromValue v = typeError "local date" v -- | Matches local time literals instance FromValue TimeOfDay where fromValue (TimeOfDay' _ x) = pure x fromValue v = typeError "local time" v -- | Matches offset date-time literals instance FromValue ZonedTime where fromValue (ZonedTime' _ x) = pure x fromValue v = typeError "offset date-time" v -- | Matches offset date-time literals and converts to UTC instance FromValue UTCTime where fromValue (ZonedTime' _ x) = pure (zonedTimeToUTC x) fromValue v = typeError "offset date-time" v -- | Matches local date-time literals instance FromValue LocalTime where fromValue (LocalTime' _ x) = pure x fromValue v = typeError "local date-time" v -- | Matches all values, used for pass-through instance FromValue Value where fromValue = pure . forgetValueAnns -- | Convenience function for matching an optional key with a 'FromValue' -- instance. -- -- @optKey key = 'optKeyOf' key 'fromValue'@ optKey :: FromValue a => Text -> ParseTable l (Maybe a) optKey key = optKeyOf key fromValue -- | Convenience function for matching a required key with a 'FromValue' -- instance. -- -- @reqKey key = 'reqKeyOf' key 'fromValue'@ reqKey :: FromValue a => Text -> ParseTable l a reqKey key = reqKeyOf key fromValue -- | Match a table entry by key if it exists or return 'Nothing' if not. -- If the key is defined, it is matched by the given function. -- -- See 'pickKey' for more complex cases. optKeyOf :: Text {- ^ key -} -> (Value' l -> Matcher l a) {- ^ value matcher -} -> ParseTable l (Maybe a) optKeyOf key k = pickKey [Key key (fmap Just . k), Else (pure Nothing)] -- | Match a table entry by key or report an error if missing. -- -- See 'pickKey' for more complex cases. reqKeyOf :: Text {- ^ key -} -> (Value' l -> Matcher l a) {- ^ value matcher -} -> ParseTable l a reqKeyOf key k = pickKey [Key key k] toml-parser-2.0.2.0/src/Toml/Schema/Generic.hs0000644000000000000000000000614607346545000017130 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, UndecidableInstances, ScopedTypeVariables, InstanceSigs #-} {-| Module : Toml.Schema.Generic Description : Integration with DerivingVia extension Copyright : (c) Eric Mertens, 2024 License : ISC Maintainer : emertens@gmail.com This module makes it possible to easily derive the TOML classes using the @DerivingVia@ extension. For example: @ data Physical = Physical { color :: String, shape :: String } deriving (Eq, Show, Generic) deriving (ToTable, ToValue, FromValue) via GenericTomlTable Physical @ These derived instances would allow you to match TOML @{color="red", shape="round"}@ to value @Physical "red" "round"@. @ data Coord = Coord Int Int deriving (Eq, Show, Generic) deriving (ToValue, FromValue) via GenericTomlArray Physical @ These derived instances would allow you to match TOML @[1,2]@ to value @Coord 1 2@. -} module Toml.Schema.Generic ( -- * DerivingVia GenericTomlTable(GenericTomlTable), GenericTomlArray(GenericTomlArray), -- * FromValue genericFromArray, genericFromTable, GFromArray, GParseTable, -- * ToValue genericToArray, genericToTable, GToArray, GToTable, ) where import Data.Coerce (coerce) import GHC.Generics (Generic(Rep)) import Toml.Schema.FromValue import Toml.Schema.Matcher import Toml.Schema.Generic.FromValue import Toml.Schema.Generic.ToValue (GToTable, GToArray, genericToTable, genericToArray) import Toml.Schema.ToValue (ToTable(toTable), ToValue(toValue), defaultTableToValue) import Toml.Semantics (Value, Value', Table) -- | Helper type to use GHC's DerivingVia extension to derive -- 'ToValue', 'ToTable', 'FromValue' for records. newtype GenericTomlTable a = GenericTomlTable a -- | Instance derived from 'ToTable' instance using 'defaultTableToValue' instance (Generic a, GToTable (Rep a)) => ToValue (GenericTomlTable a) where toValue = defaultTableToValue {-# INLINE toValue #-} -- | Instance derived using 'genericToTable' instance (Generic a, GToTable (Rep a)) => ToTable (GenericTomlTable a) where toTable = coerce (genericToTable :: a -> Table) {-# INLINE toTable #-} -- | Instance derived using 'genericParseTable' instance (Generic a, GParseTable (Rep a)) => FromValue (GenericTomlTable a) where fromValue :: forall l. Value' l -> Matcher l (GenericTomlTable a) fromValue = coerce (parseTableFromValue genericParseTable :: Value' l -> Matcher l a) {-# INLINE fromValue #-} -- | Helper type to use GHC's DerivingVia extension to derive -- 'ToValue', 'ToTable', 'FromValue' for any product type. newtype GenericTomlArray a = GenericTomlArray a -- | Instance derived using 'genericToArray' instance (Generic a, GToArray (Rep a)) => ToValue (GenericTomlArray a) where toValue = coerce (genericToArray :: a -> Value) {-# INLINE toValue #-} -- | Instance derived using 'genericFromArray' instance (Generic a, GFromArray (Rep a)) => FromValue (GenericTomlArray a) where fromValue :: forall l. Value' l -> Matcher l (GenericTomlArray a) fromValue = coerce (genericFromArray :: Value' l -> Matcher l a) {-# INLINE fromValue #-} toml-parser-2.0.2.0/src/Toml/Schema/Generic/0000755000000000000000000000000007346545000016565 5ustar0000000000000000toml-parser-2.0.2.0/src/Toml/Schema/Generic/FromValue.hs0000644000000000000000000001063207346545000021023 0ustar0000000000000000{-# Language DataKinds, InstanceSigs, ScopedTypeVariables, TypeOperators #-} {-| Module : Toml.Schema.Generic.FromValue Description : GHC.Generics derived table parsing Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com Generic implementations of matching tables and arrays. -} module Toml.Schema.Generic.FromValue ( -- * Record from table GParseTable(..), genericParseTable, genericFromTable, -- * Product type from array GFromArray(..), genericFromArray, ) where import Control.Monad.Trans.State (StateT(..)) import Data.Coerce (coerce) import Data.Text qualified as Text import GHC.Generics import Toml.Schema.FromValue (FromValue, fromValue, optKey, reqKey, parseTableFromValue, typeError) import Toml.Schema.Matcher (Matcher, failAt) import Toml.Schema.ParseTable (ParseTable) import Toml.Semantics (Value'(List')) -- | Match a 'Toml.Semantics.Table'' using the field names in a record. genericParseTable :: (Generic a, GParseTable (Rep a)) => ParseTable l a genericParseTable = to <$> gParseTable {-# INLINE genericParseTable #-} -- | Implementation of 'fromValue' using 'genericParseTable' to derive -- a match from the record field names of the target type. genericFromTable :: (Generic a, GParseTable (Rep a)) => Value' l -> Matcher l a genericFromTable = parseTableFromValue genericParseTable {-# INLINE genericFromTable #-} -- | Match a 'Toml.Semantics.Value'' as an array positionally matching field fields -- of a constructor to the elements of the array. genericFromArray :: (Generic a, GFromArray (Rep a)) => Value' l -> Matcher l a genericFromArray (List' a xs) = do (gen, xs') <- runStateT gFromArray xs if null xs' then pure (to gen) else failAt a ("array " ++ show (length xs') ++ " elements too long") genericFromArray v = typeError "array" v {-# INLINE genericFromArray #-} -- 'gParseTable' is written in continuation passing style because -- it allows all the "GHC.Generics" constructors to inline into -- a single location which allows the optimizer to optimize them -- complete away. -- | Supports conversion of TOML tables into record values using -- field selector names as TOML keys. class GParseTable f where -- | Convert a value and apply the continuation to the result. gParseTable :: ParseTable l (f a) -- | Ignores type constructor name instance GParseTable f => GParseTable (D1 c f) where gParseTable = M1 <$> gParseTable {-# INLINE gParseTable #-} -- | Ignores value constructor name - only supports record constructors instance GParseTable f => GParseTable (C1 ('MetaCons sym fix 'True) f) where gParseTable = M1 <$> gParseTable {-# INLINE gParseTable #-} -- | Matches left then right component instance (GParseTable f, GParseTable g) => GParseTable (f :*: g) where gParseTable = do x <- gParseTable y <- gParseTable pure (x :*: y) {-# INLINE gParseTable #-} -- | Omits the key from the table on nothing, includes it on just instance {-# OVERLAPS #-} (Selector s, FromValue a) => GParseTable (S1 s (K1 i (Maybe a))) where gParseTable = do x <- optKey (Text.pack (selName (M1 [] :: S1 s [] ()))) pure (M1 (K1 x)) {-# INLINE gParseTable #-} -- | Uses record selector name as table key instance (Selector s, FromValue a) => GParseTable (S1 s (K1 i a)) where gParseTable = do x <- reqKey (Text.pack (selName (M1 [] :: S1 s [] ()))) pure (M1 (K1 x)) {-# INLINE gParseTable #-} -- | Emits empty table instance GParseTable U1 where gParseTable = pure U1 {-# INLINE gParseTable #-} -- | Supports conversion of TOML arrays into product-type values. class GFromArray f where gFromArray :: StateT [Value' l] (Matcher l) (f a) instance GFromArray f => GFromArray (M1 i c f) where gFromArray :: forall a l. StateT [Value' l] (Matcher l) (M1 i c f a) gFromArray = coerce (gFromArray :: StateT [Value' l] (Matcher l) (f a)) {-# INLINE gFromArray #-} instance (GFromArray f, GFromArray g) => GFromArray (f :*: g) where gFromArray = do x <- gFromArray y <- gFromArray pure (x :*: y) {-# INLINE gFromArray #-} instance FromValue a => GFromArray (K1 i a) where gFromArray = StateT \case [] -> fail "array too short" x:xs -> (\v -> (K1 v, xs)) <$> fromValue x {-# INLINE gFromArray #-} -- | Uses no array elements instance GFromArray U1 where gFromArray = pure U1 {-# INLINE gFromArray #-} toml-parser-2.0.2.0/src/Toml/Schema/Generic/ToValue.hs0000644000000000000000000000567607346545000020516 0ustar0000000000000000{-| Module : Toml.Schema.Generic.ToValue Description : GHC.Generics derived table generation Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com Use 'genericToTable' to derive an instance of 'Toml.ToValue.ToTable' using the field names of a record. Use 'genericToArray' to derive an instance of 'Toml.ToValue.ToValue' using the positions of data in a constructor. -} module Toml.Schema.Generic.ToValue ( -- * Records to Tables GToTable(..), genericToTable, -- * Product types to Arrays GToArray(..), genericToArray, ) where import Data.Text (Text) import Data.Text qualified as Text import GHC.Generics import Toml.Semantics import Toml.Schema.ToValue (ToValue(..), table) -- | Use a record's field names to generate a 'Table' genericToTable :: (Generic a, GToTable (Rep a)) => a -> Table genericToTable x = table (gToTable (from x) []) {-# INLINE genericToTable #-} -- | Use a record's field names to generate a 'Table' genericToArray :: (Generic a, GToArray (Rep a)) => a -> Value genericToArray a = List (gToArray (from a) []) {-# INLINE genericToArray #-} -- | Supports conversion of product types with field selector names -- to TOML values. class GToTable f where gToTable :: f a -> [(Text, Value)] -> [(Text, Value)] -- | Ignores type constructor names instance GToTable f => GToTable (D1 c f) where gToTable (M1 x) = gToTable x {-# INLINE gToTable #-} -- | Ignores value constructor names instance GToTable f => GToTable (C1 c f) where gToTable (M1 x) = gToTable x {-# INLINE gToTable #-} instance (GToTable f, GToTable g) => GToTable (f :*: g) where gToTable (x :*: y) = gToTable x <> gToTable y {-# INLINE gToTable #-} -- | Omits the key from the table on nothing, includes it on just instance {-# OVERLAPS #-} (Selector s, ToValue a) => GToTable (S1 s (K1 i (Maybe a))) where gToTable (M1 (K1 Nothing)) = id gToTable s@(M1 (K1 (Just x))) = ((Text.pack (selName s), toValue x):) {-# INLINE gToTable #-} -- | Uses record selector name as table key instance (Selector s, ToValue a) => GToTable (S1 s (K1 i a)) where gToTable s@(M1 (K1 x)) = ((Text.pack (selName s), toValue x):) {-# INLINE gToTable #-} -- | Emits empty table instance GToTable U1 where gToTable _ = id {-# INLINE gToTable #-} instance GToTable V1 where gToTable v = case v of {} {-# INLINE gToTable #-} -- | Convert product types to arrays positionally. class GToArray f where gToArray :: f a -> [Value] -> [Value] -- | Ignore metadata instance GToArray f => GToArray (M1 i c f) where gToArray (M1 x) = gToArray x {-# INLINE gToArray #-} -- | Convert left and then right instance (GToArray f, GToArray g) => GToArray (f :*: g) where gToArray (x :*: y) = gToArray x . gToArray y {-# INLINE gToArray #-} -- | Convert fields using 'ToValue' instances instance ToValue a => GToArray (K1 i a) where gToArray (K1 x) = (toValue x :) {-# INLINE gToArray #-} toml-parser-2.0.2.0/src/Toml/Schema/Matcher.hs0000644000000000000000000001370207346545000017133 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-| Module : Toml.Schema.Matcher Description : A type for building results while tracking scopes Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com This type helps to build up computations that can validate a TOML value and compute some application-specific representation. It supports warning messages which can be used to deprecate old configuration options and to detect unused table keys. It supports tracking multiple error messages when you have more than one decoding option and all of them have failed. Use 'Toml.Pretty.prettyMatchMessage' for an easy way to make human readable strings from matcher outputs. -} module Toml.Schema.Matcher ( -- * Types Matcher, Result(..), MatchMessage(..), -- * Operations runMatcher, withScope, getScope, warn, warnAt, failAt, -- * Run helpers runMatcherIgnoreWarn, runMatcherFatalWarn, -- * Scope helpers Scope(..), inKey, inIndex, ) where import Control.Applicative (Alternative(..)) import Control.Monad (MonadPlus, ap, liftM) import Data.Monoid (Endo(..)) import Data.Text (Text) -- | Computations that result in a 'Result' and which track a list -- of nested contexts to assist in generating warnings and error -- messages. -- -- Use 'withScope' to run a 'Matcher' in a new, nested scope. newtype Matcher l a = Matcher { unMatcher :: forall r. [Scope] -> DList (MatchMessage l) -> (DList (MatchMessage l) -> r) -> (DList (MatchMessage l) -> a -> r) -> r } instance Functor (Matcher a) where fmap = liftM instance Applicative (Matcher a) where pure x = Matcher (\_env ws _err ok -> ok ws x) (<*>) = ap instance Monad (Matcher a) where m >>= f = Matcher (\env ws err ok -> unMatcher m env ws err (\warn' x -> unMatcher (f x) env warn' err ok)) {-# INLINE (>>=) #-} instance Alternative (Matcher a) where empty = Matcher (\_env _warn err _ok -> err mempty) Matcher x <|> Matcher y = Matcher (\env ws err ok -> x env ws (\errs1 -> y env ws (\errs2 -> err (errs1 <> errs2)) ok) ok) instance MonadPlus (Matcher a) -- | Scopes for TOML message. data Scope = ScopeIndex Int -- ^ zero-based array index | ScopeKey Text -- ^ key in a table deriving ( Read {- ^ Default instance -}, Show {- ^ Default instance -}, Eq {- ^ Default instance -}, Ord {- ^ Default instance -}) -- | A message emitted while matching a TOML value. The message is paired -- with the path to the value that was in focus when the message was -- generated. These message get used for both warnings and errors. -- -- For a convenient way to render these to a string, see 'Toml.Pretty.prettyMatchMessage'. data MatchMessage a = MatchMessage { matchAnn :: Maybe a, matchPath :: [Scope], -- ^ path to message location matchMessage :: String -- ^ error and warning message body } deriving ( Read {- ^ Default instance -}, Show {- ^ Default instance -}, Eq {- ^ Default instance -}, Ord {- ^ Default instance -}, Functor, Foldable, Traversable) -- | List of strings that supports efficient left- and right-biased append newtype DList a = DList (Endo [a]) deriving (Semigroup, Monoid) -- | Create a singleton list of strings one :: a -> DList a one x = DList (Endo (x:)) -- | Extract the list of strings runDList :: DList a -> [a] runDList (DList x) = x `appEndo` [] -- | Computation outcome with error and warning messages. Multiple error -- messages can occur when multiple alternatives all fail. Resolving any -- one of the error messages could allow the computation to succeed. data Result e a = Failure [e] -- ^ error messages | Success [e] a -- ^ warning messages and result deriving ( Read {- ^ Default instance -}, Show {- ^ Default instance -}, Eq {- ^ Default instance -}, Ord {- ^ Default instance -}) -- | Run a 'Matcher' with an empty scope. runMatcher :: Matcher l a -> Result (MatchMessage l) a runMatcher (Matcher m) = m [] mempty (Failure . runDList) (Success . runDList) -- | Run 'Matcher' and ignore warnings. runMatcherIgnoreWarn :: Matcher l a -> Either [MatchMessage l] a runMatcherIgnoreWarn m = case runMatcher m of Failure err -> Left err Success _ x -> Right x -- | Run 'Matcher' and treat warnings as errors. runMatcherFatalWarn :: Matcher l a -> Either [MatchMessage l] a runMatcherFatalWarn m = case runMatcher m of Success [] x -> Right x Success ws _ -> Left ws Failure err -> Left err -- | Run a 'Matcher' with a locally extended scope. withScope :: Scope -> Matcher l a -> Matcher l a withScope scope (Matcher m) = Matcher (\scopes -> m (scope : scopes)) -- | Get the current list of scopes. getScope :: Matcher a [Scope] getScope = Matcher (\env ws _err ok -> ok ws (reverse env)) -- | Emit a warning without an annotation. warn :: String -> Matcher a () warn w = Matcher (\scopes ws _err ok -> ok (ws <> one (MatchMessage Nothing (reverse scopes) w)) ()) -- | Emit a warning mentioning the given annotation. warnAt :: l -> String -> Matcher l () warnAt loc w = Matcher (\scopes ws _err ok -> ok (ws <> one (MatchMessage (Just loc) (reverse scopes) w)) ()) -- | Fail with an error message without an annotation. instance MonadFail (Matcher a) where fail e = Matcher (\scopes _warn err _ok -> err (one (MatchMessage Nothing (reverse scopes) e))) -- | Terminate the match with an error mentioning the given annotation. failAt :: l -> String -> Matcher l a failAt l e = Matcher (\scopes _warn err _ok -> err (one (MatchMessage (Just l) (reverse scopes) e))) -- | Update the scope with the message corresponding to a table key inKey :: Text -> Matcher l a -> Matcher l a inKey = withScope . ScopeKey -- | Update the scope with the message corresponding to an array index inIndex :: Int -> Matcher l a -> Matcher l a inIndex = withScope . ScopeIndex toml-parser-2.0.2.0/src/Toml/Schema/ParseTable.hs0000644000000000000000000001074607346545000017577 0ustar0000000000000000{-| Module : Toml.Schema.ParseTable Description : A type for matching keys out of a table Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com This module provides utilities for matching key-value pairs out of tables while building up application-specific values. It will help generate warnings for unused keys, help select between multiple possible keys, and emit location-specific error messages when keys are unavailable. -} module Toml.Schema.ParseTable ( -- * Base interface ParseTable, KeyAlt(..), pickKey, parseTable, -- * Primitives liftMatcher, warnTable, warnTableAt, failTableAt, setTable, getTable, ) where import Control.Applicative (Alternative, empty) import Control.Monad (MonadPlus) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader (ReaderT(..), ask) import Control.Monad.Trans.State.Strict (StateT(..), get, put) import Data.Foldable (for_) import Data.List (intercalate) import Data.Map qualified as Map import Data.Text (Text) import Toml.Schema.Matcher (Matcher, inKey, failAt, warn, warnAt) import Toml.Semantics (Table'(..), Value') import Toml.Pretty -- | Parser that tracks a current set of unmatched key-value -- pairs from a table. -- -- Use 'Toml.Schema.optKey' and 'Toml.Schema.reqKey' to extract keys. -- -- Use 'getTable' and 'setTable' to override the table and implement -- other primitives. newtype ParseTable l a = ParseTable (ReaderT l (StateT (Table' l) (Matcher l)) a) deriving (Functor, Applicative, Monad, Alternative, MonadPlus) -- | Implemented in terms of 'fail' on 'Matcher' instance MonadFail (ParseTable l) where fail = ParseTable . fail -- | Lift a matcher into the current table parsing context. liftMatcher :: Matcher l a -> ParseTable l a liftMatcher = ParseTable . lift . lift -- | Run a 'ParseTable' computation with a given starting 'Table''. -- Unused tables will generate a warning. To change this behavior -- 'getTable' and 'setTable' can be used to discard or generate -- error messages. parseTable :: ParseTable l a -> l -> Table' l -> Matcher l a parseTable (ParseTable p) l t = do (x, MkTable t') <- runStateT (runReaderT p l) t for_ (Map.assocs t') \(k, (a, _)) -> warnAt a ("unexpected key: " ++ show (prettySimpleKey k)) pure x -- | Return the remaining portion of the table being matched. getTable :: ParseTable l (Table' l) getTable = ParseTable (lift get) -- | Replace the remaining portion of the table being matched. setTable :: Table' l -> ParseTable l () setTable = ParseTable . lift . put -- | Emit a warning without an annotation. warnTable :: String -> ParseTable l () warnTable = liftMatcher . warn -- | Emit a warning with the given annotation. warnTableAt :: l -> String -> ParseTable l () warnTableAt l = liftMatcher . warnAt l -- | Abort the current table matching with an error message at the given annotation. failTableAt :: l -> String -> ParseTable l a failTableAt l = liftMatcher . failAt l -- | Key and value matching function data KeyAlt l a = Key Text (Value' l -> Matcher l a) -- ^ pick alternative based on key match | Else (Matcher l a) -- ^ default case when no previous cases matched -- | Take the first option from a list of table keys and matcher functions. -- This operation will commit to the first table key that matches. If the -- associated matcher fails, only that error will be propagated and the -- other alternatives will not be matched. -- -- If no keys match, an error message is generated explaining which keys -- would have been accepted. -- -- This is provided as an alternative to chaining multiple -- 'Toml.Schema.reqKey' cases together with 'Control.Applicative.Alternative' -- which will fall-through as a result of any failure to the next case. pickKey :: [KeyAlt l a] -> ParseTable l a pickKey xs = do MkTable t <- getTable foldr (f t) errCase xs where f _ (Else m) _ = liftMatcher m f t (Key k c) continue = case Map.lookup k t of Nothing -> continue Just (_, v) -> do setTable $! MkTable (Map.delete k t) liftMatcher (inKey k (c v)) errCase = do l <- ParseTable ask case xs of [] -> empty -- there's nothing a user can do here [Key k _] -> failTableAt l ("missing key: " ++ show (prettySimpleKey k)) _ -> failTableAt l ("possible keys: " ++ intercalate ", " [show (prettySimpleKey k) | Key k _ <- xs]) toml-parser-2.0.2.0/src/Toml/Schema/ToValue.hs0000644000000000000000000001370307346545000017130 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} -- needed for type equality on old GHC {-| Module : Toml.Schema.ToValue Description : Automation for converting application values to TOML. Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com The 'ToValue' class provides a conversion function from application-specific to TOML values. Because the top-level TOML document is always a table, the 'ToTable' class is for types that specifically support conversion to a 'Table'. "Toml.Schema.Generic" can be used to derive instances of 'ToTable' automatically for record types and 'ToValue' for array types. -} module Toml.Schema.ToValue ( ToValue(..), -- * Table construction ToTable(..), ToKey(..), defaultTableToValue, table, (.=), ) where import Data.Foldable (toList) import Data.Int (Int8, Int16, Int32, Int64) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty import Data.Map (Map) import Data.Map qualified as Map import Data.Ratio (Ratio) import Data.Sequence (Seq) import Data.Text (Text) import Data.Text qualified as Text import Data.Text.Lazy qualified import Data.Time (Day, TimeOfDay, LocalTime, ZonedTime, UTCTime, utcToZonedTime, utc) import Data.Word (Word8, Word16, Word32, Word64) import Numeric.Natural (Natural) import Toml.Semantics -- | Build a 'Table' from a list of key-value pairs. -- -- Use '.=' for a convenient way to build the pairs. table :: [(Text, Value)] -> Table table kvs = MkTable (Map.fromList [(k, ((), v)) | (k, v) <- kvs]) {-# INLINE table #-} -- | Convenience function for building key-value pairs while -- constructing a 'Table'. -- -- @'table' [a '.=' b, c '.=' d]@ (.=) :: ToValue a => Text -> a -> (Text, Value) k .= v = (k, toValue v) -- | Class for types that can be embedded into 'Value' class ToValue a where -- | Embed a single thing into a TOML value. toValue :: a -> Value -- | Helper for converting a list of things into a value. This is typically -- left to be defined by its default implementation and exists to help define -- the encoding for TOML arrays. toValueList :: [a] -> Value toValueList = List . map toValue -- | Class for things that can be embedded into a TOML table. -- -- Implement this for things that always embed into a 'Table' and then -- the 'ToValue' instance can be derived with 'defaultTableToValue'. -- -- @ -- instance ToValue Example where -- toValue = defaultTableToValue -- -- -- Option 1: Manual instance -- instance ToTable Example where -- toTable x = 'table' ["field1" '.=' field1 x, "field2" '.=' field2 x] -- -- -- Option 2: GHC.Generics derived instance using Toml.ToValue.Generic -- instance ToTable Example where -- toTable = genericToTable -- @ class ToValue a => ToTable a where -- | Convert a single value into a table toTable :: a -> Table instance (ToKey k, ToValue v) => ToTable (Map k v) where toTable m = table [(toKey k, toValue v) | (k,v) <- Map.assocs m] instance (ToKey k, ToValue v) => ToValue (Map k v) where toValue = defaultTableToValue instance ToTable (Table' a) where toTable = forgetTableAnns instance ToValue (Table' a) where toValue = defaultTableToValue -- | Convert to a table key. This class enables various string types to be -- used as the keys of a 'Map' when converting into TOML tables. class ToKey a where toKey :: a -> Text instance Char ~ a => ToKey [a] where toKey = Text.pack instance ToKey Text.Text where toKey = id instance ToKey Data.Text.Lazy.Text where toKey = Data.Text.Lazy.toStrict -- | Convenience function for building 'ToValue' instances. defaultTableToValue :: ToTable a => a -> Value defaultTableToValue = Table . toTable -- | Identity function instance ToValue Value where toValue = id -- | Single characters are encoded as singleton strings. Lists of characters -- are encoded as a single string value. instance ToValue Char where toValue x = Text (Text.singleton x) toValueList = Text . Text.pack -- | Encodes as string literal instance ToValue Text.Text where toValue = Text -- | Encodes as string literal instance ToValue Data.Text.Lazy.Text where toValue = Text . Data.Text.Lazy.toStrict -- | This instance defers to the list element's 'toValueList' implementation. instance ToValue a => ToValue [a] where toValue = toValueList -- | Converts to list and encodes that to value instance ToValue a => ToValue (NonEmpty a) where toValue = toValue . NonEmpty.toList -- | Converts to list and encodes that to value instance ToValue a => ToValue (Seq a) where toValue = toValue . toList -- | TOML represents floating point numbers with 'Prelude.Double'. -- This operation lose precision and can overflow to infinity. instance Integral a => ToValue (Ratio a) where toValue = Double . realToFrac instance ToValue Double where toValue = Double instance ToValue Float where toValue = Double . realToFrac instance ToValue Bool where toValue = Bool instance ToValue TimeOfDay where toValue = TimeOfDay instance ToValue LocalTime where toValue = LocalTime instance ToValue ZonedTime where toValue = ZonedTime instance ToValue UTCTime where toValue = ZonedTime . utcToZonedTime utc instance ToValue Day where toValue = Day instance ToValue Integer where toValue = Integer instance ToValue Natural where toValue = Integer . fromIntegral instance ToValue Int where toValue = Integer . fromIntegral instance ToValue Int8 where toValue = Integer . fromIntegral instance ToValue Int16 where toValue = Integer . fromIntegral instance ToValue Int32 where toValue = Integer . fromIntegral instance ToValue Int64 where toValue = Integer . fromIntegral instance ToValue Word where toValue = Integer . fromIntegral instance ToValue Word8 where toValue = Integer . fromIntegral instance ToValue Word16 where toValue = Integer . fromIntegral instance ToValue Word32 where toValue = Integer . fromIntegral instance ToValue Word64 where toValue = Integer . fromIntegral toml-parser-2.0.2.0/src/Toml/Semantics.hs0000644000000000000000000002274307346545000016303 0ustar0000000000000000{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use section" #-} {-| Module : Toml.Semantics Description : Semantic interpretation of raw TOML expressions Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com This module extracts a nested Map representation of a TOML file. It detects invalid key assignments and resolves dotted key assignments. -} module Toml.Semantics ( -- * Types Value, Value'(..), Table, Table'(..), -- * Validation semantics, SemanticError(..), SemanticErrorKind(..), -- * Annotations forgetTableAnns, forgetValueAnns, valueAnn, valueType, ) where import Control.Monad (foldM) import Data.List.NonEmpty (NonEmpty((:|))) import Data.List.NonEmpty qualified as NonEmpty import Data.Map (Map) import Data.Map qualified as Map import Data.Text (Text) import Toml.Syntax.Types (SectionKind(..), Key, Val(..), Expr(..)) import Toml.Semantics.Types -- | This type represents errors generated when resolving keys in a TOML -- document. -- -- @since 1.3.0.0 data SemanticError a = SemanticError { errorAnn :: a, -- ^ Annotation associated with offending key errorKey :: Text, errorKind :: SemanticErrorKind } deriving ( Read {- ^ Default instance -}, Show {- ^ Default instance -}, Eq {- ^ Default instance -}, Ord {- ^ Default instance -}, Functor, Foldable, Traversable) -- | Enumeration of the kinds of conflicts a key can generate. -- -- @since 1.3.0.0 data SemanticErrorKind = AlreadyAssigned -- ^ Attempted to assign to a key that was already assigned | ClosedTable -- ^ Attempted to open a table already closed | ImplicitlyTable -- ^ Attempted to open a tables as an array of tables that was implicitly defined to be a table deriving ( Read {- ^ Default instance -}, Show {- ^ Default instance -}, Eq {- ^ Default instance -}, Ord {- ^ Default instance -}) -- | Extracts a semantic value from a sequence of raw TOML expressions, -- or reports a semantic error if one occurs. semantics :: [Expr a] -> Either (SemanticError a) (Table' a) semantics exprs = do f <- foldM processExpr (flip assignKeyVals Map.empty) exprs framesToTable <$> f [] where processExpr f = \case KeyValExpr k v -> Right (f . ((k,v):)) TableExpr k -> processSection TableKind k ArrayTableExpr k -> processSection ArrayTableKind k where processSection kind k = flip (addSection kind k) <$> f [] -- | A top-level table used to distinguish top-level defined arrays -- and tables from inline values. type FrameTable a = Map Text (a, Frame a) -- | M is the error-handling monad used through this module for -- propagating semantic errors through the 'semantics' function. type M a = Either (SemanticError a) -- | Frames are the top-level skeleton of the TOML file that mirror the -- subset of values that can be constructed with with top-level syntax. -- TOML syntax makes a distinction between tables and arrays that are -- defined at the top-level and those defined with inline syntax. This -- separate type keeps these syntactic differences separate while table -- and array resolution is still happening. Frames can keep track of which -- tables finished and which are eligible for extension. data Frame a = FrameTable a FrameKind (FrameTable a) | FrameArray (NonEmpty (a, FrameTable a)) -- stored in reverse order for easy "append" | FrameValue (Value' a) deriving Show -- | Top-level tables can be in various states of completeness. This type -- keeps track of the current state of a top-level defined table. data FrameKind = Open -- ^ table implicitly defined as super-table of [x.y.z] | Dotted -- ^ table implicitly defined using dotted key assignment | Closed -- ^ table closed to further extension deriving Show -- | Convert a top-level table "frame" representation into the plain Value -- representation once the distinction is no longer needed. framesToTable :: FrameTable a -> Table' a framesToTable = fmap MkTable $ fmap $ fmap \case FrameTable a _kind t -> Table' a (framesToTable t) FrameArray (NonEmpty.reverse -> t :| ts) -> -- the array itself is attributed to the first table defined List' (fst t) [Table' a (framesToTable x) | (a, x) <- t : ts] FrameValue v -> v -- | Attempts to insert the key-value pairs given into a new section -- located at the given key-path in a frame map. addSection :: SectionKind {- ^ section kind -} -> Key a {- ^ section key -} -> [(Key a, Val a)] {- ^ values to install -} -> FrameTable a {- ^ local frame map -} -> M a (FrameTable a) {- ^ error message or updated local frame table -} addSection kind (k :| []) kvs = alterFrame k -- defining a new table (case kind of TableKind -> FrameTable (fst k) Closed <$> go mempty ArrayTableKind -> FrameArray . (:| []) . (,) (fst k) <$> go mempty) \case -- defining a super table of a previously defined sub-table FrameTable _ Open t -> case kind of -- the annotation of the open table changes from the first mention closing key TableKind -> FrameTable (fst k) Closed <$> go t ArrayTableKind -> invalidKey k ImplicitlyTable -- Add a new array element to an existing table array FrameArray (t :| ts) -> case kind of TableKind -> invalidKey k ClosedTable ArrayTableKind -> FrameArray . (:| t : ts) . (,) (fst k) <$> go mempty -- failure cases FrameTable _ Closed _ -> invalidKey k ClosedTable FrameTable _ Dotted _ -> error "addSection: dotted table left unclosed" FrameValue {} -> invalidKey k AlreadyAssigned where go = assignKeyVals kvs addSection kind (k1 :| k2 : ks) kvs = alterFrame k1 (FrameTable (fst k1) Open <$> go mempty) \case FrameTable a tk t -> FrameTable a tk <$> go t FrameArray (t :| ts) -> FrameArray . (:| ts) <$> traverse go t FrameValue _ -> invalidKey k1 AlreadyAssigned where go = addSection kind (k2 :| ks) kvs -- | Close all of the tables that were implicitly defined with -- dotted prefixes. These tables are only eligible for extension -- within the @[table]@ section in which they were introduced. closeDots :: FrameTable a -> FrameTable a closeDots = fmap $ fmap \case FrameTable a Dotted t -> FrameTable a Closed (closeDots t) frame -> frame -- | Extend the given frame table with a list of key-value pairs. -- Any tables created through dotted keys will be closed after -- all of the key-value pairs are processed. assignKeyVals :: [(Key a, Val a)] -> FrameTable a -> M a (FrameTable a) assignKeyVals kvs t = closeDots <$> foldM f t kvs where f m (k,v) = assign k v m -- | Assign a single dotted key in a frame. Any open table traversed -- by a dotted key will be marked as dotted so that it will become -- closed at the end of the current call to 'assignKeyVals'. assign :: Key a -> Val a -> FrameTable a -> M a (FrameTable a) assign (key :| []) val = alterFrame key (FrameValue <$> valToValue val) (\_ -> invalidKey key AlreadyAssigned) assign (key :| k1 : keys) val = alterFrame key (go (fst key) mempty) \case FrameTable a Open t -> go a t FrameTable a Dotted t -> go a t FrameTable _ Closed _ -> invalidKey key ClosedTable FrameArray _ -> invalidKey key ClosedTable FrameValue _ -> invalidKey key AlreadyAssigned where go a t = FrameTable a Dotted <$> assign (k1 :| keys) val t -- | Convert 'Val' to 'Value' potentially raising an error if -- it contains inline tables with key-conflicts. valToValue :: Val a -> M a (Value' a) valToValue = \case ValInteger a x -> Right (Integer' a x) ValFloat a x -> Right (Double' a x) ValBool a x -> Right (Bool' a x) ValString a x -> Right (Text' a x) ValTimeOfDay a x -> Right (TimeOfDay' a x) ValZonedTime a x -> Right (ZonedTime' a x) ValLocalTime a x -> Right (LocalTime' a x) ValDay a x -> Right (Day' a x) ValArray a xs -> List' a <$> traverse valToValue xs ValTable a kvs -> Table' a . framesToTable <$> assignKeyVals kvs mempty -- | Abort validation by reporting an error about the given key. invalidKey :: (a, Text) {- ^ sub-key -} -> SemanticErrorKind {- ^ error kind -} -> M a b invalidKey (a, key) kind = Left (SemanticError a key kind) -- | Specialization of 'Map.alterF' used to adjust a location in a 'FrameTable' alterFrame :: (a, Text) {- ^ annotated key -} -> M a (Frame a) {- ^ new value case -} -> (Frame a -> M a (Frame a)) {- ^ update value case -} -> FrameTable a -> M a (FrameTable a) alterFrame (a, k) create update = Map.alterF g k where -- insert a new value g Nothing = do lf <- create pure (Just (a, lf)) -- update an existing value and preserve its annotation g (Just (op, ov)) = do lf <- update ov pure (Just (op, lf)) toml-parser-2.0.2.0/src/Toml/Semantics/0000755000000000000000000000000007346545000015737 5ustar0000000000000000toml-parser-2.0.2.0/src/Toml/Semantics/Ordered.hs0000644000000000000000000001004607346545000017660 0ustar0000000000000000{-| 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) @ -} 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 Data.Text (Text) import Data.Text qualified as Text import Toml.Syntax.Types (Expr(..), Key, Val(ValTable, ValArray)) -- | Summary of the order of the keys in a TOML document. newtype TableOrder = TO (Map Text KeyOrder) -- | Internal type used by 'TableOrder' -- -- The 'Int' field determines the order of the current key and the -- 'TableOrder' determines the order of the children of this key. data KeyOrder = KeyOrder !Int TableOrder -- | Opaque type used by 'projectKey' newtype ProjectedKey = PK (Either Int Text) deriving (Eq, Ord) -- | Generate a projection function for use with 'Toml.Pretty.prettyTomlOrdered' projectKey :: TableOrder {- ^ table order -} -> [Text] {- ^ table path -} -> Text {- ^ 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 a] -> TableOrder extractTableOrder = snd . foldl' addExpr ([], emptyOrder) addExpr :: ([Text], TableOrder) -> Expr a -> ([Text], 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 :: [Text] -> TableOrder -> Val a -> TableOrder addVal prefix to lval = case lval of 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 -> [Text] -> 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 a -> [Text] keyPath = map snd . 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) ' ' ++ Text.unpack k) : go (i+1) v z p (_, KeyOrder i _) = i toml-parser-2.0.2.0/src/Toml/Semantics/Types.hs0000644000000000000000000001400107346545000017373 0ustar0000000000000000{-# Language PatternSynonyms, DeriveTraversable, TypeFamilies #-} {-| Module : Toml.Semantics.Types Description : Semantic TOML values Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com This module provides the type for the semantics of a TOML file. All dotted keys are resolved in this representation. Each table is a Map with a single level of keys. Values are parameterized over an annotation type to allow values to be attributed to a file location. When values are constructed programmatically, there might not be any interesting annotations. In this case a trivial @()@ unit annotation can be used. The 'Value' type-synonym and related pattern synonyms can make using this case more convenient. -} module Toml.Semantics.Types ( -- * Unlocated value synonyms Value, Table, -- * Annotated values Value'(.., Integer, Double, Text, Bool, ZonedTime, Day, LocalTime, TimeOfDay, List, Table), Table'(..), -- * Utilities forgetValueAnns, forgetTableAnns, valueAnn, valueType, ) where import Data.Map (Map) import Data.String (IsString(fromString)) import Data.Text (Text) import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime(zonedTimeToLocalTime, zonedTimeZone), timeZoneMinutes) pattern Integer :: Integer -> Value pattern Integer x <- Integer' _ x where Integer x = Integer' () x pattern Double :: Double -> Value pattern Double x <- Double' _ x where Double x = Double' () x pattern List :: [Value] -> Value pattern List x <- List' _ x where List x = List' () x pattern Table :: Table -> Value pattern Table x <- Table' _ x where Table x = Table' () x pattern Bool :: Bool -> Value pattern Bool x <- Bool' _ x where Bool x = Bool' () x pattern Text :: Text -> Value pattern Text x <- Text' _ x where Text x = Text' () x pattern TimeOfDay :: TimeOfDay -> Value pattern TimeOfDay x <- TimeOfDay' _ x where TimeOfDay x = TimeOfDay' () x pattern ZonedTime :: ZonedTime -> Value pattern ZonedTime x <- ZonedTime' _ x where ZonedTime x = ZonedTime' () x pattern LocalTime :: LocalTime -> Value pattern LocalTime x <- LocalTime' _ x where LocalTime x = LocalTime' () x pattern Day :: Day -> Value pattern Day x <- Day' _ x where Day x = Day' () x {-# Complete List, Table, Text, Bool, Integer, Double, Day, LocalTime, ZonedTime, TimeOfDay #-} -- | Semantic TOML value with all table assignments resolved. data Value' a = Integer' a Integer | Double' a Double | List' a [Value' a] | Table' a (Table' a) | Bool' a Bool | Text' a Text | TimeOfDay' a TimeOfDay | ZonedTime' a ZonedTime | LocalTime' a LocalTime | Day' a Day deriving ( Show {- ^ Default instance -}, Read {- ^ Default instance -}, Functor {- ^ Derived -}, Foldable {- ^ Derived -}, Traversable {- ^ Derived -}) -- | Extract the top-level annotation from a value. valueAnn :: Value' a -> a valueAnn = \case Integer' a _ -> a Double' a _ -> a List' a _ -> a Table' a _ -> a Bool' a _ -> a Text' a _ -> a TimeOfDay' a _ -> a ZonedTime' a _ -> a LocalTime' a _ -> a Day' a _ -> a -- | String representation of the kind of value using TOML vocabulary valueType :: Value' l -> String valueType = \case Integer' {} -> "integer" Double' {} -> "float" List' {} -> "array" Table' {} -> "table" Bool' {} -> "boolean" Text' {} -> "string" TimeOfDay' {} -> "local time" LocalTime' {} -> "local date-time" Day' {} -> "locate date" ZonedTime' {} -> "offset date-time" -- | A table with annotated keys and values. newtype Table' a = MkTable (Map Text (a, Value' a)) deriving ( Show {- ^ Default instance -}, Read {- ^ Default instance -}, Eq {- ^ Default instance -}, Functor {- ^ Derived -}, Foldable {- ^ Derived -}, Traversable {- ^ Derived -}) -- | A 'Table'' with trivial annotations type Table = Table' () -- | A 'Value'' with trivial annotations type Value = Value' () -- | Replaces annotations with a unit. forgetTableAnns :: Table' a -> Table forgetTableAnns (MkTable t) = MkTable (fmap (\(_, v) -> ((), forgetValueAnns v)) t) -- | Replaces annotations with a unit. forgetValueAnns :: Value' a -> Value forgetValueAnns = \case Integer' _ x -> Integer x Double' _ x -> Double x List' _ x -> List (map forgetValueAnns x) Table' _ x -> Table (forgetTableAnns x) Bool' _ x -> Bool x Text' _ x -> Text x TimeOfDay' _ x -> TimeOfDay x ZonedTime' _ x -> ZonedTime x LocalTime' _ x -> LocalTime x Day' _ x -> Day x -- | Nearly default instance except 'ZonedTime' doesn't have an -- 'Eq' instance. 'ZonedTime' values are equal if their times and -- time-zones are both equal. instance Eq a => Eq (Value' a) where Integer' a x == Integer' b y = a == b && x == y Double' a x == Double' b y = a == b && x == y List' a x == List' b y = a == b && x == y Table' a x == Table' b y = a == b && x == y Bool' a x == Bool' b y = a == b && x == y Text' a x == Text' b y = a == b && x == y TimeOfDay' a x == TimeOfDay' b y = a == b && x == y LocalTime' a x == LocalTime' b y = a == b && x == y Day' a x == Day' b y = a == b && x == y ZonedTime' a x == ZonedTime' b y = a == b && projectZT x == projectZT y _ == _ = False -- Extract the relevant parts to build an 'Eq' instance projectZT :: ZonedTime -> (LocalTime, Int) projectZT x = (zonedTimeToLocalTime x, timeZoneMinutes (zonedTimeZone x)) -- | Constructs a TOML string literal. -- -- @ -- fromString = String -- @ instance () ~ a => IsString (Value' a) where fromString = Text . fromString toml-parser-2.0.2.0/src/Toml/Syntax.hs0000644000000000000000000000122707346545000015635 0ustar0000000000000000{-| Module : Toml.Syntax Description : Parsing and lexing for TOML syntax Copyright : (c) Eric Mertens, 2024 License : ISC Maintainer : emertens@gmail.com These are the low-level processing functions for transforming concrete TOML syntax into abstract TOML syntax. This module does not do any semantic validation of the parsed TOML. -} module Toml.Syntax ( -- * Parsing parseRawToml, Key, Expr(..), Val(..), -- * Lexing scanToken, Context(..), Token(..), -- * Locations Located(..), Position(..), startPos, ) where import Toml.Syntax.Lexer import Toml.Syntax.Parser import Toml.Syntax.Position toml-parser-2.0.2.0/src/Toml/Syntax/0000755000000000000000000000000007346545000015277 5ustar0000000000000000toml-parser-2.0.2.0/src/Toml/Syntax/Lexer.x0000644000000000000000000001657107346545000016561 0ustar0000000000000000{ {-| Module : Toml.Syntax.Lexer Description : TOML lexical analyzer Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com This module parses a TOML file into a lazy sequence of tokens. The lexer is aware of nested brackets and equals signs in order to handle TOML's context-sensitive lexing requirements. This context enables the lexer to distinguish between bare keys and various values like: floating-point literals, integer literals, and date literals. This module uses actions and lexical hooks defined in "LexerUtils". -} module Toml.Syntax.Lexer (Context(..), scanToken, lexValue, Token(..)) where import Data.Text (Text) import Data.Text qualified as Text import Toml.Syntax.Token import Toml.Syntax.LexerUtils import Toml.Syntax.Position } $non_ascii = \x1 $wschar = [\ \t] @ws = $wschar* @newline = \r? \n $bindig = [0-1] $octdig = [0-7] $digit = [0-9] $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 \- _]+ @unsigned_dec_int = $digit | [1-9] ($digit | _ $digit)+ @dec_int = [\-\+]? @unsigned_dec_int @zero_prefixable_int = $digit ($digit | _ $digit)* @hex_int = "0x" $hexdig ($hexdig | _ $hexdig)* @oct_int = "0o" $octdig ($octdig | _ $octdig)* @bin_int = "0b" $bindig ($bindig | _ $bindig)* @frac = "." @zero_prefixable_int @float_exp_part = [\+\-]? @zero_prefixable_int @special_float = [\+\-]? ("inf" | "nan") @exp = [Ee] @float_exp_part @float_int_part = @dec_int @float = @float_int_part ( @exp | @frac @exp? ) | @special_float @bad_dec_int = [\-\+]? 0 ($digit | _ $digit)+ $non_eol = [\x09 \x20-\x7E $non_ascii] @comment = $comment_start_symbol $non_eol* $literal_char = [\x09 \x20-\x26 \x28-\x7E $non_ascii] @mll_content = $literal_char | @newline @mlb_escaped_nl = \\ @ws @newline ($wschar | @newline)* $unescaped = [$wschar \x21 \x23-\x5B \x5D-\x7E $non_ascii] @date_fullyear = $digit {4} @date_month = $digit {2} @date_mday = $digit {2} $time_delim = [Tt\ ] @time_hour = $digit {2} @time_minute = $digit {2} @time_second = $digit {2} @offset_hour = [01] $digit | 2 [0-3] @offset_minute = [0-5] $digit @time_secfrac = "." $digit+ @time_numoffset = [\+\-] @offset_hour ":" @offset_minute @time_offset = [Zz] | @time_numoffset @partial_time = @time_hour ":" @time_minute (":" @time_second @time_secfrac?)? @full_date = @date_fullyear "-" @date_month "-" @date_mday @full_time = @partial_time @time_offset @offset_date_time = @full_date $time_delim @full_time @local_date_time = @full_date $time_delim @partial_time @local_date = @full_date @local_time = @partial_time toml :- { @bad_dec_int { failure "leading zero prohibited" } @dec_int { token mkDecInteger } @hex_int { token mkHexInteger } @oct_int { token mkOctInteger } @bin_int { token mkBinInteger } @float { token mkFloat } "true" { token_ TokTrue } "false" { token_ TokFalse } @offset_date_time { timeValue "offset date-time" offsetDateTimePatterns TokOffsetDateTime } @local_date { timeValue "local date" localDatePatterns TokLocalDate } @local_date_time { timeValue "local date-time" localDateTimePatterns TokLocalDateTime } @local_time { timeValue "local time" localTimePatterns TokLocalTime } } <0> { "[[" { token_ Tok2SquareO } "]]" { token_ Tok2SquareC } } <0,val,tab> { @newline { token_ TokNewline } @comment; $wschar+; "=" { token_ TokEquals } "." { token_ TokPeriod } "," { token_ TokComma } "[" { token_ TokSquareO } "]" { token_ TokSquareC } "{" { token_ TokCurlyO } "}" { token_ TokCurlyC } @barekey { textToken TokBareKey } \"{3} @newline? { startMlBstr } \" { startBstr } "'''" @newline? { startMlLstr } "'" { startLstr } } { $literal_char+ { strFrag } "'" { endStr . fmap (Text.drop 1) } } { $unescaped+ { strFrag } \" { endStr . fmap (Text.drop 1) } } { @mll_content+ { strFrag } "'" {1,2} { strFrag } "'" {3,5} { endStr . fmap (Text.drop 3) } } { @mlb_escaped_nl; ($unescaped | @newline)+ { strFrag } \" {1,2} { strFrag } \" {3,5} { endStr . fmap (Text.drop 3) } } { \\ x $hexdig{2} { unicodeEscape } \\ x { failure "\\x requires exactly 2 hex digits"} \\ u $hexdig{4} { unicodeEscape } \\ u { failure "\\u requires exactly 4 hex digits"} \\ U $hexdig{8} { unicodeEscape } \\ U { failure "\\U requires exactly 8 hex digits"} \\ n { strFrag . (Text.singleton '\n' <$) } \\ t { strFrag . (Text.singleton '\t' <$) } \\ r { strFrag . (Text.singleton '\r' <$) } \\ f { strFrag . (Text.singleton '\f' <$) } \\ b { strFrag . (Text.singleton '\b' <$) } \\ e { strFrag . (Text.singleton '\ESC' <$) } \\ \\ { strFrag . (Text.singleton '\\' <$) } \\ \" { strFrag . (Text.singleton '\"' <$) } \\ . { failure "unknown escape sequence" } \\ { failure "incomplete escape sequence" } $control # [\t\r\n] { recommendEscape } } { type AlexInput = Located Text alexGetByte :: AlexInput -> Maybe (Int, AlexInput) alexGetByte = locatedUncons -- | Get the next token from a located string or a located error message. scanToken :: Context -> Located Text -> Either (Located String) (Located Token, Located Text) scanToken st str = case alexScan str (stateInt st) of AlexEOF -> eofToken st str AlexError str' -> Left (mkError . Text.unpack <$> str') AlexSkip str' _ -> scanToken st str' AlexToken str' n action -> case action (Text.take n <$> str) st of Resume st' -> scanToken st' str' LexerError e -> Left e EmitToken t -> Right (t, str') -- Map the logical lexer state to an Alex state number stateInt :: Context -> Int stateInt = \case TopContext -> 0 TableContext -> tab ValueContext -> val BstrContext {} -> bstr MlBstrContext{} -> mlbstr LstrContext {} -> lstr MlLstrContext{} -> mllstr -- | Lex a single token in a value context. This is mostly useful for testing. lexValue :: Text -> Either String Token lexValue str = case scanToken ValueContext Located{ locPosition = startPos, locThing = str } of Left e -> Left (locThing e) Right (t,_) -> Right (locThing t) } toml-parser-2.0.2.0/src/Toml/Syntax/LexerUtils.hs0000644000000000000000000001522507346545000017740 0ustar0000000000000000{-| Module : Toml.Syntax.LexerUtils Description : Wrapper and actions for generated lexer Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com This module provides a custom engine for the Alex generated lexer. This lexer drive provides nested states, unicode support, and file location tracking. The various states of this module are needed to deal with the varying lexing rules while lexing values, keys, and string-literals. -} module Toml.Syntax.LexerUtils ( -- * Types Action, Context(..), Outcome(..), -- * Input processing locatedUncons, -- * Actions token, token_, textToken, timeValue, eofToken, failure, -- * String literals strFrag, startMlBstr, startBstr, startMlLstr, startLstr, endStr, unicodeEscape, recommendEscape, mkError, ) where import Data.Char (ord, chr, isAscii, isControl) import Data.Foldable (asum) import Data.Text (Text) import Data.Text qualified as Text import Data.Time.Format (parseTimeM, defaultTimeLocale, ParseTime) import Numeric (readHex) import Text.Printf (printf) import Toml.Syntax.Token (Token(..)) import Toml.Syntax.Position (move, Located(..), Position) -- | Type of actions associated with lexer patterns type Action = Located Text -> Context -> Outcome data Outcome = Resume Context | LexerError (Located String) | EmitToken (Located Token) -- | Representation of the current lexer state. data Context = TopContext -- ^ top-level where @[[@ and @]]@ have special meaning | TableContext -- ^ inline table - lex key names | ValueContext -- ^ value lexer - lex number literals | MlBstrContext Position [Text] -- ^ multiline basic string: position of opening delimiter and list of fragments | BstrContext Position [Text] -- ^ basic string: position of opening delimiter and list of fragments | MlLstrContext Position [Text] -- ^ multiline literal string: position of opening delimiter and list of fragments | LstrContext Position [Text] -- ^ literal string: position of opening delimiter and list of fragments deriving Show -- | Add a literal fragment of a string to the current string state. strFrag :: Action strFrag (Located _ s) = \case BstrContext p acc -> Resume (BstrContext p (s : acc)) MlBstrContext p acc -> Resume (MlBstrContext p (s : acc)) LstrContext p acc -> Resume (LstrContext p (s : acc)) MlLstrContext p acc -> Resume (MlLstrContext p (s : acc)) _ -> error "strFrag: panic" -- | End the current string state and emit the string literal token. endStr :: Action endStr (Located _ x) = \case BstrContext p acc -> EmitToken (Located p (TokString (Text.concat (reverse (x : acc))))) MlBstrContext p acc -> EmitToken (Located p (TokMlString (Text.concat (reverse (x : acc))))) LstrContext p acc -> EmitToken (Located p (TokString (Text.concat (reverse (x : acc))))) MlLstrContext p acc -> EmitToken (Located p (TokMlString (Text.concat (reverse (x : acc))))) _ -> error "endStr: panic" -- | Start a basic string literal startBstr :: Action startBstr (Located p _) _ = Resume (BstrContext p []) -- | Start a literal string literal startLstr :: Action startLstr (Located p _) _ = Resume (LstrContext p []) -- | Start a multi-line basic string literal startMlBstr :: Action startMlBstr (Located p _) _ = Resume (MlBstrContext p []) -- | Start a multi-line literal string literal startMlLstr :: Action startMlLstr (Located p _) _ = Resume (MlLstrContext p []) -- | Resolve a unicode escape sequence and add it to the current string literal unicodeEscape :: Action unicodeEscape (Located p lexeme) ctx = case readHex (drop 2 (Text.unpack lexeme)) of [(n,_)] | 0xd800 <= n, n < 0xe000 -> LexerError (Located p "non-scalar unicode escape") | n >= 0x110000 -> LexerError (Located p "unicode escape too large") | otherwise -> strFrag (Located p (Text.singleton (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 (Text.head x)))) -- | Emit a token ignoring the current lexeme token_ :: Token -> Action token_ t x _ = EmitToken (t <$ x) -- | Emit a token using the current lexeme token :: (String -> Token) -> Action token f x _ = EmitToken (f . Text.unpack <$> x) -- | Emit a token using the current lexeme textToken :: (Text -> Token) -> Action textToken f x _ = EmitToken (f <$> x) -- | Attempt to parse the current lexeme as a date-time token. timeValue :: ParseTime a => String {- ^ description for error messages -} -> [String] {- ^ possible valid patterns -} -> (a -> Token) {- ^ token constructor -} -> Action timeValue description patterns constructor (Located p str) _ = case asum [parseTimeM False defaultTimeLocale pat (Text.unpack str) | pat <- patterns] of Nothing -> LexerError (Located p ("malformed " ++ description)) Just t -> EmitToken (Located p (constructor t)) -- | Pop the first character off a located string if it's not empty. -- The resulting 'Int' will either be the ASCII value of the character -- or @1@ for non-ASCII Unicode values. To avoid a clash, @\x1@ is -- remapped to @0@. locatedUncons :: Located Text -> Maybe (Int, Located Text) locatedUncons Located { locPosition = p, locThing = str } = case Text.uncons str of Nothing -> Nothing Just (x, xs) | rest `seq` False -> undefined | x == '\1' -> Just (0, rest) | isAscii x -> Just (ord x, rest) | otherwise -> Just (1, rest) where rest = Located { locPosition = move x p, locThing = xs } -- | Generate the correct terminating token given the current lexer state. eofToken :: Context -> Located Text -> Either (Located String) (Located Token, Located Text) eofToken (MlBstrContext p _) _ = Left (Located p "unterminated multi-line basic string") eofToken (BstrContext p _) _ = Left (Located p "unterminated basic string") eofToken (MlLstrContext p _) _ = Left (Located p "unterminated multi-line literal string") eofToken (LstrContext p _) _ = Left (Located p "unterminated literal string") eofToken _ t = Right (TokEOF <$ t, t) failure :: String -> Action failure err t _ = LexerError (err <$ t) -- | Generate an error message given the current string being lexed. mkError :: String -> String mkError "" = "unexpected end-of-input" mkError ('\n':_) = "unexpected end-of-line" mkError ('\r':'\n':_) = "unexpected end-of-line" mkError (x:_) | isControl x = "control characters prohibited" | otherwise = "unexpected " ++ show x toml-parser-2.0.2.0/src/Toml/Syntax/Parser.y0000644000000000000000000001616407346545000016735 0ustar0000000000000000{ {-| Module : Toml.Syntax.Parser Description : Raw TOML expression parser Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com This module parses TOML tokens into a list of raw, uninterpreted sections and assignments. -} module Toml.Syntax.Parser ( -- * Types Expr(..), SectionKind(..), Val(..), Key, -- * Parser parseRawToml, ) where import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty import Data.Text (Text) import Toml.Syntax.Lexer (Context(..), Token(..)) import Toml.Syntax.ParserUtils import Toml.Syntax.Position (Located(Located, locThing), Position) import Toml.Syntax.Position (startPos) import Toml.Syntax.Types (Expr(..), Key, Val(..), SectionKind(..)) } %tokentype { Located Token } %token ',' { Located $$ TokComma } '=' { Located $$ TokEquals } NEWLINE { Located $$ TokNewline } '.' { Located $$ TokPeriod } '[' { Located $$ TokSquareO } ']' { Located $$ TokSquareC } '[[' { Located $$ Tok2SquareO } ']]' { Located $$ Tok2SquareC } '{' { Located $$ TokCurlyO } '}' { Located $$ TokCurlyC } BAREKEY { (traverse asBareKey -> Just $$) } STRING { (traverse asString -> Just $$) } MLSTRING { (traverse asMlString -> Just $$) } BOOL { (traverse asBool -> Just $$) } INTEGER { (traverse asInteger -> Just $$) } FLOAT { (traverse asFloat -> Just $$) } OFFSETDATETIME { (traverse asOffsetDateTime -> Just $$) } LOCALDATETIME { (traverse asLocalDateTime -> Just $$) } LOCALDATE { (traverse asLocalDate -> Just $$) } LOCALTIME { (traverse asLocalTime -> Just $$) } %monad { Parser r } { thenP } { pureP } %lexer { lexerP } { Located _ TokEOF } %error { errorP } %name parseRawToml_ toml %% toml :: { [Expr Position] } : sepBy1(expression, NEWLINE) { concat $1 } expression :: { [Expr Position] } : { [] } | keyval { [uncurry KeyValExpr $1] } | '[' key ']' { [TableExpr $2 ] } | '[[' key ']]' { [ArrayTableExpr $2 ] } keyval :: { (Key Position, Val Position) } : key rhs '=' pop val { ($1,$5) } key :: { Key Position } : sepBy1(simplekey, '.') { $1 } simplekey :: { (Position, Text) } : BAREKEY { locVal (,) $1 } | STRING { locVal (,) $1 } val :: { Val Position } : INTEGER { locVal ValInteger $1 } | FLOAT { locVal ValFloat $1 } | BOOL { locVal ValBool $1 } | STRING { locVal ValString $1 } | MLSTRING { locVal ValString $1 } | LOCALDATE { locVal ValDay $1 } | LOCALTIME { locVal ValTimeOfDay $1 } | OFFSETDATETIME { locVal ValZonedTime $1 } | LOCALDATETIME { locVal ValLocalTime $1 } | array { locVal ValArray $1 } | inlinetable { locVal ValTable $1 } inlinetable :: { Located [(Key Position, Val Position)] } : lhs '{' inlinetablekeyvals newlines pop '}' { Located $2 (reverse $3) } | lhs '{' inlinetablekeyvals newlines ',' newlines pop '}' { Located $2 (reverse $3) } | lhs '{' newlines pop '}' { Located $2 [] } inlinetablekeyvals :: { [(Key Position, Val Position)] } : newlines keyval { [$2] } | inlinetablekeyvals newlines ',' newlines keyval { $5 : $1 } array :: { Located [Val Position] } : rhs '[' newlines pop ']' { Located $2 [] } | rhs '[' newlines arrayvalues pop ']' { Located $2 (reverse $4) } | rhs '[' newlines arrayvalues ',' newlines pop ']' { Located $2 (reverse $4) } arrayvalues :: { [Val Position] } : val newlines { [$1] } | arrayvalues ',' newlines val newlines { $4 : $1 } newlines :: { () } : { () } | newlines NEWLINE { () } sepBy(p,q) :: { [p] } : { [] } | sepBy1(p,q) { NonEmpty.toList $1 } sepBy1(p,q) :: { NonEmpty p } : sepBy1_(p,q) { NonEmpty.reverse $1 } sepBy1_(p,q) :: { NonEmpty p } : p { pure $1 } | sepBy1_(p,q) q p { NonEmpty.cons $3 $1 } rhs :: { () } : {% push ValueContext } lhs :: { () } : {% push TableContext } pop :: { () } : {% pop } { -- | Parse a list of tokens either returning the first unexpected -- token or a list of the TOML statements in the file to be -- processed by "Toml.Semantics". parseRawToml :: Text -> Either (Located String) [Expr Position] parseRawToml = runParser parseRawToml_ TopContext . Located startPos } toml-parser-2.0.2.0/src/Toml/Syntax/ParserUtils.hs0000644000000000000000000001001607346545000020106 0ustar0000000000000000{-| Module : Toml.Syntax.ParserUtils Description : Primitive operations used by the happy-generated parser Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com This module contains all the primitives used by the Parser module. By extracting it from the @.y@ file we minimize the amount of code that has warnings disabled and get better editor support. -} module Toml.Syntax.ParserUtils ( Parser, runParser, pureP, thenP, asString, asMlString, asBareKey, asInteger, asBool, asFloat, asOffsetDateTime, asLocalDate, asLocalTime, asLocalDateTime, locVal, lexerP, errorP, -- * Lexer-state management push, pop, ) where import Data.Text (Text) import Data.Time import Data.List.NonEmpty (NonEmpty((:|))) import Data.List.NonEmpty qualified as NonEmpty import Toml.Pretty (prettyToken) import Toml.Syntax.Lexer (scanToken, Context(..)) import Toml.Syntax.Position (Located(..), Position) import Toml.Syntax.Token (Token(..)) -- continuation passing implementation of a state monad with errors newtype Parser r a = P { getP :: NonEmpty Context -> Located Text -> (NonEmpty Context -> Located Text -> a -> Either (Located String) r) -> Either (Located String) r } -- | Run the top-level parser runParser :: Parser r r -> Context -> Located Text -> Either (Located String) r runParser (P k) ctx str = k (ctx :| []) str \_ _ r -> Right r -- | Bind implementation used in the happy-generated parser thenP :: Parser r a -> (a -> Parser r b) -> Parser r b thenP (P m) f = P \ctx str k -> m ctx str \ctx' str' x -> getP (f x) ctx' str' k {-# Inline thenP #-} -- | Return implementation used in the happy-generated parser pureP :: a -> Parser r a pureP x = P \ctx str k -> k ctx str x {-# Inline pureP #-} -- | Add a new context to the lexer context stack push :: Context -> Parser r () push x = P \st str k -> k (NonEmpty.cons x st) str () {-# Inline push #-} -- | Pop the top context off the lexer context stack. It is a program -- error to pop without first pushing. pop :: Parser r () pop = P \ctx str k -> case snd (NonEmpty.uncons ctx) of Nothing -> error "toml-parser: PANIC! malformed production in parser" Just ctx' -> k ctx' str () {-# Inline pop #-} -- | Operation the parser generator uses when it reaches an unexpected token. errorP :: Located Token -> Parser r a errorP e = P \_ _ _ -> Left (fmap (\t -> "parse error: unexpected " ++ prettyToken t) e) -- | Operation the parser generator uses to request the next token. lexerP :: (Located Token -> Parser r a) -> Parser r a lexerP f = P \st str k -> case scanToken (NonEmpty.head st) str of Left le -> Left (("lexical error: " ++) <$> le) Right (t, str') -> getP (f t) st str' k {-# Inline lexerP #-} asString :: Token -> Maybe Text asString = \case TokString i -> Just i _ -> Nothing asBareKey :: Token -> Maybe Text asBareKey = \case TokBareKey i -> Just i _ -> Nothing asMlString :: Token -> Maybe Text asMlString = \case TokMlString i -> Just i _ -> Nothing asInteger :: Token -> Maybe Integer asInteger = \case TokInteger i -> Just i _ -> Nothing asBool :: Token -> Maybe Bool asBool = \case TokTrue -> Just True TokFalse -> Just False _ -> Nothing asFloat :: Token -> Maybe Double asFloat = \case TokFloat x -> Just x _ -> Nothing asOffsetDateTime :: Token -> Maybe ZonedTime asOffsetDateTime = \case TokOffsetDateTime x -> Just x _ -> Nothing asLocalDateTime :: Token -> Maybe LocalTime asLocalDateTime = \case TokLocalDateTime x -> Just x _ -> Nothing asLocalDate :: Token -> Maybe Day asLocalDate = \case TokLocalDate x -> Just x _ -> Nothing asLocalTime :: Token -> Maybe TimeOfDay asLocalTime = \case TokLocalTime x -> Just x _ -> Nothing locVal :: (Position -> a -> b) -> Located a -> b locVal f (Located l x) = f l x toml-parser-2.0.2.0/src/Toml/Syntax/Position.hs0000644000000000000000000000371507346545000017445 0ustar0000000000000000{-| Module : Toml.Syntax.Position Description : File position representation Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com This module provides the 'Position' type for tracking locations in files while doing lexing and parsing for providing more useful error messages. This module assumes 8 column wide tab stops. -} module Toml.Syntax.Position ( Located(..), Position(..), startPos, move, ) where -- | A value annotated with its text file position data Located a = Located { locPosition :: {-# UNPACK #-} !Position -- ^ position , locThing :: !a -- ^ thing at position } deriving ( Read {- ^ Default instance -}, Show {- ^ Default instance -}, Functor {- ^ Default instance -}, Foldable {- ^ Default instance -}, Traversable {- ^ Default instance -}) -- | A position in a text file data Position = Position { posIndex :: {-# UNPACK #-} !Int, -- ^ code-point index (zero-based) posLine :: {-# UNPACK #-} !Int, -- ^ line index (one-based) posColumn :: {-# UNPACK #-} !Int -- ^ column index (one-based) } deriving ( Read {- ^ Default instance -}, Show {- ^ Default instance -}, Ord {- ^ Default instance -}, Eq {- ^ Default instance -}) -- | The initial 'Position' for the start of a file startPos :: Position startPos = Position { posIndex = 0, posLine = 1, posColumn = 1 } -- | Adjust a file position given a single character handling -- newlines and tabs. All other characters are considered to fill -- exactly one column. move :: Char -> Position -> Position move x Position{ posIndex = i, posLine = l, posColumn = c} = case x of '\n' -> Position{ posIndex = i+1, posLine = l+1, posColumn = 1 } '\t' -> Position{ posIndex = i+1, posLine = l, posColumn = (c + 7) `quot` 8 * 8 + 1 } _ -> Position{ posIndex = i+1, posLine = l, posColumn = c+1 } toml-parser-2.0.2.0/src/Toml/Syntax/Token.hs0000644000000000000000000001035407346545000016716 0ustar0000000000000000{-| Module : Toml.Syntax.Token Description : Lexical tokens Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com This module provides the datatype for the lexical syntax of TOML files. These tokens are generated by "Toml.Syntax.Lexer" and consumed in "Toml.Syntax.Parser". -} module Toml.Syntax.Token ( -- * Types Token(..), -- * Integer literals mkBinInteger, mkDecInteger, mkOctInteger, mkHexInteger, -- * Float literals mkFloat, -- * Date and time patterns localDatePatterns, localTimePatterns, localDateTimePatterns, offsetDateTimePatterns, ) where import Data.Char (digitToInt) import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime) import Data.Text (Text) import Numeric (readInt, readHex, readOct) -- | Lexical token data Token = TokTrue -- ^ @true@ | TokFalse -- ^ @false@ | TokComma -- ^ @','@ | TokEquals -- ^ @'='@ | TokNewline -- ^ @end-of-line@ | TokPeriod -- ^ @'.'@ | TokSquareO -- ^ @'['@ | TokSquareC -- ^ @']'@ | Tok2SquareO -- ^ @'[['@ | Tok2SquareC -- ^ @']]'@ | TokCurlyO -- ^ @'{'@ | TokCurlyC -- ^ @'}'@ | TokBareKey Text -- ^ bare key | TokString Text -- ^ string literal | TokMlString Text -- ^ multiline string literal | TokInteger !Integer -- ^ integer literal | TokFloat !Double -- ^ floating-point literal | TokOffsetDateTime !ZonedTime -- ^ date-time with timezone offset | TokLocalDateTime !LocalTime -- ^ local date-time | TokLocalDate !Day -- ^ local date | TokLocalTime !TimeOfDay -- ^ local time | TokEOF -- ^ @end-of-input@ deriving (Read, Show) -- | Remove underscores from number literals scrub :: String -> String scrub = filter ('_' /=) -- | Construct a 'TokInteger' from a decimal integer literal lexeme. mkDecInteger :: String -> Token mkDecInteger ('+':xs) = TokInteger (read (scrub xs)) mkDecInteger xs = TokInteger (read (scrub xs)) -- | Construct a 'TokInteger' from a hexadecimal integer literal lexeme. mkHexInteger :: String -> Token mkHexInteger ('0':'x':xs) = TokInteger (fst (head (readHex (scrub xs)))) mkHexInteger _ = error "processHex: bad input" -- | Construct a 'TokInteger' from a octal integer literal lexeme. mkOctInteger :: String -> Token mkOctInteger ('0':'o':xs) = TokInteger (fst (head (readOct (scrub xs)))) mkOctInteger _ = error "processHex: bad input" -- | Construct a 'TokInteger' from a binary integer literal lexeme. mkBinInteger :: String -> Token mkBinInteger ('0':'b':xs) = TokInteger (fst (head (readBin (scrub xs)))) mkBinInteger _ = error "processHex: bad input" -- This wasn't added to base until 4.16 readBin :: (Eq a, Num a) => ReadS a readBin = readInt 2 isBinDigit digitToInt isBinDigit :: Char -> Bool isBinDigit x = x == '0' || x == '1' -- | Construct a 'TokFloat' from a floating-point literal lexeme. mkFloat :: String -> Token mkFloat "nan" = TokFloat (0/0) mkFloat "+nan" = TokFloat (0/0) mkFloat "-nan" = TokFloat (0/0) mkFloat "inf" = TokFloat (1/0) mkFloat "+inf" = TokFloat (1/0) mkFloat "-inf" = TokFloat (-1/0) mkFloat ('+':x) = TokFloat (read (scrub x)) mkFloat x = TokFloat (read (scrub x)) -- | Format strings for local date lexemes. localDatePatterns :: [String] localDatePatterns = ["%Y-%m-%d"] -- | Format strings for local time lexemes. localTimePatterns :: [String] localTimePatterns = ["%H:%M:%S%Q", "%H:%M"] -- | Format strings for local datetime lexemes. localDateTimePatterns :: [String] localDateTimePatterns = ["%Y-%m-%dT%H:%M:%S%Q", "%Y-%m-%d %H:%M:%S%Q", "%Y-%m-%dT%H:%M", "%Y-%m-%d %H:%M"] -- | Format strings for offset datetime lexemes. offsetDateTimePatterns :: [String] offsetDateTimePatterns = ["%Y-%m-%dT%H:%M:%S%Q%Ez", "%Y-%m-%dT%H:%M:%S%QZ", "%Y-%m-%d %H:%M:%S%Q%Ez", "%Y-%m-%d %H:%M:%S%QZ", "%Y-%m-%dT%H:%M%Ez", "%Y-%m-%dT%H:%MZ", "%Y-%m-%d %H:%M%Ez", "%Y-%m-%d %H:%MZ"] toml-parser-2.0.2.0/src/Toml/Syntax/Types.hs0000644000000000000000000000315207346545000016740 0ustar0000000000000000{-| Module : Toml.Syntax.Types Description : Raw expressions from a parsed TOML file Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com This module provides a raw representation of TOML files as a list of table definitions and key-value assignments. These values use the raw dotted keys and have no detection for overlapping assignments. Further processing will happen in the "Semantics" module. -} module Toml.Syntax.Types ( Key, Expr(..), Val(..), SectionKind(..), ) where import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime) -- | Non-empty sequence of dotted simple keys type Key a = NonEmpty (a, Text) -- | Headers and assignments corresponding to lines of a TOML file data Expr a = KeyValExpr (Key a) (Val a) -- ^ key value assignment: @key = value@ | TableExpr (Key a) -- ^ table: @[key]@ | ArrayTableExpr (Key a) -- ^ array of tables: @[[key]]@ deriving (Read, Show) -- | Unvalidated TOML values. Table are represented as a list of -- assignments rather than as resolved maps. data Val a = ValInteger a Integer | ValFloat a Double | ValArray a [Val a] | ValTable a [(Key a, Val a)] | ValBool a Bool | ValString a Text | ValTimeOfDay a TimeOfDay | ValZonedTime a ZonedTime | ValLocalTime a LocalTime | ValDay a Day deriving (Read, Show) -- | Kinds of table headers data SectionKind = TableKind -- ^ [table] | ArrayTableKind -- ^ [[array of tables]] deriving (Read, Show, Eq) toml-parser-2.0.2.0/test/0000755000000000000000000000000007346545000013266 5ustar0000000000000000toml-parser-2.0.2.0/test/DecodeSpec.hs0000644000000000000000000000760207346545000015625 0ustar0000000000000000{-# Language DuplicateRecordFields, OverloadedStrings #-} {-| Module : DecodeSpec Description : Show that decoding TOML works using the various provided classes Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com -} module DecodeSpec (spec) where import Data.Maybe (fromMaybe) import GHC.Generics (Generic) import QuoteStr (quoteStr) import Test.Hspec (it, shouldBe, Spec) import Toml (decode, encode) import Toml.Schema newtype Fruits = Fruits { fruits :: [Fruit] } deriving (Eq, Show, Generic) data Fruit = Fruit { name :: String, physical :: Maybe Physical, varieties :: [Variety] } deriving (Eq, Show, Generic) data Physical = Physical { color :: String, shape :: String } deriving (Eq, Show, Generic) newtype Variety = Variety { name :: String } deriving (Eq, Show, Generic) instance FromValue Fruits where fromValue = genericFromTable instance FromValue Physical where fromValue = genericFromTable instance FromValue Variety where fromValue = genericFromTable instance ToTable Fruits where toTable = genericToTable instance ToTable Physical where toTable = genericToTable instance ToTable Variety where toTable = genericToTable 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 Fruit where fromValue = parseTableFromValue (Fruit <$> reqKey "name" <*> optKey "physical" <*> (fromMaybe [] <$> optKey "varieties")) instance ToTable Fruit where toTable (Fruit n mbp vs) = table $ ["varieties" .= vs | not (null vs)] ++ ["physical" .= p | Just p <- [mbp]] ++ ["name" .= n] spec :: Spec spec = do let expect = Fruits [ Fruit "apple" (Just (Physical "red" "round")) [Variety "red delicious", Variety "granny smith"], Fruit "banana" Nothing [Variety "plantain"]] it "handles fruit example" $ decode [quoteStr| [[fruits]] name = "apple" [fruits.physical] # subtable color = "red" shape = "round" [[fruits.varieties]] # nested array of tables name = "red delicious" [[fruits.varieties]] name = "granny smith" [[fruits]] name = "banana" [[fruits.varieties]] name = "plantain"|] `shouldBe` Success mempty expect it "encodes correctly" $ show (encode expect) `shouldBe` [quoteStr| [[fruits]] name = "apple" [fruits.physical] color = "red" shape = "round" [[fruits.varieties]] name = "red delicious" [[fruits.varieties]] name = "granny smith" [[fruits]] name = "banana" [[fruits.varieties]] name = "plantain"|] it "generates warnings for unused keys" $ decode [quoteStr| [[fruits]] name = "peach" taste = "sweet" count = 5 [[fruits]] name = "pineapple" color = "yellow"|] `shouldBe` Success [ "4:1: unexpected key: count in fruits[0]", "3:1: unexpected key: taste in fruits[0]", "7:1: unexpected key: color in fruits[1]"] (Fruits [Fruit "peach" Nothing [], Fruit "pineapple" Nothing []]) it "handles missing key errors" $ (decode "[[fruits]]" :: Result String Fruits) `shouldBe` Failure ["1:3: missing key: name in fruits[0]"] it "handles parse errors while decoding" $ (decode "x =" :: Result String Fruits) `shouldBe` Failure ["1:4: parse error: unexpected end-of-input"] toml-parser-2.0.2.0/test/DerivingViaSpec.hs0000644000000000000000000000326607346545000016653 0ustar0000000000000000{-# LANGUAGE DerivingVia, DeriveGeneric, OverloadedStrings #-} {-| Module : DerivingViaSpec Description : Show that TOML classes can be derived with DerivingVia Copyright : (c) Eric Mertens, 2024 License : ISC Maintainer : emertens@gmail.com This module ensures that the classes are actually derivable with generalized newtype deriving. In particular 'fromValue' uses the 'Matcher' type and that type can't use monad transformers without preventing this from working. The test ensures we don't have a regression later. -} module DerivingViaSpec (spec) where import GHC.Generics (Generic) import Test.Hspec (it, shouldBe, Spec) import Toml.Schema data Physical = Physical { color :: String, shape :: String } deriving (Eq, Show, Generic) deriving (ToTable, FromValue, ToValue) via GenericTomlTable Physical data TwoThings = TwoThings Int String deriving (Eq, Show, Generic) deriving (FromValue, ToValue) via GenericTomlArray TwoThings spec :: Spec spec = do let sem = Physical "red" "round" tab = table ["color" .= Text "red", "shape" .= Text "round"] it "supports toValue" $ toValue sem `shouldBe` Table tab it "supports toTable" $ toTable sem `shouldBe` tab it "supports fromValue" $ runMatcher (fromValue (Table tab)) `shouldBe` Success [] sem it "converts from arrays positionally" $ runMatcher (fromValue (List [Integer 42, Text "forty-two"])) `shouldBe` Success [] (TwoThings 42 "forty-two") it "converts to arrays positionally" $ toValue (TwoThings 42 "forty-two") `shouldBe` List [Integer 42, Text "forty-two"] toml-parser-2.0.2.0/test/FromValueSpec.hs0000644000000000000000000001001007346545000016325 0ustar0000000000000000{-# Language OverloadedStrings #-} {-| Module : FromValueSpec Description : Exercise various components of FromValue Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com -} module FromValueSpec (spec) where import Control.Applicative ((<|>), empty) import Control.Monad (when) import Test.Hspec (it, shouldBe, Spec) import Toml import Toml.Schema import Toml.Syntax (startPos) humanMatcher :: Matcher l a -> Result String a humanMatcher m = case runMatcher m of Failure e -> Failure (prettyMatchMessage . fmap (const startPos) <$> e) Success w x -> Success (prettyMatchMessage . fmap (const startPos) <$> w) x spec :: Spec spec = do it "handles one reqKey" $ humanMatcher (parseTable (reqKey "test") () (table ["test" .= Text "val"])) `shouldBe` Success [] ("val" :: String) it "handles one optKey" $ humanMatcher (parseTable (optKey "test") () (table ["test" .= Text "val"])) `shouldBe` Success [] (Just ("val" :: String)) it "handles one missing optKey" $ humanMatcher (parseTable (optKey "test") () (table ["nottest" .= Text "val"])) `shouldBe` Success ["1:1: unexpected key: nottest in "] (Nothing :: Maybe String) it "handles one missing reqKey" $ humanMatcher (parseTable (reqKey "test") () (table ["nottest" .= Text "val"])) `shouldBe` (Failure ["1:1: missing key: test in "] :: Result String String) it "handles one mismatched reqKey" $ humanMatcher (parseTable (reqKey "test") () (table ["test" .= Text "val"])) `shouldBe` (Failure ["1:1: expected integer but got string in test"] :: Result String Integer) it "handles one mismatched optKey" $ humanMatcher (parseTable (optKey "test") () (table ["test" .= Text "val"])) `shouldBe` (Failure ["1:1: expected integer but got string in test"] :: Result String (Maybe Integer)) it "handles concurrent errors" $ humanMatcher (parseTable (reqKey "a" <|> empty <|> reqKey "b") () (table [])) `shouldBe` (Failure ["1:1: missing key: a in ", "1:1: missing key: b in "] :: Result String Integer) it "handles concurrent value mismatch" $ let v = "" in humanMatcher (Left <$> fromValue v <|> empty <|> Right <$> fromValue v) `shouldBe` (Failure [ "1:1: expected boolean but got string in ", "1:1: expected integer but got string in "] :: Result String (Either Bool Int)) it "doesn't emit an error for empty" $ humanMatcher (parseTable empty () (table [])) `shouldBe` (Failure [] :: Result String Integer) it "matches single characters" $ runMatcher (fromValue (Text "x")) `shouldBe` Success [] 'x' it "rejections non-single characters" $ humanMatcher (fromValue (Text "xy")) `shouldBe` (Failure ["1:1: expected single character in "] :: Result String Char) it "collects warnings in table matching" $ let pt = do i1 <- reqKey "k1" i2 <- reqKey "k2" let n = i1 + i2 when (odd n) (warnTable "k1 and k2 sum to an odd value") pure n in humanMatcher (parseTable pt () (table ["k1" .= (1 :: Integer), "k2" .= (2 :: Integer)])) `shouldBe` Success ["k1 and k2 sum to an odd value in "] (3 :: Integer) it "offers helpful messages when no keys match" $ let pt = pickKey [Key "this" \_ -> pure 'a', Key "." \_ -> pure 'b'] in humanMatcher (parseTable pt () (table [])) `shouldBe` (Failure ["1:1: possible keys: this, \".\" in "] :: Result String Char) it "generates an error message on an empty pickKey" $ let pt = pickKey [] in humanMatcher (parseTable pt () (table [])) `shouldBe` (Failure [] :: Result String Char) toml-parser-2.0.2.0/test/HieDemoSpec.hs0000644000000000000000000003641507346545000015760 0ustar0000000000000000{-# Language GADTs, OverloadedStrings #-} {-| Module : HieDemoSpec Description : Exercise various components of FromValue on a life-sized example Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com This module demonstrates how "Toml.Schema" can handle a real-world format as used in hie-bios. These types are copied from with slight alterations because the Other case is for YAML-specific extensibility. This approach would work just the same when parameterized in that same way. -} module HieDemoSpec where import Data.Text (Text) import GHC.Generics ( Generic ) import QuoteStr (quoteStr) import Test.Hspec (Spec, it, shouldBe) import Toml (decode) import Toml.Schema as Toml ----------------------------------------------------------------------- -- THIS CODE DERIVED FROM CODE UNDER THE FOLLOWING LICENSE ----------------------------------------------------------------------- -- Copyright (c) 2009, IIJ Innovation Institute Inc. -- All rights reserved. -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions -- are met: -- * Redistributions of source code must retain the above copyright -- notice, this list of conditions and the following disclaimer. -- * Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in -- the documentation and/or other materials provided with the -- distribution. -- * Neither the name of the copyright holders nor the names of its -- contributors may be used to endorse or promote products derived -- from this software without specific prior written permission. -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS -- FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -- COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, -- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, -- BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; -- LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN -- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -- POSSIBILITY OF SUCH DAMAGE. data CradleConfig = CradleConfig { cradle :: CradleComponent , dependencies :: Maybe [FilePath] } deriving (Generic, Show, Eq) data CradleComponent = Multi [MultiSubComponent] | Cabal CabalConfig | Stack StackConfig | Direct DirectConfig | Bios BiosConfig | None NoneConfig deriving (Generic, Show, Eq) data NoneConfig = NoneConfig deriving (Generic, Show, Eq) data MultiSubComponent = MultiSubComponent { path :: FilePath , config :: CradleConfig } deriving (Generic, Show, Eq) data CabalConfig = CabalConfig { cabalProject :: Maybe FilePath , cabalComponents :: OneOrManyComponents CabalComponent } deriving (Show, Eq) data CabalComponent = CabalComponent { cabalPath :: FilePath , cabalComponent :: String , cabalComponentProject :: Maybe FilePath } deriving (Show, Eq) data StackConfig = StackConfig { stackYaml :: Maybe FilePath , stackComponents :: OneOrManyComponents StackComponent } deriving (Show, Eq) data StackComponent = StackComponent { stackPath :: FilePath , stackComponent :: String , stackComponentYAML :: Maybe FilePath } deriving (Show, Eq) data OneOrManyComponents component = SingleComponent String | ManyComponents [component] | NoComponent deriving (Show, Eq) data DirectConfig = DirectConfig { arguments :: [String] } deriving (Generic, Show, Eq) data BiosConfig = BiosConfig { callable :: Callable , depsCallable :: Maybe Callable , ghcPath :: Maybe FilePath } deriving (Show, Eq) data Callable = Program FilePath | Shell String deriving (Show, Eq) ----------------------------------------------------------------------- -- END OF DERIVED CODE ----------------------------------------------------------------------- instance FromValue CradleConfig where fromValue = genericFromTable instance FromValue CradleComponent where fromValue = parseTableFromValue $ reqAlts [ KeyCase Multi "multi", KeyCase Cabal "cabal", KeyCase Stack "stack", KeyCase Direct "direct", KeyCase Bios "bios", KeyCase None "none"] instance FromValue MultiSubComponent where fromValue = genericFromTable instance FromValue CabalConfig where fromValue v@Toml.List'{} = CabalConfig Nothing . ManyComponents <$> fromValue v fromValue (Toml.Table' l t) = getComponentTable CabalConfig "cabalProject" l t fromValue _ = fail "cabal configuration expects table or array" getComponentTable :: FromValue b => (Maybe FilePath -> OneOrManyComponents b -> a) -> Text -> l -> Toml.Table' l -> Matcher l a getComponentTable con pathKey = parseTable $ con <$> optKey pathKey <*> pickKey [ Key "component" (fmap SingleComponent . fromValue), Key "components" (fmap ManyComponents . fromValue), Else (pure NoComponent)] instance FromValue CabalComponent where fromValue = parseTableFromValue $ CabalComponent <$> reqKey "path" <*> reqKey "component" <*> optKey "cabalProject" instance FromValue StackConfig where fromValue v@Toml.List'{} = StackConfig Nothing . ManyComponents <$> fromValue v fromValue (Toml.Table' l t) = getComponentTable StackConfig "stackYaml" l t fromValue _ = fail "stack configuration expects table or array" instance FromValue StackComponent where fromValue = parseTableFromValue $ StackComponent <$> reqKey "path" <*> reqKey "component" <*> optKey "stackYaml" instance FromValue DirectConfig where fromValue = genericFromTable instance FromValue BiosConfig where fromValue = parseTableFromValue $ BiosConfig <$> getCallable <*> getDepsCallable <*> optKey "with-ghc" where getCallable = reqAlts [ KeyCase Program "program", KeyCase Shell "shell"] getDepsCallable = optAlts [ KeyCase Program "dependency-program", KeyCase Shell "dependency-shell"] data KeyCase a where KeyCase :: FromValue b => (b -> a) -> Text -> KeyCase a reqAlts :: [KeyCase a] -> ParseTable l a reqAlts xs = pickKey [Key key (fmap con . fromValue) | KeyCase con key <- xs] optAlts :: [KeyCase a] -> ParseTable l (Maybe a) optAlts xs = pickKey $ [Key key (fmap (Just . con) . fromValue) | KeyCase con key <- xs] ++ [Else (pure Nothing)] instance FromValue NoneConfig where fromValue = parseTableFromValue (pure NoneConfig) spec :: Spec spec = do it "parses this project's hie.toml" $ decode [quoteStr| dependencies = [ "src/Toml/Lexer.x", "src/Toml/Parser.y", ] [[cradle.cabal]] path = "./src" component = "toml-parser:lib:toml-parser" [[cradle.cabal]] path = "./test" component = "toml-parser:test:unittests" [[cradle.cabal]] path = "./test-drivers/encoder" component = "toml-test-drivers:exe:TomlEncoder" [[cradle.cabal]] path = "./test-drivers/decoder" component = "toml-test-drivers:exe:TomlDecoder" [[cradle.cabal]] path = "./test-drivers/highlighter" component = "toml-test-drivers:exe:TomlHighlighter" |] `shouldBe` Success [] CradleConfig { cradle = Cabal CabalConfig { cabalProject = Nothing , cabalComponents = ManyComponents [ CabalComponent { cabalPath = "./src" , cabalComponent = "toml-parser:lib:toml-parser" , cabalComponentProject = Nothing } , CabalComponent { cabalPath = "./test" , cabalComponent = "toml-parser:test:unittests" , cabalComponentProject = Nothing } , CabalComponent { cabalPath = "./test-drivers/encoder" , cabalComponent = "toml-test-drivers:exe:TomlEncoder" , cabalComponentProject = Nothing } , CabalComponent { cabalPath = "./test-drivers/decoder" , cabalComponent = "toml-test-drivers:exe:TomlDecoder" , cabalComponentProject = Nothing } , CabalComponent { cabalPath = "./test-drivers/highlighter" , cabalComponent = "toml-test-drivers:exe:TomlHighlighter" , cabalComponentProject = Nothing } ] } , dependencies = Just ["src/Toml/Lexer.x" , "src/Toml/Parser.y"] } it "has focused error messages" $ decode [quoteStr| [cradle.cabal] path = "./src" component = 42 |] `shouldBe` (Failure ["3:13: expected string but got integer in cradle.cabal.component"] :: Result String CradleConfig) it "detects unusd keys" $ decode [quoteStr| [[cradle.multi]] path = "./src" [cradle.multi.config.cradle.cabal] component = "toml-parser:lib:toml-parser" thing1 = 10 # unused key for test case [[cradle.multi]] path = "./test" [cradle.multi.config.cradle.stack] component = "toml-parser:test:unittests" thing2 = 20 # more unused keys for test case thing3 = false |] `shouldBe` Success [ "5:1: unexpected key: thing1 in cradle.multi[0].config.cradle.cabal" , "11:1: unexpected key: thing2 in cradle.multi[1].config.cradle.stack" , "12:1: unexpected key: thing3 in cradle.multi[1].config.cradle.stack" ] CradleConfig { cradle = Multi [ MultiSubComponent { path = "./src" , config = CradleConfig { cradle = Cabal CabalConfig { cabalProject = Nothing , cabalComponents = SingleComponent "toml-parser:lib:toml-parser" } , dependencies = Nothing } } , MultiSubComponent { path = "./test" , config = CradleConfig { cradle = Stack StackConfig { stackYaml = Nothing , stackComponents = SingleComponent "toml-parser:test:unittests" } , dependencies = Nothing } } ] , dependencies = Nothing } it "parses things using components" $ decode [quoteStr| dependencies = [ "src/Toml/Lexer.x", "src/Toml/Parser.y", ] [cradle.cabal] cabalProject = "cabal.project" [[cradle.cabal.components]] path = "./src" component = "toml-parser:lib:toml-parser" [[cradle.cabal.components]] path = "./test" component = "toml-parser:test:unittests" [[cradle.cabal.components]] path = "./test-drivers/encoder" component = "toml-test-drivers:exe:TomlEncoder" [[cradle.cabal.components]] path = "./test-drivers/decoder" component = "toml-test-drivers:exe:TomlDecoder" [[cradle.cabal.components]] path = "./test-drivers/highlighter" component = "toml-test-drivers:exe:TomlHighlighter" |] `shouldBe` Success [] CradleConfig { cradle = Cabal CabalConfig { cabalProject = Just "cabal.project" , cabalComponents = ManyComponents [ CabalComponent { cabalPath = "./src" , cabalComponent = "toml-parser:lib:toml-parser" , cabalComponentProject = Nothing } , CabalComponent { cabalPath = "./test" , cabalComponent = "toml-parser:test:unittests" , cabalComponentProject = Nothing } , CabalComponent { cabalPath = "./test-drivers/encoder" , cabalComponent = "toml-test-drivers:exe:TomlEncoder" , cabalComponentProject = Nothing } , CabalComponent { cabalPath = "./test-drivers/decoder" , cabalComponent = "toml-test-drivers:exe:TomlDecoder" , cabalComponentProject = Nothing } , CabalComponent { cabalPath = "./test-drivers/highlighter" , cabalComponent = "toml-test-drivers:exe:TomlHighlighter" , cabalComponentProject = Nothing } ] } , dependencies = Just [ "src/Toml/Lexer.x" , "src/Toml/Parser.y" ] } it "handles the none case" $ decode [quoteStr| [cradle.none]|] `shouldBe` Success [] (CradleConfig { cradle = None NoneConfig, dependencies = Nothing}) toml-parser-2.0.2.0/test/LexerSpec.hs0000644000000000000000000000567007346545000015524 0ustar0000000000000000{-# Language OverloadedStrings #-} module LexerSpec (spec) where import Data.Text (Text) import Test.Hspec (it, shouldBe, Spec) import Toml import Toml.Schema (table, (.=)) parse_ :: Text -> Either String Table parse_ str = forgetTableAnns <$> parse str spec :: Spec spec = do it "handles special cased control character" $ parse "x = '\SOH'" `shouldBe` 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 '}'" $ parse "}" `shouldBe` Left "1:1: parse error: unexpected '}'" it "handles unexpected '{'" $ parse "{" `shouldBe` Left "1:1: parse error: unexpected '{'" it "accepts tabs" $ parse_ "x\t=\t1" `shouldBe` Right (table ["x" .= Integer 1]) it "computes columns correctly with tabs" $ parse "x\t=\t=" `shouldBe` Left "1:17: parse error: unexpected '='" it "detects non-scalars in strings" $ parse "x = \"\\udfff\"" `shouldBe` Left "1:6: lexical error: non-scalar unicode escape" it "catches unclosed [" $ parse "x = [1,2,3" `shouldBe` Left "1:11: parse error: unexpected end-of-input" it "catches unclosed {" $ parse "x = { y" `shouldBe` Left "1:8: parse error: unexpected end-of-input" it "catches unclosed \"" $ parse "x = \"abc" `shouldBe` Left "1:5: lexical error: unterminated basic string" it "catches unclosed \"\"\"" $ parse "x = \"\"\"test" `shouldBe` Left "1:5: lexical error: unterminated multi-line basic string" it "catches unclosed '" $ parse "x = 'abc\ny = 2" `shouldBe` Left "1:9: lexical error: unexpected end-of-line" it "catches unclosed '" $ parse "x = 'abc" `shouldBe` Left "1:5: lexical error: unterminated literal string" it "catches unclosed '''" $ parse "x = '''test\n\n" `shouldBe` Left "1:5: lexical error: unterminated multi-line literal string" it "handles escapes at the end of input" $ parse "x = \"\\" `shouldBe` Left "1:6: lexical error: incomplete escape sequence" it "handles invalid escapes" $ parse "x = \"\\p\"" `shouldBe` Left "1:6: lexical error: unknown escape sequence" it "allows multi-byte characters in ''' strings" $ parse_ "x = '''§'''" `shouldBe` Right (table ["x" .= Text "§"]) toml-parser-2.0.2.0/test/Main.hs0000644000000000000000000000005407346545000014505 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} toml-parser-2.0.2.0/test/PrettySpec.hs0000644000000000000000000001061507346545000015727 0ustar0000000000000000{-# Language OverloadedStrings #-} module PrettySpec (spec) where import Data.Map qualified as Map import Data.Text (Text) import QuoteStr (quoteStr) import Test.Hspec (it, shouldBe, Spec) import Toml tomlString :: Table -> String tomlString = show . prettyToml parse_ :: Text -> Either String Table parse_ str = forgetTableAnns <$> parse str spec :: Spec spec = do it "renders example 1" $ show (encode (Map.singleton ("x" :: Text) (1 :: Integer))) `shouldBe` [quoteStr| x = 1|] it "renders example 2" $ fmap tomlString (parse_ "x=1\ny=2") `shouldBe` Right [quoteStr| x = 1 y = 2|] it "renders example lists" $ fmap tomlString (parse_ "x=[1,'two', [true]]") `shouldBe` Right [quoteStr| x = [1, "two", [true]]|] it "renders empty tables" $ fmap tomlString (parse_ "x.y.z={}\nz.y.w=false") `shouldBe` Right [quoteStr| [x.y.z] [z] y.w = false|] it "renders empty tables in array of tables" $ fmap tomlString (parse_ "ex=[{},{},{a=9}]") `shouldBe` Right [quoteStr| [[ex]] [[ex]] [[ex]] a = 9|] it "renders multiple tables" $ fmap tomlString (parse_ "a.x=1\nb.x=3\na.y=2\nb.y=4") `shouldBe` Right [quoteStr| [a] x = 1 y = 2 [b] x = 3 y = 4|] it "renders escapes in strings" $ fmap tomlString (parse_ "a=\"\\\\\\b\\t\\r\\n\\f\\e\\\"\\u007f\\U0001000c\"") `shouldBe` Right [quoteStr| a = "\\\b\t\r\n\f\e\"\x7F\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| a = 0.0 b = -0.1 c = 0.1 d = 3.141592653589793 e = 4.0e123|] it "renders special floats" $ fmap tomlString (parse_ "a=inf\nb=-inf\nc=nan") `shouldBe` Right [quoteStr| a = inf b = -inf c = nan|] it "renders empty documents" $ fmap tomlString (parse_ "") `shouldBe` Right "" it "renders dates and time" $ fmap tomlString (parse_ [quoteStr| a = 2020-05-07 b = 15:16:17.990 c = 2020-05-07T15:16:17.990 d = 2020-05-07T15:16:17.990Z e = 2020-05-07T15:16:17-07:00 f = 2021-09-06T14:15:19+08:00 g = 0008-10-11T12:13:14+15:00|]) `shouldBe` Right [quoteStr| a = 2020-05-07 b = 15:16:17.99 c = 2020-05-07T15:16:17.99 d = 2020-05-07T15:16:17.99Z e = 2020-05-07T15:16:17-07:00 f = 2021-09-06T14:15:19+08:00 g = 0008-10-11T12:13:14+15:00|] it "renders quoted keys" $ fmap tomlString (parse_ "''.'a b'.'\"' = 10") `shouldBe` Right [quoteStr| ""."a b"."\"" = 10|] it "renders inline tables" $ fmap tomlString (parse_ [quoteStr| x = [[{a = 'this is a longer example', b = 'and it will linewrap'},{c = 'all on its own'}]]|]) `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-2.0.2.0/test/QuoteStr.hs0000644000000000000000000000214707346545000015414 0ustar0000000000000000{-| Module : QuoteStr Description : Quasiquoter for multi-line string literals Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com This module makes it easy to write inline TOML for test cases without worrying about escaping newlines or quotation marks. -} module QuoteStr (quoteStr) where import Language.Haskell.TH (Exp(LitE), ExpQ, Lit(StringL)) import Language.Haskell.TH.Quote ( QuasiQuoter(..) ) import Data.List ( stripPrefix ) quoteStr :: QuasiQuoter quoteStr = QuasiQuoter { quoteDec = \_ -> fail "quoteStr doesn't support declarations", quotePat = \_ -> fail "quoteStr doesn't support patterns", quoteType = \_ -> fail "quoteStr doesn't support types", quoteExp = processString } processString :: String -> ExpQ processString ('\n':xs) = let ws = takeWhile (' '==) xs cleanup "" = pure "" cleanup x = case stripPrefix ws x of Nothing -> fail "bad prefix" Just x' -> pure x' in LitE . StringL . unlines <$> traverse cleanup (lines xs) processString _ = fail "malformed string literal" toml-parser-2.0.2.0/test/ToValueSpec.hs0000644000000000000000000000075707346545000016025 0ustar0000000000000000{-# Language OverloadedStrings #-} module ToValueSpec where import Test.Hspec (it, shouldBe, Spec) import Toml (Value'(Integer, Text, List)) import Toml.Schema (ToValue(toValue)) spec :: Spec spec = do it "converts characters as singleton strings" $ toValue '!' `shouldBe` Text "!" it "converts strings normally" $ toValue ("demo" :: String) `shouldBe` Text "demo" it "converts lists" $ toValue [1,2,3::Int] `shouldBe` List [Integer 1, Integer 2, Integer 3] toml-parser-2.0.2.0/test/TomlSpec.hs0000644000000000000000000006441707346545000015364 0ustar0000000000000000{-# Language QuasiQuotes, OverloadedStrings #-} {-| Module : TomlSpec Description : Unit tests Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com TOML parser and validator unit tests (primarily drawn from the specification document). -} module TomlSpec (spec) where import Data.Map qualified as Map import Data.Text (Text) import Data.Time (Day) import QuoteStr (quoteStr) import Test.Hspec (describe, it, shouldBe, shouldSatisfy, Spec) import Toml import Toml.Schema (table, (.=)) parse_ :: Text -> Either String Table parse_ str = forgetTableAnns <$> parse str spec :: Spec spec = do describe "comment" do it "ignores comments" $ parse_ [quoteStr| # This is a full-line comment key = "value" # This is a comment at the end of a line another = "# This is not a comment"|] `shouldBe` Right (table [("another", Text "# This is not a comment"), ("key", Text "value")]) describe "key/value pair" do it "supports the most basic assignments" $ parse_ "key = \"value\"" `shouldBe` Right (table ["key" .= Text "value"]) it "requires a value after equals" $ parse_ "key = # INVALID" `shouldBe` Left "1:16: parse error: unexpected end-of-input" it "requires newlines between assignments" $ parse_ "first = \"Tom\" last = \"Preston-Werner\" # INVALID" `shouldBe` Left "1:15: parse error: unexpected bare key" describe "keys" do it "allows bare keys" $ parse_ [quoteStr| key = "value" bare_key = "value" bare-key = "value" 1234 = "value"|] `shouldBe` Right (table [ "1234" .= Text "value", "bare-key" .= Text "value", "bare_key" .= Text "value", "key" .= Text "value"]) it "allows quoted keys" $ parse_ [quoteStr| "127.0.0.1" = "value" "character encoding" = "value" "ʎǝʞ" = "value" 'key2' = "value" 'quoted "value"' = "value"|] `shouldBe` Right (table [ "127.0.0.1" .= Text "value", "character encoding" .= Text "value", "key2" .= Text "value", "quoted \"value\"" .= Text "value", "ʎǝʞ" .= Text "value"]) it "allows dotted keys" $ parse_ [quoteStr| name = "Orange" physical.color = "orange" physical.shape = "round" site."google.com" = true|] `shouldBe` Right (table [ "name" .= Text "Orange", "physical" .= table ["color" .= Text "orange", "shape" .= Text "round"], "site" .= table ["google.com" .= True]]) it "prevents duplicate keys" $ parse [quoteStr| name = "Tom" name = "Pradyun"|] `shouldBe` Left "2:1: key error: name is already assigned" it "prevents duplicate keys even between bare and quoted" $ parse [quoteStr| spelling = "favorite" "spelling" = "favourite"|] `shouldBe` Left "2:1: key error: spelling is already assigned" it "allows out of order definitions" $ parse_ [quoteStr| apple.type = "fruit" orange.type = "fruit" apple.skin = "thin" orange.skin = "thick" apple.color = "red" orange.color = "orange"|] `shouldBe` Right (table [ "apple" .= table [ "color" .= Text "red", "skin" .= Text "thin", "type" .= Text "fruit"], "orange" .= table [ "color" .= Text "orange", "skin" .= Text "thick", "type" .= Text "fruit"]]) it "allows numeric bare keys" $ parse_ "3.14159 = 'pi'" `shouldBe` Right (table [ "3" .= table ["14159" .= Text "pi"]]) it "allows keys that look like other values" $ parse_ [quoteStr| true = true false = false 1900-01-01 = 1900-01-01 1_2 = 2_3|] `shouldBe` Right (table [ "1900-01-01" .= (read "1900-01-01" :: Day), "1_2" .= (23::Int), "false" .= False, "true" .= True]) describe "string" do it "parses escapes" $ parse_ [quoteStr| str = "I'm a string. \"You can quote me\". Name\tJos\u00E9\nLocation\tSF."|] `shouldBe` Right (table ["str" .= Text "I'm a string. \"You can quote me\". Name\tJos\xe9\nLocation\tSF."]) it "strips the initial newline from multiline strings" $ parse_ [quoteStr| str1 = """ Roses are red Violets are blue"""|] `shouldBe` Right (table ["str1" .= Text "Roses are red\nViolets are blue"]) it "strips whitespace with a trailing escape" $ parse_ [quoteStr| # The following strings are byte-for-byte equivalent: str1 = "The quick brown fox jumps over the lazy dog." str2 = """ The quick brown \ fox jumps over \ the lazy dog.""" str3 = """\ The quick brown \ fox jumps over \ the lazy dog.\ """|] `shouldBe` Right (table [ "str1" .= Text "The quick brown fox jumps over the lazy dog.", "str2" .= Text "The quick brown fox jumps over the lazy dog.", "str3" .= Text "The quick brown fox jumps over the lazy dog."]) it "allows quotes inside multiline quoted strings" $ parse_ [quoteStr| str4 = """Here are two quotation marks: "". Simple enough.""" str5 = """Here are three quotation marks: ""\".""" str6 = """Here are fifteen quotation marks: ""\"""\"""\"""\"""\".""" # "This," she said, "is just a pointless statement." str7 = """"This," she said, "is just a pointless statement.""""|] `shouldBe` Right (table [ "str4" .= Text "Here are two quotation marks: \"\". Simple enough.", "str5" .= Text "Here are three quotation marks: \"\"\".", "str6" .= Text "Here are fifteen quotation marks: \"\"\"\"\"\"\"\"\"\"\"\"\"\"\".", "str7" .= Text "\"This,\" she said, \"is just a pointless statement.\""]) it "disallows triple quotes inside a multiline string" $ parse [quoteStr| str5 = """Here are three quotation marks: """.""" # INVALID|] `shouldBe` Left "1:46: parse error: unexpected '.'" it "ignores escapes in literal strings" $ parse_ [quoteStr| # What you see is what you get. winpath = 'C:\Users\nodejs\templates' winpath2 = '\\ServerX\admin$\system32\' quoted = 'Tom "Dubs" Preston-Werner' regex = '<\i\c*\s*>'|] `shouldBe` Right (table [ "quoted" .= Text "Tom \"Dubs\" Preston-Werner", "regex" .= Text "<\\i\\c*\\s*>", "winpath" .= Text "C:\\Users\\nodejs\\templates", "winpath2" .= Text "\\\\ServerX\\admin$\\system32\\"]) it "handles multiline literal strings" $ parse_ [quoteStr| regex2 = '''I [dw]on't need \d{2} apples''' lines = ''' The first newline is trimmed in raw strings. All other whitespace is preserved. '''|] `shouldBe` Right (table [ "lines" .= Text "The first newline is\ntrimmed in raw strings.\nAll other whitespace\nis preserved.\n", "regex2" .= Text "I [dw]on't need \\d{2} apples"]) it "parses all the other escapes" $ parse_ [quoteStr| x = "\\\b\f\r\U0010abcd" y = """\\\b\f\r\u7bca\U0010abcd\n\r\t"""|] `shouldBe` Right (table [ "x" .= Text "\\\b\f\r\x0010abcd", "y" .= Text "\\\b\f\r\x7bca\x0010abcd\n\r\t"]) it "rejects out of range unicode escapes" $ parse [quoteStr| x = "\U11111111"|] `shouldBe` Left "1:6: lexical error: unicode escape too large" it "handles unexpected end of line" $ parse [quoteStr| x = "example y = 42|] `shouldBe` Left "1:13: lexical error: unexpected end-of-line" describe "integer" do it "parses literals correctly" $ parse_ [quoteStr| int1 = +99 int2 = 42 int3 = 0 int4 = -17 int5 = 1_000 int6 = 5_349_221 int7 = 53_49_221 # Indian number system grouping int8 = 1_2_3_4_5 # VALID but discouraged # hexadecimal with prefix `0x` hex1 = 0xDEADBEEF hex2 = 0xdeadbeef hex3 = 0xdead_beef # octal with prefix `0o` oct1 = 0o01234567 oct2 = 0o755 # useful for Unix file permissions # binary with prefix `0b` bin1 = 0b11010110|] `shouldBe` Right (table [ "bin1" .= Integer 214, "hex1" .= Integer 0xDEADBEEF, "hex2" .= Integer 0xDEADBEEF, "hex3" .= Integer 0xDEADBEEF, "int1" .= Integer 99, "int2" .= Integer 42, "int3" .= Integer 0, "int4" .= Integer (-17), "int5" .= Integer 1000, "int6" .= Integer 5349221, "int7" .= Integer 5349221, "int8" .= Integer 12345, "oct1" .= Integer 0o01234567, "oct2" .= Integer 0o755]) it "handles leading zeros gracefully" $ parse "x = 01" `shouldBe` Left "1:5: lexical error: leading zero prohibited" describe "float" do it "parses floats" $ parse_ [quoteStr| # fractional flt1 = +1.0 flt2 = 3.1415 flt3 = -0.01 # exponent flt4 = 5e+22 flt5 = 1e06 flt6 = -2E-2 # both flt7 = 6.626e-34 flt8 = 224_617.445_991_228 # infinity sf1 = inf # positive infinity sf2 = +inf # positive infinity sf3 = -inf # negative infinity|] `shouldBe` Right (table [ "flt1" .= Double 1.0, "flt2" .= Double 3.1415, "flt3" .= Double (-1.0e-2), "flt4" .= Double 4.9999999999999996e22, "flt5" .= Double 1000000.0, "flt6" .= Double (-2.0e-2), "flt7" .= Double 6.626e-34, "flt8" .= Double 224617.445991228, "sf1" .= Double (1/0), "sf2" .= Double (1/0), "sf3" .= Double (-1/0)]) it "parses nan correctly" $ let checkNaN (Double' _ x) = isNaN x checkNaN _ = False in parse [quoteStr| # not a number sf4 = nan # actual sNaN/qNaN encoding is implementation-specific sf5 = +nan # same as `nan` sf6 = -nan # valid, actual encoding is implementation-specific|] `shouldSatisfy` \case Left{} -> False Right (MkTable x) -> all (checkNaN . snd) x -- code using Numeric.readFloat can use significant -- resources. this makes sure this doesn't start happening -- in the future it "parses huge floats without great delays" $ parse_ "x = 1e1000000000000" `shouldBe` Right (table ["x" .= Double (1/0)]) describe "boolean" do it "parses boolean literals" $ parse_ [quoteStr| bool1 = true bool2 = false|] `shouldBe` Right (table [ "bool1" .= True, "bool2" .= False]) describe "offset date-time" do it "parses offset date times" $ parse_ [quoteStr| odt1 = 1979-05-27T07:32:00Z odt2 = 1979-05-27T00:32:00-07:00 odt3 = 1979-05-27T00:32:00.999999-07:00 odt4 = 1979-05-27 07:32:00Z|] `shouldBe` Right (table [ "odt1" .= ZonedTime (read "1979-05-27 07:32:00 +0000"), "odt2" .= ZonedTime (read "1979-05-27 00:32:00 -0700"), "odt3" .= ZonedTime (read "1979-05-27 00:32:00.999999 -0700"), "odt4" .= ZonedTime (read "1979-05-27 07:32:00 +0000")]) describe "local date-time" do it "parses local date-times" $ parse_ [quoteStr| ldt1 = 1979-05-27T07:32:00 ldt2 = 1979-05-27T00:32:00.999999 ldt3 = 1979-05-28 00:32:00.999999|] `shouldBe` Right (table [ "ldt1" .= LocalTime (read "1979-05-27 07:32:00"), "ldt2" .= LocalTime (read "1979-05-27 00:32:00.999999"), "ldt3" .= LocalTime (read "1979-05-28 00:32:00.999999")]) it "catches invalid date-times" $ parse [quoteStr| ldt = 9999-99-99T99:99:99|] `shouldBe` Left "1:7: lexical error: malformed local date-time" describe "local date" do it "parses dates" $ parse_ [quoteStr| ld1 = 1979-05-27|] `shouldBe` Right (table ["ld1" .= Day (read "1979-05-27")]) describe "local time" do it "parses times" $ parse_ [quoteStr| lt1 = 07:32:00 lt2 = 00:32:00.999999|] `shouldBe` Right (table [ "lt1" .= TimeOfDay (read "07:32:00"), "lt2" .= TimeOfDay (read "00:32:00.999999")]) describe "array" do it "parses array examples" $ parse_ [quoteStr| integers = [ 1, 2, 3 ] colors = [ "red", "yellow", "green" ] nested_arrays_of_ints = [ [ 1, 2 ], [3, 4, 5] ] nested_mixed_array = [ [ 1, 2 ], ["a", "b", "c"] ] string_array = [ "all", 'strings', """are the same""", '''type''' ] # Mixed-type arrays are allowed numbers = [ 0.1, 0.2, 0.5, 1, 2, 5 ] contributors = [ "Foo Bar ", { name = "Baz Qux", email = "bazqux@example.com", url = "https://example.com/bazqux" } ]|] `shouldBe` Right (table [ "colors" .= [Text "red", Text "yellow", Text "green"], "contributors" .= [ "Foo Bar ", Table (table [ "email" .= Text "bazqux@example.com", "name" .= Text "Baz Qux", "url" .= Text "https://example.com/bazqux"])], "integers" .= [1, 2, 3 :: Integer], "nested_arrays_of_ints" .= [[1, 2], [3, 4, 5 :: Integer]], "nested_mixed_array" .= [[Integer 1, Integer 2], [Text "a", Text "b", Text "c"]], "numbers" .= [Double 0.1, Double 0.2, Double 0.5, Integer 1, Integer 2, Integer 5], "string_array" .= [Text "all", Text "strings", Text "are the same", Text "type"]]) it "handles newlines and comments" $ parse_ [quoteStr| integers2 = [ 1, 2, 3 ] integers3 = [ 1, 2, # this is ok ]|] `shouldBe` Right (table [ "integers2" .= [1, 2, 3 :: Int], "integers3" .= [1, 2 :: Int]]) it "disambiguates double brackets from array tables" $ parse_ "x = [[1]]" `shouldBe` Right (table ["x" .= List [List [Integer 1]]]) describe "table" do it "allows empty tables" $ parse_ "[table]" `shouldBe` Right (table ["table" .= table []]) it "parses simple tables" $ parse_ [quoteStr| [table-1] key1 = "some string" key2 = 123 [table-2] key1 = "another string" key2 = 456|] `shouldBe` Right (table [ "table-1" .= table [ "key1" .= Text "some string", "key2" .= Integer 123], "table-2" .= table [ "key1" .= Text "another string", "key2" .= Integer 456]]) it "allows quoted keys" $ parse_ [quoteStr| [dog."tater.man"] type.name = "pug"|] `shouldBe` Right (table ["dog" .= table ["tater.man" .= table ["type" .= table ["name" .= Text "pug"]]]]) it "allows whitespace around keys" $ parse_ [quoteStr| [a.b.c] # this is best practice [ d.e.f ] # same as [d.e.f] [ g . h . i ] # same as [g.h.i] [ j . "ʞ" . 'l' ] # same as [j."ʞ".'l']|] `shouldBe` Right (table [ "a" .= table ["b" .= table ["c" .= table []]], "d" .= table ["e" .= table ["f" .= table []]], "g" .= table ["h" .= table ["i" .= table []]], "j" .= table ["ʞ" .= table ["l" .= table []]]]) it "allows supertables to be defined after subtables" $ parse_ [quoteStr| # [x] you # [x.y] don't # [x.y.z] need these [x.y.z.w] # for this to work [x] # defining a super-table afterward is ok q=1|] `shouldBe` Right (table [ "x" .= table [ "q" .= Integer 1, "y" .= table [ "z" .= table [ "w" .= table []]]]]) it "prevents using a [table] to open a table defined with dotted keys" $ parse [quoteStr| [fruit] apple.color = 'red' apple.taste.sweet = true [fruit.apple]|] `shouldBe` Left "4:8: key error: apple is a closed table" it "can add subtables" $ parse_ [quoteStr| [fruit] apple.color = "red" apple.taste.sweet = true [fruit.apple.texture] # you can add sub-tables smooth = true|] `shouldBe` Right (table [ "fruit" .= table [ "apple" .= table [ "color" .= Text "red", "taste" .= table [ "sweet" .= True], "texture" .= table [ "smooth" .= True]]]]) describe "inline table" do it "parses inline tables" $ parse_ [quoteStr| name = { first = "Tom", last = "Preston-Werner" } point = { x = 1, y = 2 } animal = { type.name = "pug" }|] `shouldBe` Right (table [ "animal" .= table ["type" .= table ["name" .= Text "pug"]], "name" .= table ["first" .= Text "Tom", "last" .= Text "Preston-Werner"], "point" .= table ["x" .= Integer 1, "y" .= Integer 2]]) it "prevents altering inline tables with dotted keys" $ parse [quoteStr| [product] type = { name = "Nail" } type.edible = false # INVALID|] `shouldBe` Left "3:1: key error: type is already assigned" it "prevents using inline tables to add keys to existing tables" $ parse [quoteStr| [product] type.name = "Nail" type = { edible = false } # INVALID|] `shouldBe` Left "3:1: key error: type is already assigned" it "checks that inline keys aren't reassigned" $ parse [quoteStr| x = {a = 1, a = 2}|] `shouldBe` Left "1:13: key error: a is already assigned" it "checks that inline keys don't overlap with implicit inline tables" $ parse [quoteStr| x = {a.b = 1, a = 2}|] `shouldBe` Left "1:15: key error: a is already assigned" it "checks for overwrites from other inline tables" $ parse [quoteStr| tab = { inner = { dog = "best" }, inner.cat = "worst" }|] `shouldBe` Left "1:35: key error: inner is already assigned" it "checks for overlaps of other inline tables" $ parse [quoteStr| tbl = { fruit = { apple.color = "red" }, fruit.apple.texture = { smooth = true } }|] `shouldBe` Left "1:42: key error: fruit is already assigned" describe "array of tables" do it "supports array of tables syntax" $ decode [quoteStr| [[products]] name = "Hammer" sku = 738594937 [[products]] # empty table within the array [[products]] name = "Nail" sku = 284758393 color = "gray"|] `shouldBe` Success mempty (Map.singleton ("products" :: Text) [ table [ "name" .= Text "Hammer", "sku" .= Integer 738594937], table [], table [ "color" .= Text "gray", "name" .= Text "Nail", "sku" .= Integer 284758393]]) it "handles subtables under array of tables" $ parse_ [quoteStr| [[fruits]] name = "apple" [fruits.physical] # subtable color = "red" shape = "round" [[fruits.varieties]] # nested array of tables name = "red delicious" [[fruits.varieties]] name = "granny smith" [[fruits]] name = "banana" [[fruits.varieties]] name = "plantain"|] `shouldBe` Right (table [ "fruits" .= [ table [ "name" .= Text "apple", "physical" .= table [ "color" .= Text "red", "shape" .= Text "round"], "varieties" .= [ table ["name" .= Text "red delicious"], table ["name" .= Text "granny smith"]]], table [ "name" .= Text "banana", "varieties" .= [ table ["name" .= Text "plantain"]]]]]) it "prevents redefining a supertable with an array of tables" $ parse [quoteStr| # INVALID TOML DOC [fruit.physical] # subtable, but to which parent element should it belong? color = "red" shape = "round" [[fruit]] # parser must throw an error upon discovering that "fruit" is # an array rather than a table name = "apple"|] `shouldBe` Left "6:3: key error: fruit is already implicitly defined to be a table" it "prevents redefining an inline array" $ parse [quoteStr| # INVALID TOML DOC fruits = [] [[fruits]] # Not allowed|] `shouldBe` Left "4:3: key error: fruits is already assigned" -- these cases are needed to complete coverage checking on Semantics module describe "corner cases" do it "stays open" $ parse_ [quoteStr| [x.y.z] [x] [x.y]|] `shouldBe` parse_ "x.y.z={}" it "stays closed" $ parse [quoteStr| [x.y] [x] [x.y]|] `shouldBe` Left "3:4: key error: y is a closed table" it "super tables of array tables preserve array tables" $ parse_ [quoteStr| [[x.y]] [x] [[x.y]]|] `shouldBe` parse_ "x.y=[{},{}]" it "super tables of array tables preserve array tables" $ parse_ [quoteStr| [[x.y]] [x] [x.y.z]|] `shouldBe` parse_ "x.y=[{z={}}]" it "detects conflicting inline keys" $ parse [quoteStr| x = { y = 1, y.z = 2}|] `shouldBe` Left "1:14: key error: y is already assigned" it "handles merging dotted inline table keys" $ parse_ [quoteStr| t = { a.x.y = 1, a.x.z = 2, a.q = 3}|] `shouldBe` Right (table [ "t" .= table [ "a" .= table [ "q" .= Integer 3, "x" .= table [ "y" .= Integer 1, "z" .= Integer 2]]]]) it "disallows overwriting assignments with tables" $ parse [quoteStr| x = 1 [x.y]|] `shouldBe` Left "2:2: key error: x is already assigned" it "handles super super tables" $ parse_ [quoteStr| [x.y.z] [x.y] [x]|] `shouldBe` parse_ "x.y.z={}" it "You can dot into open supertables" $ parse_ [quoteStr| [x.y.z] [x] y.q = 1|] `shouldBe` parse_ "x.y={z={},q=1}" it "dotted tables close previously open tables" $ parse [quoteStr| [x.y.z] [x] y.q = 1 [x.y]|] `shouldBe` Left "4:4: key error: y is a closed table" it "dotted tables can't assign through closed tables!" $ parse [quoteStr| [x.y] [x] y.z.w = 1|] `shouldBe` Left "3:1: key error: y is a closed table" it "super tables can't add new subtables to array tables via dotted keys" $ parse [quoteStr| [[x.y]] [x] y.z.a = 1 y.z.b = 2|] `shouldBe` Left "3:1: key error: y is a closed table" it "the previous example preserves closeness" $ parse [quoteStr| [[x.y]] [x] y.z.a = 1 y.w = 2|] `shouldBe` Left "3:1: key error: y is a closed table" it "defining a supertable closes the supertable" $ parse [quoteStr| [x.y] [x] [x]|] `shouldBe` Left "3:2: key error: x is a closed table" it "prevents redefining an array of tables" $ parse [quoteStr| [[x.y]] [x.y]|] `shouldBe` Left "2:4: key error: y is a closed table" it "quotes table names in semantic errors" $ parse [quoteStr| [[x.""]] [x.""]|] `shouldBe` Left "2:4: key error: \"\" is a closed table" toml-parser-2.0.2.0/toml-parser.cabal0000644000000000000000000000745007346545000015546 0ustar0000000000000000cabal-version: 3.0 name: toml-parser version: 2.0.2.0 synopsis: TOML 1.1.0 parser description: TOML parser using generated lexers and parsers with careful attention to the TOML 1.1.0 semantics for defining tables. license: ISC license-file: LICENSE author: Eric Mertens maintainer: emertens@gmail.com copyright: 2023 Eric Mertens category: Text build-type: Simple tested-with: GHC == {8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.7, 9.8.4, 9.10.3, 9.12.2} extra-doc-files: ChangeLog.md README.md source-repository head type: git location: https://github.com/glguy/toml-parser tag: main common extensions default-language: Haskell2010 default-extensions: BlockArguments DeriveDataTypeable DeriveGeneric DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving ImportQualifiedPost LambdaCase ScopedTypeVariables TypeOperators TypeSynonymInstances ViewPatterns library import: extensions hs-source-dirs: src default-language: Haskell2010 exposed-modules: Toml Toml.Pretty Toml.Schema Toml.Schema.FromValue Toml.Schema.Generic Toml.Schema.Generic.FromValue Toml.Schema.Generic.ToValue Toml.Schema.Matcher Toml.Schema.ParseTable Toml.Schema.ToValue Toml.Semantics Toml.Semantics.Ordered Toml.Semantics.Types Toml.Syntax Toml.Syntax.Lexer Toml.Syntax.Parser Toml.Syntax.Position Toml.Syntax.Token Toml.Syntax.Types other-modules: Toml.Syntax.LexerUtils Toml.Syntax.ParserUtils build-depends: array ^>= 0.5, base ^>= {4.14, 4.15, 4.16, 4.17, 4.18, 4.19, 4.20, 4.21}, containers ^>= {0.5, 0.6, 0.7, 0.8}, prettyprinter ^>= 1.7, text >= 0.2 && < 3, time ^>= {1.9, 1.10, 1.11, 1.12, 1.14, 1.15}, transformers ^>= {0.5, 0.6}, build-tool-depends: alex:alex >= 3.2, happy:happy >= 1.19, if impl(ghc >= 9.8) ghc-options: -Wno-x-partial test-suite unittests import: extensions type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs default-extensions: QuasiQuotes build-tool-depends: hspec-discover:hspec-discover ^>= {2.10, 2.11} build-depends: base, containers, hspec ^>= {2.10, 2.11}, template-haskell ^>= {2.16, 2.17, 2.18, 2.19, 2.20, 2.21, 2.22, 2.23}, text, time, toml-parser, other-modules: DecodeSpec DerivingViaSpec FromValueSpec HieDemoSpec LexerSpec PrettySpec QuoteStr TomlSpec ToValueSpec test-suite readme import: extensions type: exitcode-stdio-1.0 main-is: README.lhs ghc-options: -pgmL markdown-unlit -optL "haskell toml" default-extensions: QuasiQuotes DerivingVia 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, 2.22, 2.23}, text, build-tool-depends: markdown-unlit:markdown-unlit ^>= {0.5.1, 0.6.0}, executable toml-benchmarker buildable: False main-is: benchmarker.hs default-language: Haskell2010 build-depends: base, toml-parser, time, text hs-source-dirs: benchmarker