diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,20 @@ # Revision history for toml-parser +## 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. diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -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 "] -- 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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 "] -- 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 diff --git a/benchmarker/benchmarker.hs b/benchmarker/benchmarker.hs --- a/benchmarker/benchmarker.hs +++ b/benchmarker/benchmarker.hs @@ -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 " - 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 diff --git a/src/Toml.hs b/src/Toml.hs --- a/src/Toml.hs +++ b/src/Toml.hs @@ -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 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 + [] -> "" + 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" diff --git a/src/Toml/FromValue.hs b/src/Toml/FromValue.hs deleted file mode 100644 --- a/src/Toml/FromValue.hs +++ /dev/null @@ -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] diff --git a/src/Toml/FromValue/Generic.hs b/src/Toml/FromValue/Generic.hs deleted file mode 100644 --- a/src/Toml/FromValue/Generic.hs +++ /dev/null @@ -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 #-} diff --git a/src/Toml/FromValue/Matcher.hs b/src/Toml/FromValue/Matcher.hs deleted file mode 100644 --- a/src/Toml/FromValue/Matcher.hs +++ /dev/null @@ -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 diff --git a/src/Toml/FromValue/ParseTable.hs b/src/Toml/FromValue/ParseTable.hs deleted file mode 100644 --- a/src/Toml/FromValue/ParseTable.hs +++ /dev/null @@ -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]) diff --git a/src/Toml/Generic.hs b/src/Toml/Generic.hs deleted file mode 100644 --- a/src/Toml/Generic.hs +++ /dev/null @@ -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 #-} diff --git a/src/Toml/Lexer.x b/src/Toml/Lexer.x deleted file mode 100644 --- a/src/Toml/Lexer.x +++ /dev/null @@ -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 :- - - - { - -@bad_dec_int { failure "leading zero prohibited" } -@dec_int { token mkDecInteger } -@hex_int { token mkHexInteger } -@oct_int { token mkOctInteger } -@bin_int { token mkBinInteger } -@float { token mkFloat } -"true" { token_ TokTrue } -"false" { token_ TokFalse } - -@offset_date_time { timeValue "offset date-time" offsetDateTimePatterns TokOffsetDateTime } -@local_date { timeValue "local date" localDatePatterns TokLocalDate } -@local_date_time { timeValue "local date-time" localDateTimePatterns TokLocalDateTime } -@local_time { timeValue "local time" localTimePatterns TokLocalTime } - -} - -<0> { -"[[" { token_ Tok2SquareO } -"]]" { token_ Tok2SquareC } -} - -<0,val,tab> { -@newline { token_ TokNewline } -@comment; -$wschar+; - -"=" { token_ TokEquals } -"." { token_ TokPeriod } -"," { token_ TokComma } - -"[" { token_ TokSquareO } -"]" { token_ TokSquareC } -"{" { token_ TokCurlyO } -"}" { token_ TokCurlyC } - -@barekey { token TokBareKey } - -\"{3} @newline? { startMlBstr } -\" { startBstr } -"'''" @newline? { startMlLstr } -"'" { startLstr } - -} - - { - $literal_char+ { strFrag } - "'" { endStr . fmap (drop 1) } -} - - { - $unescaped+ { strFrag } - \" { endStr . fmap (drop 1) } -} - - { - @mll_content+ { strFrag } - "'" {1,2} { strFrag } - "'" {3,5} { endStr . fmap (drop 3) } -} - - { - @mlb_escaped_nl; - ($unescaped | @newline)+ { strFrag } - \" {1,2} { strFrag } - \" {3,5} { endStr . fmap (drop 3) } -} - - { - \\ U $hexdig{8} { unicodeEscape } - \\ U { failure "\\U requires exactly 8 hex digits"} - \\ u $hexdig{4} { unicodeEscape } - \\ u { failure "\\u requires exactly 4 hex digits"} - \\ n { strFrag . ("\n" <$) } - \\ t { strFrag . ("\t" <$) } - \\ r { strFrag . ("\r" <$) } - \\ f { strFrag . ("\f" <$) } - \\ b { strFrag . ("\b" <$) } - \\ \\ { strFrag . ("\\" <$) } - \\ \" { strFrag . ("\"" <$) } - $control # [\t\r\n] { recommendEscape } -} - -{ - -type AlexInput = Located String - -alexGetByte :: AlexInput -> Maybe (Int, AlexInput) -alexGetByte = locatedUncons - --- | Get the next token from a located string. This function can be total --- because one of the possible token outputs is an error token. -scanToken :: Context -> Located String -> Either (Located String) (Located Token, Located String) -scanToken st str = - case alexScan str (stateInt st) of - AlexEOF -> eofToken st str - AlexError str' -> Left (mkError <$> str') - AlexSkip str' _ -> scanToken st str' - AlexToken str' n action -> - case action (take n <$> str) st of - Resume st' -> scanToken st' str' - LexerError e -> Left e - EmitToken t -> Right (t, str') - -stateInt :: Context -> Int -stateInt TopContext = 0 -stateInt TableContext = tab -stateInt ValueContext = val -stateInt BstrContext {} = bstr -stateInt MlBstrContext{} = mlbstr -stateInt LstrContext {} = lstr -stateInt MlLstrContext{} = mllstr - --- | Lex a single token in a value context. This is mostly useful for testing. -lexValue :: String -> Either String Token -lexValue str = - case scanToken ValueContext Located{ locPosition = startPos, locThing = str } of - Left e -> Left (locThing e) - Right (t,_) -> Right (locThing t) - -} diff --git a/src/Toml/Lexer/Token.hs b/src/Toml/Lexer/Token.hs deleted file mode 100644 --- a/src/Toml/Lexer/Token.hs +++ /dev/null @@ -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"] diff --git a/src/Toml/Lexer/Utils.hs b/src/Toml/Lexer/Utils.hs deleted file mode 100644 --- a/src/Toml/Lexer/Utils.hs +++ /dev/null @@ -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 diff --git a/src/Toml/Located.hs b/src/Toml/Located.hs deleted file mode 100644 --- a/src/Toml/Located.hs +++ /dev/null @@ -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 -}) diff --git a/src/Toml/Parser.y b/src/Toml/Parser.y deleted file mode 100644 --- a/src/Toml/Parser.y +++ /dev/null @@ -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 - -} diff --git a/src/Toml/Parser/Types.hs b/src/Toml/Parser/Types.hs deleted file mode 100644 --- a/src/Toml/Parser/Types.hs +++ /dev/null @@ -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) diff --git a/src/Toml/Parser/Utils.hs b/src/Toml/Parser/Utils.hs deleted file mode 100644 --- a/src/Toml/Parser/Utils.hs +++ /dev/null @@ -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 #-} diff --git a/src/Toml/Position.hs b/src/Toml/Position.hs deleted file mode 100644 --- a/src/Toml/Position.hs +++ /dev/null @@ -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 } diff --git a/src/Toml/Pretty.hs b/src/Toml/Pretty.hs --- a/src/Toml/Pretty.hs +++ b/src/Toml/Pretty.hs @@ -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 @@ -125,7 +123,7 @@ | 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 +155,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 +248,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 +260,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 +286,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 +298,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 +311,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 +323,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) diff --git a/src/Toml/Schema.hs b/src/Toml/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Schema.hs @@ -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 diff --git a/src/Toml/Schema/FromValue.hs b/src/Toml/Schema/FromValue.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Schema/FromValue.hs @@ -0,0 +1,288 @@ +{-# 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) +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 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] diff --git a/src/Toml/Schema/Generic.hs b/src/Toml/Schema/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Schema/Generic.hs @@ -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 #-} diff --git a/src/Toml/Schema/Generic/FromValue.hs b/src/Toml/Schema/Generic/FromValue.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Schema/Generic/FromValue.hs @@ -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 #-} diff --git a/src/Toml/Schema/Generic/ToValue.hs b/src/Toml/Schema/Generic/ToValue.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Schema/Generic/ToValue.hs @@ -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 #-} diff --git a/src/Toml/Schema/Matcher.hs b/src/Toml/Schema/Matcher.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Schema/Matcher.hs @@ -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 diff --git a/src/Toml/Schema/ParseTable.hs b/src/Toml/Schema/ParseTable.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Schema/ParseTable.hs @@ -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]) diff --git a/src/Toml/Schema/ToValue.hs b/src/Toml/Schema/ToValue.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Schema/ToValue.hs @@ -0,0 +1,178 @@ +{-# 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) +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 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 diff --git a/src/Toml/Semantics.hs b/src/Toml/Semantics.hs --- a/src/Toml/Semantics.hs +++ b/src/Toml/Semantics.hs @@ -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)) diff --git a/src/Toml/Semantics/Ordered.hs b/src/Toml/Semantics/Ordered.hs --- a/src/Toml/Semantics/Ordered.hs +++ b/src/Toml/Semantics/Ordered.hs @@ -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 diff --git a/src/Toml/Semantics/Types.hs b/src/Toml/Semantics/Types.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Semantics/Types.hs @@ -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 diff --git a/src/Toml/Syntax.hs b/src/Toml/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Syntax.hs @@ -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 diff --git a/src/Toml/Syntax/Lexer.x b/src/Toml/Syntax/Lexer.x new file mode 100644 --- /dev/null +++ b/src/Toml/Syntax/Lexer.x @@ -0,0 +1,220 @@ +{ +{-| +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_char = [\x09 \x20-\x26 \x28-\x7E] +@mll_content = $mll_char | @newline + +@mlb_escaped_nl = \\ @ws @newline ($wschar | @newline)* +$unescaped = [$wschar \x21 \x23-\x5B \x5D-\x7E $non_ascii] + +@date_fullyear = $digit {4} +@date_month = $digit {2} +@date_mday = $digit {2} +$time_delim = [Tt\ ] +@time_hour = $digit {2} +@time_minute = $digit {2} +@time_second = $digit {2} +@time_secfrac = "." $digit+ +@time_numoffset = [\+\-] @time_hour ":" @time_minute +@time_offset = [Zz] | @time_numoffset + +@partial_time = @time_hour ":" @time_minute ":" @time_second @time_secfrac? +@full_date = @date_fullyear "-" @date_month "-" @date_mday +@full_time = @partial_time @time_offset + +@offset_date_time = @full_date $time_delim @full_time +@local_date_time = @full_date $time_delim @partial_time +@local_date = @full_date +@local_time = @partial_time + +toml :- + + + { + +@bad_dec_int { failure "leading zero prohibited" } +@dec_int { token mkDecInteger } +@hex_int { token mkHexInteger } +@oct_int { token mkOctInteger } +@bin_int { token mkBinInteger } +@float { token mkFloat } +"true" { token_ TokTrue } +"false" { token_ TokFalse } + +@offset_date_time { timeValue "offset date-time" offsetDateTimePatterns TokOffsetDateTime } +@local_date { timeValue "local date" localDatePatterns TokLocalDate } +@local_date_time { timeValue "local date-time" localDateTimePatterns TokLocalDateTime } +@local_time { timeValue "local time" localTimePatterns TokLocalTime } + +} + +<0> { +"[[" { token_ Tok2SquareO } +"]]" { token_ Tok2SquareC } +} + +<0,val,tab> { +@newline { token_ TokNewline } +@comment; +$wschar+; + +"=" { token_ TokEquals } +"." { token_ TokPeriod } +"," { token_ TokComma } + +"[" { token_ TokSquareO } +"]" { token_ TokSquareC } +"{" { token_ TokCurlyO } +"}" { token_ TokCurlyC } + +@barekey { textToken TokBareKey } + +\"{3} @newline? { startMlBstr } +\" { startBstr } +"'''" @newline? { startMlLstr } +"'" { startLstr } + +} + + { + $literal_char+ { strFrag } + "'" { endStr . fmap (Text.drop 1) } +} + + { + $unescaped+ { strFrag } + \" { endStr . fmap (Text.drop 1) } +} + + { + @mll_content+ { strFrag } + "'" {1,2} { strFrag } + "'" {3,5} { endStr . fmap (Text.drop 3) } +} + + { + @mlb_escaped_nl; + ($unescaped | @newline)+ { strFrag } + \" {1,2} { strFrag } + \" {3,5} { endStr . fmap (Text.drop 3) } +} + + { + \\ 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 . (Text.singleton '\n' <$) } + \\ t { strFrag . (Text.singleton '\t' <$) } + \\ r { strFrag . (Text.singleton '\r' <$) } + \\ f { strFrag . (Text.singleton '\f' <$) } + \\ b { strFrag . (Text.singleton '\b' <$) } + \\ \\ { 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) + +} diff --git a/src/Toml/Syntax/LexerUtils.hs b/src/Toml/Syntax/LexerUtils.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Syntax/LexerUtils.hs @@ -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 diff --git a/src/Toml/Syntax/Parser.y b/src/Toml/Syntax/Parser.y new file mode 100644 --- /dev/null +++ b/src/Toml/Syntax/Parser.y @@ -0,0 +1,151 @@ +{ +{-| +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 '{' sepBy(keyval, ',') pop '}' + { Located $2 $3 } + +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 + +} diff --git a/src/Toml/Syntax/ParserUtils.hs b/src/Toml/Syntax/ParserUtils.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Syntax/ParserUtils.hs @@ -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 diff --git a/src/Toml/Syntax/Position.hs b/src/Toml/Syntax/Position.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Syntax/Position.hs @@ -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 } diff --git a/src/Toml/Syntax/Token.hs b/src/Toml/Syntax/Token.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Syntax/Token.hs @@ -0,0 +1,123 @@ +{-| +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"] + +-- | 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"] diff --git a/src/Toml/Syntax/Types.hs b/src/Toml/Syntax/Types.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Syntax/Types.hs @@ -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) diff --git a/src/Toml/ToValue.hs b/src/Toml/ToValue.hs deleted file mode 100644 --- a/src/Toml/ToValue.hs +++ /dev/null @@ -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 diff --git a/src/Toml/ToValue/Generic.hs b/src/Toml/ToValue/Generic.hs deleted file mode 100644 --- a/src/Toml/ToValue/Generic.hs +++ /dev/null @@ -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 #-} diff --git a/src/Toml/Value.hs b/src/Toml/Value.hs deleted file mode 100644 --- a/src/Toml/Value.hs +++ /dev/null @@ -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)) diff --git a/test/DecodeSpec.hs b/test/DecodeSpec.hs --- a/test/DecodeSpec.hs +++ b/test/DecodeSpec.hs @@ -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) diff --git a/test/DerivingViaSpec.hs b/test/DerivingViaSpec.hs --- a/test/DerivingViaSpec.hs +++ b/test/DerivingViaSpec.hs @@ -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"] diff --git a/test/FromValueSpec.hs b/test/FromValueSpec.hs --- a/test/FromValueSpec.hs +++ b/test/FromValueSpec.hs @@ -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 "] (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 "] :: 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 ", + "1:1: missing key: b in "] :: 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 ", + "1:1: expected integer but got string in "] :: 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 "] :: 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 "] (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 "] :: 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) diff --git a/test/HieDemoSpec.hs b/test/HieDemoSpec.hs --- a/test/HieDemoSpec.hs +++ b/test/HieDemoSpec.hs @@ -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 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 = diff --git a/test/LexerSpec.hs b/test/LexerSpec.hs --- a/test/LexerSpec.hs +++ b/test/LexerSpec.hs @@ -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,9 @@ 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" diff --git a/test/PrettySpec.hs b/test/PrettySpec.hs --- a/test/PrettySpec.hs +++ b/test/PrettySpec.hs @@ -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\\\"\\u007f\\U0001000c\"") `shouldBe` Right [quoteStr| a = "\\\b\t\r\n\f\"\u007F\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" diff --git a/test/QuoteStr.hs b/test/QuoteStr.hs --- a/test/QuoteStr.hs +++ b/test/QuoteStr.hs @@ -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 ) diff --git a/test/ToValueSpec.hs b/test/ToValueSpec.hs --- a/test/ToValueSpec.hs +++ b/test/ToValueSpec.hs @@ -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] diff --git a/test/TomlSpec.hs b/test/TomlSpec.hs --- a/test/TomlSpec.hs +++ b/test/TomlSpec.hs @@ -1,4 +1,4 @@ -{-# Language QuasiQuotes #-} +{-# Language QuasiQuotes, OverloadedStrings #-} {-| Module : TomlSpec Description : Unit tests @@ -12,54 +12,59 @@ -} module TomlSpec (spec) where +import Data.Map (Map) 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 +72,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 +103,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 +115,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 +142,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 +173,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 +187,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 +198,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 +206,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 +222,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 +247,7 @@ describe "integer" do it "parses literals correctly" $ - parse [quoteStr| + parse_ [quoteStr| int1 = +99 int2 = 42 int3 = 0 @@ -287,7 +292,7 @@ describe "float" do it "parses floats" $ - parse [quoteStr| + parse_ [quoteStr| # fractional flt1 = +1.0 flt2 = 3.1415 @@ -307,42 +312,39 @@ 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 (-0.01), + "flt4" .= Double 5e22, + "flt5" .= Double 1e06, + "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 - checkNaN _ = False - in - parse [quoteStr| + decode [quoteStr| # not a number sf4 = nan # actual sNaN/qNaN encoding is implementation-specific sf5 = +nan # same as `nan` sf6 = -nan # valid, actual encoding is implementation-specific|] `shouldSatisfy` \case - Left{} -> False - Right x -> all checkNaN x + Success _ t -> all isNaN (t :: Map Text Double) + Failure{} -> False -- 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 +354,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 +368,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 +386,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 +403,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 +418,21 @@ ]|] `shouldBe` Right (table [ - "colors" .= ["red", "yellow", "green"], + "colors" .= [Text "red", Text "yellow", Text "green"], "contributors" .= [ - String "Foo Bar ", + "Foo Bar ", 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 +447,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 +465,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 +492,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 +517,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 +527,7 @@ Right (table [ "fruit" .= table [ "apple" .= table [ - "color" .= "red", + "color" .= Text "red", "taste" .= table [ "sweet" .= True], "texture" .= table [ @@ -533,14 +535,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 +568,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 +594,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 +629,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 +664,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 +678,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 +699,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 +707,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 +717,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| diff --git a/toml-parser.cabal b/toml-parser.cabal --- a/toml-parser.cabal +++ b/toml-parser.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: toml-parser -version: 1.3.2.0 +version: 2.0.0.0 synopsis: TOML 1.0.0 parser description: TOML parser using generated lexers and parsers with @@ -48,26 +48,27 @@ 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}, @@ -79,6 +80,8 @@ 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 @@ -94,6 +97,7 @@ containers, hspec ^>= {2.10, 2.11}, template-haskell ^>= {2.16, 2.17, 2.18, 2.19, 2.20, 2.21}, + text, time, toml-parser, other-modules: @@ -125,6 +129,7 @@ toml-parser, hspec ^>= {2.10, 2.11}, template-haskell ^>= {2.16, 2.17, 2.18, 2.19, 2.20, 2.21}, + 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