packages feed

toml-parser 1.3.2.0 → 2.0.2.0

raw patch · 51 files changed

Files

ChangeLog.md view
@@ -1,5 +1,41 @@ # Revision history for toml-parser +## 2.0.2.0++* Update for TOML 1.1.0+  - Add \e and \x escapes+  - Allow omitting seconds in times+  - Allow newlines and trailing commas in inline tables++## 2.0.1.2++* Reject inputs with out-of-bounds time zone offsets in accordance+  with the toml-tests test suite.++## 2.0.1.1++* Fixes bug that prohibited non-ASCII characters in `'''` strings.++## 2.0.1.0++* Added `ToValue UTCTime` and `FromValue UTCTime`. These correspond+  to offset data-times with the timezone translated to UTC.++## 2.0.0.0++* Pervasive annotations on the values added to allow for detailed+  positional error reporting throughout parsing and validation.+* Replace uses of String with Text in the Value type and throughout+  the API+* Reorganized almost all of the modules to minimize imports that upstream+  packages will actually need.++## 1.3.3.0++* Added `IsString Value` instance.+* Addded helpers for `runMatcher` for ignoring and failing on warning+  `runMatcherIgnoreWarn` and `runMatcherFatalWarn`+ ## 1.3.2.0  * Added `Toml.Generic` to make instances easily derivable via DerivingVia.
README.lhs view
@@ -1,6 +1,6 @@ # TOML Parser -This package implements a validating parser for [TOML 1.0.0](https://toml.io/en/v1.0.0).+This package implements a validating parser for [TOML 1.1.0](https://toml.io/en/v1.1.0).  This package uses an [alex](https://haskell-alex.readthedocs.io/en/latest/)-generated lexer and [happy](https://haskell-happy.readthedocs.io/en/latest/)-generated parser.@@ -18,22 +18,23 @@      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-+    TOML --> [Token]: Lexer+    [Token] --> [Expr]: Parser+    [Expr] --> Table : Semantics+    Table --> ApplicationTypes : FromValue+    ApplicationTypes --> Table : ToValue+    Table --> 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.+Most users will only need to import **Toml** or **Toml.Schema**. Other top-level+modules are for low-level hacking on the TOML format itself. All modules below+these top-level modules are exposed to provide direct access to library implementation+details. -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.+- **Toml** - Basic encoding and decoding TOML+- **Toml.Schema** - TOML schemas for application types+- **Toml.Semantics** - Low-level semantic operations on TOML syntax+- **Toml.Syntax** - Low-level parsing of text into TOML raw syntax  ## Examples @@ -41,16 +42,16 @@ to ensure that its code typechecks and stays in sync with the rest of the package.  ```haskell+{-# Language OverloadedStrings #-}+import Data.Text (Text) import GHC.Generics (Generic) import QuoteStr (quoteStr) import Test.Hspec (Spec, hspec, it, shouldBe)-import Toml (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, (.=))+import Toml+import Toml.Schema  main :: IO ()-main = hspec (parses >> decodes >> encodes)+main = hspec (parses >> decodes >> encodes >> warns >> errors) ```  ### Using the raw parser@@ -58,7 +59,7 @@ Consider this sample TOML text from the TOML specification.  ```haskell-fruitStr :: String+fruitStr :: Text fruitStr = [quoteStr| ``` @@ -88,35 +89,35 @@ |] ``` -Parsing using this package generates the following value+Parsing using this package generates the following unstructured value  ```haskell parses :: Spec parses = it "parses" $-    parse fruitStr+    forgetTableAnns <$> parse fruitStr     `shouldBe`     Right (table [-        ("fruits", Array [+        ("fruits", List [             Table (table [-                ("name", String "apple"),+                ("name", Text "apple"),                 ("physical", Table (table [-                    ("color", String "red"),-                    ("shape", String "round")])),-                ("varieties", Array [-                    Table (table [("name", String "red delicious")]),-                    Table (table [("name", String "granny smith")])])]),+                    ("color", Text "red"),+                    ("shape", Text "round")])),+                ("varieties", List [+                    Table (table [("name", Text "red delicious")]),+                    Table (table [("name", Text "granny smith")])])]),             Table (table [-                ("name", String "banana"),-                ("varieties", Array [-                    Table (table [("name", String "plantain")])])])])])+                ("name", Text "banana"),+                ("varieties", List [+                    Table (table [("name", Text "plantain")])])])])]) ``` -### Using decoding classes+### Defining a schema -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.+We can define a schema for our TOML format in the form of instances of+`FromValue`, `ToValue`, and `ToTable` in order to read TOML directly+into structured data form. This example manually derives some of the+instances as a demonstration.  ```haskell newtype Fruits = Fruits { fruits :: [Fruit] }@@ -128,16 +129,19 @@     deriving (ToTable, ToValue, FromValue) via GenericTomlTable Fruit  data Physical = Physical { color :: String, shape :: String }-    deriving (Eq, Show)+    deriving (Eq, Show, Generic)+    deriving (ToTable, ToValue, FromValue) via GenericTomlTable Physical  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")+instance ToValue Variety where+    toValue = defaultTableToValue+instance ToTable Variety where+    toTable (Variety x) = table ["name" .= x]+ ```  We can run this example on the original value to deserialize it into domain-specific datatypes.@@ -153,24 +157,7 @@             (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@@ -190,6 +177,35 @@          [[fruits.varieties]]         name = "granny smith"|]+```++### Useful errors and warnings++This package takes care to preserve source information as much as possible+in order to provide useful feedback to users. These examples show a couple+of the message that can be generated when things don't go perfectly.++```haskell+warns :: Spec+warns = it "warns" $+    decode [quoteStr|+        name = "simulated"+        typo = 10|]+    `shouldBe`+    Success+        ["2:1: unexpected key: typo in <top-level>"] -- warnings+        (Variety "simulated")++errors :: Spec+errors = it "errors" $+    decode [quoteStr|+        # Physical characteristics table+        color = "blue"+        shape = []|]+    `shouldBe`+    (Failure+        ["3:9: expected string but got array in shape"]+        :: Result String Physical) ```  ## More Examples
README.md view
@@ -1,6 +1,6 @@ # TOML Parser -This package implements a validating parser for [TOML 1.0.0](https://toml.io/en/v1.0.0).+This package implements a validating parser for [TOML 1.1.0](https://toml.io/en/v1.1.0).  This package uses an [alex](https://haskell-alex.readthedocs.io/en/latest/)-generated lexer and [happy](https://haskell-happy.readthedocs.io/en/latest/)-generated parser.@@ -18,22 +18,23 @@      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-+    TOML --> [Token]: Lexer+    [Token] --> [Expr]: Parser+    [Expr] --> Table : Semantics+    Table --> ApplicationTypes : FromValue+    ApplicationTypes --> Table : ToValue+    Table --> 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.+Most users will only need to import **Toml** or **Toml.Schema**. Other top-level+modules are for low-level hacking on the TOML format itself. All modules below+these top-level modules are exposed to provide direct access to library implementation+details. -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.+- **Toml** - Basic encoding and decoding TOML+- **Toml.Schema** - TOML schemas for application types+- **Toml.Semantics** - Low-level semantic operations on TOML syntax+- **Toml.Syntax** - Low-level parsing of text into TOML raw syntax  ## Examples @@ -41,16 +42,16 @@ to ensure that its code typechecks and stays in sync with the rest of the package.  ```haskell+{-# Language OverloadedStrings #-}+import Data.Text (Text) import GHC.Generics (Generic) import QuoteStr (quoteStr) import Test.Hspec (Spec, hspec, it, shouldBe)-import Toml (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, (.=))+import Toml+import Toml.Schema  main :: IO ()-main = hspec (parses >> decodes >> encodes)+main = hspec (parses >> decodes >> encodes >> warns >> errors) ```  ### Using the raw parser@@ -58,7 +59,7 @@ Consider this sample TOML text from the TOML specification.  ```haskell-fruitStr :: String+fruitStr :: Text fruitStr = [quoteStr| ``` @@ -88,35 +89,35 @@ |] ``` -Parsing using this package generates the following value+Parsing using this package generates the following unstructured value  ```haskell parses :: Spec parses = it "parses" $-    parse fruitStr+    forgetTableAnns <$> parse fruitStr     `shouldBe`     Right (table [-        ("fruits", Array [+        ("fruits", List [             Table (table [-                ("name", String "apple"),+                ("name", Text "apple"),                 ("physical", Table (table [-                    ("color", String "red"),-                    ("shape", String "round")])),-                ("varieties", Array [-                    Table (table [("name", String "red delicious")]),-                    Table (table [("name", String "granny smith")])])]),+                    ("color", Text "red"),+                    ("shape", Text "round")])),+                ("varieties", List [+                    Table (table [("name", Text "red delicious")]),+                    Table (table [("name", Text "granny smith")])])]),             Table (table [-                ("name", String "banana"),-                ("varieties", Array [-                    Table (table [("name", String "plantain")])])])])])+                ("name", Text "banana"),+                ("varieties", List [+                    Table (table [("name", Text "plantain")])])])])]) ``` -### Using decoding classes+### Defining a schema -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.+We can define a schema for our TOML format in the form of instances of+`FromValue`, `ToValue`, and `ToTable` in order to read TOML directly+into structured data form. This example manually derives some of the+instances as a demonstration.  ```haskell newtype Fruits = Fruits { fruits :: [Fruit] }@@ -128,16 +129,19 @@     deriving (ToTable, ToValue, FromValue) via GenericTomlTable Fruit  data Physical = Physical { color :: String, shape :: String }-    deriving (Eq, Show)+    deriving (Eq, Show, Generic)+    deriving (ToTable, ToValue, FromValue) via GenericTomlTable Physical  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")+instance ToValue Variety where+    toValue = defaultTableToValue+instance ToTable Variety where+    toTable (Variety x) = table ["name" .= x]+ ```  We can run this example on the original value to deserialize it into domain-specific datatypes.@@ -153,24 +157,7 @@             (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@@ -190,6 +177,35 @@          [[fruits.varieties]]         name = "granny smith"|]+```++### Useful errors and warnings++This package takes care to preserve source information as much as possible+in order to provide useful feedback to users. These examples show a couple+of the message that can be generated when things don't go perfectly.++```haskell+warns :: Spec+warns = it "warns" $+    decode [quoteStr|+        name = "simulated"+        typo = 10|]+    `shouldBe`+    Success+        ["2:1: unexpected key: typo in <top-level>"] -- warnings+        (Variety "simulated")++errors :: Spec+errors = it "errors" $+    decode [quoteStr|+        # Physical characteristics table+        color = "blue"+        shape = []|]+    `shouldBe`+    (Failure+        ["3:9: expected string but got array in shape"]+        :: Result String Physical) ```  ## More Examples
benchmarker/benchmarker.hs view
@@ -1,6 +1,7 @@   import Control.Exception (evaluate)+import qualified Data.Text.IO import Data.Time (diffUTCTime, getCurrentTime) import System.Environment (getArgs) import Toml (parse)@@ -11,8 +12,7 @@     filename <- case args of       [filename] -> pure filename       _ -> fail "Usage: benchmarker <file.toml>"-    txt <- readFile filename-    evaluate (length txt) -- readFile uses lazy IO, force it to load+    txt <- Data.Text.IO.readFile filename     start <- getCurrentTime     evaluate (parse txt)     stop <- getCurrentTime
src/Toml.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE PatternSynonyms #-} {-| Module      : Toml Description : TOML parsing, printing, and codecs@@ -6,60 +7,145 @@ 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+It enables parsing, printing, and conversion into and out of application-specific representations. -This parser implements TOML 1.0.0 <https://toml.io/en/v1.0.0>+This parser implements TOML 1.1.0 <https://toml.io/en/v1.1.0> as carefully as possible. +Use "Toml.Schema" to implement functions mapping between TOML+values and your application types.++Use "Toml.Syntax" and "Toml.Semantics" for low-level TOML syntax+processing and semantic validation. Most applications will not+need to use these modules directly unless the application is+about TOML itself.++The types and functions of this package are parameterized over+an annotation type in order to allow applications to provide+detailed feedback messages tracked back to specific source+locations in an original TOML file. While the default annotation+is a simple file position, some applications might upgrade this+annotation to track multiple file names or synthetically generated+sources. Other applications won't need source location and can+replace annotations with a simple unit type.+ -} module Toml (      -- * Types     Table,-    Value(..),+    Value, +    -- * Located types+    Located(..),+    Position(..),+    Table'(..),+    Value'(..),+    valueAnn,+    valueType,+    forgetTableAnns,+    forgetValueAnns,+     -- * Parsing+    decode',+    decode,     parse,+    DecodeError,+    Result(..),      -- * Printing+    encode,     prettyToml,     DocClass(..), -    -- * Serialization-    decode,-    encode,-    Result(..),+    -- * Error rendering+    prettyDecodeError,+    prettyLocated,+    prettyMatchMessage,+    prettySemanticError,     ) 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(..))+import Data.Text (Text)+import Text.Printf (printf)+import Toml.Pretty+import Toml.Schema+import Toml.Semantics+import Toml.Syntax --- | Parse a TOML formatted 'String' or report an error message.-parse :: String -> Either String Table-parse str =+-- | Parse a TOML formatted 'String' or report a structured error message.+parse' :: Text -> Either DecodeError (Table' Position)+parse' str =     case parseRawToml str of-        Left e -> Left (prettyLocated e)+        Left e -> Left (ErrSyntax e)         Right exprs ->             case semantics exprs of-                Left e -> Left (prettyLocated (prettySemanticError <$> e))+                Left e -> Left (ErrSemantics 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+-- | Parse a TOML formatted 'String' or report a human-readable error message.+parse :: Text -> Either String (Table' Position)+parse str =+    case parse' str of+        Left e -> Left (prettyDecodeError e)+        Right x -> Right x++-- | Sum of errors that can occur during TOML decoding+data DecodeError+    = ErrSyntax    (Located String)         -- ^ Error during the lexer/parser phase+    | ErrSemantics (SemanticError Position) -- ^ Error during TOML validation+    | ErrSchema    (MatchMessage Position)  -- ^ Error during schema matching++-- | Decode TOML syntax into an application value.+decode' :: FromValue a => Text -> Result DecodeError a+decode' str =+    case parse' str of         Left e -> Failure [e]         Right tab ->-            case runMatcher (fromValue (Table tab)) of-                Failure es -> Failure (prettyMatchMessage <$> es)-                Success ws x -> Success (prettyMatchMessage <$> ws) x+            case runMatcher (fromValue (Table' startPos tab)) of+                Failure es -> Failure (ErrSchema <$> es)+                Success ws x -> Success (ErrSchema <$> ws) x +-- | Wrapper rending error and warning messages into human-readable strings.+decode :: FromValue a => Text -> Result String a+decode str =+    case decode' str of+        Failure e -> Failure (map prettyDecodeError e)+        Success w x -> Success (map prettyDecodeError w) x+ -- | Use the 'ToTable' instance to encode a value to a TOML string. encode :: ToTable a => a -> TomlDoc encode = prettyToml . toTable++-- | Human-readable representation of a 'DecodeError'+prettyDecodeError :: DecodeError -> String+prettyDecodeError = \case+    ErrSyntax e -> prettyLocated e+    ErrSemantics e -> prettySemanticError e+    ErrSchema e -> prettyMatchMessage e++-- | Render a TOML decoding error as a human-readable string.+prettyMatchMessage :: MatchMessage Position -> String+prettyMatchMessage (MatchMessage loc scope msg) = prefix ++ msg ++ " in " ++ path+    where+        prefix =+            case loc of+                Nothing -> ""+                Just l -> prettyPosition l ++ ": "+        path =+            case scope of+                [] -> "<top-level>"+                ScopeKey key : scope' -> shows (prettySimpleKey key) (foldr f "" scope')+                ScopeIndex i : scope' -> foldr f "" (ScopeIndex i : scope') -- should be impossible++        f (ScopeIndex i) = showChar '[' . shows i . showChar ']'+        f (ScopeKey key) = showChar '.' . shows (prettySimpleKey key)++-- | Render a semantic TOML error in a human-readable string.+prettySemanticError :: SemanticError Position -> String+prettySemanticError (SemanticError a key kind) =+    printf "%s: key error: %s %s" (prettyPosition a) (show (prettySimpleKey key))+    case kind of+        AlreadyAssigned -> "is already assigned" :: String+        ClosedTable     -> "is a closed table"+        ImplicitlyTable -> "is already implicitly defined to be a table"
− src/Toml/FromValue.hs 
@@ -1,295 +0,0 @@-{-# 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]
− src/Toml/FromValue/Generic.hs 
@@ -1,130 +0,0 @@-{-# 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 #-}
− src/Toml/FromValue/Matcher.hs 
@@ -1,168 +0,0 @@-{-# 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
− src/Toml/FromValue/ParseTable.hs 
@@ -1,125 +0,0 @@-{-|-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])
− src/Toml/Generic.hs 
@@ -1,83 +0,0 @@-{-# 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 #-}
− src/Toml/Lexer.x 
@@ -1,215 +0,0 @@-{-{-|-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 :----<val> {--@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                         }--}--<lstr> {-  $literal_char+    { strFrag                           }-  "'"               { endStr . fmap (drop 1)            }-}--<bstr> {-  $unescaped+       { strFrag                           }-  \"                { endStr . fmap (drop 1)            }-}--<mllstr> {-  @mll_content+     { strFrag                           }-  "'" {1,2}         { strFrag                           }-  "'" {3,5}         { endStr . fmap (drop 3)            }-}--<mlbstr> {-  @mlb_escaped_nl;-  ($unescaped | @newline)+ { strFrag                    }-  \" {1,2}          { strFrag                           }-  \" {3,5}          { endStr . fmap (drop 3)            }-}--<mlbstr, bstr> {-  \\ 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)--}
− src/Toml/Lexer/Token.hs 
@@ -1,122 +0,0 @@-{-|-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"]
− src/Toml/Lexer/Utils.hs 
@@ -1,177 +0,0 @@-{-|-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 x
− src/Toml/Located.hs 
@@ -1,28 +0,0 @@-{-|-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 -})
− src/Toml/Parser.y 
@@ -1,145 +0,0 @@-{-{-|-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--}
− src/Toml/Parser/Types.hs 
@@ -1,57 +0,0 @@-{-|-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)
− src/Toml/Parser/Utils.hs 
@@ -1,87 +0,0 @@-{-|-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 #-}
− src/Toml/Position.hs 
@@ -1,44 +0,0 @@-{-|-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 }
src/Toml/Pretty.hs view
@@ -33,10 +33,9 @@     prettySimpleKey,     prettyKey, -    -- * Pretty errors-    prettySemanticError,-    prettyMatchMessage,+    -- * Locations     prettyLocated,+    prettyPosition,     ) where  import Data.Char (ord, isAsciiLower, isAsciiUpper, isDigit, isPrint)@@ -46,17 +45,16 @@ import Data.List.NonEmpty qualified as NonEmpty import Data.Map qualified as Map import Data.String (fromString)+import Data.Text (Text)+import Data.Text qualified as Text import Data.Time (ZonedTime(zonedTimeZone), TimeZone (timeZoneMinutes)) import Data.Time.Format (formatTime, defaultTimeLocale) import Prettyprinter import Text.Printf (printf)-import Toml.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)+import Toml.Semantics+import Toml.Syntax.Lexer (Token(..))+import Toml.Syntax.Position (Located(..), Position(..))+import Toml.Syntax.Types (SectionKind(..))  -- | Annotation used to enable styling pretty-printed TOML data DocClass@@ -74,14 +72,14 @@  -- | Renders a dotted-key using quotes where necessary and annotated -- as a 'KeyClass'.-prettyKey :: NonEmpty String -> TomlDoc+prettyKey :: NonEmpty Text -> TomlDoc prettyKey = annotate KeyClass . fold . NonEmpty.intersperse dot . fmap prettySimpleKey  -- | Renders a simple-key using quotes where necessary.-prettySimpleKey :: String -> Doc a+prettySimpleKey :: Text -> Doc a prettySimpleKey str-    | not (null str), all isBareKey str = fromString str-    | otherwise                         = fromString (quoteString str)+    | not (Text.null str), Text.all isBareKey str = pretty str+    | otherwise = fromString (quoteString (Text.unpack str))  -- | Predicate for the character-class that is allowed in bare keys isBareKey :: Char -> Bool@@ -96,12 +94,14 @@             '"'  : xs -> '\\' : '"'  : go xs             '\\' : xs -> '\\' : '\\' : go xs             '\b' : xs -> '\\' : 'b'  : go xs+            '\ESC':xs -> '\\' : 'e'  : go xs             '\f' : xs -> '\\' : 'f'  : go xs             '\n' : xs -> '\\' : 'n'  : go xs             '\r' : xs -> '\\' : 'r'  : go xs             '\t' : xs -> '\\' : 't'  : go xs             x    : xs                 | isPrint x     -> x : go xs+                | x <= '\xff'   -> printf "\\x%02X%s" (ord x) (go xs)                 | x <= '\xffff' -> printf "\\u%04X%s" (ord x) (go xs)                 | otherwise     -> printf "\\U%08X%s" (ord x) (go xs) @@ -114,6 +114,7 @@             '"' : '"' : '"' : xs -> "\"\"\\\"" ++ go xs             '\\' : xs -> '\\' : '\\' : go xs             '\b' : xs -> '\\' : 'b' : go xs+            '\ESC':xs -> '\\' : 'e'  : go xs             '\f' : xs -> '\\' : 'f' : go xs             '\t' : xs -> '\\' : 't' : go xs             '\n' : xs -> '\n' : go xs@@ -121,11 +122,12 @@             '\r' : xs -> '\\' : 'r' : go xs             x    : xs                 | isPrint x     -> x : go xs+                | x <= '\xff'   -> printf "\\x%02X%s" (ord x) (go xs)                 | x <= '\xffff' -> printf "\\u%04X%s" (ord x) (go xs)                 | otherwise     -> printf "\\U%08X%s" (ord x) (go xs)  -- | Pretty-print a section heading. The result is annotated as a 'TableClass'.-prettySectionKind :: SectionKind -> NonEmpty String -> TomlDoc+prettySectionKind :: SectionKind -> NonEmpty Text -> TomlDoc prettySectionKind TableKind      key =     annotate TableClass (unAnnotate (lbracket <> prettyKey key <> rbracket)) prettySectionKind ArrayTableKind key =@@ -157,92 +159,92 @@     TokLocalTime      _ -> "local time"     TokEOF              -> "end-of-input" -prettyAssignment :: String -> Value -> TomlDoc+prettyAssignment :: Text -> Value' l -> TomlDoc prettyAssignment = go . pure     where-        go ks (Table (Map.assocs -> [(k,v)])) = go (NonEmpty.cons k ks) v+        go ks (Table' _ (MkTable (Map.assocs -> [(k,(_, v))]))) = go (NonEmpty.cons k ks) v         go ks v = prettyKey (NonEmpty.reverse ks) <+> equals <+> prettyValue v  -- | Render a value suitable for assignment on the right-hand side -- of an equals sign. This value will always use inline table and list -- syntax.-prettyValue :: Value -> TomlDoc+prettyValue :: Value' l -> TomlDoc prettyValue = \case-    Integer i           -> annotate NumberClass (pretty i)-    Float   f+    Integer' _ i           -> annotate NumberClass (pretty i)+    Double' _   f         | isNaN f       -> annotate NumberClass "nan"         | isInfinite f  -> annotate NumberClass (if f > 0 then "inf" else "-inf")         | otherwise     -> annotate NumberClass (pretty f)-    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+    List' _ a           -> align (list [prettyValue v | v <- a])+    Table' _ (MkTable t) -> lbrace <> concatWith (surround ", ") [prettyAssignment k v | (k,(_, v)) <- Map.assocs t] <> rbrace+    Bool' _ True        -> annotate BoolClass "true"+    Bool' _ False       -> annotate BoolClass "false"+    Text' _ str         -> prettySmartString str+    TimeOfDay' _ tod    -> annotate DateClass (fromString (formatTime defaultTimeLocale "%H:%M:%S%Q" tod))+    ZonedTime' _ zt         | timeZoneMinutes (zonedTimeZone zt) == 0 ->                            annotate DateClass (fromString (formatTime defaultTimeLocale "%0Y-%m-%dT%H:%M:%S%QZ" zt))         | otherwise     -> annotate DateClass (fromString (formatTime defaultTimeLocale "%0Y-%m-%dT%H:%M:%S%Q%Ez" zt))-    LocalTime lt        -> annotate DateClass (fromString (formatTime defaultTimeLocale "%0Y-%m-%dT%H:%M:%S%Q" lt))-    Day d               -> annotate DateClass (fromString (formatTime defaultTimeLocale "%0Y-%m-%d" d))+    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 :: Text -> TomlDoc prettySmartString str-    | '\n' `elem` str =+    | '\n' `elem` Text.unpack str = -- Text.elem isn't in text-1.2         column \i ->         pageWidth \case-            AvailablePerLine n _ | length str > n - i ->+            AvailablePerLine n _ | Text.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)))+prettyMlString :: Text -> TomlDoc+prettyMlString str = annotate StringClass (column \i -> hang (-i) (fromString (quoteMlString (Text.unpack str)))) -prettyString :: String -> TomlDoc-prettyString str = annotate StringClass (fromString (quoteString str))+prettyString :: Text -> TomlDoc+prettyString str = annotate StringClass (fromString (quoteString (Text.unpack str)))  -- | Predicate for values that CAN rendered on the--- righthand-side of an @=@.-isSimple :: Value -> Bool+-- right-hand side of an @=@.+isSimple :: Value' l -> 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)+    Integer'   {} -> True+    Double'    {} -> True+    Bool'      {} -> True+    Text'      {} -> True+    TimeOfDay' {} -> True+    ZonedTime' {} -> True+    LocalTime' {} -> True+    Day'       {} -> True+    Table' _    x -> isSingularTable x -- differs from isAlwaysSimple+    List'  _    x -> null x || not (all isTable x)  -- | Predicate for values that can be MUST rendered on the--- righthand-side of an @=@.-isAlwaysSimple :: Value -> Bool+-- right-hand side of an @=@.+isAlwaysSimple :: Value' l -> 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)+    Integer'   {} -> True+    Double'    {} -> True+    Bool'      {} -> True+    Text'      {} -> True+    TimeOfDay' {} -> True+    ZonedTime' {} -> True+    LocalTime' {} -> True+    Day'       {} -> True+    Table'     {} -> False -- differs from isSimple+    List' _     x -> null x || not (all isTable x)  -- | Predicate for table values.-isTable :: Value -> Bool-isTable Table {} = True+isTable :: Value' l -> Bool+isTable Table'{} = True isTable _        = False  -- | Predicate for tables that can be rendered with a single assignment.--- These can be collapsed using dotted-key notation on the lefthand-side+-- These can be collapsed using dotted-key notation on the left-hand side -- of a @=@.-isSingularTable :: Table -> Bool-isSingularTable (Map.elems -> [v])  = isSimple v-isSingularTable _                   = False+isSingularTable :: Table' l -> Bool+isSingularTable (MkTable (Map.elems -> [(_, v)])) = isSimple v+isSingularTable _ = False  -- | Render a complete TOML document using top-level table and array of -- table sections where possible.@@ -250,7 +252,7 @@ -- Keys are sorted alphabetically. To provide a custom ordering, see -- 'prettyTomlOrdered'. prettyToml ::-    Table {- ^ table to print -} ->+    Table' a {- ^ table to print -} ->     TomlDoc {- ^ TOML syntax -} prettyToml = prettyToml_ NoProjection TableKind [] @@ -262,7 +264,7 @@ -- 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.+-- of the ancillary configuration sections. -- -- The /table path/ is the name of the table being sorted. This allows -- the projection to be aware of which table is being sorted.@@ -288,12 +290,10 @@ -- 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 -} ->+  ([Text] -> Text -> a) {- ^ table path -> key -> projection -} ->+  Table' l {- ^ table to print -} ->   TomlDoc {- ^ TOML syntax -} prettyTomlOrdered proj = prettyToml_ (KeyProjection proj) TableKind [] @@ -302,10 +302,10 @@     -- | No projection provided; alphabetical order used     NoProjection :: KeyProjection     -- | Projection provided: table name and current key are available-    KeyProjection :: Ord a => ([String] -> String -> a) -> KeyProjection+    KeyProjection :: Ord a => ([Text] -> Text -> a) -> KeyProjection -prettyToml_ :: KeyProjection -> SectionKind -> [String] -> Table -> TomlDoc-prettyToml_ mbKeyProj kind prefix t = vcat (topLines ++ subtables)+prettyToml_ :: KeyProjection -> SectionKind -> [Text] -> Table' l -> TomlDoc+prettyToml_ mbKeyProj kind prefix (MkTable t) = vcat (topLines ++ subtables)     where         order =             case mbKeyProj of@@ -315,9 +315,9 @@         kvs = order (Map.assocs t)          -- this table will require no subsequent tables to be defined-        simpleToml = all isSimple t+        simpleToml = all (isSimple . snd) t -        (simple, sections) = partition (isAlwaysSimple . snd) kvs+        (simple, sections) = partition (isAlwaysSimple . snd . snd) kvs          topLines = [fold topElts | let topElts = headers ++ assignments, not (null topElts)] @@ -327,36 +327,20 @@                     [prettySectionKind kind key <> hardline]                 _ -> [] -        assignments = [prettyAssignment k v <> hardline | (k,v) <- if simpleToml then kvs else simple]+        assignments = [prettyAssignment k v <> hardline | (k,(_, v)) <- if simpleToml then kvs else simple] -        subtables = [prettySection (prefix ++ [k]) v | not simpleToml, (k,v) <- sections]+        subtables = [prettySection (prefix ++ [k]) v | not simpleToml, (k,(_, v)) <- sections] -        prettySection key (Table tab) =+        prettySection key (Table' _ tab) =             prettyToml_ mbKeyProj TableKind key tab-        prettySection key (Array a) =-            vcat [prettyToml_ mbKeyProj ArrayTableKind key tab | Table tab <- a]+        prettySection key (List' _ 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)-+-- | Pretty-print as @line:col: message@ prettyLocated :: Located String -> String-prettyLocated (Located p s) = printf "%d:%d: %s" (posLine p) (posColumn p) s+prettyLocated (Located p s) = printf "%s: %s" (prettyPosition p) s++-- | Pretty-print as @line:col@+prettyPosition :: Position -> String+prettyPosition p = printf "%d:%d" (posLine p) (posColumn p)
+ src/Toml/Schema.hs view
@@ -0,0 +1,72 @@+{-|+Module      : Toml.Schema+Description : Infrastructure for converting between TOML and application values+Copyright   : (c) Eric Mertens, 2024+License     : ISC+Maintainer  : emertens@gmail.com++-}+module Toml.Schema (+    -- * FromValue+    FromValue(..),+    mapOf,+    listOf,++    -- ** Matcher+    Matcher,+    runMatcher,+    runMatcherFatalWarn,+    runMatcherIgnoreWarn,+    Result(..),+    MatchMessage(..),+    Scope(..),+    parseTableFromValue,+    parseTable,+    getScope,+    warn,+    warnAt,+    failAt,+    getTable,+    setTable,++    -- ** Tables+    ParseTable,+    reqKey,+    optKey,+    reqKeyOf,+    optKeyOf,+    pickKey,+    KeyAlt(..),+    warnTable,+    warnTableAt,+    failTableAt,+    liftMatcher,++    -- * ToValue+    ToValue(..),+    ToTable(..),++    table,+    (.=),+    defaultTableToValue,++    -- * Types+    Value, Value'(..),+    Table, Table'(..),++    -- * Generics+    GenericTomlArray(..),+    GenericTomlTable(..),+    genericFromTable,+    genericFromArray,+    genericToArray,+    genericToTable,++) where++import Toml.Schema.FromValue+import Toml.Schema.Generic+import Toml.Schema.ParseTable+import Toml.Schema.Matcher+import Toml.Schema.ToValue+import Toml.Semantics
+ src/Toml/Schema/FromValue.hs view
@@ -0,0 +1,293 @@+{-# Language TypeFamilies #-}+{-|+Module      : Toml.Schema.FromValue+Description : Automation for converting TOML values to application values.+Copyright   : (c) Eric Mertens, 2023+License     : ISC+Maintainer  : emertens@gmail.com++Use 'FromValue' to define a transformation from some 'Value' to an application+domain type.++Use 'ParseTable' to help build 'FromValue' instances that match tables. It+will make it easy to track which table keys have been used and which are left+over.++Warnings can be emitted using 'warn' and 'warnTable' (depending on what)+context you're in. These warnings can provide useful feedback about+problematic values or keys that might be unused now but were perhaps+meaningful in an old version of a configuration file.++"Toml.Schema.FromValue.Generic" can be used to derive instances of 'FromValue'+automatically for record types.++-}+module Toml.Schema.FromValue (+    -- * Deserialization classes+    FromValue(..),+    FromKey(..),++    -- * Containers+    mapOf,+    listOf,++    -- * Tables+    parseTableFromValue,+    reqKey,+    reqKeyOf,+    optKey,+    optKeyOf,++    -- * Errors+    typeError,++    ) where++import Control.Monad (zipWithM, liftM2)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Ratio (Ratio)+import Data.Sequence (Seq)+import Data.Sequence qualified as Seq+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Lazy qualified+import Data.Time (ZonedTime, LocalTime, Day, TimeOfDay, UTCTime, zonedTimeToUTC)+import Data.Word (Word8, Word16, Word32, Word64)+import Numeric.Natural (Natural)+import Toml.Schema.Matcher+import Toml.Schema.ParseTable+import Toml.Semantics++-- | Table matching function used to help implement 'fromValue' for tables.+-- Key matching function is given the annotation of the key for error reporting.+-- Value matching function is given the key in case values can depend on their keys.+mapOf ::+    Ord k =>+    (l -> Text -> Matcher l k)         {- ^ key matcher   -} ->+    (Text -> Value' l -> Matcher l v)  {- ^ value matcher -} ->+    Value' l -> Matcher l (Map k v)+mapOf matchKey matchVal =+    \case+        Table' _ (MkTable t) -> Map.fromList <$> sequence kvs+            where+                kvs = [liftM2 (,) (matchKey l k) (inKey k (matchVal k v)) | (k, (l, v)) <- Map.assocs t]+        v -> typeError "table" v++-- | List matching function used to help implemented 'fromValue' for arrays.+-- The element matching function is given the list index in case values can+-- depend on their index.+listOf ::+    (Int -> Value' l -> Matcher l a) ->+    Value' l -> Matcher l [a]+listOf matchElt =+    \case+        List' _ xs -> zipWithM (\i -> inIndex i . matchElt i) [0..] xs+        v -> typeError "array" v++-- | Class for types that can be decoded from a TOML value.+class FromValue a where+    -- | Convert a 'Value' or report an error message+    fromValue :: Value' l -> Matcher l a++    -- | Used to implement instance for @[]@. Most implementations rely on the default implementation.+    listFromValue :: Value' l -> Matcher l [a]+    listFromValue = listOf (const fromValue)++instance (Ord k, FromKey k, FromValue v) => FromValue (Map k v) where+    fromValue = mapOf fromKey (const fromValue)++instance FromValue Table where+    fromValue (Table' _ t) = pure (forgetTableAnns t)+    fromValue v = typeError "table" v++-- | Convert from a table key+class FromKey a where+    fromKey :: l -> Text -> Matcher l a++-- | Matches all strings+instance a ~ Char => FromKey [a] where+    fromKey _ = pure . Text.unpack++-- | Matches all strings+instance FromKey Text where+    fromKey _ = pure++-- | Matches all strings+instance FromKey Data.Text.Lazy.Text where+    fromKey _ = pure . Data.Text.Lazy.fromStrict++-- | Report a type error+typeError :: String {- ^ expected type -} -> Value' l {- ^ actual value -} -> Matcher l a+typeError wanted got = failAt (valueAnn got) ("expected " ++ wanted ++ " but got " ++ valueType got)++-- | Used to derive a 'fromValue' implementation from a 'ParseTable' matcher.+parseTableFromValue :: ParseTable l a -> Value' l -> Matcher l a+parseTableFromValue p (Table' l t) = parseTable p l t+parseTableFromValue _ v = typeError "table" v++-- | Matches integer values+instance FromValue Integer where+    fromValue (Integer' _ x) = pure x+    fromValue v = typeError "integer" v++-- | Matches non-negative integer values+instance FromValue Natural where+    fromValue v =+     do i <- fromValue v+        if 0 <= i then+            pure (fromInteger i)+        else+            failAt (valueAnn v) "integer out of range for Natural"++fromValueSized :: forall l a. (Bounded a, Integral a) => String -> Value' l -> Matcher l a+fromValueSized name v =+ do i <- fromValue v+    if fromIntegral (minBound :: a) <= i && i <= fromIntegral (maxBound :: a) then+        pure (fromInteger i)+    else+        failAt (valueAnn v) ("integer out of range for " ++ name)++instance FromValue Int    where fromValue = fromValueSized "Int"+instance FromValue Int8   where fromValue = fromValueSized "Int8"+instance FromValue Int16  where fromValue = fromValueSized "Int16"+instance FromValue Int32  where fromValue = fromValueSized "Int32"+instance FromValue Int64  where fromValue = fromValueSized "Int64"+instance FromValue Word   where fromValue = fromValueSized "Word"+instance FromValue Word8  where fromValue = fromValueSized "Word8"+instance FromValue Word16 where fromValue = fromValueSized "Word16"+instance FromValue Word32 where fromValue = fromValueSized "Word32"+instance FromValue Word64 where fromValue = fromValueSized "Word64"++-- | Matches single-character strings with 'fromValue' and arbitrary+-- strings with 'listFromValue' to support 'Prelude.String'+instance FromValue Char where+    fromValue (Text' l t) =+        case Text.uncons t of+            Just (c, t')+                | Text.null t' -> pure c+            _ -> failAt l "expected single character"+    fromValue v = typeError "string" v++    listFromValue (Text' _ t) = pure (Text.unpack t)+    listFromValue v = typeError "string" v++-- | Matches string literals+instance FromValue Text where+    fromValue (Text' _ t) = pure t+    fromValue v = typeError "string" v++-- | Matches string literals+instance FromValue Data.Text.Lazy.Text where+    fromValue v = Data.Text.Lazy.fromStrict <$> fromValue v++-- | Matches floating-point and integer values+instance FromValue Double where+    fromValue (Double' _ x) = pure x+    fromValue (Integer' _ x) = pure (fromInteger x)+    fromValue v = typeError "float" v++-- | Matches floating-point and integer values+instance FromValue Float where+    fromValue (Double' _ x) = pure (realToFrac x)+    fromValue (Integer' _ x) = pure (fromInteger x)+    fromValue v = typeError "float" v++-- | Matches floating-point and integer values.+--+-- TOML specifies @Floats should be implemented as IEEE 754 binary64 values.@+-- so note that the given 'Rational' will be converted from a double+-- representation and will often be an approximation rather than the exact+-- value.+instance Integral a => FromValue (Ratio a) where+    fromValue (Double' a x)+        | isNaN x || isInfinite x = failAt a "finite float required"+        | otherwise = pure (realToFrac x)+    fromValue (Integer' _ x) = pure (fromInteger x)+    fromValue v = typeError "float" v++-- | Matches non-empty arrays or reports an error.+instance FromValue a => FromValue (NonEmpty a) where+    fromValue v =+     do xs <- fromValue v+        case NonEmpty.nonEmpty xs of+            Nothing -> failAt (valueAnn v) "non-empty list required"+            Just ne -> pure ne++-- | Matches arrays+instance FromValue a => FromValue (Seq a) where+    fromValue v = Seq.fromList <$> fromValue v++-- | Matches @true@ and @false@+instance FromValue Bool where+    fromValue (Bool' _ x) = pure x+    fromValue v = typeError "boolean" v++-- | Implemented in terms of 'listFromValue'+instance FromValue a => FromValue [a] where+    fromValue = listFromValue++-- | Matches local date literals+instance FromValue Day where+    fromValue (Day' _ x) = pure x+    fromValue v = typeError "local date" v++-- | Matches local time literals+instance FromValue TimeOfDay where+    fromValue (TimeOfDay' _ x) = pure x+    fromValue v = typeError "local time" v++-- | Matches offset date-time literals+instance FromValue ZonedTime where+    fromValue (ZonedTime' _ x) = pure x+    fromValue v = typeError "offset date-time" v++-- | Matches offset date-time literals and converts to UTC+instance FromValue UTCTime where+    fromValue (ZonedTime' _ x) = pure (zonedTimeToUTC x)+    fromValue v = typeError "offset date-time" v++-- | Matches local date-time literals+instance FromValue LocalTime where+    fromValue (LocalTime' _ x) = pure x+    fromValue v = typeError "local date-time" v++-- | Matches all values, used for pass-through+instance FromValue Value where+    fromValue = pure . forgetValueAnns++-- | Convenience function for matching an optional key with a 'FromValue'+-- instance.+--+-- @optKey key = 'optKeyOf' key 'fromValue'@+optKey :: FromValue a => Text -> ParseTable l (Maybe a)+optKey key = optKeyOf key fromValue++-- | Convenience function for matching a required key with a 'FromValue'+-- instance.+--+-- @reqKey key = 'reqKeyOf' key 'fromValue'@+reqKey :: FromValue a => Text -> ParseTable l a+reqKey key = reqKeyOf key fromValue++-- | Match a table entry by key if it exists or return 'Nothing' if not.+-- If the key is defined, it is matched by the given function.+--+-- See 'pickKey' for more complex cases.+optKeyOf ::+    Text                      {- ^ key           -} ->+    (Value' l -> Matcher l a) {- ^ value matcher -} ->+    ParseTable l (Maybe a)+optKeyOf key k = pickKey [Key key (fmap Just . k), Else (pure Nothing)]++-- | Match a table entry by key or report an error if missing.+--+-- See 'pickKey' for more complex cases.+reqKeyOf ::+    Text                      {- ^ key           -} ->+    (Value' l -> Matcher l a) {- ^ value matcher -} ->+    ParseTable l a+reqKeyOf key k = pickKey [Key key k]
+ src/Toml/Schema/Generic.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances, ScopedTypeVariables, InstanceSigs #-}+{-|+Module      : Toml.Schema.Generic+Description : Integration with DerivingVia extension+Copyright   : (c) Eric Mertens, 2024+License     : ISC+Maintainer  : emertens@gmail.com++This module makes it possible to easily derive the TOML classes+using the @DerivingVia@ extension.++For example:++@+data Physical = Physical {+    color :: String,+    shape :: String+    }+    deriving (Eq, Show, Generic)+    deriving (ToTable, ToValue, FromValue) via GenericTomlTable Physical+@++These derived instances would allow you to match TOML+@{color="red", shape="round"}@ to value @Physical "red" "round"@.++@+data Coord = Coord Int Int+    deriving (Eq, Show, Generic)+    deriving (ToValue, FromValue) via GenericTomlArray Physical+@++These derived instances would allow you to match TOML @[1,2]@ to value @Coord 1 2@.++-}+module Toml.Schema.Generic (+    -- * DerivingVia+    GenericTomlTable(GenericTomlTable),+    GenericTomlArray(GenericTomlArray),++    -- * FromValue+    genericFromArray,+    genericFromTable,+    GFromArray,+    GParseTable,++    -- * ToValue+    genericToArray,+    genericToTable,+    GToArray,+    GToTable,+    ) where++import Data.Coerce (coerce)+import GHC.Generics (Generic(Rep))+import Toml.Schema.FromValue+import Toml.Schema.Matcher+import Toml.Schema.Generic.FromValue+import Toml.Schema.Generic.ToValue (GToTable, GToArray, genericToTable, genericToArray)+import Toml.Schema.ToValue (ToTable(toTable), ToValue(toValue), defaultTableToValue)+import Toml.Semantics (Value, Value', Table)++-- | Helper type to use GHC's DerivingVia extension to derive+-- 'ToValue', 'ToTable', 'FromValue' for records.+newtype GenericTomlTable a = GenericTomlTable a++-- | Instance derived from 'ToTable' instance using 'defaultTableToValue'+instance (Generic a, GToTable (Rep a)) => ToValue (GenericTomlTable a) where+    toValue = defaultTableToValue+    {-# INLINE toValue #-}++-- | Instance derived using 'genericToTable'+instance (Generic a, GToTable (Rep a)) => ToTable (GenericTomlTable a) where+    toTable = coerce (genericToTable :: a -> Table)+    {-# INLINE toTable #-}++-- | Instance derived using 'genericParseTable'+instance (Generic a, GParseTable (Rep a)) => FromValue (GenericTomlTable a) where+    fromValue :: forall l. Value' l -> Matcher l (GenericTomlTable a)+    fromValue = coerce (parseTableFromValue genericParseTable :: Value' l -> Matcher l a)+    {-# INLINE fromValue #-}++-- | Helper type to use GHC's DerivingVia extension to derive+-- 'ToValue', 'ToTable', 'FromValue' for any product type.+newtype GenericTomlArray a = GenericTomlArray a++-- | Instance derived using 'genericToArray'+instance (Generic a, GToArray (Rep a)) => ToValue (GenericTomlArray a) where+    toValue = coerce (genericToArray :: a -> Value)+    {-# INLINE toValue #-}++-- | Instance derived using 'genericFromArray'+instance (Generic a, GFromArray (Rep a)) => FromValue (GenericTomlArray a) where+    fromValue :: forall l. Value' l -> Matcher l (GenericTomlArray a)+    fromValue = coerce (genericFromArray :: Value' l -> Matcher l a)+    {-# INLINE fromValue #-}
+ src/Toml/Schema/Generic/FromValue.hs view
@@ -0,0 +1,129 @@+{-# Language DataKinds, InstanceSigs, ScopedTypeVariables, TypeOperators #-}+{-|+Module      : Toml.Schema.Generic.FromValue+Description : GHC.Generics derived table parsing+Copyright   : (c) Eric Mertens, 2023+License     : ISC+Maintainer  : emertens@gmail.com++Generic implementations of matching tables and arrays.++-}+module Toml.Schema.Generic.FromValue (+    -- * Record from table+    GParseTable(..),+    genericParseTable,+    genericFromTable,++    -- * Product type from array+    GFromArray(..),+    genericFromArray,+    ) where++import Control.Monad.Trans.State (StateT(..))+import Data.Coerce (coerce)+import Data.Text qualified as Text+import GHC.Generics+import Toml.Schema.FromValue (FromValue, fromValue, optKey, reqKey, parseTableFromValue, typeError)+import Toml.Schema.Matcher (Matcher, failAt)+import Toml.Schema.ParseTable (ParseTable)+import Toml.Semantics (Value'(List'))++-- | Match a 'Toml.Semantics.Table'' using the field names in a record.+genericParseTable :: (Generic a, GParseTable (Rep a)) => ParseTable l a+genericParseTable = to <$> gParseTable+{-# INLINE genericParseTable #-}++-- | Implementation of 'fromValue' using 'genericParseTable' to derive+-- a match from the record field names of the target type.+genericFromTable :: (Generic a, GParseTable (Rep a)) => Value' l -> Matcher l a+genericFromTable = parseTableFromValue genericParseTable+{-# INLINE genericFromTable #-}++-- | Match a 'Toml.Semantics.Value'' as an array positionally matching field fields+-- of a constructor to the elements of the array.+genericFromArray :: (Generic a, GFromArray (Rep a)) => Value' l -> Matcher l a+genericFromArray (List' a xs) =+ do (gen, xs') <- runStateT gFromArray xs+    if null xs' then+        pure (to gen)+    else+        failAt a ("array " ++ show (length xs') ++ " elements too long")+genericFromArray v = typeError "array" v++{-# INLINE genericFromArray #-}++-- 'gParseTable' is written in continuation passing style because+-- it allows all the "GHC.Generics" constructors to inline into+-- a single location which allows the optimizer to optimize them+-- complete away.++-- | Supports conversion of TOML tables into record values using+-- field selector names as TOML keys.+class GParseTable f where+    -- | Convert a value and apply the continuation to the result.+    gParseTable :: ParseTable l (f a)++-- | Ignores type constructor name+instance GParseTable f => GParseTable (D1 c f) where+    gParseTable = M1 <$>  gParseTable+    {-# INLINE gParseTable #-}++-- | Ignores value constructor name - only supports record constructors+instance GParseTable f => GParseTable (C1 ('MetaCons sym fix 'True) f) where+    gParseTable = M1 <$> gParseTable+    {-# INLINE gParseTable #-}++-- | Matches left then right component+instance (GParseTable f, GParseTable g) => GParseTable (f :*: g) where+    gParseTable =+     do x <- gParseTable+        y <- gParseTable+        pure (x :*: y)+    {-# INLINE gParseTable #-}++-- | Omits the key from the table on nothing, includes it on just+instance {-# OVERLAPS #-} (Selector s, FromValue a) => GParseTable (S1 s (K1 i (Maybe a))) where+    gParseTable =+     do x <- optKey (Text.pack (selName (M1 [] :: S1 s [] ())))+        pure (M1 (K1 x))+    {-# INLINE gParseTable #-}++-- | Uses record selector name as table key+instance (Selector s, FromValue a) => GParseTable (S1 s (K1 i a)) where+    gParseTable =+     do x <- reqKey (Text.pack (selName (M1 [] :: S1 s [] ())))+        pure (M1 (K1 x))+    {-# INLINE gParseTable #-}++-- | Emits empty table+instance GParseTable U1 where+    gParseTable = pure U1+    {-# INLINE gParseTable #-}++-- | Supports conversion of TOML arrays into product-type values.+class GFromArray f where+    gFromArray :: StateT [Value' l] (Matcher l) (f a)++instance GFromArray f => GFromArray (M1 i c f) where+    gFromArray :: forall a l. StateT [Value' l] (Matcher l) (M1 i c f a)+    gFromArray = coerce (gFromArray :: StateT [Value' l] (Matcher l) (f a))+    {-# INLINE gFromArray #-}++instance (GFromArray f, GFromArray g) => GFromArray (f :*: g) where+    gFromArray =+     do x <- gFromArray+        y <- gFromArray+        pure (x :*: y)+    {-# INLINE gFromArray #-}++instance FromValue a => GFromArray (K1 i a) where+    gFromArray = StateT \case+        [] -> fail "array too short"+        x:xs -> (\v -> (K1 v, xs)) <$> fromValue x+    {-# INLINE gFromArray #-}++-- | Uses no array elements+instance GFromArray U1 where+    gFromArray = pure U1+    {-# INLINE gFromArray #-}
+ src/Toml/Schema/Generic/ToValue.hs view
@@ -0,0 +1,98 @@+{-|+Module      : Toml.Schema.Generic.ToValue+Description : GHC.Generics derived table generation+Copyright   : (c) Eric Mertens, 2023+License     : ISC+Maintainer  : emertens@gmail.com++Use 'genericToTable' to derive an instance of 'Toml.ToValue.ToTable'+using the field names of a record.++Use 'genericToArray' to derive an instance of 'Toml.ToValue.ToValue'+using the positions of data in a constructor.++-}+module Toml.Schema.Generic.ToValue (++    -- * Records to Tables+    GToTable(..),+    genericToTable,++    -- * Product types to Arrays+    GToArray(..),+    genericToArray,+    ) where++import Data.Text (Text)+import Data.Text qualified as Text+import GHC.Generics+import Toml.Semantics+import Toml.Schema.ToValue (ToValue(..), table)++-- | Use a record's field names to generate a 'Table'+genericToTable :: (Generic a, GToTable (Rep a)) => a -> Table+genericToTable x = table (gToTable (from x) [])+{-# INLINE genericToTable #-}++-- | Use a record's field names to generate a 'Table'+genericToArray :: (Generic a, GToArray (Rep a)) => a -> Value+genericToArray a = List (gToArray (from a) [])+{-# INLINE genericToArray #-}++-- | Supports conversion of product types with field selector names+-- to TOML values.+class GToTable f where+    gToTable :: f a -> [(Text, Value)] -> [(Text, Value)]++-- | Ignores type constructor names+instance GToTable f => GToTable (D1 c f) where+    gToTable (M1 x) = gToTable x+    {-# INLINE gToTable #-}++-- | Ignores value constructor names+instance GToTable f => GToTable (C1 c f) where+    gToTable (M1 x) = gToTable x+    {-# INLINE gToTable #-}++instance (GToTable f, GToTable g) => GToTable (f :*: g) where+    gToTable (x :*: y) = gToTable x <> gToTable y+    {-# INLINE gToTable #-}++-- | Omits the key from the table on nothing, includes it on just+instance {-# OVERLAPS #-} (Selector s, ToValue a) => GToTable (S1 s (K1 i (Maybe a))) where+    gToTable (M1 (K1 Nothing)) = id+    gToTable s@(M1 (K1 (Just x))) = ((Text.pack (selName s), toValue x):)+    {-# INLINE gToTable #-}++-- | Uses record selector name as table key+instance (Selector s, ToValue a) => GToTable (S1 s (K1 i a)) where+    gToTable s@(M1 (K1 x)) = ((Text.pack (selName s), toValue x):)+    {-# INLINE gToTable #-}++-- | Emits empty table+instance GToTable U1 where+    gToTable _ = id+    {-# INLINE gToTable #-}++instance GToTable V1 where+    gToTable v = case v of {}+    {-# INLINE gToTable #-}++-- | Convert product types to arrays positionally.+class GToArray f where+    gToArray :: f a -> [Value] -> [Value]++-- | Ignore metadata+instance GToArray f => GToArray (M1 i c f) where+    gToArray (M1 x) = gToArray x+    {-# INLINE gToArray #-}++-- | Convert left and then right+instance (GToArray f, GToArray g) => GToArray (f :*: g) where+    gToArray (x :*: y) = gToArray x . gToArray y+    {-# INLINE gToArray #-}++-- | Convert fields using 'ToValue' instances+instance ToValue a => GToArray (K1 i a) where+    gToArray (K1 x) = (toValue x :)+    {-# INLINE gToArray #-}
+ src/Toml/Schema/Matcher.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE RankNTypes #-}+{-|+Module      : Toml.Schema.Matcher+Description : A type for building results while tracking scopes+Copyright   : (c) Eric Mertens, 2023+License     : ISC+Maintainer  : emertens@gmail.com++This type helps to build up computations that can validate a TOML+value and compute some application-specific representation.++It supports warning messages which can be used to deprecate old+configuration options and to detect unused table keys.++It supports tracking multiple error messages when you have more+than one decoding option and all of them have failed.++Use 'Toml.Pretty.prettyMatchMessage' for an easy way to make human+readable strings from matcher outputs.++-}+module Toml.Schema.Matcher (+    -- * Types+    Matcher,+    Result(..),+    MatchMessage(..),++    -- * Operations+    runMatcher,+    withScope,+    getScope,+    warn,+    warnAt,+    failAt,++    -- * Run helpers+    runMatcherIgnoreWarn,+    runMatcherFatalWarn,++    -- * Scope helpers+    Scope(..),+    inKey,+    inIndex,+    ) where++import Control.Applicative (Alternative(..))+import Control.Monad (MonadPlus, ap, liftM)+import Data.Monoid (Endo(..))+import Data.Text (Text)++-- | Computations that result in a 'Result' and which track a list+-- of nested contexts to assist in generating warnings and error+-- messages.+--+-- Use 'withScope' to run a 'Matcher' in a new, nested scope.+newtype Matcher l a = Matcher {+    unMatcher ::+        forall r.+        [Scope] ->+        DList (MatchMessage l) ->+        (DList (MatchMessage l) -> r) ->+        (DList (MatchMessage l) -> a -> r) ->+        r+    }++instance Functor (Matcher a) where+    fmap = liftM++instance Applicative (Matcher a) where+    pure x = Matcher (\_env ws _err ok -> ok ws x)+    (<*>) = ap++instance Monad (Matcher a) where+    m >>= f = Matcher (\env ws err ok -> unMatcher m env ws err (\warn' x -> unMatcher (f x) env warn' err ok))+    {-# INLINE (>>=) #-}++instance Alternative (Matcher a) where+    empty = Matcher (\_env _warn err _ok -> err mempty)+    Matcher x <|> Matcher y = Matcher (\env ws err ok -> x env ws (\errs1 -> y env ws (\errs2 -> err (errs1 <> errs2)) ok) ok)++instance MonadPlus (Matcher a)++-- | Scopes for TOML message.+data Scope+    = ScopeIndex Int -- ^ zero-based array index+    | ScopeKey Text -- ^ key in a table+    deriving (+        Read {- ^ Default instance -},+        Show {- ^ Default instance -},+        Eq   {- ^ Default instance -},+        Ord  {- ^ Default instance -})++-- | A message emitted while matching a TOML value. The message is paired+-- with the path to the value that was in focus when the message was+-- generated. These message get used for both warnings and errors.+--+-- For a convenient way to render these to a string, see 'Toml.Pretty.prettyMatchMessage'.+data MatchMessage a = MatchMessage {+    matchAnn :: Maybe a,+    matchPath :: [Scope], -- ^ path to message location+    matchMessage :: String -- ^ error and warning message body+    } deriving (+        Read {- ^ Default instance -},+        Show {- ^ Default instance -},+        Eq   {- ^ Default instance -},+        Ord  {- ^ Default instance -},+        Functor, Foldable, Traversable)++-- | List of strings that supports efficient left- and right-biased append+newtype DList a = DList (Endo [a])+    deriving (Semigroup, Monoid)++-- | Create a singleton list of strings+one :: a -> DList a+one x = DList (Endo (x:))++-- | Extract the list of strings+runDList :: DList a -> [a]+runDList (DList x) = x `appEndo` []++-- | Computation outcome with error and warning messages. Multiple error+-- messages can occur when multiple alternatives all fail. Resolving any+-- one of the error messages could allow the computation to succeed.+data Result e a+    = Failure [e]   -- ^ error messages+    | Success [e] a -- ^ warning messages and result+    deriving (+        Read {- ^ Default instance -},+        Show {- ^ Default instance -},+        Eq   {- ^ Default instance -},+        Ord  {- ^ Default instance -})++-- | Run a 'Matcher' with an empty scope.+runMatcher :: Matcher l a -> Result (MatchMessage l) a+runMatcher (Matcher m) = m [] mempty (Failure . runDList) (Success . runDList)++-- | Run 'Matcher' and ignore warnings.+runMatcherIgnoreWarn :: Matcher l a -> Either [MatchMessage l] a+runMatcherIgnoreWarn m =+    case runMatcher m of+        Failure err -> Left err+        Success _ x -> Right x++-- | Run 'Matcher' and treat warnings as errors.+runMatcherFatalWarn :: Matcher l a -> Either [MatchMessage l] a+runMatcherFatalWarn m =+    case runMatcher m of+        Success [] x   -> Right x+        Success ws _   -> Left ws+        Failure err    -> Left err++-- | Run a 'Matcher' with a locally extended scope.+withScope :: Scope -> Matcher l a -> Matcher l a+withScope scope (Matcher m) = Matcher (\scopes -> m (scope : scopes))++-- | Get the current list of scopes.+getScope :: Matcher a [Scope]+getScope = Matcher (\env ws _err ok -> ok ws (reverse env))++-- | Emit a warning without an annotation.+warn :: String -> Matcher a ()+warn w =+    Matcher (\scopes ws _err ok -> ok (ws <> one (MatchMessage Nothing (reverse scopes) w)) ())++-- | Emit a warning mentioning the given annotation.+warnAt :: l -> String -> Matcher l ()+warnAt loc w =+    Matcher (\scopes ws _err ok -> ok (ws <> one (MatchMessage (Just loc) (reverse scopes) w)) ())++-- | Fail with an error message without an annotation.+instance MonadFail (Matcher a) where+    fail e =+        Matcher (\scopes _warn err _ok -> err (one (MatchMessage Nothing (reverse scopes) e)))++-- | Terminate the match with an error mentioning the given annotation.+failAt :: l -> String -> Matcher l a+failAt l e =+    Matcher (\scopes _warn err _ok -> err (one (MatchMessage (Just l) (reverse scopes) e)))++-- | Update the scope with the message corresponding to a table key+inKey :: Text -> Matcher l a -> Matcher l a+inKey = withScope . ScopeKey++-- | Update the scope with the message corresponding to an array index+inIndex :: Int -> Matcher l a -> Matcher l a+inIndex = withScope . ScopeIndex
+ src/Toml/Schema/ParseTable.hs view
@@ -0,0 +1,128 @@+{-|+Module      : Toml.Schema.ParseTable+Description : A type for matching keys out of a table+Copyright   : (c) Eric Mertens, 2023+License     : ISC+Maintainer  : emertens@gmail.com++This module provides utilities for matching key-value pairs+out of tables while building up application-specific values.++It will help generate warnings for unused keys, help select+between multiple possible keys, and emit location-specific+error messages when keys are unavailable.++-}+module Toml.Schema.ParseTable (+    -- * Base interface+    ParseTable,+    KeyAlt(..),+    pickKey,+    parseTable,++    -- * Primitives+    liftMatcher,+    warnTable,+    warnTableAt,+    failTableAt,+    setTable,+    getTable,+    ) where++import Control.Applicative (Alternative, empty)+import Control.Monad (MonadPlus)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ReaderT(..), ask)+import Control.Monad.Trans.State.Strict (StateT(..), get, put)+import Data.Foldable (for_)+import Data.List (intercalate)+import Data.Map qualified as Map+import Data.Text (Text)+import Toml.Schema.Matcher (Matcher, inKey, failAt, warn, warnAt)+import Toml.Semantics (Table'(..), Value')+import Toml.Pretty++-- | Parser that tracks a current set of unmatched key-value+-- pairs from a table.+--+-- Use 'Toml.Schema.optKey' and 'Toml.Schema.reqKey' to extract keys.+--+-- Use 'getTable' and 'setTable' to override the table and implement+-- other primitives.+newtype ParseTable l a = ParseTable (ReaderT l (StateT (Table' l) (Matcher l)) a)+    deriving (Functor, Applicative, Monad, Alternative, MonadPlus)++-- | Implemented in terms of 'fail' on 'Matcher'+instance MonadFail (ParseTable l) where+    fail = ParseTable . fail++-- | Lift a matcher into the current table parsing context.+liftMatcher :: Matcher l a -> ParseTable l a+liftMatcher = ParseTable . lift . lift++-- | Run a 'ParseTable' computation with a given starting 'Table''.+-- Unused tables will generate a warning. To change this behavior+-- 'getTable' and 'setTable' can be used to discard or generate+-- error messages.+parseTable :: ParseTable l a -> l -> Table' l -> Matcher l a+parseTable (ParseTable p) l t =+ do (x, MkTable t') <- runStateT (runReaderT p l) t+    for_ (Map.assocs t') \(k, (a, _)) ->+        warnAt a ("unexpected key: " ++ show (prettySimpleKey k))+    pure x++-- | Return the remaining portion of the table being matched.+getTable :: ParseTable l (Table' l)+getTable = ParseTable (lift get)++-- | Replace the remaining portion of the table being matched.+setTable :: Table' l -> ParseTable l ()+setTable = ParseTable . lift . put++-- | Emit a warning without an annotation.+warnTable :: String -> ParseTable l ()+warnTable = liftMatcher . warn++-- | Emit a warning with the given annotation.+warnTableAt :: l -> String -> ParseTable l ()+warnTableAt l = liftMatcher . warnAt l++-- | Abort the current table matching with an error message at the given annotation.+failTableAt :: l -> String -> ParseTable l a+failTableAt l = liftMatcher . failAt l++-- | Key and value matching function+data KeyAlt l a+    = Key Text (Value' l -> Matcher l a) -- ^ pick alternative based on key match+    | Else (Matcher l a) -- ^ default case when no previous cases matched++-- | Take the first option from a list of table keys and matcher functions.+-- This operation will commit to the first table key that matches. If the+-- associated matcher fails, only that error will be propagated and the+-- other alternatives will not be matched.+--+-- If no keys match, an error message is generated explaining which keys+-- would have been accepted.+--+-- This is provided as an alternative to chaining multiple+-- 'Toml.Schema.reqKey' cases together with 'Control.Applicative.Alternative'+-- which will fall-through as a result of any failure to the next case.+pickKey :: [KeyAlt l a] -> ParseTable l a+pickKey xs =+ do MkTable t <- getTable+    foldr (f t) errCase xs+    where+        f _ (Else m) _ = liftMatcher m+        f t (Key k c) continue =+            case Map.lookup k t of+                Nothing -> continue+                Just (_, v) ->+                 do setTable $! MkTable (Map.delete k t)+                    liftMatcher (inKey k (c v))++        errCase =+         do l <- ParseTable ask+            case xs of+                []        -> empty -- there's nothing a user can do here+                [Key k _] -> failTableAt l ("missing key: " ++ show (prettySimpleKey k))+                _         -> failTableAt l ("possible keys: " ++ intercalate ", " [show (prettySimpleKey k) | Key k _ <- xs])
+ src/Toml/Schema/ToValue.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE TypeFamilies #-} -- needed for type equality on old GHC+{-|+Module      : Toml.Schema.ToValue+Description : Automation for converting application values to TOML.+Copyright   : (c) Eric Mertens, 2023+License     : ISC+Maintainer  : emertens@gmail.com++The 'ToValue' class provides a conversion function from+application-specific to TOML values.++Because the top-level TOML document is always a table,+the 'ToTable' class is for types that specifically support+conversion to a 'Table'.++"Toml.Schema.Generic" can be used to derive instances of 'ToTable'+automatically for record types and 'ToValue' for array types.++-}+module Toml.Schema.ToValue (+    ToValue(..),++    -- * Table construction+    ToTable(..),+    ToKey(..),+    defaultTableToValue,+    table,+    (.=),+    ) where++import Data.Foldable (toList)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Ratio (Ratio)+import Data.Sequence (Seq)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Lazy qualified+import Data.Time (Day, TimeOfDay, LocalTime, ZonedTime, UTCTime, utcToZonedTime, utc)+import Data.Word (Word8, Word16, Word32, Word64)+import Numeric.Natural (Natural)+import Toml.Semantics++-- | Build a 'Table' from a list of key-value pairs.+--+-- Use '.=' for a convenient way to build the pairs.+table :: [(Text, Value)] -> Table+table kvs = MkTable (Map.fromList [(k, ((), v)) | (k, v) <- kvs])+{-# INLINE table #-}++-- | Convenience function for building key-value pairs while+-- constructing a 'Table'.+--+-- @'table' [a '.=' b, c '.=' d]@+(.=) :: ToValue a => Text -> a -> (Text, Value)+k .= v = (k, toValue v)++-- | Class for types that can be embedded into 'Value'+class ToValue a where++    -- | Embed a single thing into a TOML value.+    toValue :: a -> Value++    -- | Helper for converting a list of things into a value. This is typically+    -- left to be defined by its default implementation and exists to help define+    -- the encoding for TOML arrays.+    toValueList :: [a] -> Value+    toValueList = List . map toValue++-- | Class for things that can be embedded into a TOML table.+--+-- Implement this for things that always embed into a 'Table' and then+-- the 'ToValue' instance can be derived with 'defaultTableToValue'.+--+-- @+-- instance ToValue Example where+--     toValue = defaultTableToValue+--+-- -- Option 1: Manual instance+-- instance ToTable Example where+--     toTable x = 'table' ["field1" '.=' field1 x, "field2" '.=' field2 x]+--+-- -- Option 2: GHC.Generics derived instance using Toml.ToValue.Generic+-- instance ToTable Example where+--     toTable = genericToTable+-- @+class ToValue a => ToTable a where++    -- | Convert a single value into a table+    toTable :: a -> Table++instance (ToKey k, ToValue v) => ToTable (Map k v) where+    toTable m = table [(toKey k, toValue v) | (k,v) <- Map.assocs m]++instance (ToKey k, ToValue v) => ToValue (Map k v) where+    toValue = defaultTableToValue++instance ToTable (Table' a) where+    toTable = forgetTableAnns++instance ToValue (Table' a) where+    toValue = defaultTableToValue++-- | Convert to a table key. This class enables various string types to be+-- used as the keys of a 'Map' when converting into TOML tables.+class ToKey a where+    toKey :: a -> Text++instance Char ~ a => ToKey [a] where+    toKey = Text.pack++instance ToKey Text.Text where+    toKey = id++instance ToKey Data.Text.Lazy.Text where+    toKey = Data.Text.Lazy.toStrict++-- | Convenience function for building 'ToValue' instances.+defaultTableToValue :: ToTable a => a -> Value+defaultTableToValue = Table . toTable++-- | Identity function+instance ToValue Value where+    toValue = id++-- | Single characters are encoded as singleton strings. Lists of characters+-- are encoded as a single string value.+instance ToValue Char where+    toValue x = Text (Text.singleton x)+    toValueList = Text . Text.pack++-- | Encodes as string literal+instance ToValue Text.Text where+    toValue = Text++-- | Encodes as string literal+instance ToValue Data.Text.Lazy.Text where+    toValue = Text . Data.Text.Lazy.toStrict++-- | This instance defers to the list element's 'toValueList' implementation.+instance ToValue a => ToValue [a] where+    toValue = toValueList++-- | Converts to list and encodes that to value+instance ToValue a => ToValue (NonEmpty a) where+    toValue = toValue . NonEmpty.toList++-- | Converts to list and encodes that to value+instance ToValue a => ToValue (Seq a) where+    toValue = toValue . toList++-- | TOML represents floating point numbers with 'Prelude.Double'.+-- This operation lose precision and can overflow to infinity.+instance Integral a => ToValue (Ratio a) where+    toValue = Double . realToFrac++instance ToValue Double    where toValue = Double+instance ToValue Float     where toValue = Double . realToFrac+instance ToValue Bool      where toValue = Bool+instance ToValue TimeOfDay where toValue = TimeOfDay+instance ToValue LocalTime where toValue = LocalTime+instance ToValue ZonedTime where toValue = ZonedTime+instance ToValue UTCTime   where toValue = ZonedTime . utcToZonedTime utc+instance ToValue Day       where toValue = Day+instance ToValue Integer   where toValue = Integer+instance ToValue Natural   where toValue = Integer . fromIntegral+instance ToValue Int       where toValue = Integer . fromIntegral+instance ToValue Int8      where toValue = Integer . fromIntegral+instance ToValue Int16     where toValue = Integer . fromIntegral+instance ToValue Int32     where toValue = Integer . fromIntegral+instance ToValue Int64     where toValue = Integer . fromIntegral+instance ToValue Word      where toValue = Integer . fromIntegral+instance ToValue Word8     where toValue = Integer . fromIntegral+instance ToValue Word16    where toValue = Integer . fromIntegral+instance ToValue Word32    where toValue = Integer . fromIntegral+instance ToValue Word64    where toValue = Integer . fromIntegral
src/Toml/Semantics.hs view
@@ -12,28 +12,47 @@ key assignments.  -}-module Toml.Semantics (SemanticError(..), SemanticErrorKind(..), semantics) where+module Toml.Semantics ( +    -- * Types+    Value, Value'(..),+    Table, Table'(..),++    -- * Validation+    semantics,+    SemanticError(..), SemanticErrorKind(..),++    -- * Annotations+    forgetTableAnns,+    forgetValueAnns,+    valueAnn,+    valueType,++    ) where+ import Control.Monad (foldM) import Data.List.NonEmpty (NonEmpty((:|)))+import Data.List.NonEmpty qualified as NonEmpty import Data.Map (Map) import Data.Map qualified as Map-import Toml.Located (locThing, Located)-import Toml.Parser.Types (SectionKind(..), Key, Val(..), Expr(..))-import Toml.Value (Table, Value(..))+import Data.Text (Text)+import Toml.Syntax.Types (SectionKind(..), Key, Val(..), Expr(..))+import Toml.Semantics.Types  -- | This type represents errors generated when resolving keys in a TOML -- document. -- -- @since 1.3.0.0-data SemanticError = SemanticError {-    errorKey :: String,+data SemanticError a = SemanticError {+    errorAnn :: a, -- ^ Annotation associated with offending key+    errorKey :: Text,     errorKind :: SemanticErrorKind     } deriving (         Read {- ^ Default instance -},         Show {- ^ Default instance -},         Eq   {- ^ Default instance -},-        Ord  {- ^ Default instance -})+        Ord  {- ^ Default instance -},+        Functor, Foldable, Traversable)  -- | Enumeration of the kinds of conflicts a key can generate. --@@ -50,9 +69,7 @@  -- | 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 :: [Expr a] -> Either (SemanticError a) (Table' a) semantics exprs =  do f <- foldM processExpr (flip assignKeyVals Map.empty) exprs     framesToTable <$> f []@@ -66,11 +83,11 @@  -- | A top-level table used to distinguish top-level defined arrays -- and tables from inline values.-type FrameTable = Map String Frame+type FrameTable a = Map Text (a, Frame a)  -- | M is the error-handling monad used through this module for -- propagating semantic errors through the 'semantics' function.-type M = Either (Located SemanticError)+type M a = Either (SemanticError a)  -- | Frames are the top-level skeleton of the TOML file that mirror the -- subset of values that can be constructed with with top-level syntax.@@ -79,94 +96,91 @@ -- 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+data Frame a+    = FrameTable a FrameKind (FrameTable a)+    | FrameArray (NonEmpty (a, FrameTable a)) -- stored in reverse order for easy "append"+    | FrameValue (Value' a)     deriving Show  -- | Top-level tables can be in various states of completeness. This type -- keeps track of the current state of a top-level defined table. data FrameKind-    = Open   -- ^ table implicitly defined as supertable of [x.y.z]+    = Open   -- ^ table implicitly defined as super-table of [x.y.z]     | Dotted -- ^ table implicitly defined using dotted key assignment     | Closed -- ^ table closed to further extension     deriving Show  -- | Convert a top-level table "frame" representation into the plain Value -- representation once the distinction is no longer needed.-framesToTable :: FrameTable -> 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+framesToTable :: FrameTable a -> Table' a+framesToTable = fmap MkTable $ fmap $ fmap+    \case+        FrameTable a _kind t -> Table' a (framesToTable t)+        FrameArray (NonEmpty.reverse -> t :| ts) ->+            -- the array itself is attributed to the first table defined+            List' (fst t) [Table' a (framesToTable x) | (a, x) <- t : ts]+        FrameValue v -> v  -- | Attempts to insert the key-value pairs given into a new section -- located at the given key-path in a frame map. addSection ::-    SectionKind  {- ^ section kind                               -} ->-    Key          {- ^ section key                                -} ->-    [(Key, Val)] {- ^ values to install                          -} ->-    FrameTable   {- ^ local frame map                            -} ->-    M FrameTable {- ^ error message or updated local frame table -}+    SectionKind      {- ^ section kind                           -} ->+    Key a            {- ^ section key                            -} ->+    [(Key a, Val a)] {- ^ values to install                      -} ->+    FrameTable a     {- ^ local frame map                        -} ->+    M a (FrameTable a) {- ^ error message or updated local frame table -}  addSection kind (k :| []) kvs =-    alterFrame k \case+    alterFrame k         -- defining a new table-        Nothing ->-            case kind of-                TableKind      -> FrameTable Closed <$> go mempty-                ArrayTableKind -> FrameArray . (:| []) <$> go mempty+        (case kind of+                TableKind      -> FrameTable (fst k) Closed <$> go mempty+                ArrayTableKind -> FrameArray . (:| []) . (,) (fst k) <$> go mempty) -        -- defining a super table of a previously defined subtable-        Just (FrameTable Open t) ->+        \case+        -- defining a super table of a previously defined sub-table+        FrameTable _ Open t ->             case kind of-                TableKind      -> FrameTable Closed <$> go t+                -- the annotation of the open table changes from the first mention closing key+                TableKind      -> FrameTable (fst k) Closed <$> go t                 ArrayTableKind -> invalidKey k ImplicitlyTable          -- Add a new array element to an existing table array-        Just (FrameArray (t :| ts)) ->+        FrameArray (t :| ts) ->             case kind of                 TableKind      -> invalidKey k ClosedTable-                ArrayTableKind -> FrameArray . (:| t : ts) <$> go mempty+                ArrayTableKind -> FrameArray . (:| t : ts) . (,) (fst k) <$> go mempty          -- failure cases-        Just (FrameTable Closed _) -> invalidKey k ClosedTable-        Just (FrameTable Dotted _) -> error "addSection: dotted table left unclosed"-        Just (FrameValue {})       -> invalidKey k AlreadyAssigned+        FrameTable _ Closed _ -> invalidKey k ClosedTable+        FrameTable _ Dotted _ -> error "addSection: dotted table left unclosed"+        FrameValue {}         -> invalidKey k AlreadyAssigned         where             go = assignKeyVals kvs  addSection kind (k1 :| k2 : ks) kvs =-    alterFrame k1 \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+    alterFrame k1+        (FrameTable (fst k1) Open      <$> go mempty)+        \case+        FrameTable a tk t    -> FrameTable a tk      <$> go t+        FrameArray (t :| ts) -> FrameArray . (:| ts) <$> traverse go t+        FrameValue _         -> invalidKey k1 AlreadyAssigned         where             go = addSection kind (k2 :| ks) kvs  -- | Close all of the tables that were implicitly defined with -- dotted prefixes. These tables are only eligible for extension -- within the @[table]@ section in which they were introduced.-closeDots :: FrameTable -> FrameTable+closeDots :: FrameTable a -> FrameTable a closeDots =-    fmap \case-        FrameTable Dotted t -> FrameTable Closed (closeDots t)-        frame               -> frame+    fmap $ fmap \case+        FrameTable a Dotted t -> FrameTable a Closed (closeDots t)+        frame                 -> frame  -- | Extend the given frame table with a list of key-value pairs. -- Any tables created through dotted keys will be closed after -- all of the key-value pairs are processed.-assignKeyVals :: [(Key, Val)] -> FrameTable -> M FrameTable+assignKeyVals :: [(Key a, Val a)] -> FrameTable a -> M a (FrameTable a) assignKeyVals kvs t = closeDots <$> foldM f t kvs     where         f m (k,v) = assign k v m@@ -174,46 +188,61 @@ -- | 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 a -> Val a -> FrameTable a -> M a (FrameTable a)  assign (key :| []) val =-    alterFrame key \case-        Nothing -> FrameValue <$> valToValue val-        Just{}  -> invalidKey key AlreadyAssigned+    alterFrame key+        (FrameValue <$> valToValue val)+        (\_ -> 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+    alterFrame key (go (fst key) mempty)+        \case+        FrameTable a Open   t -> go a t+        FrameTable a Dotted t -> go a t+        FrameTable _ Closed _ -> invalidKey key ClosedTable+        FrameArray          _ -> invalidKey key ClosedTable+        FrameValue          _ -> invalidKey key AlreadyAssigned     where-        go t = FrameTable Dotted <$> assign (k1 :| keys) val t+        go a t = FrameTable a Dotted <$> assign (k1 :| keys) val t  -- | Convert 'Val' to 'Value' potentially raising an error if -- it contains inline tables with key-conflicts.-valToValue :: Val -> 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+valToValue :: Val a -> M a (Value' a)+valToValue =+    \case+        ValInteger   a x    -> Right (Integer'   a x)+        ValFloat     a x    -> Right (Double'    a x)+        ValBool      a x    -> Right (Bool'      a x)+        ValString    a x    -> Right (Text'      a x)+        ValTimeOfDay a x    -> Right (TimeOfDay' a x)+        ValZonedTime a x    -> Right (ZonedTime' a x)+        ValLocalTime a x    -> Right (LocalTime' a x)+        ValDay       a x    -> Right (Day'       a x)+        ValArray     a xs   -> List' a <$> traverse valToValue xs+        ValTable     a kvs  -> Table' a . framesToTable <$> assignKeyVals kvs mempty  -- | Abort validation by reporting an error about the given key. invalidKey ::-    Located String    {- ^ subkey     -} ->+    (a, Text)         {- ^ sub-key    -} ->     SemanticErrorKind {- ^ error kind -} ->-    M a-invalidKey key kind = Left ((`SemanticError` kind) <$> key)+    M a b+invalidKey (a, key) kind = Left (SemanticError a key kind)  -- | Specialization of 'Map.alterF' used to adjust a location in a 'FrameTable'-alterFrame :: Located String -> (Maybe Frame -> M Frame) -> FrameTable -> M FrameTable-alterFrame k f = Map.alterF (fmap Just . f) (locThing k)+alterFrame ::+    (a, Text)                  {- ^ annotated key     -} ->+    M a (Frame a)              {- ^ new value case    -} ->+    (Frame a -> M a (Frame a)) {- ^ update value case -} ->+    FrameTable a -> M a (FrameTable a)+alterFrame (a, k) create update = Map.alterF g k+    where+        -- insert a new value+        g Nothing =+            do lf <- create+               pure (Just (a, lf))++        -- update an existing value and preserve its annotation+        g (Just (op, ov)) =+            do lf <- update ov+               pure (Just (op, lf))
src/Toml/Semantics/Ordered.hs view
@@ -24,8 +24,6 @@     'print' ('Toml.Pretty.prettyTomlOrdered' projection toml) @ -@since 1.3.1.0- -} module Toml.Semantics.Ordered (     TableOrder,@@ -39,22 +37,28 @@ 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))+import Data.Text (Text)+import Data.Text qualified as Text+import Toml.Syntax.Types (Expr(..), Key, Val(ValTable, ValArray))  -- | Summary of the order of the keys in a TOML document.-newtype TableOrder = TO (Map String KeyOrder)+newtype TableOrder = TO (Map Text KeyOrder) +-- | Internal type used by 'TableOrder'+--+-- The 'Int' field determines the order of the current key and the+-- 'TableOrder' determines the order of the children of this key. data KeyOrder = KeyOrder !Int TableOrder -newtype ProjectedKey = PK (Either Int String)+-- | Opaque type used by 'projectKey'+newtype ProjectedKey = PK (Either Int Text)     deriving (Eq, Ord)  -- | Generate a projection function for use with 'Toml.Pretty.prettyTomlOrdered' projectKey ::-    TableOrder {- ^ table order -} ->-    [String] {- ^ table path -} ->-    String {- ^ key -} ->+    TableOrder   {- ^ table order                           -} ->+    [Text]       {- ^ table path                            -} ->+    Text         {- ^ key                                   -} ->     ProjectedKey {- ^ type suitable for ordering table keys -} projectKey (TO to) [] = \k ->     case Map.lookup k to of@@ -70,32 +74,34 @@  -- | Extract a 'TableOrder' from the output of 'Toml.Parser.parseRawToml' -- to be later used with 'projectKey'.-extractTableOrder :: [Expr] -> TableOrder+extractTableOrder :: [Expr a] -> TableOrder extractTableOrder = snd . foldl' addExpr ([], emptyOrder) -addExpr :: ([String], TableOrder) -> Expr -> ([String], TableOrder)+addExpr :: ([Text], TableOrder) -> Expr a -> ([Text], TableOrder) addExpr (prefix, to) = \case     TableExpr k      -> let k' = keyPath k in (k', addKey to k')     ArrayTableExpr k -> let k' = keyPath k in (k', addKey to k')     KeyValExpr k v   -> (prefix, addVal prefix (addKey to (prefix ++ keyPath k)) v) -addVal :: [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+addVal :: [Text] -> TableOrder -> Val a -> TableOrder+addVal prefix to lval =+    case lval of+        ValArray _ xs -> foldl' (addVal prefix) to xs+        ValTable _ kvs ->+            foldl' (\acc (k,v) ->+                let k' = prefix ++ keyPath k in+                addVal k' (addKey acc k') v) to kvs+        _ -> to -addKey :: TableOrder -> [String] -> TableOrder+addKey :: TableOrder -> [Text] -> TableOrder addKey to [] = to addKey (TO to) (x:xs) = TO (Map.alter f x to)     where         f Nothing = Just (KeyOrder (Map.size to) (addKey emptyOrder xs))         f (Just (KeyOrder i m)) = Just (KeyOrder i (addKey m xs)) -keyPath :: Key -> [String]-keyPath = map locThing . toList+keyPath :: Key a -> [Text]+keyPath = map snd . toList  -- | Render a white-space nested representation of the key ordering extracted -- by 'extractTableOrder'. This is provided for debugging and understandability.@@ -107,7 +113,7 @@                 (sortOn p (Map.assocs m))          go1 i (k, KeyOrder _ v) z =-            (replicate (4*i) ' ' ++ k) :+            (replicate (4*i) ' ' ++ Text.unpack k) :             go (i+1) v z          p (_, KeyOrder i _) = i
+ src/Toml/Semantics/Types.hs view
@@ -0,0 +1,195 @@+{-# Language PatternSynonyms, DeriveTraversable, TypeFamilies #-}+{-|+Module      : Toml.Semantics.Types+Description : Semantic TOML values+Copyright   : (c) Eric Mertens, 2023+License     : ISC+Maintainer  : emertens@gmail.com++This module provides the type for the semantics of a TOML file.+All dotted keys are resolved in this representation. Each table+is a Map with a single level of keys.++Values are parameterized over an annotation type to allow values+to be attributed to a file location. When values are constructed+programmatically, there might not be any interesting annotations.+In this case a trivial @()@ unit annotation can be used. The+'Value' type-synonym and related pattern synonyms can make using+this case more convenient.++-}+module Toml.Semantics.Types (+    -- * Unlocated value synonyms+    Value,+    Table,++    -- * Annotated values+    Value'(..,+        Integer, Double, Text, Bool,+        ZonedTime, Day, LocalTime, TimeOfDay,+        List, Table),+    Table'(..),++    -- * Utilities+    forgetValueAnns,+    forgetTableAnns,+    valueAnn,+    valueType,+    ) where++import Data.Map (Map)+import Data.String (IsString(fromString))+import Data.Text (Text)+import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime(zonedTimeToLocalTime, zonedTimeZone), timeZoneMinutes)++pattern Integer :: Integer -> Value+pattern Integer x <- Integer' _ x+    where Integer x = Integer' () x++pattern Double :: Double -> Value+pattern Double x <- Double' _ x+    where Double x = Double' () x++pattern List :: [Value] -> Value+pattern List x <- List' _ x+    where List x = List' () x++pattern Table :: Table -> Value+pattern Table x <- Table' _ x+    where Table x = Table' () x++pattern Bool :: Bool -> Value+pattern Bool x <- Bool' _ x+    where Bool x = Bool' () x++pattern Text :: Text -> Value+pattern Text x <- Text' _ x+    where Text x = Text' () x++pattern TimeOfDay :: TimeOfDay -> Value+pattern TimeOfDay x <- TimeOfDay' _ x+    where TimeOfDay x = TimeOfDay' () x++pattern ZonedTime :: ZonedTime -> Value+pattern ZonedTime x <- ZonedTime' _ x+    where ZonedTime x = ZonedTime' () x++pattern LocalTime :: LocalTime -> Value+pattern LocalTime x <- LocalTime' _ x+    where LocalTime x = LocalTime' () x++pattern Day :: Day -> Value+pattern Day x <- Day' _ x+    where Day x = Day' () x++{-# Complete List, Table, Text, Bool, Integer, Double, Day, LocalTime, ZonedTime, TimeOfDay #-}++-- | Semantic TOML value with all table assignments resolved.+data Value' a+    = Integer'   a Integer+    | Double'    a Double+    | List'      a [Value' a]+    | Table'     a (Table' a)+    | Bool'      a Bool+    | Text'      a Text+    | TimeOfDay' a TimeOfDay+    | ZonedTime' a ZonedTime+    | LocalTime' a LocalTime+    | Day'       a Day+    deriving (+        Show        {- ^ Default instance -},+        Read        {- ^ Default instance -},+        Functor     {- ^ Derived          -},+        Foldable    {- ^ Derived          -},+        Traversable {- ^ Derived          -})++-- | Extract the top-level annotation from a value.+valueAnn :: Value' a -> a+valueAnn = \case+    Integer'   a _ -> a+    Double'    a _ -> a+    List'      a _ -> a+    Table'     a _ -> a+    Bool'      a _ -> a+    Text'      a _ -> a+    TimeOfDay' a _ -> a+    ZonedTime' a _ -> a+    LocalTime' a _ -> a+    Day'       a _ -> a++-- | String representation of the kind of value using TOML vocabulary+valueType :: Value' l -> String+valueType = \case+    Integer'   {} -> "integer"+    Double'    {} -> "float"+    List'      {} -> "array"+    Table'     {} -> "table"+    Bool'      {} -> "boolean"+    Text'      {} -> "string"+    TimeOfDay' {} -> "local time"+    LocalTime' {} -> "local date-time"+    Day'       {} -> "locate date"+    ZonedTime' {} -> "offset date-time"++-- | A table with annotated keys and values.+newtype Table' a = MkTable (Map Text (a, Value' a))+    deriving (+        Show        {- ^ Default instance -},+        Read        {- ^ Default instance -},+        Eq          {- ^ Default instance -},+        Functor     {- ^ Derived          -},+        Foldable    {- ^ Derived          -},+        Traversable {- ^ Derived          -})++-- | A 'Table'' with trivial annotations+type Table = Table' ()++-- | A 'Value'' with trivial annotations+type Value = Value' ()++-- | Replaces annotations with a unit.+forgetTableAnns :: Table' a -> Table+forgetTableAnns (MkTable t) = MkTable (fmap (\(_, v) -> ((), forgetValueAnns v)) t)++-- | Replaces annotations with a unit.+forgetValueAnns :: Value' a -> Value+forgetValueAnns =+    \case+        Integer'   _ x -> Integer   x+        Double'    _ x -> Double    x+        List'      _ x -> List      (map forgetValueAnns x)+        Table'     _ x -> Table     (forgetTableAnns x)+        Bool'      _ x -> Bool      x+        Text'      _ x -> Text      x+        TimeOfDay' _ x -> TimeOfDay x+        ZonedTime' _ x -> ZonedTime x+        LocalTime' _ x -> LocalTime x+        Day'       _ x -> Day       x++-- | Nearly default instance except 'ZonedTime' doesn't have an+-- 'Eq' instance. 'ZonedTime' values are equal if their times and+-- time-zones are both equal.+instance Eq a => Eq (Value' a) where+    Integer'   a x == Integer'   b y = a == b && x == y+    Double'    a x == Double'    b y = a == b && x == y+    List'      a x == List'      b y = a == b && x == y+    Table'     a x == Table'     b y = a == b && x == y+    Bool'      a x == Bool'      b y = a == b && x == y+    Text'      a x == Text'      b y = a == b && x == y+    TimeOfDay' a x == TimeOfDay' b y = a == b && x == y+    LocalTime' a x == LocalTime' b y = a == b && x == y+    Day'       a x == Day'       b y = a == b && x == y+    ZonedTime' a x == ZonedTime' b y = a == b && projectZT x == projectZT y+    _              == _              = False++-- Extract the relevant parts to build an 'Eq' instance+projectZT :: ZonedTime -> (LocalTime, Int)+projectZT x = (zonedTimeToLocalTime x, timeZoneMinutes (zonedTimeZone x))++-- | Constructs a TOML string literal.+--+-- @+-- fromString = String+-- @+instance () ~ a => IsString (Value' a) where+    fromString = Text . fromString
+ src/Toml/Syntax.hs view
@@ -0,0 +1,33 @@+{-|+Module      : Toml.Syntax+Description : Parsing and lexing for TOML syntax+Copyright   : (c) Eric Mertens, 2024+License     : ISC+Maintainer  : emertens@gmail.com++These are the low-level processing functions for transforming+concrete TOML syntax into abstract TOML syntax. This module+does not do any semantic validation of the parsed TOML.++-}+module Toml.Syntax (+    -- * Parsing+    parseRawToml,+    Key,+    Expr(..),+    Val(..),++    -- * Lexing+    scanToken,+    Context(..),+    Token(..),++    -- * Locations+    Located(..),+    Position(..),+    startPos,+) where++import Toml.Syntax.Lexer+import Toml.Syntax.Parser+import Toml.Syntax.Position
+ src/Toml/Syntax/Lexer.x view
@@ -0,0 +1,224 @@+{+{-|+Module      : Toml.Syntax.Lexer+Description : TOML lexical analyzer+Copyright   : (c) Eric Mertens, 2023+License     : ISC+Maintainer  : emertens@gmail.com++This module parses a TOML file into a lazy sequence+of tokens. The lexer is aware of nested brackets and+equals signs in order to handle TOML's context-sensitive+lexing requirements. This context enables the lexer to+distinguish between bare keys and various values like:+floating-point literals, integer literals, and date literals.++This module uses actions and lexical hooks defined in+"LexerUtils".++-}+module Toml.Syntax.Lexer (Context(..), scanToken, lexValue, Token(..)) where++import Data.Text (Text)+import Data.Text qualified as Text+import Toml.Syntax.Token+import Toml.Syntax.LexerUtils+import Toml.Syntax.Position++}+$non_ascii        = \x1+$wschar           = [\ \t]++@ws               = $wschar*+@newline          = \r? \n++$bindig           = [0-1]+$octdig           = [0-7]+$digit            = [0-9]+$hexdig           = [ $digit A-F a-f ]+$basic_unescaped  = [ $wschar \x21 \x23-\x5B \x5D-\x7E $non_ascii ]+$comment_start_symbol = \#+$control          = [\x00-\x1F \x7F]++@barekey = [0-9 A-Z a-z \- _]+++@unsigned_dec_int = $digit | [1-9] ($digit | _ $digit)++@dec_int = [\-\+]? @unsigned_dec_int+@zero_prefixable_int = $digit ($digit | _ $digit)*+@hex_int = "0x" $hexdig ($hexdig | _ $hexdig)*+@oct_int = "0o" $octdig ($octdig | _ $octdig)*+@bin_int = "0b" $bindig ($bindig | _ $bindig)*++@frac = "." @zero_prefixable_int+@float_exp_part = [\+\-]? @zero_prefixable_int+@special_float = [\+\-]? ("inf" | "nan")+@exp = [Ee] @float_exp_part+@float_int_part = @dec_int+@float = @float_int_part ( @exp | @frac @exp? ) | @special_float++@bad_dec_int = [\-\+]? 0 ($digit | _ $digit)+++$non_eol = [\x09 \x20-\x7E $non_ascii]+@comment = $comment_start_symbol $non_eol*++$literal_char = [\x09 \x20-\x26 \x28-\x7E $non_ascii]++@mll_content = $literal_char | @newline++@mlb_escaped_nl = \\ @ws @newline ($wschar | @newline)*+$unescaped = [$wschar \x21 \x23-\x5B \x5D-\x7E $non_ascii]++@date_fullyear  = $digit {4}+@date_month     = $digit {2}+@date_mday      = $digit {2}+$time_delim     = [Tt\ ]+@time_hour      = $digit {2}+@time_minute    = $digit {2}+@time_second    = $digit {2}+@offset_hour    = [01] $digit | 2 [0-3]+@offset_minute  = [0-5] $digit+@time_secfrac   = "." $digit++@time_numoffset = [\+\-] @offset_hour ":" @offset_minute+@time_offset    = [Zz] | @time_numoffset++@partial_time = @time_hour ":" @time_minute (":" @time_second @time_secfrac?)?+@full_date = @date_fullyear "-" @date_month "-" @date_mday+@full_time = @partial_time @time_offset++@offset_date_time = @full_date $time_delim @full_time+@local_date_time = @full_date $time_delim @partial_time+@local_date = @full_date+@local_time = @partial_time++toml :-+++<val> {++@bad_dec_int        { failure "leading zero prohibited" }+@dec_int            { token mkDecInteger                }+@hex_int            { token mkHexInteger                }+@oct_int            { token mkOctInteger                }+@bin_int            { token mkBinInteger                }+@float              { token mkFloat                     }+"true"              { token_ TokTrue                    }+"false"             { token_ TokFalse                   }++@offset_date_time   { timeValue "offset date-time" offsetDateTimePatterns TokOffsetDateTime }+@local_date         { timeValue "local date"       localDatePatterns      TokLocalDate      }+@local_date_time    { timeValue "local date-time"  localDateTimePatterns  TokLocalDateTime  }+@local_time         { timeValue "local time"       localTimePatterns      TokLocalTime      }++}++<0> {+"[["                { token_ Tok2SquareO                }+"]]"                { token_ Tok2SquareC                }+}++<0,val,tab> {+@newline            { token_ TokNewline                 }+@comment;+$wschar+;++"="                 { token_ TokEquals                  }+"."                 { token_ TokPeriod                  }+","                 { token_ TokComma                   }++"["                 { token_ TokSquareO                 }+"]"                 { token_ TokSquareC                 }+"{"                 { token_ TokCurlyO                  }+"}"                 { token_ TokCurlyC                  }++@barekey            { textToken TokBareKey              }++\"{3} @newline?     { startMlBstr                       }+\"                  { startBstr                         }+"'''" @newline?     { startMlLstr                       }+"'"                 { startLstr                         }++}++<lstr> {+  $literal_char+    { strFrag                           }+  "'"               { endStr . fmap (Text.drop 1)       }+}++<bstr> {+  $unescaped+       { strFrag                           }+  \"                { endStr . fmap (Text.drop 1)       }+}++<mllstr> {+  @mll_content+     { strFrag                           }+  "'" {1,2}         { strFrag                           }+  "'" {3,5}         { endStr . fmap (Text.drop 3)       }+}++<mlbstr> {+  @mlb_escaped_nl;+  ($unescaped | @newline)+ { strFrag                    }+  \" {1,2}          { strFrag                           }+  \" {3,5}          { endStr . fmap (Text.drop 3)       }+}++<mlbstr, bstr> {+  \\ x $hexdig{2}   { unicodeEscape                     }+  \\ x              { failure "\\x requires exactly 2 hex digits"}+  \\ u $hexdig{4}   { unicodeEscape                     }+  \\ u              { failure "\\u requires exactly 4 hex digits"}+  \\ U $hexdig{8}   { unicodeEscape                     }+  \\ U              { failure "\\U requires exactly 8 hex digits"}+  \\ n              { strFrag . (Text.singleton '\n' <$) }+  \\ t              { strFrag . (Text.singleton '\t' <$) }+  \\ r              { strFrag . (Text.singleton '\r' <$) }+  \\ f              { strFrag . (Text.singleton '\f' <$) }+  \\ b              { strFrag . (Text.singleton '\b' <$) }+  \\ e              { strFrag . (Text.singleton '\ESC' <$) }+  \\ \\             { strFrag . (Text.singleton '\\' <$) }+  \\ \"             { strFrag . (Text.singleton '\"' <$) }+  \\ .              { failure "unknown escape sequence" }+  \\                { failure "incomplete escape sequence" }+  $control # [\t\r\n] { recommendEscape                 }+}++{++type AlexInput = Located Text++alexGetByte :: AlexInput -> Maybe (Int, AlexInput)+alexGetByte = locatedUncons++-- | Get the next token from a located string or a located error message.+scanToken :: Context -> Located Text -> Either (Located String) (Located Token, Located Text)+scanToken st str =+  case alexScan str (stateInt st) of+    AlexEOF          -> eofToken st str+    AlexError str'   -> Left (mkError . Text.unpack <$> str')+    AlexSkip  str' _ -> scanToken st str'+    AlexToken str' n action ->+      case action (Text.take n <$> str) st of+        Resume st'   -> scanToken st' str'+        LexerError e -> Left e+        EmitToken  t -> Right (t, str')++-- Map the logical lexer state to an Alex state number+stateInt :: Context -> Int+stateInt =+  \case+    TopContext      -> 0+    TableContext    -> tab+    ValueContext    -> val+    BstrContext  {} -> bstr+    MlBstrContext{} -> mlbstr+    LstrContext  {} -> lstr+    MlLstrContext{} -> mllstr++-- | Lex a single token in a value context. This is mostly useful for testing.+lexValue :: Text -> Either String Token+lexValue str =+    case scanToken ValueContext Located{ locPosition = startPos, locThing = str } of+      Left e -> Left (locThing e)+      Right (t,_) -> Right (locThing t)++}
+ src/Toml/Syntax/LexerUtils.hs view
@@ -0,0 +1,183 @@+{-|+Module      : Toml.Syntax.LexerUtils+Description : Wrapper and actions for generated lexer+Copyright   : (c) Eric Mertens, 2023+License     : ISC+Maintainer  : emertens@gmail.com++This module provides a custom engine for the Alex generated+lexer. This lexer drive provides nested states, unicode support,+and file location tracking.++The various states of this module are needed to deal with the varying+lexing rules while lexing values, keys, and string-literals.++-}+module Toml.Syntax.LexerUtils (++    -- * Types+    Action,+    Context(..),+    Outcome(..),++    -- * Input processing+    locatedUncons,++    -- * Actions+    token,+    token_,+    textToken,++    timeValue,+    eofToken,++    failure,++    -- * String literals+    strFrag,+    startMlBstr,+    startBstr,+    startMlLstr,+    startLstr,+    endStr,+    unicodeEscape,+    recommendEscape,++    mkError,+    ) where++import Data.Char (ord, chr, isAscii, isControl)+import Data.Foldable (asum)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time.Format (parseTimeM, defaultTimeLocale, ParseTime)+import Numeric (readHex)+import Text.Printf (printf)+import Toml.Syntax.Token (Token(..))+import Toml.Syntax.Position (move, Located(..), Position)++-- | Type of actions associated with lexer patterns+type Action = Located Text -> Context -> Outcome++data Outcome+  = Resume Context+  | LexerError (Located String)+  | EmitToken (Located Token)++-- | Representation of the current lexer state.+data Context+  = TopContext -- ^ top-level where @[[@ and @]]@ have special meaning+  | TableContext -- ^ inline table - lex key names+  | ValueContext -- ^ value lexer - lex number literals+  | MlBstrContext Position [Text] -- ^ multiline basic string: position of opening delimiter and list of fragments+  | BstrContext   Position [Text] -- ^ basic string: position of opening delimiter and list of fragments+  | MlLstrContext Position [Text] -- ^ multiline literal string: position of opening delimiter and list of fragments+  | LstrContext   Position [Text] -- ^ literal string: position of opening delimiter and list of fragments+  deriving Show++-- | Add a literal fragment of a string to the current string state.+strFrag :: Action+strFrag (Located _ s) = \case+  BstrContext   p acc -> Resume (BstrContext   p (s : acc))+  MlBstrContext p acc -> Resume (MlBstrContext p (s : acc))+  LstrContext   p acc -> Resume (LstrContext   p (s : acc))+  MlLstrContext p acc -> Resume (MlLstrContext p (s : acc))+  _                   -> error "strFrag: panic"++-- | End the current string state and emit the string literal token.+endStr :: Action+endStr (Located _ x) = \case+    BstrContext   p acc -> EmitToken (Located p (TokString   (Text.concat (reverse (x : acc)))))+    MlBstrContext p acc -> EmitToken (Located p (TokMlString (Text.concat (reverse (x : acc)))))+    LstrContext   p acc -> EmitToken (Located p (TokString   (Text.concat (reverse (x : acc)))))+    MlLstrContext p acc -> EmitToken (Located p (TokMlString (Text.concat (reverse (x : acc)))))+    _                  -> error "endStr: panic"++-- | Start a basic string literal+startBstr :: Action+startBstr (Located p _) _ = Resume (BstrContext p [])++-- | Start a literal string literal+startLstr :: Action+startLstr (Located p _) _ = Resume (LstrContext p [])++-- | Start a multi-line basic string literal+startMlBstr :: Action+startMlBstr (Located p _) _ = Resume (MlBstrContext p [])++-- | Start a multi-line literal string literal+startMlLstr :: Action+startMlLstr (Located p _) _ = Resume (MlLstrContext p [])++-- | Resolve a unicode escape sequence and add it to the current string literal+unicodeEscape :: Action+unicodeEscape (Located p lexeme) ctx =+  case readHex (drop 2 (Text.unpack lexeme)) of+    [(n,_)] | 0xd800 <= n, n < 0xe000 -> LexerError (Located p "non-scalar unicode escape")+      | n >= 0x110000                 -> LexerError (Located p "unicode escape too large")+      | otherwise                     -> strFrag (Located p (Text.singleton (chr n))) ctx+    _                                 -> error "unicodeEscape: panic"++recommendEscape :: Action+recommendEscape (Located p x) _ =+  LexerError (Located p (printf "control characters must be escaped, use: \\u%04X" (ord (Text.head x))))++-- | Emit a token ignoring the current lexeme+token_ :: Token -> Action+token_ t x _ = EmitToken (t <$ x)++-- | Emit a token using the current lexeme+token :: (String -> Token) -> Action+token f x _ = EmitToken (f . Text.unpack <$> x)++-- | Emit a token using the current lexeme+textToken :: (Text -> Token) -> Action+textToken f x _ = EmitToken (f <$> x)++-- | Attempt to parse the current lexeme as a date-time token.+timeValue ::+  ParseTime a =>+  String       {- ^ description for error messages -} ->+  [String]     {- ^ possible valid patterns        -} ->+  (a -> Token) {- ^ token constructor              -} ->+  Action+timeValue description patterns constructor (Located p str) _ =+  case asum [parseTimeM False defaultTimeLocale pat (Text.unpack str) | pat <- patterns] of+    Nothing -> LexerError (Located p ("malformed " ++ description))+    Just t  -> EmitToken (Located p (constructor t))++-- | Pop the first character off a located string if it's not empty.+-- The resulting 'Int' will either be the ASCII value of the character+-- or @1@ for non-ASCII Unicode values. To avoid a clash, @\x1@ is+-- remapped to @0@.+locatedUncons :: Located Text -> Maybe (Int, Located Text)+locatedUncons Located { locPosition = p, locThing = str } =+  case Text.uncons str of+    Nothing -> Nothing+    Just (x, xs)+      | rest `seq` False -> undefined+      | x == '\1' -> Just (0,     rest)+      | isAscii x -> Just (ord x, rest)+      | otherwise -> Just (1,     rest)+      where+        rest = Located { locPosition = move x p, locThing = xs }++-- | Generate the correct terminating token given the current lexer state.+eofToken :: Context -> Located Text -> Either (Located String) (Located Token, Located Text)+eofToken (MlBstrContext p _) _ = Left (Located p "unterminated multi-line basic string")+eofToken (BstrContext   p _) _ = Left (Located p "unterminated basic string")+eofToken (MlLstrContext p _) _ = Left (Located p "unterminated multi-line literal string")+eofToken (LstrContext   p _) _ = Left (Located p "unterminated literal string")+eofToken _                   t = Right (TokEOF <$ t, t)++failure :: String -> Action+failure err t _ = LexerError (err <$ t)++-- | Generate an error message given the current string being lexed.+mkError :: String -> String+mkError ""    = "unexpected end-of-input"+mkError ('\n':_) = "unexpected end-of-line"+mkError ('\r':'\n':_) = "unexpected end-of-line"+mkError (x:_)+    | isControl x = "control characters prohibited"+    | otherwise   = "unexpected " ++ show x
+ src/Toml/Syntax/Parser.y view
@@ -0,0 +1,160 @@+{+{-|+Module      : Toml.Syntax.Parser+Description : Raw TOML expression parser+Copyright   : (c) Eric Mertens, 2023+License     : ISC+Maintainer  : emertens@gmail.com++This module parses TOML tokens into a list of raw,+uninterpreted sections and assignments.++-}+module Toml.Syntax.Parser (+  -- * Types+  Expr(..),+  SectionKind(..),+  Val(..),+  Key,++  -- * Parser+  parseRawToml,+  ) where++import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Text (Text)+import Toml.Syntax.Lexer (Context(..), Token(..))+import Toml.Syntax.ParserUtils+import Toml.Syntax.Position (Located(Located, locThing), Position)+import Toml.Syntax.Position (startPos)+import Toml.Syntax.Types (Expr(..), Key, Val(..), SectionKind(..))++}++%tokentype            { Located Token                               }+%token+','                   { Located $$ TokComma                         }+'='                   { Located $$ TokEquals                        }+NEWLINE               { Located $$ TokNewline                       }+'.'                   { Located $$ TokPeriod                        }+'['                   { Located $$ TokSquareO                       }+']'                   { Located $$ TokSquareC                       }+'[['                  { Located $$ Tok2SquareO                      }+']]'                  { Located $$ Tok2SquareC                      }+'{'                   { Located $$ TokCurlyO                        }+'}'                   { Located $$ TokCurlyC                        }+BAREKEY               { (traverse asBareKey        -> Just $$)      }+STRING                { (traverse asString         -> Just $$)      }+MLSTRING              { (traverse asMlString       -> Just $$)      }+BOOL                  { (traverse asBool           -> Just $$)      }+INTEGER               { (traverse asInteger        -> Just $$)      }+FLOAT                 { (traverse asFloat          -> Just $$)      }+OFFSETDATETIME        { (traverse asOffsetDateTime -> Just $$)      }+LOCALDATETIME         { (traverse asLocalDateTime  -> Just $$)      }+LOCALDATE             { (traverse asLocalDate      -> Just $$)      }+LOCALTIME             { (traverse asLocalTime      -> Just $$)      }++%monad                { Parser r } { thenP } { pureP }+%lexer                { lexerP } { Located _ TokEOF }+%error                { errorP }++%name parseRawToml_ toml++%%++toml ::               { [Expr Position]                             }+  : sepBy1(expression, NEWLINE)+                      { concat $1                                   }++expression ::         { [Expr Position]                             }+  :                   { []                                          }+  | keyval            { [uncurry KeyValExpr $1]                     }+  | '['  key ']'      { [TableExpr      $2    ]                     }+  | '[[' key ']]'     { [ArrayTableExpr $2    ]                     }++keyval ::             { (Key Position, Val Position)                }+  : key rhs '=' pop val+                      { ($1,$5)                                     }++key ::                { Key Position                                }+  : sepBy1(simplekey, '.')+                      { $1                                          }++simplekey ::          { (Position, Text)                            }+  : BAREKEY           { locVal (,) $1                               }+  | STRING            { locVal (,) $1                               }++val ::                { Val Position                                }+  : INTEGER           { locVal ValInteger    $1                     }+  | FLOAT             { locVal ValFloat      $1                     }+  | BOOL              { locVal ValBool       $1                     }+  | STRING            { locVal ValString     $1                     }+  | MLSTRING          { locVal ValString     $1                     }+  | LOCALDATE         { locVal ValDay        $1                     }+  | LOCALTIME         { locVal ValTimeOfDay  $1                     }+  | OFFSETDATETIME    { locVal ValZonedTime  $1                     }+  | LOCALDATETIME     { locVal ValLocalTime  $1                     }+  | array             { locVal ValArray      $1                     }+  | inlinetable       { locVal ValTable      $1                     }++inlinetable ::        { Located [(Key Position, Val Position)]      }+  : lhs '{' inlinetablekeyvals              newlines pop '}'+                      { Located $2 (reverse $3)                     }+  | lhs '{' inlinetablekeyvals newlines ',' newlines pop '}'+                      { Located $2 (reverse $3)                     }+  | lhs '{'                                 newlines pop '}'+                      { Located $2 []                               }++inlinetablekeyvals :: { [(Key Position, Val Position)]              }+  : newlines keyval   { [$2]                                        }+  | inlinetablekeyvals newlines ',' newlines keyval+                      { $5 : $1                                     }++array ::              { Located [Val Position]                      }+  : rhs '[' newlines                          pop ']'+                      { Located $2 []                               }+  | rhs '[' newlines arrayvalues              pop ']'+                      { Located $2 (reverse $4)                     }+  | rhs '[' newlines arrayvalues ',' newlines pop ']'+                      { Located $2 (reverse $4)                     }++arrayvalues ::        { [Val Position]                              }+  :                          val newlines+                      { [$1]                                        }+  | arrayvalues ',' newlines val newlines+                      { $4 : $1                                     }++newlines ::           { ()                                          }+  :                   { ()                                          }+  | newlines NEWLINE  { ()                                          }++sepBy(p,q) ::         { [p]                                         }+  :                   { []                                          }+  | sepBy1(p,q)       { NonEmpty.toList $1                          }++sepBy1(p,q) ::        { NonEmpty p                                  }+  : sepBy1_(p,q)      { NonEmpty.reverse $1                         }++sepBy1_(p,q) ::       { NonEmpty p                                  }+  :                p  { pure $1                                     }+  | sepBy1_(p,q) q p  { NonEmpty.cons $3 $1                         }++rhs ::                { ()                                          }+  :                   {% push ValueContext                          }++lhs ::                { ()                                          }+  :                   {% push TableContext                          }++pop ::                { ()                                          }+  :                   {% pop                                        }++{++-- | Parse a list of tokens either returning the first unexpected+-- token or a list of the TOML statements in the file to be+-- processed by "Toml.Semantics".+parseRawToml :: Text -> Either (Located String) [Expr Position]+parseRawToml = runParser parseRawToml_ TopContext . Located startPos++}
+ src/Toml/Syntax/ParserUtils.hs view
@@ -0,0 +1,161 @@+{-|+Module      : Toml.Syntax.ParserUtils+Description : Primitive operations used by the happy-generated parser+Copyright   : (c) Eric Mertens, 2023+License     : ISC+Maintainer  : emertens@gmail.com++This module contains all the primitives used by the Parser module.+By extracting it from the @.y@ file we minimize the amount of code+that has warnings disabled and get better editor support.++-}+module Toml.Syntax.ParserUtils (+    Parser,+    runParser,+    pureP,+    thenP,+    asString,+    asMlString,+    asBareKey,+    asInteger,+    asBool,+    asFloat,+    asOffsetDateTime,+    asLocalDate,+    asLocalTime,+    asLocalDateTime,+    locVal,++    lexerP,+    errorP,++    -- * Lexer-state management+    push,+    pop,+    ) where++import Data.Text (Text)+import Data.Time+import Data.List.NonEmpty (NonEmpty((:|)))+import Data.List.NonEmpty qualified as NonEmpty+import Toml.Pretty (prettyToken)+import Toml.Syntax.Lexer (scanToken, Context(..))+import Toml.Syntax.Position (Located(..), Position)+import Toml.Syntax.Token (Token(..))++-- continuation passing implementation of a state monad with errors+newtype Parser r a = P {+    getP ::+        NonEmpty Context -> Located Text ->+        (NonEmpty Context -> Located Text -> a -> Either (Located String) r) ->+        Either (Located String) r+    }++-- | Run the top-level parser+runParser :: Parser r r -> Context -> Located Text -> Either (Located String) r+runParser (P k) ctx str = k (ctx :| []) str \_ _ r -> Right r++-- | Bind implementation used in the happy-generated parser+thenP :: Parser r a -> (a -> Parser r b) -> Parser r b+thenP (P m) f = P \ctx str k -> m ctx str \ctx' str' x -> getP (f x) ctx' str' k+{-# Inline thenP #-}++-- | Return implementation used in the happy-generated parser+pureP :: a -> Parser r a+pureP x = P \ctx str k -> k ctx str x+{-# Inline pureP #-}++-- | Add a new context to the lexer context stack+push :: Context -> Parser r ()+push x = P \st str k -> k (NonEmpty.cons x st) str ()+{-# Inline push #-}++-- | Pop the top context off the lexer context stack. It is a program+-- error to pop without first pushing.+pop :: Parser r ()+pop = P \ctx str k ->+    case snd (NonEmpty.uncons ctx) of+        Nothing -> error "toml-parser: PANIC! malformed production in parser"+        Just ctx' -> k ctx' str ()+{-# Inline pop #-}++-- | Operation the parser generator uses when it reaches an unexpected token.+errorP :: Located Token -> Parser r a+errorP e = P \_ _ _ -> Left (fmap (\t -> "parse error: unexpected " ++ prettyToken t) e)++-- | Operation the parser generator uses to request the next token.+lexerP :: (Located Token -> Parser r a) -> Parser r a+lexerP f = P \st str k ->+    case scanToken (NonEmpty.head st) str of+        Left le -> Left (("lexical error: " ++) <$> le)+        Right (t, str') -> getP (f t) st str' k+{-# Inline lexerP #-}+++asString :: Token -> Maybe Text+asString =+    \case+        TokString i -> Just i+        _ -> Nothing++asBareKey :: Token -> Maybe Text+asBareKey =+    \case+        TokBareKey i -> Just i+        _ -> Nothing++asMlString :: Token -> Maybe Text+asMlString =+    \case+        TokMlString i -> Just i+        _ -> Nothing+++asInteger :: Token -> Maybe Integer+asInteger =+    \case+        TokInteger i -> Just i+        _ -> Nothing++asBool :: Token -> Maybe Bool+asBool =+    \case+        TokTrue -> Just True+        TokFalse -> Just False+        _ -> Nothing++asFloat :: Token -> Maybe Double+asFloat =+    \case+        TokFloat x -> Just x+        _ -> Nothing++asOffsetDateTime :: Token -> Maybe ZonedTime+asOffsetDateTime =+    \case+        TokOffsetDateTime x -> Just x+        _ -> Nothing+++asLocalDateTime :: Token -> Maybe LocalTime+asLocalDateTime =+    \case+        TokLocalDateTime x -> Just x+        _ -> Nothing+++asLocalDate :: Token -> Maybe Day+asLocalDate =+    \case+        TokLocalDate x -> Just x+        _ -> Nothing++asLocalTime :: Token -> Maybe TimeOfDay+asLocalTime =+    \case+        TokLocalTime x -> Just x+        _ -> Nothing++locVal :: (Position -> a -> b) -> Located a -> b+locVal f (Located l x) = f l x
+ src/Toml/Syntax/Position.hs view
@@ -0,0 +1,57 @@+{-|+Module      : Toml.Syntax.Position+Description : File position representation+Copyright   : (c) Eric Mertens, 2023+License     : ISC+Maintainer  : emertens@gmail.com++This module provides the 'Position' type for tracking locations+in files while doing lexing and parsing for providing more useful+error messages.++This module assumes 8 column wide tab stops.++-}+module Toml.Syntax.Position (+    Located(..),+    Position(..),+    startPos,+    move,+    ) where++-- | A value annotated with its text file position+data Located a = Located+    { locPosition :: {-# UNPACK #-} !Position -- ^ position+    , locThing    :: !a -- ^ thing at position+    }+    deriving (+        Read        {- ^ Default instance -},+        Show        {- ^ Default instance -},+        Functor     {- ^ Default instance -},+        Foldable    {- ^ Default instance -},+        Traversable {- ^ Default instance -})++-- | A position in a text file+data Position = Position {+    posIndex  :: {-# UNPACK #-} !Int, -- ^ code-point index (zero-based)+    posLine   :: {-# UNPACK #-} !Int, -- ^ line index (one-based)+    posColumn :: {-# UNPACK #-} !Int  -- ^ column index (one-based)+    } deriving (+        Read    {- ^ Default instance -},+        Show    {- ^ Default instance -},+        Ord     {- ^ Default instance -},+        Eq      {- ^ Default instance -})++-- | The initial 'Position' for the start of a file+startPos :: Position+startPos = Position { posIndex = 0, posLine = 1, posColumn = 1 }++-- | Adjust a file position given a single character handling+-- newlines and tabs. All other characters are considered to fill+-- exactly one column.+move :: Char -> Position -> Position+move x Position{ posIndex = i, posLine = l, posColumn = c} =+    case x of+        '\n' -> Position{ posIndex = i+1, posLine = l+1, posColumn = 1 }+        '\t' -> Position{ posIndex = i+1, posLine = l, posColumn = (c + 7) `quot` 8 * 8 + 1 }+        _    -> Position{ posIndex = i+1, posLine = l, posColumn = c+1 }
+ src/Toml/Syntax/Token.hs view
@@ -0,0 +1,133 @@+{-|+Module      : Toml.Syntax.Token+Description : Lexical tokens+Copyright   : (c) Eric Mertens, 2023+License     : ISC+Maintainer  : emertens@gmail.com++This module provides the datatype for the lexical syntax of TOML files.+These tokens are generated by "Toml.Syntax.Lexer" and consumed in "Toml.Syntax.Parser".++-}+module Toml.Syntax.Token (+    -- * Types+    Token(..),++    -- * Integer literals+    mkBinInteger,+    mkDecInteger,+    mkOctInteger,+    mkHexInteger,++    -- * Float literals+    mkFloat,++    -- * Date and time patterns+    localDatePatterns,+    localTimePatterns,+    localDateTimePatterns,+    offsetDateTimePatterns,+    ) where++import Data.Char (digitToInt)+import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime)+import Data.Text (Text)+import Numeric (readInt, readHex, readOct)++-- | Lexical token+data Token+    = TokTrue                       -- ^ @true@+    | TokFalse                      -- ^ @false@+    | TokComma                      -- ^ @','@+    | TokEquals                     -- ^ @'='@+    | TokNewline                    -- ^ @end-of-line@+    | TokPeriod                     -- ^ @'.'@+    | TokSquareO                    -- ^ @'['@+    | TokSquareC                    -- ^ @']'@+    | Tok2SquareO                   -- ^ @'[['@+    | Tok2SquareC                   -- ^ @']]'@+    | TokCurlyO                     -- ^ @'{'@+    | TokCurlyC                     -- ^ @'}'@+    | TokBareKey Text               -- ^ bare key+    | TokString Text                -- ^ string literal+    | TokMlString Text              -- ^ multiline string literal+    | TokInteger !Integer           -- ^ integer literal+    | TokFloat !Double              -- ^ floating-point literal+    | TokOffsetDateTime !ZonedTime  -- ^ date-time with timezone offset+    | TokLocalDateTime !LocalTime   -- ^ local date-time+    | TokLocalDate !Day             -- ^ local date+    | TokLocalTime !TimeOfDay       -- ^ local time+    | TokEOF                        -- ^ @end-of-input@+    deriving (Read, Show)++-- | Remove underscores from number literals+scrub :: String -> String+scrub = filter ('_' /=)++-- | Construct a 'TokInteger' from a decimal integer literal lexeme.+mkDecInteger :: String -> Token+mkDecInteger ('+':xs) = TokInteger (read (scrub xs))+mkDecInteger xs = TokInteger (read (scrub xs))++-- | Construct a 'TokInteger' from a hexadecimal integer literal lexeme.+mkHexInteger :: String -> Token+mkHexInteger ('0':'x':xs) = TokInteger (fst (head (readHex (scrub xs))))+mkHexInteger _ = error "processHex: bad input"++-- | Construct a 'TokInteger' from a octal integer literal lexeme.+mkOctInteger :: String -> Token+mkOctInteger ('0':'o':xs) = TokInteger (fst (head (readOct (scrub xs))))+mkOctInteger _ = error "processHex: bad input"++-- | Construct a 'TokInteger' from a binary integer literal lexeme.+mkBinInteger :: String -> Token+mkBinInteger ('0':'b':xs) = TokInteger (fst (head (readBin (scrub xs))))+mkBinInteger _ = error "processHex: bad input"++-- This wasn't added to base until 4.16+readBin :: (Eq a, Num a) => ReadS a+readBin = readInt 2 isBinDigit digitToInt++isBinDigit :: Char -> Bool+isBinDigit x = x == '0' || x == '1'++-- | Construct a 'TokFloat' from a floating-point literal lexeme.+mkFloat :: String -> Token+mkFloat "nan"   = TokFloat (0/0)+mkFloat "+nan"  = TokFloat (0/0)+mkFloat "-nan"  = TokFloat (0/0)+mkFloat "inf"   = TokFloat (1/0)+mkFloat "+inf"  = TokFloat (1/0)+mkFloat "-inf"  = TokFloat (-1/0)+mkFloat ('+':x) = TokFloat (read (scrub x))+mkFloat x       = TokFloat (read (scrub x))++-- | Format strings for local date lexemes.+localDatePatterns :: [String]+localDatePatterns = ["%Y-%m-%d"]++-- | Format strings for local time lexemes.+localTimePatterns :: [String]+localTimePatterns =+    ["%H:%M:%S%Q",+     "%H:%M"]++-- | Format strings for local datetime lexemes.+localDateTimePatterns :: [String]+localDateTimePatterns =+    ["%Y-%m-%dT%H:%M:%S%Q",+     "%Y-%m-%d %H:%M:%S%Q",+     "%Y-%m-%dT%H:%M",+     "%Y-%m-%d %H:%M"]++-- | Format strings for offset datetime lexemes.+offsetDateTimePatterns :: [String]+offsetDateTimePatterns =+    ["%Y-%m-%dT%H:%M:%S%Q%Ez",+     "%Y-%m-%dT%H:%M:%S%QZ",+     "%Y-%m-%d %H:%M:%S%Q%Ez",+     "%Y-%m-%d %H:%M:%S%QZ",+     "%Y-%m-%dT%H:%M%Ez",+     "%Y-%m-%dT%H:%MZ",+     "%Y-%m-%d %H:%M%Ez",+     "%Y-%m-%d %H:%MZ"]
+ src/Toml/Syntax/Types.hs view
@@ -0,0 +1,58 @@+{-|+Module      : Toml.Syntax.Types+Description : Raw expressions from a parsed TOML file+Copyright   : (c) Eric Mertens, 2023+License     : ISC+Maintainer  : emertens@gmail.com++This module provides a raw representation of TOML files as+a list of table definitions and key-value assignments.++These values use the raw dotted keys and have no detection+for overlapping assignments.++Further processing will happen in the "Semantics" module.++-}+module Toml.Syntax.Types (+    Key,+    Expr(..),+    Val(..),+    SectionKind(..),+    ) where++import Data.List.NonEmpty (NonEmpty)+import Data.Text (Text)+import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime)++-- | Non-empty sequence of dotted simple keys+type Key a = NonEmpty (a, Text)++-- | Headers and assignments corresponding to lines of a TOML file+data Expr a+    = KeyValExpr     (Key a) (Val a) -- ^ key value assignment: @key = value@+    | TableExpr      (Key a)         -- ^ table: @[key]@+    | ArrayTableExpr (Key a)         -- ^ array of tables: @[[key]]@+    deriving (Read, Show)+++-- | Unvalidated TOML values. Table are represented as a list of+-- assignments rather than as resolved maps.+data Val a+    = ValInteger   a Integer+    | ValFloat     a Double+    | ValArray     a [Val a]+    | ValTable     a [(Key a, Val a)]+    | ValBool      a Bool+    | ValString    a Text+    | ValTimeOfDay a TimeOfDay+    | ValZonedTime a ZonedTime+    | ValLocalTime a LocalTime+    | ValDay       a Day+    deriving (Read, Show)++-- | Kinds of table headers+data SectionKind+    = TableKind -- ^ [table]+    | ArrayTableKind -- ^ [[array of tables]]+    deriving (Read, Show, Eq)
− src/Toml/ToValue.hs 
@@ -1,195 +0,0 @@-{-# 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
− src/Toml/ToValue/Generic.hs 
@@ -1,105 +0,0 @@-{-|-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 #-}
− src/Toml/Value.hs 
@@ -1,63 +0,0 @@-{-|-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))
test/DecodeSpec.hs view
@@ -1,4 +1,4 @@-{-# Language DuplicateRecordFields #-}+{-# Language DuplicateRecordFields, OverloadedStrings #-} {-| Module      : DecodeSpec Description : Show that decoding TOML works using the various provided classes@@ -13,13 +13,8 @@ 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)+import Toml (decode, encode)+import Toml.Schema  newtype Fruits = Fruits { fruits :: [Fruit] }     deriving (Eq, Show, Generic)@@ -39,9 +34,9 @@     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 FromValue Fruits   where fromValue = genericFromTable+instance FromValue Physical where fromValue = genericFromTable+instance FromValue Variety  where fromValue = genericFromTable  instance ToTable Fruits   where toTable = genericToTable instance ToTable Physical where toTable = genericToTable@@ -127,14 +122,15 @@             color = "yellow"|]         `shouldBe`         Success [-            "unexpected keys: count, taste in top.fruits[0]",-            "unexpected key: color in top.fruits[1]"]+            "4:1: unexpected key: count in fruits[0]",+            "3:1: unexpected key: taste in fruits[0]",+            "7:1: unexpected key: color in fruits[1]"]             (Fruits [Fruit "peach" Nothing [], Fruit "pineapple" Nothing []])      it "handles missing key errors" $         (decode "[[fruits]]" :: Result String Fruits)         `shouldBe`-        Failure ["missing key: name in top.fruits[0]"]+        Failure ["1:3: missing key: name in fruits[0]"]      it "handles parse errors while decoding" $         (decode "x =" :: Result String Fruits)
test/DerivingViaSpec.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DerivingVia, DeriveGeneric #-}+{-# LANGUAGE DerivingVia, DeriveGeneric, OverloadedStrings #-} {-| Module      : DerivingViaSpec Description : Show that TOML classes can be derived with DerivingVia@@ -17,11 +17,7 @@  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))+import Toml.Schema  data Physical = Physical {     color :: String,@@ -37,7 +33,7 @@ spec :: Spec spec =  do let sem = Physical "red" "round"-        tab = table ["color" .= "red", "shape" .= "round"]+        tab = table ["color" .= Text "red", "shape" .= Text "round"]      it "supports toValue" $         toValue sem@@ -55,11 +51,11 @@         Success [] sem      it "converts from arrays positionally" $-        runMatcher (fromValue (Array [Integer 42, String "forty-two"]))+        runMatcher (fromValue (List [Integer 42, Text "forty-two"]))         `shouldBe`         Success [] (TwoThings 42 "forty-two")      it "converts to arrays positionally" $         toValue (TwoThings 42 "forty-two")         `shouldBe`-        Array [Integer 42, String "forty-two"]+        List [Integer 42, Text "forty-two"]
test/FromValueSpec.hs view
@@ -1,3 +1,4 @@+{-# Language OverloadedStrings #-} {-| Module      : FromValueSpec Description : Exercise various components of FromValue@@ -11,79 +12,77 @@ 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, (.=))+import Toml+import Toml.Schema+import Toml.Syntax (startPos) -humanMatcher :: Matcher a -> Result String a+humanMatcher :: Matcher l a -> Result String a humanMatcher m =     case runMatcher m of-        Failure e -> Failure (prettyMatchMessage <$> e)-        Success w x -> Success (prettyMatchMessage <$> w) x+        Failure e -> Failure (prettyMatchMessage . fmap (const startPos) <$> e)+        Success w x -> Success (prettyMatchMessage . fmap (const startPos) <$> w) x  spec :: Spec spec =  do it "handles one reqKey" $-        humanMatcher (runParseTable (reqKey "test") (table ["test" .= "val"]))+        humanMatcher (parseTable (reqKey "test") () (table ["test" .= Text "val"]))         `shouldBe`-        Success [] "val"+        Success [] ("val" :: String)      it "handles one optKey" $-        humanMatcher (runParseTable (optKey "test") (table ["test" .= "val"]))+        humanMatcher (parseTable (optKey "test") () (table ["test" .= Text "val"]))         `shouldBe`-        Success [] (Just "val")+        Success [] (Just ("val" :: String))      it "handles one missing optKey" $-        humanMatcher (runParseTable (optKey "test") (table ["nottest" .= "val"]))+        humanMatcher (parseTable (optKey "test") () (table ["nottest" .= Text "val"]))         `shouldBe`-        Success ["unexpected key: nottest in top"] (Nothing :: Maybe String)+        Success ["1:1: unexpected key: nottest in <top-level>"] (Nothing :: Maybe String)      it "handles one missing reqKey" $-        humanMatcher (runParseTable (reqKey "test") (table ["nottest" .= "val"]))+        humanMatcher (parseTable (reqKey "test") () (table ["nottest" .= Text "val"]))         `shouldBe`-        (Failure ["missing key: test in top"] :: Result String String)+        (Failure ["1:1: missing key: test in <top-level>"] :: Result String String)      it "handles one mismatched reqKey" $-        humanMatcher (runParseTable (reqKey "test") (table ["test" .= "val"]))+        humanMatcher (parseTable (reqKey "test") () (table ["test" .= Text "val"]))         `shouldBe`-        (Failure ["type error. wanted: integer got: string in top.test"] :: Result String Integer)+        (Failure ["1:1: expected integer but got string in test"] :: Result String Integer)      it "handles one mismatched optKey" $-        humanMatcher (runParseTable (optKey "test") (table ["test" .= "val"]))+        humanMatcher (parseTable (optKey "test") () (table ["test" .= Text "val"]))         `shouldBe`-        (Failure ["type error. wanted: integer got: string in top.test"] :: Result String (Maybe Integer))+        (Failure ["1:1: expected integer but got string in test"] :: Result String (Maybe Integer))      it "handles concurrent errors" $-        humanMatcher (runParseTable (reqKey "a" <|> empty <|> reqKey "b") (table []))+        humanMatcher (parseTable (reqKey "a" <|> empty <|> reqKey "b") () (table []))         `shouldBe`-        (Failure ["missing key: a in top", "missing key: b in top"] :: Result String Integer)+        (Failure ["1:1: missing key: a in <top-level>",+                  "1:1: missing key: b in <top-level>"] :: Result String Integer)      it "handles concurrent value mismatch" $-        let v = String "" in+        let v = "" 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"]+            "1:1: expected boolean but got string in <top-level>",+            "1:1: expected integer but got string in <top-level>"]             :: Result String (Either Bool Int))      it "doesn't emit an error for empty" $-        humanMatcher (runParseTable empty (table []))+        humanMatcher (parseTable empty () (table []))         `shouldBe`         (Failure [] :: Result String Integer)      it "matches single characters" $-        runMatcher (fromValue (String "x"))+        runMatcher (fromValue (Text "x"))         `shouldBe`         Success [] 'x'      it "rejections non-single characters" $-        humanMatcher (fromValue (String "xy"))+        humanMatcher (fromValue (Text "xy"))         `shouldBe`-        (Failure ["type error. wanted: character got: string in top"] :: Result String Char)+        (Failure ["1:1: expected single character in <top-level>"] :: Result String Char)      it "collects warnings in table matching" $         let pt =@@ -93,20 +92,20 @@                 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)]))+        humanMatcher (parseTable pt () (table ["k1" .= (1 :: Integer), "k2" .= (2 :: Integer)]))         `shouldBe`-        Success ["k1 and k2 sum to an odd value in top"] (3 :: Integer)+        Success ["k1 and k2 sum to an odd value in <top-level>"] (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 []))+        humanMatcher (parseTable pt () (table []))         `shouldBe`-        (Failure ["possible keys: this, \".\" in top"] :: Result String Char)+        (Failure ["1:1: possible keys: this, \".\" in <top-level>"] :: Result String Char)      it "generates an error message on an empty pickKey" $         let pt = pickKey []         in-        humanMatcher (runParseTable pt (table []))+        humanMatcher (parseTable pt () (table []))         `shouldBe`         (Failure [] :: Result String Char)
test/HieDemoSpec.hs view
@@ -1,4 +1,4 @@-{-# Language GADTs #-}+{-# Language GADTs, OverloadedStrings #-} {-| Module      : HieDemoSpec Description : Exercise various components of FromValue on a life-sized example@@ -6,7 +6,7 @@ License     : ISC Maintainer  : emertens@gmail.com -This module demonstrates how "Toml.FromValue" can handle a real-world+This module demonstrates how "Toml.Schema" can handle a real-world format as used in hie-bios. These types are copied from <https://github.com/haskell/hie-bios/blob/master/src/HIE/Bios/Config/YAML.hs> with slight alterations because the Other case is for YAML-specific extensibility.@@ -15,12 +15,12 @@ -} module HieDemoSpec where +import Data.Text (Text) 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)+import Toml (decode)+import Toml.Schema as Toml  ----------------------------------------------------------------------- -- THIS CODE DERIVED FROM CODE UNDER THE FOLLOWING LICENSE@@ -126,7 +126,7 @@ -----------------------------------------------------------------------  instance FromValue CradleConfig where-    fromValue = parseTableFromValue genericParseTable+    fromValue = genericFromTable  instance FromValue CradleComponent where     fromValue = parseTableFromValue $@@ -139,15 +139,15 @@             KeyCase None   "none"]  instance FromValue MultiSubComponent where-    fromValue = parseTableFromValue genericParseTable+    fromValue = genericFromTable  instance FromValue CabalConfig where-    fromValue v@Toml.Array{} = CabalConfig Nothing . ManyComponents <$> fromValue v-    fromValue (Toml.Table t)  = getComponentTable CabalConfig "cabalProject" t+    fromValue v@Toml.List'{} = CabalConfig Nothing . ManyComponents <$> fromValue v+    fromValue (Toml.Table' l t) = getComponentTable CabalConfig "cabalProject" l t     fromValue _               = fail "cabal configuration expects table or array" -getComponentTable :: FromValue b => (Maybe FilePath -> OneOrManyComponents b -> a) -> String -> Toml.Table -> Matcher a-getComponentTable con pathKey = runParseTable $ con+getComponentTable :: FromValue b => (Maybe FilePath -> OneOrManyComponents b -> a) -> Text -> l -> Toml.Table' l -> Matcher l a+getComponentTable con pathKey = parseTable $ con     <$> optKey pathKey     <*> pickKey [         Key "component"  (fmap  SingleComponent . fromValue),@@ -161,9 +161,9 @@         <*> 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"+    fromValue v@Toml.List'{} = StackConfig Nothing . ManyComponents <$> fromValue v+    fromValue (Toml.Table' l t) = getComponentTable StackConfig "stackYaml" l t+    fromValue _ = fail "stack configuration expects table or array"  instance FromValue StackComponent where     fromValue = parseTableFromValue $ StackComponent@@ -172,7 +172,7 @@         <*> optKey "stackYaml"  instance FromValue DirectConfig where-    fromValue = parseTableFromValue genericParseTable+    fromValue = genericFromTable  instance FromValue BiosConfig where     fromValue = parseTableFromValue $ BiosConfig@@ -190,13 +190,13 @@                     KeyCase Shell   "dependency-shell"]  data KeyCase a where-    KeyCase :: FromValue b => (b -> a) -> String -> KeyCase a+    KeyCase :: FromValue b => (b -> a) -> Text -> KeyCase a -reqAlts :: [KeyCase a] -> ParseTable a+reqAlts :: [KeyCase a] -> ParseTable l a reqAlts xs = pickKey     [Key key (fmap con . fromValue) | KeyCase con key <- xs] -optAlts :: [KeyCase a] -> ParseTable (Maybe a)+optAlts :: [KeyCase a] -> ParseTable l (Maybe a) optAlts xs = pickKey $     [Key key (fmap (Just . con) . fromValue) | KeyCase con key <- xs] ++     [Else (pure Nothing)]@@ -278,7 +278,7 @@             component = 42             |]         `shouldBe`-        (Failure ["type error. wanted: string got: integer in top.cradle.cabal.component"]+        (Failure ["3:13: expected string but got integer in cradle.cabal.component"]             :: Result String CradleConfig)      it "detects unusd keys" $@@ -298,8 +298,10 @@             |]         `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"+            [ "5:1: unexpected key: thing1 in cradle.multi[0].config.cradle.cabal"+            , "11:1: unexpected key: thing2 in cradle.multi[1].config.cradle.stack"+            , "12:1: unexpected key: thing3 in cradle.multi[1].config.cradle.stack"+             ]             CradleConfig                 { cradle =
test/LexerSpec.hs view
@@ -1,9 +1,14 @@+{-# Language OverloadedStrings #-} module LexerSpec (spec) where -import Data.Map qualified as Map+import Data.Text (Text) import Test.Hspec (it, shouldBe, Spec)-import Toml (parse, Value(Integer))+import Toml+import Toml.Schema (table, (.=)) +parse_ :: Text -> Either String Table+parse_ str = forgetTableAnns <$> parse str+ spec :: Spec spec =  do it "handles special cased control character" $@@ -33,9 +38,9 @@         Left "1:1: parse error: unexpected '{'"      it "accepts tabs" $-        parse "x\t=\t1"+        parse_ "x\t=\t1"         `shouldBe`-        Right (Map.singleton "x" (Integer 1))+        Right (table ["x" .= Integer 1])      it "computes columns correctly with tabs" $         parse "x\t=\t="@@ -85,9 +90,14 @@     it "handles escapes at the end of input" $         parse "x = \"\\"         `shouldBe`-        Left "1:7: lexical error: unexpected end-of-input"+        Left "1:6: lexical error: incomplete escape sequence"      it "handles invalid escapes" $         parse "x = \"\\p\""         `shouldBe`-        Left "1:7: lexical error: unexpected 'p'"+        Left "1:6: lexical error: unknown escape sequence"++    it "allows multi-byte characters in ''' strings" $+        parse_ "x = '''§'''"+        `shouldBe`+        Right (table ["x" .= Text "§"])
test/PrettySpec.hs view
@@ -1,33 +1,38 @@+{-# Language OverloadedStrings #-} module PrettySpec (spec) where -import Test.Hspec (it, shouldBe, Spec)-import QuoteStr (quoteStr)-import Toml (encode, parse, prettyToml, Table) import Data.Map qualified as Map+import Data.Text (Text)+import QuoteStr (quoteStr)+import Test.Hspec (it, shouldBe, Spec)+import Toml  tomlString :: Table -> String tomlString = show . prettyToml +parse_ :: Text -> Either String Table+parse_ str = forgetTableAnns <$> parse str+ spec :: Spec spec =  do it "renders example 1" $-        show (encode (Map.singleton "x" (1 :: Integer)))+        show (encode (Map.singleton ("x" :: Text) (1 :: Integer)))         `shouldBe` [quoteStr|             x = 1|]      it "renders example 2" $-        fmap tomlString (parse "x=1\ny=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]]")+        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")+        fmap tomlString (parse_ "x.y.z={}\nz.y.w=false")         `shouldBe` Right [quoteStr|             [x.y.z] @@ -35,7 +40,7 @@             y.w = false|]      it "renders empty tables in array of tables" $-        fmap tomlString (parse "ex=[{},{},{a=9}]")+        fmap tomlString (parse_ "ex=[{},{},{a=9}]")         `shouldBe` Right [quoteStr|             [[ex]] @@ -45,7 +50,7 @@             a = 9|]      it "renders multiple tables" $-        fmap tomlString (parse "a.x=1\nb.x=3\na.y=2\nb.y=4")+        fmap tomlString (parse_ "a.x=1\nb.x=3\na.y=2\nb.y=4")         `shouldBe` Right [quoteStr|             [a]             x = 1@@ -56,12 +61,12 @@             y = 4|]      it "renders escapes in strings" $-        fmap tomlString (parse "a=\"\\\\\\b\\t\\r\\n\\f\\\"\\u007f\\U0001000c\"")+        fmap tomlString (parse_ "a=\"\\\\\\b\\t\\r\\n\\f\\e\\\"\\u007f\\U0001000c\"")         `shouldBe` Right [quoteStr|-            a = "\\\b\t\r\n\f\"\u007F\U0001000C"|]+            a = "\\\b\t\r\n\f\e\"\x7F\U0001000C"|]      it "renders multiline strings" $-        fmap tomlString (parse [quoteStr|+        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.",@@ -79,7 +84,7 @@                        , "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")+        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@@ -88,18 +93,18 @@             e = 4.0e123|]      it "renders special floats" $-        fmap tomlString (parse "a=inf\nb=-inf\nc=nan")+        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 "")+        fmap tomlString (parse_ "")         `shouldBe` Right ""      it "renders dates and time" $-        fmap tomlString (parse [quoteStr|+        fmap tomlString (parse_ [quoteStr|             a = 2020-05-07             b = 15:16:17.990             c = 2020-05-07T15:16:17.990@@ -117,19 +122,19 @@             g = 0008-10-11T12:13:14+15:00|]      it "renders quoted keys" $-        fmap tomlString (parse "''.'a b'.'\"' = 10")+        fmap tomlString (parse_ "''.'a b'.'\"' = 10")         `shouldBe` Right [quoteStr|         ""."a b"."\"" = 10|]      it "renders inline tables" $-        fmap tomlString (parse [quoteStr|+        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|+        fmap tomlString (parse_ [quoteStr|             [x]             i = 1             p.q = "a"
test/QuoteStr.hs view
@@ -12,7 +12,7 @@ -} module QuoteStr (quoteStr) where -import Language.Haskell.TH ( Exp(LitE), ExpQ, Lit(StringL) )+import Language.Haskell.TH (Exp(LitE), ExpQ, Lit(StringL)) import Language.Haskell.TH.Quote ( QuasiQuoter(..) ) import Data.List ( stripPrefix )
test/ToValueSpec.hs view
@@ -1,16 +1,17 @@+{-# Language OverloadedStrings #-} module ToValueSpec where  import Test.Hspec (it, shouldBe, Spec)-import Toml (Value(..))-import Toml.ToValue (ToValue(toValue))+import Toml (Value'(Integer, Text, List))+import Toml.Schema (ToValue(toValue))  spec :: Spec spec =  do it "converts characters as singleton strings" $-        toValue '!' `shouldBe` String "!"+        toValue '!' `shouldBe` Text "!"      it "converts strings normally" $-        toValue "demo" `shouldBe` String "demo"+        toValue ("demo" :: String) `shouldBe` Text "demo"      it "converts lists" $-        toValue [1,2,3::Int] `shouldBe` Array [Integer 1, Integer 2, Integer 3]+        toValue [1,2,3::Int] `shouldBe` List [Integer 1, Integer 2, Integer 3]
test/TomlSpec.hs view
@@ -1,4 +1,4 @@-{-# Language QuasiQuotes #-}+{-# Language QuasiQuotes, OverloadedStrings #-} {-| Module      : TomlSpec Description : Unit tests@@ -13,53 +13,57 @@ module TomlSpec (spec) where  import Data.Map qualified as Map+import Data.Text (Text) import Data.Time (Day) import QuoteStr (quoteStr) import Test.Hspec (describe, it, shouldBe, shouldSatisfy, Spec)-import Toml (Value(..), parse, decode, Result(Success))-import Toml.ToValue (table, (.=))+import Toml+import Toml.Schema (table, (.=)) +parse_ :: Text -> Either String Table+parse_ str = forgetTableAnns <$> parse str+ spec :: Spec spec =  do describe "comment"      do it "ignores comments" $-          parse [quoteStr|+          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")])+          Right (table [("another", Text "# This is not a comment"), ("key", Text "value")])      describe "key/value pair"      do it "supports the most basic assignments" $-          parse "key = \"value\"" `shouldBe` Right (Map.singleton "key" (String "value"))+          parse_ "key = \"value\"" `shouldBe` Right (table ["key" .= Text "value"])          it "requires a value after equals" $-          parse "key = # INVALID"+          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"+          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|+          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"])+            "1234"     .= Text "value",+            "bare-key" .= Text "value",+            "bare_key" .= Text "value",+            "key"      .= Text "value"])          it "allows quoted keys" $-          parse [quoteStr|+          parse_ [quoteStr|             "127.0.0.1" = "value"             "character encoding" = "value"             "ʎǝʞ" = "value"@@ -67,22 +71,22 @@             'quoted "value"' = "value"|]           `shouldBe`           Right (table [-            "127.0.0.1"          .= "value",-            "character encoding" .= "value",-            "key2"               .= "value",-            "quoted \"value\""   .= "value",-            "ʎǝʞ"                .= "value"])+            "127.0.0.1"          .= Text "value",+            "character encoding" .= Text "value",+            "key2"               .= Text "value",+            "quoted \"value\""   .= Text "value",+            "ʎǝʞ"                .= Text "value"])          it "allows dotted keys" $-          parse [quoteStr|+          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"],+            "name"     .= Text "Orange",+            "physical" .= table ["color" .= Text "orange", "shape" .= Text "round"],             "site"     .= table ["google.com" .= True]])          it "prevents duplicate keys" $@@ -98,7 +102,7 @@           `shouldBe` Left "2:1: key error: spelling is already assigned"          it "allows out of order definitions" $-          parse [quoteStr|+          parse_ [quoteStr|             apple.type = "fruit"             orange.type = "fruit" @@ -110,20 +114,20 @@           `shouldBe`           Right (table [             "apple" .= table [-                "color" .= "red",-                "skin"  .= "thin",-                "type"  .= "fruit"],+                "color" .= Text "red",+                "skin"  .= Text "thin",+                "type"  .= Text "fruit"],             "orange" .= table [-                "color" .= "orange",-                "skin"  .= "thick",-                "type"  .= "fruit"]])+                "color" .= Text "orange",+                "skin"  .= Text "thick",+                "type"  .= Text "fruit"]])          it "allows numeric bare keys" $-          parse "3.14159 = 'pi'" `shouldBe` Right (table [-            "3" .= table [("14159", String "pi")]])+          parse_ "3.14159 = 'pi'" `shouldBe` Right (table [+            "3" .= table ["14159" .= Text "pi"]])          it "allows keys that look like other values" $-          parse [quoteStr|+          parse_ [quoteStr|             true = true             false = false             1900-01-01 = 1900-01-01@@ -137,20 +141,20 @@      describe "string"      do it "parses escapes" $-          parse [quoteStr|+          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."))+          Right (table ["str" .= Text "I'm a string. \"You can quote me\". Name\tJos\xe9\nLocation\tSF."])          it "strips the initial newline from multiline strings" $-          parse [quoteStr|+          parse_ [quoteStr|             str1 = """             Roses are red             Violets are blue"""|]-          `shouldBe` Right (Map.singleton "str1" (String "Roses are red\nViolets are blue"))+          `shouldBe` Right (table ["str1" .= Text "Roses are red\nViolets are blue"])          it "strips whitespace with a trailing escape" $-          parse [quoteStr|+          parse_ [quoteStr|             # The following strings are byte-for-byte equivalent:             str1 = "The quick brown fox jumps over the lazy dog." @@ -168,12 +172,12 @@                 """|]           `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."])+            "str1" .= Text "The quick brown fox jumps over the lazy dog.",+            "str2" .= Text "The quick brown fox jumps over the lazy dog.",+            "str3" .= Text "The quick brown fox jumps over the lazy dog."])          it "allows quotes inside multiline quoted strings" $-          parse [quoteStr|+          parse_ [quoteStr|             str4 = """Here are two quotation marks: "". Simple enough."""             str5 = """Here are three quotation marks: ""\"."""             str6 = """Here are fifteen quotation marks: ""\"""\"""\"""\"""\"."""@@ -182,10 +186,10 @@             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.\""])+            "str4" .= Text "Here are two quotation marks: \"\". Simple enough.",+            "str5" .= Text "Here are three quotation marks: \"\"\".",+            "str6" .= Text "Here are fifteen quotation marks: \"\"\"\"\"\"\"\"\"\"\"\"\"\"\".",+            "str7" .= Text "\"This,\" she said, \"is just a pointless statement.\""])          it "disallows triple quotes inside a multiline string" $           parse [quoteStr|@@ -193,7 +197,7 @@           `shouldBe` Left "1:46: parse error: unexpected '.'"          it "ignores escapes in literal strings" $-          parse [quoteStr|+          parse_ [quoteStr|             # What you see is what you get.             winpath  = 'C:\Users\nodejs\templates'             winpath2 = '\\ServerX\admin$\system32\'@@ -201,13 +205,13 @@             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\\"])+            "quoted"   .= Text "Tom \"Dubs\" Preston-Werner",+            "regex"    .= Text "<\\i\\c*\\s*>",+            "winpath"  .= Text "C:\\Users\\nodejs\\templates",+            "winpath2" .= Text "\\\\ServerX\\admin$\\system32\\"])          it "handles multiline literal strings" $-          parse [quoteStr|+          parse_ [quoteStr|             regex2 = '''I [dw]on't need \d{2} apples'''             lines  = '''             The first newline is@@ -217,17 +221,17 @@             '''|]           `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"])+            "lines"  .= Text "The first newline is\ntrimmed in raw strings.\nAll other whitespace\nis preserved.\n",+            "regex2" .= Text "I [dw]on't need \\d{2} apples"])          it "parses all the other escapes" $-          parse [quoteStr|+          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"])+            "x" .= Text "\\\b\f\r\x0010abcd",+            "y" .= Text "\\\b\f\r\x7bca\x0010abcd\n\r\t"])          it "rejects out of range unicode escapes" $           parse [quoteStr|@@ -242,7 +246,7 @@      describe "integer"      do it "parses literals correctly" $-          parse [quoteStr|+          parse_ [quoteStr|             int1 = +99             int2 = 42             int3 = 0@@ -287,7 +291,7 @@      describe "float"      do it "parses floats" $-          parse [quoteStr|+          parse_ [quoteStr|             # fractional             flt1 = +1.0             flt2 = 3.1415@@ -307,20 +311,20 @@             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)])+            "flt1" .= Double 1.0,+            "flt2" .= Double 3.1415,+            "flt3" .= Double (-1.0e-2),+            "flt4" .= Double 4.9999999999999996e22,+            "flt5" .= Double 1000000.0,+            "flt6" .= Double (-2.0e-2),+            "flt7" .= Double 6.626e-34,+            "flt8" .= Double 224617.445991228,+            "sf1"  .= Double (1/0),+            "sf2"  .= Double (1/0),+            "sf3"  .= Double (-1/0)])          it "parses nan correctly" $-          let checkNaN (Float x) = isNaN x+          let checkNaN (Double' _ x) = isNaN x               checkNaN _         = False           in           parse [quoteStr|@@ -330,19 +334,19 @@             sf6 = -nan # valid, actual encoding is implementation-specific|]           `shouldSatisfy` \case             Left{} -> False-            Right x -> all checkNaN x+            Right (MkTable x) -> all (checkNaN . snd) x          -- code using Numeric.readFloat can use significant         -- resources. this makes sure this doesn't start happening         -- in the future         it "parses huge floats without great delays" $-          parse "x = 1e1000000000000"+          parse_ "x = 1e1000000000000"           `shouldBe`-          Right (Map.singleton "x" (Float (1/0)))+          Right (table ["x" .= Double (1/0)])      describe "boolean"      do it "parses boolean literals" $-          parse [quoteStr|+          parse_ [quoteStr|             bool1 = true             bool2 = false|]           `shouldBe`@@ -352,7 +356,7 @@      describe "offset date-time"      do it "parses offset date times" $-          parse [quoteStr|+          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@@ -366,7 +370,7 @@      describe "local date-time"      do it "parses local date-times" $-          parse [quoteStr|+          parse_ [quoteStr|             ldt1 = 1979-05-27T07:32:00             ldt2 = 1979-05-27T00:32:00.999999             ldt3 = 1979-05-28 00:32:00.999999|]@@ -384,14 +388,14 @@      describe "local date"      do it "parses dates" $-          parse [quoteStr|+          parse_ [quoteStr|             ld1 = 1979-05-27|]           `shouldBe`-          Right (Map.singleton "ld1" (Day (read "1979-05-27")))+          Right (table ["ld1" .= Day (read "1979-05-27")])      describe "local time"      do it "parses times" $-          parse [quoteStr|+          parse_ [quoteStr|             lt1 = 07:32:00             lt2 = 00:32:00.999999|]           `shouldBe`@@ -401,7 +405,7 @@      describe "array"      do it "parses array examples" $-          parse [quoteStr|+          parse_ [quoteStr|             integers = [ 1, 2, 3 ]             colors = [ "red", "yellow", "green" ]             nested_arrays_of_ints = [ [ 1, 2 ], [3, 4, 5] ]@@ -416,21 +420,21 @@             ]|]             `shouldBe`             Right (table [-                "colors" .= ["red", "yellow", "green"],+                "colors" .= [Text "red", Text "yellow", Text "green"],                 "contributors" .= [-                    String "Foo Bar <foo@example.com>",+                    "Foo Bar <foo@example.com>",                     Table (table [-                        "email" .= "bazqux@example.com",-                        "name" .= "Baz Qux",-                        "url" .= "https://example.com/bazqux"])],+                        "email" .= Text "bazqux@example.com",+                        "name" .= Text "Baz Qux",+                        "url" .= Text "https://example.com/bazqux"])],                 "integers" .= [1, 2, 3 :: Integer],                 "nested_arrays_of_ints" .= [[1, 2], [3, 4, 5 :: Integer]],-                "nested_mixed_array" .= [[Integer 1, Integer 2], [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"]])+                "nested_mixed_array" .= [[Integer 1, Integer 2], [Text "a", Text "b", Text "c"]],+                "numbers" .= [Double 0.1, Double 0.2, Double 0.5, Integer 1, Integer 2, Integer 5],+                "string_array" .= [Text "all", Text "strings", Text "are the same", Text "type"]])          it "handles newlines and comments" $-          parse [quoteStr|+          parse_ [quoteStr|             integers2 = [             1, 2, 3             ]@@ -445,14 +449,14 @@                 "integers3" .= [1, 2 :: Int]])          it "disambiguates double brackets from array tables" $-          parse "x = [[1]]" `shouldBe` Right (Map.singleton "x" (Array [Array [Integer 1]]))+          parse_ "x = [[1]]" `shouldBe` Right (table ["x" .= List [List [Integer 1]]])      describe "table"      do it "allows empty tables" $-          parse "[table]" `shouldBe` Right (table ["table" .= table []])+          parse_ "[table]" `shouldBe` Right (table ["table" .= table []])          it "parses simple tables" $-          parse [quoteStr|+          parse_ [quoteStr|             [table-1]             key1 = "some string"             key2 = 123@@ -463,21 +467,21 @@           `shouldBe`           Right (table [             "table-1" .= table [-                "key1" .= "some string",+                "key1" .= Text "some string",                 "key2" .= Integer 123],             "table-2" .= table [-                "key1" .= "another string",+                "key1" .= Text "another string",                 "key2" .= Integer 456]])          it "allows quoted keys" $-          parse [quoteStr|+          parse_ [quoteStr|             [dog."tater.man"]             type.name = "pug"|]           `shouldBe`-          Right (table ["dog" .= table ["tater.man" .= table ["type" .= table ["name" .= "pug"]]]])+          Right (table ["dog" .= table ["tater.man" .= table ["type" .= table ["name" .= Text "pug"]]]])          it "allows whitespace around keys" $-          parse [quoteStr|+          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]@@ -490,7 +494,7 @@             "j" .= table ["ʞ" .= table ["l" .= table []]]])          it "allows supertables to be defined after subtables" $-          parse [quoteStr|+          parse_ [quoteStr|             # [x] you             # [x.y] don't             # [x.y.z] need these@@ -515,7 +519,7 @@           `shouldBe` Left "4:8: key error: apple is a closed table"          it "can add subtables" $-          parse [quoteStr|+          parse_ [quoteStr|             [fruit]             apple.color = "red"             apple.taste.sweet = true@@ -525,7 +529,7 @@           Right (table [             "fruit" .= table [                 "apple" .= table [-                    "color" .= "red",+                    "color" .= Text "red",                     "taste" .= table [                         "sweet" .= True],                         "texture" .= table [@@ -533,14 +537,14 @@      describe "inline table"      do it "parses inline tables" $-          parse [quoteStr|+          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"],+            "animal" .= table ["type" .= table ["name" .= Text "pug"]],+            "name"   .= table ["first" .= Text "Tom", "last" .= Text "Preston-Werner"],             "point"  .= table ["x" .= Integer 1, "y" .= Integer 2]])          it "prevents altering inline tables with dotted keys" $@@ -566,12 +570,12 @@           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 } }|]@@ -592,18 +596,18 @@              color = "gray"|]           `shouldBe`-          Success mempty (Map.singleton "products" [+          Success mempty (Map.singleton ("products" :: Text) [             table [-              "name" .= "Hammer",+              "name" .= Text "Hammer",               "sku"  .= Integer 738594937],-            Map.empty,+            table [],             table [-                "color" .= "gray",-                "name"  .= "Nail",+                "color" .= Text "gray",+                "name"  .= Text "Nail",                 "sku"   .= Integer 284758393]])          it "handles subtables under array of tables" $-          parse [quoteStr|+          parse_ [quoteStr|             [[fruits]]             name = "apple" @@ -627,17 +631,17 @@           Right (table [             "fruits" .= [                 table [-                    "name" .= "apple",+                    "name" .= Text "apple",                     "physical" .= table [-                        "color" .= "red",-                        "shape" .= "round"],+                        "color" .= Text "red",+                        "shape" .= Text "round"],                     "varieties" .= [-                        table ["name" .= "red delicious"],-                        table ["name" .= "granny smith"]]],+                        table ["name" .= Text "red delicious"],+                        table ["name" .= Text "granny smith"]]],                 table [-                    "name" .= "banana",+                    "name" .= Text "banana",                     "varieties" .= [-                        table ["name" .= "plantain"]]]]])+                        table ["name" .= Text "plantain"]]]]])          it "prevents redefining a supertable with an array of tables" $           parse [quoteStr|@@ -662,12 +666,12 @@     -- these cases are needed to complete coverage checking on Semantics module     describe "corner cases"      do it "stays open" $-          parse [quoteStr|+          parse_ [quoteStr|             [x.y.z]             [x]             [x.y]|]           `shouldBe`-          parse "x.y.z={}"+          parse_ "x.y.z={}"          it "stays closed" $           parse [quoteStr|@@ -676,20 +680,20 @@             [x.y]|] `shouldBe` Left "3:4: key error: y is a closed table"          it "super tables of array tables preserve array tables" $-          parse [quoteStr|+          parse_ [quoteStr|             [[x.y]]             [x]             [[x.y]]|]           `shouldBe`-          parse "x.y=[{},{}]"+          parse_ "x.y=[{},{}]"          it "super tables of array tables preserve array tables" $-          parse [quoteStr|+          parse_ [quoteStr|             [[x.y]]             [x]             [x.y.z]|]           `shouldBe`-          parse "x.y=[{z={}}]"+          parse_ "x.y=[{z={}}]"          it "detects conflicting inline keys" $           parse [quoteStr|@@ -697,7 +701,7 @@           `shouldBe` Left "1:14: key error: y is already assigned"          it "handles merging dotted inline table keys" $-          parse [quoteStr|+          parse_ [quoteStr|             t = { a.x.y = 1, a.x.z = 2, a.q = 3}|]           `shouldBe`           Right (table [@@ -705,8 +709,8 @@                 "a" .= table [                     "q" .= Integer 3,                     "x" .= table [-                        ("y",Integer 1),-                        ("z",Integer 2)]]]])+                        "y" .= Integer 1,+                        "z" .= Integer 2]]]])          it "disallows overwriting assignments with tables" $           parse [quoteStr|@@ -715,20 +719,20 @@           `shouldBe` Left "2:2: key error: x is already assigned"          it "handles super super tables" $-          parse [quoteStr|+          parse_ [quoteStr|             [x.y.z]             [x.y]             [x]|]           `shouldBe`-          parse "x.y.z={}"+          parse_ "x.y.z={}"          it "You can dot into open supertables" $-          parse [quoteStr|+          parse_ [quoteStr|             [x.y.z]             [x]             y.q = 1|]           `shouldBe`-          parse "x.y={z={},q=1}"+          parse_ "x.y={z={},q=1}"          it "dotted tables close previously open tables" $           parse [quoteStr|
toml-parser.cabal view
@@ -1,10 +1,10 @@ cabal-version:      3.0 name:               toml-parser-version:            1.3.2.0-synopsis:           TOML 1.0.0 parser+version:            2.0.2.0+synopsis:           TOML 1.1.0 parser description:     TOML parser using generated lexers and parsers with-    careful attention to the TOML 1.0.0 semantics for+    careful attention to the TOML 1.1.0 semantics for     defining tables. license:            ISC license-file:       LICENSE@@ -13,7 +13,7 @@ copyright:          2023 Eric Mertens category:           Text build-type:         Simple-tested-with:        GHC == {8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.4, 9.8.1}+tested-with:        GHC == {8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.7, 9.8.4, 9.10.3, 9.12.2}  extra-doc-files:     ChangeLog.md@@ -48,37 +48,40 @@     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.Schema+        Toml.Schema.FromValue+        Toml.Schema.Generic+        Toml.Schema.Generic.FromValue+        Toml.Schema.Generic.ToValue+        Toml.Schema.Matcher+        Toml.Schema.ParseTable+        Toml.Schema.ToValue         Toml.Semantics         Toml.Semantics.Ordered-        Toml.ToValue-        Toml.ToValue.Generic-        Toml.Value+        Toml.Semantics.Types+        Toml.Syntax+        Toml.Syntax.Lexer+        Toml.Syntax.Parser+        Toml.Syntax.Position+        Toml.Syntax.Token+        Toml.Syntax.Types     other-modules:-        Toml.Lexer.Utils-        Toml.Parser.Utils+        Toml.Syntax.LexerUtils+        Toml.Syntax.ParserUtils     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},+        base            ^>= {4.14, 4.15, 4.16, 4.17, 4.18, 4.19, 4.20, 4.21},+        containers      ^>= {0.5, 0.6, 0.7, 0.8},         prettyprinter   ^>= 1.7,         text            >= 0.2 && < 3,-        time            ^>= {1.9, 1.10, 1.11, 1.12},+        time            ^>= {1.9, 1.10, 1.11, 1.12, 1.14, 1.15},         transformers    ^>= {0.5, 0.6},     build-tool-depends:         alex:alex       >= 3.2,         happy:happy     >= 1.19,+    if impl(ghc >= 9.8)+        ghc-options: -Wno-x-partial  test-suite unittests     import:             extensions@@ -93,7 +96,8 @@         base,         containers,         hspec           ^>= {2.10, 2.11},-        template-haskell ^>= {2.16, 2.17, 2.18, 2.19, 2.20, 2.21},+        template-haskell ^>= {2.16, 2.17, 2.18, 2.19, 2.20, 2.21, 2.22, 2.23},+        text,         time,         toml-parser,     other-modules:@@ -124,7 +128,8 @@         base,         toml-parser,         hspec           ^>= {2.10, 2.11},-        template-haskell ^>= {2.16, 2.17, 2.18, 2.19, 2.20, 2.21},+        template-haskell ^>= {2.16, 2.17, 2.18, 2.19, 2.20, 2.21, 2.22, 2.23},+        text,     build-tool-depends:         markdown-unlit:markdown-unlit ^>= {0.5.1, 0.6.0}, @@ -132,5 +137,5 @@     buildable: False     main-is: benchmarker.hs     default-language: Haskell2010-    build-depends: base, toml-parser, time+    build-depends: base, toml-parser, time, text     hs-source-dirs: benchmarker