toml-parser-1.3.2.0/0000755000000000000000000000000007346545000012311 5ustar0000000000000000toml-parser-1.3.2.0/ChangeLog.md0000644000000000000000000000545107346545000014467 0ustar0000000000000000# Revision history for toml-parser ## 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-1.3.2.0/LICENSE0000644000000000000000000000133207346545000013315 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-1.3.2.0/README.lhs0000644000000000000000000001365507346545000013770 0ustar0000000000000000# TOML Parser This package implements a validating parser for [TOML 1.0.0](https://toml.io/en/v1.0.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]: Toml.Lexer [Token] --> [Expr]: Toml.Parser [Expr] --> Table : Toml.Semantics Table --> ApplicationTypes : Toml.FromValue ApplicationTypes --> Table : Toml.ToValue Table --> TOML : Toml.Pretty ``` The highest-level interface to this package is to define `FromValue` and `ToTable` instances for your application-specific datatypes. These can be used with `encode` and `decode` to convert to and from TOML. For low-level access to the TOML format, the lexer, parser, and validator are available for direct use. The diagram above shows how the different modules enable you to advance through the increasingly high-level TOML representations. ## 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 import GHC.Generics (Generic) import QuoteStr (quoteStr) import Test.Hspec (Spec, hspec, it, shouldBe) import Toml (parse, decode, encode, Value(..)) import Toml.FromValue (Result(Success), FromValue(fromValue), parseTableFromValue, reqKey) import Toml.Generic (GenericTomlTable(..)) import Toml.ToValue (ToValue(toValue), ToTable(toTable), defaultTableToValue, table, (.=)) main :: IO () main = hspec (parses >> decodes >> encodes) ``` ### Using the raw parser Consider this sample TOML text from the TOML specification. ```haskell fruitStr :: String 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 value ```haskell parses :: Spec parses = it "parses" $ parse fruitStr `shouldBe` Right (table [ ("fruits", Array [ Table (table [ ("name", String "apple"), ("physical", Table (table [ ("color", String "red"), ("shape", String "round")])), ("varieties", Array [ Table (table [("name", String "red delicious")]), Table (table [("name", String "granny smith")])])]), Table (table [ ("name", String "banana"), ("varieties", Array [ Table (table [("name", String "plantain")])])])])]) ``` ### Using decoding classes Here's an example of defining datatypes and deserializers for the TOML above. The `FromValue` typeclass is used to encode each datatype into a TOML value. Instances can be derived for simple record types. More complex examples can be manually derived. ```haskell newtype Fruits = Fruits { 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) newtype Variety = Variety String deriving (Eq, Show) instance FromValue Physical where fromValue = parseTableFromValue (Physical <$> reqKey "color" <*> reqKey "shape") instance FromValue Variety where fromValue = parseTableFromValue (Variety <$> reqKey "name") ``` 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"]]) ``` ### Using encoding classes The `ToValue` class is for all datatypes that can be encoded into TOML. The more specialized `ToTable` class is for datatypes that encode into tables and are thus eligible to be top-level types (all TOML documents are tables at the top-level). Generics can be used to derive `ToTable` for simple record types. Manually defined instances are available for the more complex cases. ```haskell instance ToValue Physical where toValue = defaultTableToValue instance ToTable Physical where toTable x = table ["color" .= color x, "shape" .= shape x] instance ToValue Variety where toValue = defaultTableToValue instance ToTable Variety where toTable (Variety x) = table ["name" .= x] encodes :: Spec encodes = it "encodes" $ show (encode (Fruits [Fruit "apple" (Just (Physical "red" "round")) [Variety "red delicious", Variety "granny smith"]])) `shouldBe` [quoteStr| [[fruits]] name = "apple" [fruits.physical] color = "red" shape = "round" [[fruits.varieties]] name = "red delicious" [[fruits.varieties]] name = "granny smith"|] ``` ## 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-1.3.2.0/README.md0000644000000000000000000001365507346545000013602 0ustar0000000000000000# TOML Parser This package implements a validating parser for [TOML 1.0.0](https://toml.io/en/v1.0.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]: Toml.Lexer [Token] --> [Expr]: Toml.Parser [Expr] --> Table : Toml.Semantics Table --> ApplicationTypes : Toml.FromValue ApplicationTypes --> Table : Toml.ToValue Table --> TOML : Toml.Pretty ``` The highest-level interface to this package is to define `FromValue` and `ToTable` instances for your application-specific datatypes. These can be used with `encode` and `decode` to convert to and from TOML. For low-level access to the TOML format, the lexer, parser, and validator are available for direct use. The diagram above shows how the different modules enable you to advance through the increasingly high-level TOML representations. ## 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 import GHC.Generics (Generic) import QuoteStr (quoteStr) import Test.Hspec (Spec, hspec, it, shouldBe) import Toml (parse, decode, encode, Value(..)) import Toml.FromValue (Result(Success), FromValue(fromValue), parseTableFromValue, reqKey) import Toml.Generic (GenericTomlTable(..)) import Toml.ToValue (ToValue(toValue), ToTable(toTable), defaultTableToValue, table, (.=)) main :: IO () main = hspec (parses >> decodes >> encodes) ``` ### Using the raw parser Consider this sample TOML text from the TOML specification. ```haskell fruitStr :: String 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 value ```haskell parses :: Spec parses = it "parses" $ parse fruitStr `shouldBe` Right (table [ ("fruits", Array [ Table (table [ ("name", String "apple"), ("physical", Table (table [ ("color", String "red"), ("shape", String "round")])), ("varieties", Array [ Table (table [("name", String "red delicious")]), Table (table [("name", String "granny smith")])])]), Table (table [ ("name", String "banana"), ("varieties", Array [ Table (table [("name", String "plantain")])])])])]) ``` ### Using decoding classes Here's an example of defining datatypes and deserializers for the TOML above. The `FromValue` typeclass is used to encode each datatype into a TOML value. Instances can be derived for simple record types. More complex examples can be manually derived. ```haskell newtype Fruits = Fruits { 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) newtype Variety = Variety String deriving (Eq, Show) instance FromValue Physical where fromValue = parseTableFromValue (Physical <$> reqKey "color" <*> reqKey "shape") instance FromValue Variety where fromValue = parseTableFromValue (Variety <$> reqKey "name") ``` 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"]]) ``` ### Using encoding classes The `ToValue` class is for all datatypes that can be encoded into TOML. The more specialized `ToTable` class is for datatypes that encode into tables and are thus eligible to be top-level types (all TOML documents are tables at the top-level). Generics can be used to derive `ToTable` for simple record types. Manually defined instances are available for the more complex cases. ```haskell instance ToValue Physical where toValue = defaultTableToValue instance ToTable Physical where toTable x = table ["color" .= color x, "shape" .= shape x] instance ToValue Variety where toValue = defaultTableToValue instance ToTable Variety where toTable (Variety x) = table ["name" .= x] encodes :: Spec encodes = it "encodes" $ show (encode (Fruits [Fruit "apple" (Just (Physical "red" "round")) [Variety "red delicious", Variety "granny smith"]])) `shouldBe` [quoteStr| [[fruits]] name = "apple" [fruits.physical] color = "red" shape = "round" [[fruits.varieties]] name = "red delicious" [[fruits.varieties]] name = "granny smith"|] ``` ## 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-1.3.2.0/benchmarker/0000755000000000000000000000000007346545000014572 5ustar0000000000000000toml-parser-1.3.2.0/benchmarker/benchmarker.hs0000644000000000000000000000077607346545000017421 0ustar0000000000000000 import Control.Exception (evaluate) 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 <- readFile filename evaluate (length txt) -- readFile uses lazy IO, force it to load start <- getCurrentTime evaluate (parse txt) stop <- getCurrentTime print (stop `diffUTCTime` start) toml-parser-1.3.2.0/src/0000755000000000000000000000000007346545000013100 5ustar0000000000000000toml-parser-1.3.2.0/src/Toml.hs0000644000000000000000000000353107346545000014351 0ustar0000000000000000{-| 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 coversion into and out of application-specific representations. This parser implements TOML 1.0.0 as carefully as possible. -} module Toml ( -- * Types Table, Value(..), -- * Parsing parse, -- * Printing prettyToml, DocClass(..), -- * Serialization decode, encode, Result(..), ) where import Toml.FromValue (FromValue (fromValue), Result(..)) import Toml.FromValue.Matcher (runMatcher) import Toml.Parser (parseRawToml) import Toml.Pretty (TomlDoc, DocClass(..), prettyToml, prettySemanticError, prettyMatchMessage, prettyLocated) import Toml.Semantics (semantics) import Toml.ToValue (ToTable (toTable)) import Toml.Value (Table, Value(..)) -- | Parse a TOML formatted 'String' or report an error message. parse :: String -> Either String Table parse str = case parseRawToml str of Left e -> Left (prettyLocated e) Right exprs -> case semantics exprs of Left e -> Left (prettyLocated (prettySemanticError <$> e)) Right tab -> Right tab -- | Use the 'FromValue' instance to decode a value from a TOML string. decode :: FromValue a => String -> Result String a decode str = case parse str of Left e -> Failure [e] Right tab -> case runMatcher (fromValue (Table tab)) of Failure es -> Failure (prettyMatchMessage <$> es) Success ws x -> Success (prettyMatchMessage <$> ws) x -- | Use the 'ToTable' instance to encode a value to a TOML string. encode :: ToTable a => a -> TomlDoc encode = prettyToml . toTable toml-parser-1.3.2.0/src/Toml/0000755000000000000000000000000007346545000014013 5ustar0000000000000000toml-parser-1.3.2.0/src/Toml/FromValue.hs0000644000000000000000000002217507346545000016256 0ustar0000000000000000{-# Language TypeFamilies #-} {-| Module : Toml.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 'warning' and 'warnTable' (depending on what) context you're in. These warnings can provide useful feedback about problematic decodings or keys that might be unused now but were perhaps meaningful in an old version of a configuration file. "Toml.FromValue.Generic" can be used to derive instances of 'FromValue' automatically for record types. -} module Toml.FromValue ( -- * Deserialization classes FromValue(..), FromKey(..), -- * Matcher Matcher, MatchMessage(..), Result(..), warning, -- * Table matching ParseTable, runParseTable, parseTableFromValue, reqKey, optKey, reqKeyOf, optKeyOf, warnTable, KeyAlt(..), pickKey, -- * Table matching primitives getTable, setTable, liftMatcher, ) where import Control.Monad (zipWithM) 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 qualified import Data.Text.Lazy qualified import Data.Time (ZonedTime, LocalTime, Day, TimeOfDay) import Data.Word (Word8, Word16, Word32, Word64) import Numeric.Natural (Natural) import Toml.FromValue.Matcher (Matcher, Result(..), MatchMessage(..), warning, inIndex, inKey) import Toml.FromValue.ParseTable import Toml.Value (Value(..)) -- | 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 -> Matcher a -- | Used to implement instance for '[]'. Most implementations rely on the default implementation. listFromValue :: Value -> Matcher [a] listFromValue (Array xs) = zipWithM (\i v -> inIndex i (fromValue v)) [0..] xs listFromValue v = typeError "array" v instance (Ord k, FromKey k, FromValue v) => FromValue (Map k v) where fromValue (Table t) = Map.fromList <$> traverse f (Map.assocs t) where f (k,v) = (,) <$> fromKey k <*> inKey k (fromValue v) fromValue v = typeError "table" v -- | Convert from a table key -- -- @since 1.3.0.0 class FromKey a where fromKey :: String -> Matcher a -- | Matches all strings -- -- @since 1.3.0.0 instance a ~ Char => FromKey [a] where fromKey = pure -- | Matches all strings -- -- @since 1.3.0.0 instance FromKey Data.Text.Text where fromKey = pure . Data.Text.pack -- | Matches all strings -- -- @since 1.3.0.0 instance FromKey Data.Text.Lazy.Text where fromKey = pure . Data.Text.Lazy.pack -- | Report a type error typeError :: String {- ^ expected type -} -> Value {- ^ actual value -} -> Matcher a typeError wanted got = fail ("type error. wanted: " ++ wanted ++ " got: " ++ valueType got) -- | Used to derive a 'fromValue' implementation from a 'ParseTable' matcher. parseTableFromValue :: ParseTable a -> Value -> Matcher a parseTableFromValue p (Table t) = runParseTable p t parseTableFromValue _ v = typeError "table" v valueType :: Value -> String valueType = \case Integer {} -> "integer" Float {} -> "float" Array {} -> "array" Table {} -> "table" Bool {} -> "boolean" String {} -> "string" TimeOfDay {} -> "local time" LocalTime {} -> "local date-time" Day {} -> "locate date" ZonedTime {} -> "offset date-time" -- | 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 fail "integer out of range for Natural" fromValueSized :: forall a. (Bounded a, Integral a) => String -> Value -> Matcher a fromValueSized name v = do i <- fromValue v if fromIntegral (minBound :: a) <= i && i <= fromIntegral (maxBound :: a) then pure (fromInteger i) else fail ("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 (String [c]) = pure c fromValue v = typeError "character" v listFromValue (String xs) = pure xs listFromValue v = typeError "string" v -- | Matches string literals -- -- @since 1.2.1.0 instance FromValue Data.Text.Text where fromValue v = Data.Text.pack <$> fromValue v -- | Matches string literals -- -- @since 1.2.1.0 instance FromValue Data.Text.Lazy.Text where fromValue v = Data.Text.Lazy.pack <$> fromValue v -- | Matches floating-point and integer values instance FromValue Double where fromValue (Float 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 (Float 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. -- -- @since 1.3.0.0 instance Integral a => FromValue (Ratio a) where fromValue (Float x) | isNaN x || isInfinite x = fail "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. -- -- @since 1.3.0.0 instance FromValue a => FromValue (NonEmpty a) where fromValue v = do xs <- fromValue v case NonEmpty.nonEmpty xs of Nothing -> fail "non-empty list required" Just ne -> pure ne -- | Matches arrays -- -- @since 1.3.0.0 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 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 -- | Convenience function for matching an optional key with a 'FromValue' -- instance. -- -- @optKey key = 'optKeyOf' key 'fromValue'@ optKey :: FromValue a => String -> ParseTable (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 => String -> ParseTable 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 :: String {- ^ key -} -> (Value -> Matcher a) {- ^ value matcher -} -> ParseTable (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 :: String {- ^ key -} -> (Value -> Matcher a) {- ^ value matcher -} -> ParseTable a reqKeyOf key k = pickKey [Key key k] toml-parser-1.3.2.0/src/Toml/FromValue/0000755000000000000000000000000007346545000015713 5ustar0000000000000000toml-parser-1.3.2.0/src/Toml/FromValue/Generic.hs0000644000000000000000000001012507346545000017622 0ustar0000000000000000{-# Language DataKinds, InstanceSigs, ScopedTypeVariables, TypeOperators #-} {-| Module : Toml.FromValue.Generic Description : GHC.Generics derived table parsing Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com Use 'genericParseTable' to derive a 'ParseTable' using the field names of a record. This can be combined with 'Toml.FromValue.parseTableFromValue' to derive a 'Toml.FromValue.FromValue' instance. -} module Toml.FromValue.Generic ( -- * Record from table GParseTable(..), genericParseTable, -- * Product type from array GFromArray(..), genericFromArray, ) where import Control.Monad.Trans.State (StateT(..)) import Data.Coerce (coerce) import GHC.Generics import Toml.FromValue (FromValue, fromValue, optKey, reqKey) import Toml.FromValue.Matcher (Matcher) import Toml.FromValue.ParseTable (ParseTable) import Toml.Value (Value) -- | Match a 'Table' using the field names in a record. -- -- @since 1.2.0.0 genericParseTable :: (Generic a, GParseTable (Rep a)) => ParseTable a genericParseTable = to <$> gParseTable {-# INLINE genericParseTable #-} -- | Match a 'Value' as an array positionally matching field fields -- of a constructor to the elements of the array. -- -- @since 1.3.2.0 genericFromArray :: (Generic a, GFromArray (Rep a)) => Value -> Matcher a genericFromArray v = do xs <- fromValue v (gen, xs') <- runStateT gFromArray xs if null xs' then pure (to gen) else fail ("array " ++ show (length xs') ++ " elements too long") {-# 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. -- -- @since 1.0.2.0 class GParseTable f where -- | Convert a value and apply the continuation to the result. gParseTable :: ParseTable (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 (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 (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. -- -- @since 1.3.2.0 class GFromArray f where gFromArray :: StateT [Value] Matcher (f a) instance GFromArray f => GFromArray (M1 i c f) where gFromArray :: forall a. StateT [Value] Matcher (M1 i c f a) gFromArray = coerce (gFromArray :: StateT [Value] Matcher (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-1.3.2.0/src/Toml/FromValue/Matcher.hs0000644000000000000000000001167207346545000017641 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-| Module : Toml.FromValue.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.FromValue.Matcher ( -- * Types Matcher, Result(..), MatchMessage(..), -- * Operations runMatcher, withScope, getScope, warning, -- * Scope helpers Scope(..), inKey, inIndex, ) where import Control.Applicative (Alternative(..)) import Control.Monad (MonadPlus, ap, liftM) import Data.Monoid (Endo(..)) -- | 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 a = Matcher { unMatcher :: forall r. [Scope] -> DList MatchMessage -> (DList MatchMessage -> r) -> (DList MatchMessage -> a -> r) -> r } instance Functor Matcher where fmap = liftM instance Applicative Matcher where pure x = Matcher (\_env warn _err ok -> ok warn x) (<*>) = ap instance Monad Matcher where m >>= f = Matcher (\env warn err ok -> unMatcher m env warn err (\warn' x -> unMatcher (f x) env warn' err ok)) {-# INLINE (>>=) #-} instance Alternative Matcher where empty = Matcher (\_env _warn err _ok -> err mempty) Matcher x <|> Matcher y = Matcher (\env warn err ok -> x env warn (\errs1 -> y env warn (\errs2 -> err (errs1 <> errs2)) ok) ok) instance MonadPlus Matcher -- | Scopes for TOML message. -- -- @since 1.3.0.0 data Scope = ScopeIndex Int -- ^ zero-based array index | ScopeKey String -- ^ 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. -- -- @since 1.3.0.0 data MatchMessage = MatchMessage { 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 -}) -- | 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. -- -- @since 1.3.0.0 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. -- -- @since 1.3.0.0 runMatcher :: Matcher a -> Result MatchMessage a runMatcher (Matcher m) = m [] mempty (Failure . runDList) (Success . runDList) -- | Run a 'Matcher' with a locally extended scope. -- -- @since 1.3.0.0 withScope :: Scope -> Matcher a -> Matcher a withScope ctx (Matcher m) = Matcher (\env -> m (ctx : env)) -- | Get the current list of scopes. -- -- @since 1.3.0.0 getScope :: Matcher [Scope] getScope = Matcher (\env warn _err ok -> ok warn (reverse env)) -- | Emit a warning mentioning the current scope. warning :: String -> Matcher () warning w = do loc <- getScope Matcher (\_env warn _err ok -> ok (warn <> one (MatchMessage loc w)) ()) -- | Fail with an error message annotated to the current location. instance MonadFail Matcher where fail e = do loc <- getScope Matcher (\_env _warn err _ok -> err (one (MatchMessage loc e))) -- | Update the scope with the message corresponding to a table key -- -- @since 1.3.0.0 inKey :: String -> Matcher a -> Matcher a inKey = withScope . ScopeKey -- | Update the scope with the message corresponding to an array index -- -- @since 1.3.0.0 inIndex :: Int -> Matcher a -> Matcher a inIndex = withScope . ScopeIndex toml-parser-1.3.2.0/src/Toml/FromValue/ParseTable.hs0000644000000000000000000001034407346545000020273 0ustar0000000000000000{-| Module : Toml.FromValue.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. This module provides the 'ParseTable' implementation, but most of the basic functionality is exported directly from "Toml.FromValue". -} module Toml.FromValue.ParseTable ( -- * Base interface ParseTable, KeyAlt(..), pickKey, runParseTable, -- * Primitives liftMatcher, warnTable, setTable, getTable, ) where import Control.Applicative (Alternative, empty) import Control.Monad (MonadPlus) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State.Strict (StateT(..), get, put) import Data.List (intercalate) import Data.Map qualified as Map import Toml.FromValue.Matcher (warning, Matcher, inKey) import Toml.Pretty (prettySimpleKey) import Toml.Value (Table, Value) -- | A 'Matcher' that tracks a current set of unmatched key-value -- pairs from a table. -- -- Use 'Toml.FromValue.optKey' and 'Toml.FromValue.reqKey' to extract keys. -- -- Use 'getTable' and 'setTable' to override the table and implement -- other primitives. newtype ParseTable a = ParseTable (StateT Table Matcher a) deriving (Functor, Applicative, Monad, Alternative, MonadPlus) -- | Implemented in terms of 'fail' on 'Matcher' instance MonadFail ParseTable where fail = ParseTable . fail -- | Lift a matcher into the current table parsing context. liftMatcher :: Matcher a -> ParseTable a liftMatcher = ParseTable . 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. runParseTable :: ParseTable a -> Table -> Matcher a runParseTable (ParseTable p) t = do (x, t') <- runStateT p t case Map.keys t' of [] -> pure x [k] -> x <$ warning ("unexpected key: " ++ show (prettySimpleKey k)) ks -> x <$ warning ("unexpected keys: " ++ intercalate ", " (map (show . prettySimpleKey) ks)) -- | Return the remaining portion of the table being matched. getTable :: ParseTable Table getTable = ParseTable get -- | Replace the remaining portion of the table being matched. setTable :: Table -> ParseTable () setTable = ParseTable . put -- | Emit a warning at the current location. warnTable :: String -> ParseTable () warnTable = ParseTable . lift . warning -- | Key and value matching function -- -- @since 1.2.0.0 data KeyAlt a = Key String (Value -> Matcher a) -- ^ pick alternative based on key match | Else (Matcher 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.FromValue.reqKey' cases together with @('<|>')@ because that will -- generate one error message for each unmatched alternative as well as -- the error associate with the matched alternative. -- -- @since 1.2.0.0 pickKey :: [KeyAlt a] -> ParseTable a pickKey xs = do 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 $! Map.delete k t liftMatcher (inKey k (c v)) errCase = case xs of [] -> empty -- there's nothing a user can do here [Key k _] -> fail ("missing key: " ++ show (prettySimpleKey k)) _ -> fail ("possible keys: " ++ intercalate ", " [show (prettySimpleKey k) | Key k _ <- xs]) toml-parser-1.3.2.0/src/Toml/Generic.hs0000644000000000000000000000552407346545000015731 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, UndecidableInstances, ScopedTypeVariables #-} {-| Module : Toml.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 @Coord 1 2@. @ 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.Generic ( GenericTomlTable(GenericTomlTable), GenericTomlArray(GenericTomlArray), ) where import Data.Coerce (coerce) import GHC.Generics (Generic(Rep)) import Toml.FromValue (FromValue(fromValue), parseTableFromValue) import Toml.FromValue.Generic (GParseTable, GFromArray, genericParseTable, genericFromArray) import Toml.FromValue.Matcher (Matcher) import Toml.ToValue (ToTable(toTable), ToValue(toValue), defaultTableToValue) import Toml.ToValue.Generic (GToTable, GToArray, genericToTable, genericToArray) import Toml.Value (Value, Table) -- | Helper type to use GHC's DerivingVia extension to derive -- 'ToValue', 'ToTable', 'FromValue' for records. -- -- @since 1.3.2.0 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 = coerce (parseTableFromValue genericParseTable :: Value -> Matcher a) {-# INLINE fromValue #-} -- | Helper type to use GHC's DerivingVia extension to derive -- 'ToValue', 'ToTable', 'FromValue' for any product type. -- -- @since 1.3.2.0 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 = coerce (genericFromArray :: Value -> Matcher a) {-# INLINE fromValue #-}toml-parser-1.3.2.0/src/Toml/Lexer.x0000644000000000000000000001573207346545000015273 0ustar0000000000000000{ {-| Module : Toml.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.Lexer (Context(..), scanToken, lexValue, Token(..)) where import Toml.Lexer.Token import Toml.Lexer.Utils import Toml.Located import Toml.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_char = [\x09 \x20-\x26 \x28-\x7E] @mll_content = $mll_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} @time_secfrac = "." $digit+ @time_numoffset = [\+\-] @time_hour ":" @time_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 { token TokBareKey } \"{3} @newline? { startMlBstr } \" { startBstr } "'''" @newline? { startMlLstr } "'" { startLstr } } { $literal_char+ { strFrag } "'" { endStr . fmap (drop 1) } } { $unescaped+ { strFrag } \" { endStr . fmap (drop 1) } } { @mll_content+ { strFrag } "'" {1,2} { strFrag } "'" {3,5} { endStr . fmap (drop 3) } } { @mlb_escaped_nl; ($unescaped | @newline)+ { strFrag } \" {1,2} { strFrag } \" {3,5} { endStr . fmap (drop 3) } } { \\ U $hexdig{8} { unicodeEscape } \\ U { failure "\\U requires exactly 8 hex digits"} \\ u $hexdig{4} { unicodeEscape } \\ u { failure "\\u requires exactly 4 hex digits"} \\ n { strFrag . ("\n" <$) } \\ t { strFrag . ("\t" <$) } \\ r { strFrag . ("\r" <$) } \\ f { strFrag . ("\f" <$) } \\ b { strFrag . ("\b" <$) } \\ \\ { strFrag . ("\\" <$) } \\ \" { strFrag . ("\"" <$) } $control # [\t\r\n] { recommendEscape } } { type AlexInput = Located String alexGetByte :: AlexInput -> Maybe (Int, AlexInput) alexGetByte = locatedUncons -- | Get the next token from a located string. This function can be total -- because one of the possible token outputs is an error token. scanToken :: Context -> Located String -> Either (Located String) (Located Token, Located String) scanToken st str = case alexScan str (stateInt st) of AlexEOF -> eofToken st str AlexError str' -> Left (mkError <$> str') AlexSkip str' _ -> scanToken st str' AlexToken str' n action -> case action (take n <$> str) st of Resume st' -> scanToken st' str' LexerError e -> Left e EmitToken t -> Right (t, str') stateInt :: Context -> Int stateInt TopContext = 0 stateInt TableContext = tab stateInt ValueContext = val stateInt BstrContext {} = bstr stateInt MlBstrContext{} = mlbstr stateInt LstrContext {} = lstr stateInt MlLstrContext{} = mllstr -- | Lex a single token in a value context. This is mostly useful for testing. lexValue :: String -> 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-1.3.2.0/src/Toml/Lexer/0000755000000000000000000000000007346545000015072 5ustar0000000000000000toml-parser-1.3.2.0/src/Toml/Lexer/Token.hs0000644000000000000000000001002207346545000016501 0ustar0000000000000000{-| Module : Toml.Lexer.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.Lexer" and consumed in "Toml.Parser". -} module Toml.Lexer.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 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 String -- ^ bare key | TokString String -- ^ string literal | TokMlString String -- ^ 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"] -- | Format strings for local datetime lexemes. localDateTimePatterns :: [String] localDateTimePatterns = ["%Y-%m-%dT%H:%M:%S%Q", "%Y-%m-%d %H:%M:%S%Q"] -- | 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"] toml-parser-1.3.2.0/src/Toml/Lexer/Utils.hs0000644000000000000000000001456607346545000016542 0ustar0000000000000000{-| Module : Toml.Lexer.Utils 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.Lexer.Utils ( -- * Types Action, Context(..), Outcome(..), -- * Input processing locatedUncons, -- * Actions token, token_, 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.Time.Format (parseTimeM, defaultTimeLocale, ParseTime) import Numeric (readHex) import Text.Printf (printf) import Toml.Lexer.Token (Token(..)) import Toml.Located (Located(..)) import Toml.Position (move, Position) -- | Type of actions associated with lexer patterns type Action = Located String -> 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 [String] -- ^ multiline basic string: position of opening delimiter and list of fragments | BstrContext Position [String] -- ^ basic string: position of opening delimiter and list of fragments | MlLstrContext Position [String] -- ^ multiline literal string: position of opening delimiter and list of fragments | LstrContext Position [String] -- ^ 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 (concat (reverse (x : acc))))) MlBstrContext p acc -> EmitToken (Located p (TokMlString (concat (reverse (x : acc))))) LstrContext p acc -> EmitToken (Located p (TokString (concat (reverse (x : acc))))) MlLstrContext p acc -> EmitToken (Located p (TokMlString (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 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 [chr n]) ctx _ -> error "unicodeEscape: panic" recommendEscape :: Action recommendEscape (Located p x) _ = LexerError (Located p (printf "control characters must be escaped, use: \\u%04X" (ord (head x)))) -- | Emit a token ignoring the current lexeme token_ :: Token -> Action token_ t x _ = EmitToken (t <$ x) -- | Emit a token using the current lexeme token :: (String -> Token) -> Action token 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 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 String -> Maybe (Int, Located String) locatedUncons Located { locPosition = p, locThing = str } = case str of "" -> Nothing 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 String -> Either (Located String) (Located Token, Located String) 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 xtoml-parser-1.3.2.0/src/Toml/Located.hs0000644000000000000000000000141307346545000015721 0ustar0000000000000000{-| Module : Toml.Located Description : Values annotated with positions Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com This module provides a simple tuple for tracking pairs of values and their file locations. -} module Toml.Located ( Located(..) ) where import Toml.Position (Position) -- | 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 -}) toml-parser-1.3.2.0/src/Toml/Parser.y0000644000000000000000000001174507346545000015451 0ustar0000000000000000{ {-| Module : Toml.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.Parser ( -- * Types Expr(..), SectionKind(..), Val(..), Key, -- * Parser parseRawToml, ) where import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty import Toml.Lexer (Context(..), Token(..)) import Toml.Located (Located(Located, locThing)) import Toml.Parser.Types (Expr(..), Key, Val(..), SectionKind(..)) import Toml.Parser.Utils (Parser, runParser, lexerP, errorP, push, pop, thenP, pureP, asString) import Toml.Position (startPos) } %tokentype { Located Token } %token 'true' { Located _ TokTrue } 'false' { Located _ TokFalse } ',' { Located _ TokComma } '=' { Located _ TokEquals } NEWLINE { Located _ TokNewline } '.' { Located _ TokPeriod } '[' { Located _ TokSquareO } ']' { Located _ TokSquareC } '[[' { Located _ Tok2SquareO } ']]' { Located _ Tok2SquareC } '{' { Located _ TokCurlyO } '}' { Located _ TokCurlyC } BAREKEY { Located _ (TokBareKey _ ) } STRING { Located _ (TokString _ ) } MLSTRING { Located _ (TokMlString $$) } INTEGER { Located _ (TokInteger $$) } FLOAT { Located _ (TokFloat $$) } OFFSETDATETIME { Located _ (TokOffsetDateTime $$) } LOCALDATETIME { Located _ (TokLocalDateTime $$) } LOCALDATE { Located _ (TokLocalDate $$) } LOCALTIME { Located _ (TokLocalTime $$) } %monad { Parser r } { thenP } { pureP } %lexer { lexerP } { Located _ TokEOF } %error { errorP } %name parseRawToml_ toml %% toml :: { [Expr] } : sepBy1(expression, NEWLINE) { concat $1 } expression :: { [Expr] } : { [] } | keyval { [KeyValExpr (fst $1) (snd $1)] } | '[' key ']' { [TableExpr $2 ] } | '[[' key ']]' { [ArrayTableExpr $2 ] } keyval :: { (Key, Val) } : key rhs '=' pop val { ($1,$5) } key :: { Key } : sepBy1(simplekey, '.') { $1 } simplekey :: { Located String } : BAREKEY { fmap asString $1 } | STRING { fmap asString $1 } val :: { Val } : INTEGER { ValInteger $1 } | FLOAT { ValFloat $1 } | 'true' { ValBool True } | 'false' { ValBool False } | STRING { ValString (asString (locThing $1)) } | MLSTRING { ValString $1 } | LOCALDATE { ValDay $1 } | LOCALTIME { ValTimeOfDay $1 } | OFFSETDATETIME { ValZonedTime $1 } | LOCALDATETIME { ValLocalTime $1 } | array { ValArray $1 } | inlinetable { ValTable $1 } inlinetable :: { [(Key, Val)] } : lhs '{' sepBy(keyval, ',') pop '}' { $3 } array :: { [Val] } : rhs '[' newlines pop ']' { [] } | rhs '[' newlines arrayvalues pop ']' { reverse $4 } | rhs '[' newlines arrayvalues ',' newlines pop ']' { reverse $4 } arrayvalues :: { [Val] } : 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 :: String -> Either (Located String) [Expr] parseRawToml = runParser parseRawToml_ TopContext . Located startPos } toml-parser-1.3.2.0/src/Toml/Parser/0000755000000000000000000000000007346545000015247 5ustar0000000000000000toml-parser-1.3.2.0/src/Toml/Parser/Types.hs0000644000000000000000000000307007346545000016707 0ustar0000000000000000{-| Module : Toml.Raw 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.Parser.Types ( Key, Expr(..), Val(..), SectionKind(..), ) where import Data.List.NonEmpty (NonEmpty) import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime) import Toml.Located (Located) -- | Non-empty sequence of dotted simple keys type Key = NonEmpty (Located String) -- | Headers and assignments corresponding to lines of a TOML file data Expr = KeyValExpr Key Val -- ^ key value assignment: @key = value@ | TableExpr Key -- ^ table: @[key]@ | ArrayTableExpr Key -- ^ 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 = ValInteger Integer | ValFloat Double | ValArray [Val] | ValTable [(Key, Val)] | ValBool Bool | ValString String | ValTimeOfDay TimeOfDay | ValZonedTime ZonedTime | ValLocalTime LocalTime | ValDay Day deriving (Read, Show) -- | Kinds of table headers. data SectionKind = TableKind -- ^ [table] | ArrayTableKind -- ^ [[array of tables]] deriving (Read, Show, Eq) toml-parser-1.3.2.0/src/Toml/Parser/Utils.hs0000644000000000000000000000525107346545000016706 0ustar0000000000000000{-| Module : Toml.Parser.Utils 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. @since 1.3.0.0 -} module Toml.Parser.Utils ( Parser, runParser, pureP, thenP, asString, lexerP, errorP, -- * Lexer-state management push, pop, ) where import Toml.Lexer (scanToken, Context(..)) import Toml.Lexer.Token (Token(TokBareKey, TokString)) import Toml.Located (Located) import Toml.Pretty (prettyToken) -- continuation passing implementation of a state monad with errors newtype Parser r a = P { getP :: [Context] -> Located String -> ([Context] -> Located String -> a -> Either (Located String) r) -> Either (Located String) r } -- | Run the top-level parser runParser :: Parser r r -> Context -> Located String -> 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 (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 ctx of [] -> error "Toml.Parser.Utils.pop: PANIC! malformed production in parser" _ : 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 (head st) str of Left le -> Left (("lexical error: " ++) <$> le) Right (t, str') -> getP (f t) st str' k {-# Inline lexerP #-} -- | Extract the string content of a bare-key or a quoted string. asString :: Token -> String asString (TokString x) = x asString (TokBareKey x) = x asString _ = error "simpleKeyLexeme: panic" {-# Inline asString #-} toml-parser-1.3.2.0/src/Toml/Position.hs0000644000000000000000000000277307346545000016164 0ustar0000000000000000{-| Module : Toml.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.Position ( Position(..), startPos, move, ) where -- | 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-1.3.2.0/src/Toml/Pretty.hs0000644000000000000000000003233207346545000015641 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, -- * Pretty errors prettySemanticError, prettyMatchMessage, prettyLocated, ) where import Data.Char (ord, isAsciiLower, isAsciiUpper, isDigit, isPrint) import Data.Foldable (fold) import Data.List (partition, sortOn) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty import Data.Map qualified as Map import Data.String (fromString) import Data.Time (ZonedTime(zonedTimeZone), TimeZone (timeZoneMinutes)) import Data.Time.Format (formatTime, defaultTimeLocale) import Prettyprinter import Text.Printf (printf) import Toml.FromValue.Matcher (MatchMessage(..), Scope (..)) import Toml.Lexer (Token(..)) import Toml.Located (Located(..)) import Toml.Parser.Types (SectionKind(..)) import Toml.Position (Position(..)) import Toml.Semantics (SemanticError (..), SemanticErrorKind (..)) import Toml.Value (Value(..), Table) -- | 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 String -> TomlDoc prettyKey = annotate KeyClass . fold . NonEmpty.intersperse dot . fmap prettySimpleKey -- | Renders a simple-key using quotes where necessary. prettySimpleKey :: String -> Doc a prettySimpleKey str | not (null str), all isBareKey str = fromString str | otherwise = fromString (quoteString 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 '\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 <= '\xffff' -> printf "\\u%04X%s" (ord x) (go xs) | otherwise -> printf "\\U%08X%s" (ord x) (go xs) -- | Quote a string using basic string literal syntax. quoteMlString :: String -> String quoteMlString = ("\"\"\"\n"++) . go where go = \case "" -> "\"\"\"" -- terminator '"' : '"' : '"' : xs -> "\"\"\\\"" ++ go xs '\\' : xs -> '\\' : '\\' : go xs '\b' : xs -> '\\' : 'b' : go xs '\f' : xs -> '\\' : 'f' : go xs '\t' : xs -> '\\' : 't' : go xs '\n' : xs -> '\n' : go xs '\r' : '\n' : xs -> '\r' : '\n' : go xs '\r' : xs -> '\\' : 'r' : go xs x : xs | isPrint x -> x : go xs | x <= '\xffff' -> printf "\\u%04X%s" (ord x) (go xs) | otherwise -> printf "\\U%08X%s" (ord x) (go xs) -- | Pretty-print a section heading. The result is annotated as a 'TableClass'. prettySectionKind :: SectionKind -> NonEmpty String -> TomlDoc prettySectionKind TableKind key = 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 :: String -> Value -> TomlDoc prettyAssignment = go . pure where go ks (Table (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 -> TomlDoc prettyValue = \case Integer i -> annotate NumberClass (pretty i) Float f | isNaN f -> annotate NumberClass "nan" | isInfinite f -> annotate NumberClass (if f > 0 then "inf" else "-inf") | otherwise -> annotate NumberClass (pretty f) Array a -> align (list [prettyValue v | v <- a]) Table t -> lbrace <> concatWith (surround ", ") [prettyAssignment k v | (k,v) <- Map.assocs t] <> rbrace Bool True -> annotate BoolClass "true" Bool False -> annotate BoolClass "false" String str -> 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 :: String -> TomlDoc prettySmartString str | '\n' `elem` str = column \i -> pageWidth \case AvailablePerLine n _ | length str > n - i -> prettyMlString str _ -> prettyString str | otherwise = prettyString str prettyMlString :: String -> TomlDoc prettyMlString str = annotate StringClass (column \i -> hang (-i) (fromString (quoteMlString str))) prettyString :: String -> TomlDoc prettyString str = annotate StringClass (fromString (quoteString str)) -- | Predicate for values that CAN rendered on the -- righthand-side of an @=@. isSimple :: Value -> Bool isSimple = \case Integer _ -> True Float _ -> True Bool _ -> True String _ -> True TimeOfDay _ -> True ZonedTime _ -> True LocalTime _ -> True Day _ -> True Table x -> isSingularTable x -- differs from isAlwaysSimple Array x -> null x || not (all isTable x) -- | Predicate for values that can be MUST rendered on the -- righthand-side of an @=@. isAlwaysSimple :: Value -> Bool isAlwaysSimple = \case Integer _ -> True Float _ -> True Bool _ -> True String _ -> True TimeOfDay _ -> True ZonedTime _ -> True LocalTime _ -> True Day _ -> True Table _ -> False -- differs from isSimple Array x -> null x || not (all isTable x) -- | Predicate for table values. isTable :: Value -> 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 lefthand-side -- of a @=@. isSingularTable :: Table -> Bool isSingularTable (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 {- ^ 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 ancilliary 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 -- @ -- -- @since 1.2.1.0 prettyTomlOrdered :: Ord a => ([String] -> String -> a) {- ^ table path -> key -> projection -} -> Table {- ^ 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 => ([String] -> String -> a) -> KeyProjection prettyToml_ :: KeyProjection -> SectionKind -> [String] -> Table -> TomlDoc prettyToml_ mbKeyProj kind prefix 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 t (simple, sections) = partition (isAlwaysSimple . snd) kvs topLines = [fold topElts | let topElts = headers ++ assignments, not (null topElts)] headers = case NonEmpty.nonEmpty prefix of Just key | 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 (Array a) = vcat [prettyToml_ mbKeyProj ArrayTableKind key tab | Table tab <- a] prettySection _ _ = error "prettySection applied to simple value" -- | Render a semantic TOML error in a human-readable string. -- -- @since 1.3.0.0 prettySemanticError :: SemanticError -> String prettySemanticError (SemanticError key kind) = printf "key error: %s %s" (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" -- | Render a TOML decoding error as a human-readable string. -- -- @since 1.3.0.0 prettyMatchMessage :: MatchMessage -> String prettyMatchMessage (MatchMessage scope msg) = msg ++ " in top" ++ foldr f "" scope where f (ScopeIndex i) = ('[' :) . shows i . (']':) f (ScopeKey key) = ('.' :) . shows (prettySimpleKey key) prettyLocated :: Located String -> String prettyLocated (Located p s) = printf "%d:%d: %s" (posLine p) (posColumn p) s toml-parser-1.3.2.0/src/Toml/Semantics.hs0000644000000000000000000002122407346545000016276 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 (SemanticError(..), SemanticErrorKind(..), semantics) where import Control.Monad (foldM) import Data.List.NonEmpty (NonEmpty((:|))) import Data.Map (Map) import Data.Map qualified as Map import Toml.Located (locThing, Located) import Toml.Parser.Types (SectionKind(..), Key, Val(..), Expr(..)) import Toml.Value (Table, Value(..)) -- | This type represents errors generated when resolving keys in a TOML -- document. -- -- @since 1.3.0.0 data SemanticError = SemanticError { errorKey :: String, errorKind :: SemanticErrorKind } deriving ( Read {- ^ Default instance -}, Show {- ^ Default instance -}, Eq {- ^ Default instance -}, Ord {- ^ Default instance -}) -- | 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. -- -- @since 1.3.0.0 semantics :: [Expr] -> Either (Located SemanticError) Table 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 = Map String Frame -- | M is the error-handling monad used through this module for -- propagating semantic errors through the 'semantics' function. type M = Either (Located SemanticError) -- | 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 = FrameTable FrameKind FrameTable | FrameArray (NonEmpty FrameTable) -- stored in reverse order for easy "append" | FrameValue Value 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 supertable 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 -> Table framesToTable = fmap \case FrameTable _ t -> framesToValue t FrameArray (t :| ts) -> Array (rev (map framesToValue (t : ts))) FrameValue v -> v where rev = foldl (flip (:)) [] -- GHC fails to inline reverse -- | Convert 'FrameTable' to a 'Value' forgetting all of the -- frame distinctions. framesToValue :: FrameTable -> Value framesToValue = Table . framesToTable -- | 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 {- ^ section key -} -> [(Key, Val)] {- ^ values to install -} -> FrameTable {- ^ local frame map -} -> M FrameTable {- ^ error message or updated local frame table -} addSection kind (k :| []) kvs = alterFrame k \case -- defining a new table Nothing -> case kind of TableKind -> FrameTable Closed <$> go mempty ArrayTableKind -> FrameArray . (:| []) <$> go mempty -- defining a super table of a previously defined subtable Just (FrameTable Open t) -> case kind of TableKind -> FrameTable Closed <$> go t ArrayTableKind -> invalidKey k ImplicitlyTable -- Add a new array element to an existing table array Just (FrameArray (t :| ts)) -> case kind of TableKind -> invalidKey k ClosedTable ArrayTableKind -> FrameArray . (:| t : ts) <$> go mempty -- failure cases Just (FrameTable Closed _) -> invalidKey k ClosedTable Just (FrameTable Dotted _) -> error "addSection: dotted table left unclosed" Just (FrameValue {}) -> invalidKey k AlreadyAssigned where go = assignKeyVals kvs addSection kind (k1 :| k2 : ks) kvs = alterFrame k1 \case Nothing -> FrameTable Open <$> go mempty Just (FrameTable tk t) -> FrameTable tk <$> go t Just (FrameArray (t :| ts)) -> FrameArray . (:| ts) <$> go t Just (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 -> FrameTable closeDots = fmap \case FrameTable Dotted t -> FrameTable 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, Val)] -> FrameTable -> M FrameTable 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 -> Val -> FrameTable -> M FrameTable assign (key :| []) val = alterFrame key \case Nothing -> FrameValue <$> valToValue val Just{} -> invalidKey key AlreadyAssigned assign (key :| k1 : keys) val = alterFrame key \case Nothing -> go mempty Just (FrameTable Open t) -> go t Just (FrameTable Dotted t) -> go t Just (FrameTable Closed _) -> invalidKey key ClosedTable Just (FrameArray _) -> invalidKey key ClosedTable Just (FrameValue _) -> invalidKey key AlreadyAssigned where go t = FrameTable Dotted <$> assign (k1 :| keys) val t -- | Convert 'Val' to 'Value' potentially raising an error if -- it contains inline tables with key-conflicts. valToValue :: Val -> M Value valToValue = \case ValInteger x -> Right (Integer x) ValFloat x -> Right (Float x) ValBool x -> Right (Bool x) ValString x -> Right (String x) ValTimeOfDay x -> Right (TimeOfDay x) ValZonedTime x -> Right (ZonedTime x) ValLocalTime x -> Right (LocalTime x) ValDay x -> Right (Day x) ValArray xs -> Array <$> traverse valToValue xs ValTable kvs -> framesToValue <$> assignKeyVals kvs mempty -- | Abort validation by reporting an error about the given key. invalidKey :: Located String {- ^ subkey -} -> SemanticErrorKind {- ^ error kind -} -> M a invalidKey key kind = Left ((`SemanticError` kind) <$> key) -- | Specialization of 'Map.alterF' used to adjust a location in a 'FrameTable' alterFrame :: Located String -> (Maybe Frame -> M Frame) -> FrameTable -> M FrameTable alterFrame k f = Map.alterF (fmap Just . f) (locThing k) toml-parser-1.3.2.0/src/Toml/Semantics/0000755000000000000000000000000007346545000015741 5ustar0000000000000000toml-parser-1.3.2.0/src/Toml/Semantics/Ordered.hs0000644000000000000000000000733407346545000017670 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) @ @since 1.3.1.0 -} module Toml.Semantics.Ordered ( TableOrder, extractTableOrder, projectKey, ProjectedKey, debugTableOrder, ) where import Data.Foldable (foldl', toList) import Data.List (sortOn) import Data.Map (Map) import Data.Map qualified as Map import Toml.Located (Located(locThing)) import Toml.Parser.Types (Expr(..), Key, Val(ValTable, ValArray)) -- | Summary of the order of the keys in a TOML document. newtype TableOrder = TO (Map String KeyOrder) data KeyOrder = KeyOrder !Int TableOrder newtype ProjectedKey = PK (Either Int String) deriving (Eq, Ord) -- | Generate a projection function for use with 'Toml.Pretty.prettyTomlOrdered' projectKey :: TableOrder {- ^ table order -} -> [String] {- ^ table path -} -> String {- ^ key -} -> ProjectedKey {- ^ type suitable for ordering table keys -} projectKey (TO to) [] = \k -> case Map.lookup k to of Just (KeyOrder i _) -> PK (Left i) Nothing -> PK (Right k) projectKey (TO to) (p:ps) = case Map.lookup p to of Just (KeyOrder _ to') -> projectKey to' ps Nothing -> PK . Right emptyOrder :: TableOrder emptyOrder = TO Map.empty -- | Extract a 'TableOrder' from the output of 'Toml.Parser.parseRawToml' -- to be later used with 'projectKey'. extractTableOrder :: [Expr] -> TableOrder extractTableOrder = snd . foldl' addExpr ([], emptyOrder) addExpr :: ([String], TableOrder) -> Expr -> ([String], TableOrder) addExpr (prefix, to) = \case TableExpr k -> let k' = keyPath k in (k', addKey to k') ArrayTableExpr k -> let k' = keyPath k in (k', addKey to k') KeyValExpr k v -> (prefix, addVal prefix (addKey to (prefix ++ keyPath k)) v) addVal :: [String] -> TableOrder -> Val -> TableOrder addVal prefix to = \case ValArray xs -> foldl' (addVal prefix) to xs ValTable kvs -> foldl' (\acc (k,v) -> let k' = prefix ++ keyPath k in addVal k' (addKey acc k') v) to kvs _ -> to addKey :: TableOrder -> [String] -> TableOrder addKey to [] = to addKey (TO to) (x:xs) = TO (Map.alter f x to) where f Nothing = Just (KeyOrder (Map.size to) (addKey emptyOrder xs)) f (Just (KeyOrder i m)) = Just (KeyOrder i (addKey m xs)) keyPath :: Key -> [String] keyPath = map locThing . toList -- | Render a white-space nested representation of the key ordering extracted -- by 'extractTableOrder'. This is provided for debugging and understandability. debugTableOrder :: TableOrder -> String debugTableOrder to = unlines (go 0 to []) where go i (TO m) z = foldr (go1 i) z (sortOn p (Map.assocs m)) go1 i (k, KeyOrder _ v) z = (replicate (4*i) ' ' ++ k) : go (i+1) v z p (_, KeyOrder i _) = i toml-parser-1.3.2.0/src/Toml/ToValue.hs0000644000000000000000000001355507346545000015737 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} -- needed for type equality on old GHC {-| Module : Toml.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.ToValue.Generic" can be used to derive instances of 'ToTable' automatically for record types. -} module Toml.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 qualified import Data.Text.Lazy qualified import Data.Time (Day, TimeOfDay, LocalTime, ZonedTime) import Data.Word (Word8, Word16, Word32, Word64) import Numeric.Natural (Natural) import Toml.Value (Value(..), Table) -- | Build a 'Table' from a list of key-value pairs. -- -- Use '.=' for a convenient way to build the pairs. -- -- @since 1.3.0.0 table :: [(String, Value)] -> Table table = Map.fromList {-# INLINE table #-} -- | Convenience function for building key-value pairs while -- constructing a 'Table'. -- -- @'table' [a '.=' b, c '.=' d]@ (.=) :: ToValue a => String -> a -> (String, 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 = Array . 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 -- | @since 1.0.1.0 instance (ToKey k, ToValue v) => ToTable (Map k v) where toTable m = table [(toKey k, toValue v) | (k,v) <- Map.assocs m] -- | @since 1.0.1.0 instance (ToKey k, ToValue v) => ToValue (Map k v) 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. -- -- @since 1.3.0.0 class ToKey a where toKey :: a -> String -- | toKey = id -- -- @since 1.3.0.0 instance Char ~ a => ToKey [a] where toKey = id -- | toKey = unpack -- -- @since 1.3.0.0 instance ToKey Data.Text.Text where toKey = Data.Text.unpack -- | toKey = unpack -- -- @since 1.3.0.0 instance ToKey Data.Text.Lazy.Text where toKey = Data.Text.Lazy.unpack -- | 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 = String [x] toValueList = String -- | Encodes as string literal -- -- @since 1.2.1.0 instance ToValue Data.Text.Text where toValue = toValue . Data.Text.unpack -- | Encodes as string literal -- -- @since 1.2.1.0 instance ToValue Data.Text.Lazy.Text where toValue = toValue . Data.Text.Lazy.unpack -- | 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 -- -- @since 1.3.0.0 instance ToValue a => ToValue (NonEmpty a) where toValue = toValue . NonEmpty.toList -- | Converts to list and encodes that to value -- -- @since 1.3.0.0 instance ToValue a => ToValue (Seq a) where toValue = toValue . toList -- | Converts to a 'Double'. This can overflow to infinity. -- -- @since 1.3.0.0 instance Integral a => ToValue (Ratio a) where toValue = Float . realToFrac instance ToValue Double where toValue = Float instance ToValue Float where toValue = Float . 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 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-1.3.2.0/src/Toml/ToValue/0000755000000000000000000000000007346545000015372 5ustar0000000000000000toml-parser-1.3.2.0/src/Toml/ToValue/Generic.hs0000644000000000000000000000574207346545000017312 0ustar0000000000000000{-| Module : Toml.ToValue.Generic 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.ToValue.Generic ( -- * Records to Tables GToTable(..), genericToTable, -- * Product types to Arrays GToArray(..), genericToArray, ) where import Data.Map qualified as Map import GHC.Generics import Toml.Value (Table, Value(Array)) import Toml.ToValue (ToValue(..)) -- | Use a record's field names to generate a 'Table' -- -- @since 1.0.2.0 genericToTable :: (Generic a, GToTable (Rep a)) => a -> Table genericToTable x = Map.fromList (gToTable (from x) []) {-# INLINE genericToTable #-} -- | Use a record's field names to generate a 'Table' -- -- @since 1.3.2.0 genericToArray :: (Generic a, GToArray (Rep a)) => a -> Value genericToArray a = Array (gToArray (from a) []) {-# INLINE genericToArray #-} -- | Supports conversion of product types with field selector names -- to TOML values. -- -- @since 1.0.2.0 class GToTable f where gToTable :: f a -> [(String, Value)] -> [(String, 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))) = ((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)) = ((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. -- -- @since 1.3.2.0 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-1.3.2.0/src/Toml/Value.hs0000644000000000000000000000363107346545000015426 0ustar0000000000000000{-| Module : Toml.Value 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. -} module Toml.Value ( Value(..), Table, ) where import Data.Data (Data) import Data.Map (Map) import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime(zonedTimeToLocalTime, zonedTimeZone), timeZoneMinutes) import GHC.Generics (Generic) -- | Representation of a TOML key-value table. type Table = Map String Value -- | Semantic TOML value with all table assignments resolved. data Value = Integer Integer | Float Double | Array [Value] | Table Table | Bool Bool | String String | TimeOfDay TimeOfDay | ZonedTime ZonedTime | LocalTime LocalTime | Day Day deriving ( Show {- ^ Default instance -}, Read {- ^ Default instance -}, Data {- ^ Default instance -}, Generic {- ^ Default instance -}) -- | Nearly default instance except 'ZonedTime' doesn't have an -- 'Eq' instance. 'ZonedTime' values are equal if their times and -- timezones are both equal. instance Eq Value where Integer x == Integer y = x == y Float x == Float y = x == y Array x == Array y = x == y Table x == Table y = x == y Bool x == Bool y = x == y String x == String y = x == y TimeOfDay x == TimeOfDay y = x == y LocalTime x == LocalTime y = x == y Day x == Day y = x == y ZonedTime x == ZonedTime y = 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)) toml-parser-1.3.2.0/test/0000755000000000000000000000000007346545000013270 5ustar0000000000000000toml-parser-1.3.2.0/test/DecodeSpec.hs0000644000000000000000000001024107346545000015620 0ustar0000000000000000{-# Language DuplicateRecordFields #-} {-| 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, Result, encode) import Toml.FromValue (FromValue(..), reqKey, optKey) import Toml.FromValue.Generic (genericParseTable) import Toml.ToValue (ToTable(..), ToValue(toValue), table, (.=), defaultTableToValue) import Toml.ToValue.Generic (genericToTable) import Toml (Result(..)) import Toml.FromValue (parseTableFromValue) 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 = parseTableFromValue genericParseTable instance FromValue Physical where fromValue = parseTableFromValue genericParseTable instance FromValue Variety where fromValue = parseTableFromValue genericParseTable 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 [ "unexpected keys: count, taste in top.fruits[0]", "unexpected key: color in top.fruits[1]"] (Fruits [Fruit "peach" Nothing [], Fruit "pineapple" Nothing []]) it "handles missing key errors" $ (decode "[[fruits]]" :: Result String Fruits) `shouldBe` Failure ["missing key: name in top.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-1.3.2.0/test/DerivingViaSpec.hs0000644000000000000000000000362607346545000016655 0ustar0000000000000000{-# LANGUAGE DerivingVia, DeriveGeneric #-} {-| 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 (Value(..)) import Toml.FromValue ( FromValue(fromValue) ) import Toml.FromValue.Matcher (runMatcher, Result(Success)) import Toml.Generic (GenericTomlTable(..), GenericTomlArray(..)) import Toml.ToValue (ToTable(toTable), (.=), table, ToValue(toValue)) 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" .= "red", "shape" .= "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 (Array [Integer 42, String "forty-two"])) `shouldBe` Success [] (TwoThings 42 "forty-two") it "converts to arrays positionally" $ toValue (TwoThings 42 "forty-two") `shouldBe` Array [Integer 42, String "forty-two"] toml-parser-1.3.2.0/test/FromValueSpec.hs0000644000000000000000000001004707346545000016341 0ustar0000000000000000{-| 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 (Result(..), Value(..)) import Toml.FromValue (FromValue(fromValue), optKey, reqKey, warnTable, pickKey, runParseTable) import Toml.FromValue.Matcher (Matcher, runMatcher) import Toml.FromValue.ParseTable (KeyAlt(..)) import Toml.Pretty (prettyMatchMessage) import Toml.ToValue (table, (.=)) humanMatcher :: Matcher a -> Result String a humanMatcher m = case runMatcher m of Failure e -> Failure (prettyMatchMessage <$> e) Success w x -> Success (prettyMatchMessage <$> w) x spec :: Spec spec = do it "handles one reqKey" $ humanMatcher (runParseTable (reqKey "test") (table ["test" .= "val"])) `shouldBe` Success [] "val" it "handles one optKey" $ humanMatcher (runParseTable (optKey "test") (table ["test" .= "val"])) `shouldBe` Success [] (Just "val") it "handles one missing optKey" $ humanMatcher (runParseTable (optKey "test") (table ["nottest" .= "val"])) `shouldBe` Success ["unexpected key: nottest in top"] (Nothing :: Maybe String) it "handles one missing reqKey" $ humanMatcher (runParseTable (reqKey "test") (table ["nottest" .= "val"])) `shouldBe` (Failure ["missing key: test in top"] :: Result String String) it "handles one mismatched reqKey" $ humanMatcher (runParseTable (reqKey "test") (table ["test" .= "val"])) `shouldBe` (Failure ["type error. wanted: integer got: string in top.test"] :: Result String Integer) it "handles one mismatched optKey" $ humanMatcher (runParseTable (optKey "test") (table ["test" .= "val"])) `shouldBe` (Failure ["type error. wanted: integer got: string in top.test"] :: Result String (Maybe Integer)) it "handles concurrent errors" $ humanMatcher (runParseTable (reqKey "a" <|> empty <|> reqKey "b") (table [])) `shouldBe` (Failure ["missing key: a in top", "missing key: b in top"] :: Result String Integer) it "handles concurrent value mismatch" $ let v = String "" in humanMatcher (Left <$> fromValue v <|> empty <|> Right <$> fromValue v) `shouldBe` (Failure [ "type error. wanted: boolean got: string in top", "type error. wanted: integer got: string in top"] :: Result String (Either Bool Int)) it "doesn't emit an error for empty" $ humanMatcher (runParseTable empty (table [])) `shouldBe` (Failure [] :: Result String Integer) it "matches single characters" $ runMatcher (fromValue (String "x")) `shouldBe` Success [] 'x' it "rejections non-single characters" $ humanMatcher (fromValue (String "xy")) `shouldBe` (Failure ["type error. wanted: character got: string in top"] :: 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 (runParseTable pt (table ["k1" .= (1 :: Integer), "k2" .= (2 :: Integer)])) `shouldBe` Success ["k1 and k2 sum to an odd value in top"] (3 :: Integer) it "offers helpful messages when no keys match" $ let pt = pickKey [Key "this" \_ -> pure 'a', Key "." \_ -> pure 'b'] in humanMatcher (runParseTable pt (table [])) `shouldBe` (Failure ["possible keys: this, \".\" in top"] :: Result String Char) it "generates an error message on an empty pickKey" $ let pt = pickKey [] in humanMatcher (runParseTable pt (table [])) `shouldBe` (Failure [] :: Result String Char) toml-parser-1.3.2.0/test/HieDemoSpec.hs0000644000000000000000000003644107346545000015761 0ustar0000000000000000{-# Language GADTs #-} {-| 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.FromValue" 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 GHC.Generics ( Generic ) import QuoteStr (quoteStr) import Test.Hspec (Spec, it, shouldBe) import Toml (Value(Table, Array), Table, decode) import Toml.FromValue import Toml.FromValue.Generic (genericParseTable) ----------------------------------------------------------------------- -- 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 = parseTableFromValue genericParseTable 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 = parseTableFromValue genericParseTable instance FromValue CabalConfig where fromValue v@Toml.Array{} = CabalConfig Nothing . ManyComponents <$> fromValue v fromValue (Toml.Table t) = getComponentTable CabalConfig "cabalProject" t fromValue _ = fail "cabal configuration expects table or array" getComponentTable :: FromValue b => (Maybe FilePath -> OneOrManyComponents b -> a) -> String -> Toml.Table -> Matcher a getComponentTable con pathKey = runParseTable $ 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.Array{} = StackConfig Nothing . ManyComponents <$> fromValue v fromValue (Toml.Table t) = getComponentTable StackConfig "stackYaml" 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 = parseTableFromValue genericParseTable 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) -> String -> KeyCase a reqAlts :: [KeyCase a] -> ParseTable a reqAlts xs = pickKey [Key key (fmap con . fromValue) | KeyCase con key <- xs] optAlts :: [KeyCase a] -> ParseTable (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 ["type error. wanted: string got: integer in top.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 [ "unexpected key: thing1 in top.cradle.multi[0].config.cradle.cabal" , "unexpected keys: thing2, thing3 in top.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-1.3.2.0/test/LexerSpec.hs0000644000000000000000000000525107346545000015521 0ustar0000000000000000module LexerSpec (spec) where import Data.Map qualified as Map import Test.Hspec (it, shouldBe, Spec) import Toml (parse, Value(Integer)) 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 (Map.singleton "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:7: lexical error: unexpected end-of-input" it "handles invalid escapes" $ parse "x = \"\\p\"" `shouldBe` Left "1:7: lexical error: unexpected 'p'" toml-parser-1.3.2.0/test/Main.hs0000644000000000000000000000005407346545000014507 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} toml-parser-1.3.2.0/test/PrettySpec.hs0000644000000000000000000001041007346545000015722 0ustar0000000000000000module PrettySpec (spec) where import Test.Hspec (it, shouldBe, Spec) import QuoteStr (quoteStr) import Toml (encode, parse, prettyToml, Table) import Data.Map qualified as Map tomlString :: Table -> String tomlString = show . prettyToml spec :: Spec spec = do it "renders example 1" $ show (encode (Map.singleton "x" (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\\\"\\u007f\\U0001000c\"") `shouldBe` Right [quoteStr| a = "\\\b\t\r\n\f\"\u007F\U0001000C"|] it "renders multiline strings" $ fmap tomlString (parse [quoteStr| Everything-I-Touch = "Everything I touch\nwith tenderness, alas,\npricks like a bramble." Two-More = [ "The west wind whispered,\nAnd touched the eyelids of spring:\nHer eyes, Primroses.", "Plum flower temple:\nVoices rise\nFrom the foothills", ]|]) `shouldBe` Right [quoteStr| Everything-I-Touch = """ Everything I touch with tenderness, alas, pricks like a bramble.""" Two-More = [ """ The west wind whispered, And touched the eyelids of spring: Her eyes, Primroses.""" , "Plum flower temple:\nVoices rise\nFrom the foothills" ]|] it "renders floats" $ fmap tomlString (parse "a=0.0\nb=-0.1\nc=0.1\nd=3.141592653589793\ne=4e123") `shouldBe` Right [quoteStr| 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-1.3.2.0/test/QuoteStr.hs0000644000000000000000000000215107346545000015411 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-1.3.2.0/test/ToValueSpec.hs0000644000000000000000000000066407346545000016024 0ustar0000000000000000module ToValueSpec where import Test.Hspec (it, shouldBe, Spec) import Toml (Value(..)) import Toml.ToValue (ToValue(toValue)) spec :: Spec spec = do it "converts characters as singleton strings" $ toValue '!' `shouldBe` String "!" it "converts strings normally" $ toValue "demo" `shouldBe` String "demo" it "converts lists" $ toValue [1,2,3::Int] `shouldBe` Array [Integer 1, Integer 2, Integer 3] toml-parser-1.3.2.0/test/TomlSpec.hs0000644000000000000000000006357207346545000015367 0ustar0000000000000000{-# Language QuasiQuotes #-} {-| 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.Time (Day) import QuoteStr (quoteStr) import Test.Hspec (describe, it, shouldBe, shouldSatisfy, Spec) import Toml (Value(..), parse, decode, Result(Success)) import Toml.ToValue (table, (.=)) 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",String "# This is not a comment"),("key",String "value")]) describe "key/value pair" do it "supports the most basic assignments" $ parse "key = \"value\"" `shouldBe` Right (Map.singleton "key" (String "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" .= "value", "bare-key" .= "value", "bare_key" .= "value", "key" .= "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" .= "value", "character encoding" .= "value", "key2" .= "value", "quoted \"value\"" .= "value", "ʎǝʞ" .= "value"]) it "allows dotted keys" $ parse [quoteStr| name = "Orange" physical.color = "orange" physical.shape = "round" site."google.com" = true|] `shouldBe` Right (table [ "name" .= "Orange", "physical" .= table ["color" .= "orange", "shape" .= "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" .= "red", "skin" .= "thin", "type" .= "fruit"], "orange" .= table [ "color" .= "orange", "skin" .= "thick", "type" .= "fruit"]]) it "allows numeric bare keys" $ parse "3.14159 = 'pi'" `shouldBe` Right (table [ "3" .= table [("14159", String "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 (Map.singleton "str" (String "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 (Map.singleton "str1" (String "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" .= "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."]) 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" .= "Here are two quotation marks: \"\". Simple enough.", "str5" .= "Here are three quotation marks: \"\"\".", "str6" .= "Here are fifteen quotation marks: \"\"\"\"\"\"\"\"\"\"\"\"\"\"\".", "str7" .= "\"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" .= "Tom \"Dubs\" Preston-Werner", "regex" .= "<\\i\\c*\\s*>", "winpath" .= "C:\\Users\\nodejs\\templates", "winpath2" .= "\\\\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" .= "The first newline is\ntrimmed in raw strings.\nAll other whitespace\nis preserved.\n", "regex2" .= "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" .= "\\\b\f\r\x0010abcd", "y" .= "\\\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" .= Float 1.0, "flt2" .= Float 3.1415, "flt3" .= Float (-1.0e-2), "flt4" .= Float 4.9999999999999996e22, "flt5" .= Float 1000000.0, "flt6" .= Float (-2.0e-2), "flt7" .= Float 6.626e-34, "flt8" .= Float 224617.445991228, "sf1" .= Float (1/0), "sf2" .= Float (1/0), "sf3" .= Float (-1/0)]) it "parses nan correctly" $ let checkNaN (Float 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 x -> all checkNaN 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 (Map.singleton "x" (Float (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 (Map.singleton "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" .= ["red", "yellow", "green"], "contributors" .= [ String "Foo Bar ", Table (table [ "email" .= "bazqux@example.com", "name" .= "Baz Qux", "url" .= "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], [String "a", String "b", String "c"]], "numbers" .= [Float 0.1, Float 0.2, Float 0.5, Integer 1, Integer 2, Integer 5], "string_array" .= ["all", "strings", "are the same", "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 (Map.singleton "x" (Array [Array [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" .= "some string", "key2" .= Integer 123], "table-2" .= table [ "key1" .= "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" .= "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" .= "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" .= "pug"]], "name" .= table ["first" .= "Tom", "last" .= "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" [ table [ "name" .= "Hammer", "sku" .= Integer 738594937], Map.empty, table [ "color" .= "gray", "name" .= "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" .= "apple", "physical" .= table [ "color" .= "red", "shape" .= "round"], "varieties" .= [ table ["name" .= "red delicious"], table ["name" .= "granny smith"]]], table [ "name" .= "banana", "varieties" .= [ table ["name" .= "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-1.3.2.0/toml-parser.cabal0000644000000000000000000000705107346545000015545 0ustar0000000000000000cabal-version: 3.0 name: toml-parser version: 1.3.2.0 synopsis: TOML 1.0.0 parser description: TOML parser using generated lexers and parsers with careful attention to the TOML 1.0.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.4, 9.8.1} 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.FromValue Toml.FromValue.Generic Toml.FromValue.Matcher Toml.FromValue.ParseTable Toml.Generic Toml.Lexer Toml.Lexer.Token Toml.Located Toml.Parser Toml.Parser.Types Toml.Position Toml.Pretty Toml.Semantics Toml.Semantics.Ordered Toml.ToValue Toml.ToValue.Generic Toml.Value other-modules: Toml.Lexer.Utils Toml.Parser.Utils build-depends: array ^>= 0.5, base ^>= {4.14, 4.15, 4.16, 4.17, 4.18, 4.19}, containers ^>= {0.5, 0.6, 0.7}, prettyprinter ^>= 1.7, text >= 0.2 && < 3, time ^>= {1.9, 1.10, 1.11, 1.12}, transformers ^>= {0.5, 0.6}, build-tool-depends: alex:alex >= 3.2, happy:happy >= 1.19, 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}, 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}, 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 hs-source-dirs: benchmarker