diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +## v0.1.0.0 + +Initial release diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,11 @@ +Copyright © 2022-present Brandon Chinn + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,104 @@ +# toml-reader + +[![](https://img.shields.io/github/workflow/status/brandonchinn178/toml-reader/CI/main)](https://github.com/brandonchinn178/toml-reader/actions) +[![](https://img.shields.io/codecov/c/gh/brandonchinn178/toml-reader)](https://app.codecov.io/gh/brandonchinn178/toml-reader) +[![](https://img.shields.io/hackage/v/toml-reader)](https://hackage.haskell.org/package/toml-reader) + +TOML format parser compliant with [v1.0.0](https://toml.io/en/v1.0.0) (verified with the [`toml-test`](https://github.com/BurntSushi/toml-test) tool). + +## Usage + +```hs +data MyConfig = MyConfig + { field1 :: Int + , field2 :: Bool + } + +instance DecodeTOML MyConfig where + tomlDecoder = + MyConfig + <$> getField "field1" + <*> getField "field2" + +main :: IO () +main = do + result <- decodeFile "config.toml" + case result of + Right cfg -> print (cfg :: MyConfig) + Left e -> print e +``` + +## Design decisions + +* Only supports reading, not writing, since TOML is lossy. For example, a simple `a.b.c = 1` line could be written in a number of ways: + + ```toml + a.b.c = 1 + a.b = { c = 1 } + a = { b.c = 1 } + + [a] + b.c = 1 + b = { c = 1 } + + [a.b] + c = 1 + ``` + + Since reading/writing isn't an idempotent operation, this library won't even pretend to provide `DecodeTOML`/`EncodeTOML` typeclasses that imply that they're inverses of each other. + + Hopefully some other `toml-writer` library may come along to make it easy to specify how to format your data in TOML (e.g. a combinator for `table` vs `inlineTable`), or you could use [`tomland`](https://github.com/kowainik/tomland). + +* This library defines `DecodeTOML` with an opaque `Decoder a` as opposed to a `Value -> DecodeM a` function, like `aeson` does. In my opinion, this makes the common case of decoding config files much more straightforward, especially around nested fields, which are much more common in TOML than JSON. e.g. + + ```hs + -- aeson-like + instance DecodeTOML MyConfig where + decodeTOML :: Value -> DecodeM MyConfig + decodeTOML = withObject "MyConfig" $ \o -> + MyConfig + <$> o .: "field1" + <*> (o .: "field2" >>= (.: "field3")) + ``` + + ```hs + -- with toml-parser + instance DecodeTOML MyConfig where + tomlDecoder :: Decoder MyConfig + tomlDecoder = + MyConfig + <$> getField "field1" + <*> getFields ["field2", "field3"] + ``` + + It also makes it easy to define ad-hoc decoders: + + ```hs + instance DecodeTOML MyConfig where + tomlDecoder = ... + + alternativeDecoder :: Decoder MyConfig + alternativeDecoder = ... + + -- uses tomlDecoder + decode "a = 1" + + -- uses explicit decoder + decodeWith alternativeDecoder "a = 1" + ``` + + As a bonus, it also makes for a less point-free interface when defining a decoder based on another decoder, which is kinda cool: + + ```hs + -- aeson-like + instance DecodeTOML MyString where + decodeTOML = fmap toMyString . decodeTOML + ``` + + ```hs + -- with toml-parser + instance DecodeTOML MyString where + tomlDecoder = toMyString <$> tomlDecoder + ``` + + Ultimately, `Decoder` is just a newtype around `Value -> DecodeM a`, so we could always go back to it. Originally, I wanted to do something like [`jordan`](https://hackage.haskell.org/package/jordan), where this interface is required due to the way it parses and deserializes at the same time, but this isn't possible with TOML due to the way TOML needs to be normalized. diff --git a/src/TOML.hs b/src/TOML.hs new file mode 100644 --- /dev/null +++ b/src/TOML.hs @@ -0,0 +1,42 @@ +module TOML ( + -- * Decoding a TOML file + decode, + decodeWith, + decodeFile, + DecodeTOML (..), + Decoder, + + -- ** Decoding getters + getField, + getFields, + getFieldOpt, + getFieldsOpt, + getFieldWith, + getFieldsWith, + getFieldOptWith, + getFieldsOptWith, + getArrayOf, + + -- ** Build custom Decoder + DecodeM, + makeDecoder, + runDecoder, + invalidValue, + typeMismatch, + decodeFail, + + -- * TOML types + Value (..), + renderValue, + Table, + TOMLError (..), + NormalizeError (..), + DecodeContext, + ContextItem (..), + DecodeError (..), + renderTOMLError, +) where + +import TOML.Decode +import TOML.Error +import TOML.Value diff --git a/src/TOML/Decode.hs b/src/TOML/Decode.hs new file mode 100644 --- /dev/null +++ b/src/TOML/Decode.hs @@ -0,0 +1,642 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module TOML.Decode ( + -- * Decoding functions + decode, + decodeWith, + decodeWithOpts, + decodeFile, + + -- * Decoder interface + DecodeTOML (..), + Decoder (..), + + -- ** Decoder getters + getField, + getFields, + getFieldOpt, + getFieldsOpt, + getFieldWith, + getFieldsWith, + getFieldOptWith, + getFieldsOptWith, + getArrayOf, + + -- ** Build custom Decoder + DecodeM (..), + makeDecoder, + runDecoder, + addContextItem, + invalidValue, + typeMismatch, + decodeFail, + decodeError, +) where + +import Control.Applicative (Alternative (..), Const (..)) +import Control.Monad (zipWithM) +#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,13,0) +import qualified Control.Monad.Fail as MonadFail +#endif +import Data.Bifunctor (first) +import Data.Fixed (Fixed, HasResolution) +import Data.Functor.Identity (Identity (..)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map (Map) +import qualified Data.Map.Strict as Map +import qualified Data.Monoid as Monoid +import Data.Proxy (Proxy (..)) +import Data.Ratio (Ratio) +import qualified Data.Semigroup as Semigroup +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String (IsString, fromString) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import qualified Data.Text.Lazy as Lazy (Text) +import qualified Data.Text.Lazy as Text.Lazy +import qualified Data.Time as Time +import qualified Data.Time.Clock.System as Time +import Data.Version (Version, parseVersion) +import Data.Void (Void) +import Data.Word (Word16, Word32, Word64, Word8) +import Numeric.Natural (Natural) +import Text.ParserCombinators.ReadP (readP_to_S) + +import TOML.Error ( + ContextItem (..), + DecodeContext, + DecodeError (..), + TOMLError (..), + ) +import TOML.Parser (parseTOML) +import TOML.Value (Value (..)) + +{--- Decoder ---} + +{- | +A @Decoder a@ represents a function for decoding a TOML value to a value of type @a@. + +Generally, you'd only need to chain the @getField*@ functions together, like + +@ +decoder = + MyConfig + \<$> getField "a" + \<*> getField "b" + \<*> getField "c" +@ + +or use interfaces like 'Monad' and 'Alternative': + +@ +decoder = do + cfgType <- getField "type" + case cfgType of + "int" -> MyIntValue \<$> (getField "int" \<|> getField "integer") + "bool" -> MyBoolValue \<$> getField "bool" + _ -> fail $ "Invalid type: " <> cfgType +@ + +but you can also manually implement a 'Decoder' with 'makeDecoder'. +-} +newtype Decoder a = Decoder {unDecoder :: Value -> DecodeM a} + +instance Functor Decoder where + fmap f = Decoder . (fmap . fmap) f . unDecoder +instance Applicative Decoder where + pure v = Decoder $ \_ -> pure v + Decoder decodeF <*> Decoder decodeV = Decoder $ \v -> decodeF v <*> decodeV v +instance Monad Decoder where + Decoder decodeA >>= f = Decoder $ \v -> do + a <- decodeA v + let Decoder decodeB = f a + decodeB v +#if !MIN_VERSION_base(4,13,0) + fail msg = Decoder $ \_ -> decodeFail $ Text.pack msg +#endif +instance Alternative Decoder where + empty = fail "Decoder.Alternative: empty" + Decoder decode1 <|> Decoder decode2 = Decoder $ \v -> decode1 v <|> decode2 v +#if MIN_VERSION_base(4,13,0) +instance MonadFail Decoder where + fail msg = Decoder $ \_ -> decodeFail $ Text.pack msg +#elif MIN_VERSION_base(4,9,0) +instance MonadFail.MonadFail Decoder where + fail msg = Decoder $ \_ -> decodeFail $ Text.pack msg +#endif + +-- | Manually implement a 'Decoder' with the given function. +makeDecoder :: (Value -> DecodeM a) -> Decoder a +makeDecoder = Decoder + +decoderToEither :: Decoder a -> Value -> DecodeContext -> Either (DecodeContext, DecodeError) a +decoderToEither decoder v ctx = unDecodeM (unDecoder decoder v) ctx + +-- | The underlying decoding monad that either returns a value of type @a@ or returns an error. +newtype DecodeM a = DecodeM {unDecodeM :: DecodeContext -> Either (DecodeContext, DecodeError) a} + +instance Functor DecodeM where + fmap f = DecodeM . (fmap . fmap) f . unDecodeM +instance Applicative DecodeM where + pure v = DecodeM $ \_ -> pure v + DecodeM decodeF <*> DecodeM decodeV = DecodeM $ \ctx -> decodeF ctx <*> decodeV ctx +instance Monad DecodeM where + DecodeM decodeA >>= f = DecodeM $ \ctx -> do + a <- decodeA ctx + let DecodeM decodeB = f a + decodeB ctx +#if !MIN_VERSION_base(4,13,0) + fail = decodeFail . Text.pack +#endif +instance Alternative DecodeM where + empty = decodeFail "DecodeM.Alternative: empty" + DecodeM decode1 <|> DecodeM decode2 = DecodeM $ \ctx -> + case decode1 ctx of + Left _ -> decode2 ctx + Right x -> Right x +#if MIN_VERSION_base(4,13,0) +instance MonadFail DecodeM where + fail = decodeFail . Text.pack +#elif MIN_VERSION_base(4,9,0) +instance MonadFail.MonadFail DecodeM where + fail = decodeFail . Text.pack +#endif + +{- | +Run a 'Decoder' with the given 'Value'. + +@ +makeDecoder $ \\v -> do + a <- runDecoder decoder1 v + b <- runDecoder decoder2 v + return (a, b) +@ + +Satisfies + +@ +makeDecoder . runDecoder === id +runDecoder . makeDecoder === id +@ +-} +runDecoder :: Decoder a -> Value -> DecodeM a +runDecoder decoder v = DecodeM (decoderToEither decoder v) + +{- | +Throw an error indicating that the given 'Value' is invalid. + +@ +makeDecoder $ \\v -> + case v of + Integer 42 -> invalidValue "We don't like this number" v + _ -> runDecoder tomlDecoder v + +-- or alternatively, +tomlDecoder >>= \case + 42 -> makeDecoder $ invalidValue "We don't like this number" + v -> pure v +@ +-} +invalidValue :: Text -> Value -> DecodeM a +invalidValue msg v = decodeError $ InvalidValue msg v + +{- | +Throw an error indicating that the given 'Value' isn't the correct type of value. + +@ +makeDecoder $ \\v -> + case v of + String s -> ... + _ -> typeMismatch v +@ +-} +typeMismatch :: Value -> DecodeM a +typeMismatch v = decodeError $ TypeMismatch v + +-- | Throw a generic failure message. +decodeFail :: Text -> DecodeM a +decodeFail msg = decodeError $ OtherDecodeError msg + +-- | Throw the given 'DecodeError'. +decodeError :: DecodeError -> DecodeM a +decodeError e = DecodeM $ \ctx -> Left (ctx, e) + +addContextItem :: ContextItem -> DecodeM a -> DecodeM a +addContextItem p m = DecodeM $ \ctx -> unDecodeM m (ctx <> [p]) + +{--- Decoding ---} + +-- | Decode the given TOML input. +decode :: DecodeTOML a => Text -> Either TOMLError a +decode = decodeWith tomlDecoder + +-- | Decode the given TOML input using the given 'Decoder'. +decodeWith :: Decoder a -> Text -> Either TOMLError a +decodeWith decoder = decodeWithOpts decoder "" + +decodeWithOpts :: Decoder a -> String -> Text -> Either TOMLError a +decodeWithOpts decoder filename input = do + v <- parseTOML filename input + first (uncurry DecodeError) $ decoderToEither decoder v [] + +-- | Decode a TOML file at the given file path. +decodeFile :: DecodeTOML a => FilePath -> IO (Either TOMLError a) +decodeFile fp = decodeWithOpts tomlDecoder fp <$> Text.readFile fp + +{--- Decoder helpers ---} + +{- | +Decode a field in a TOML Value. +Equivalent to 'getFields' with a single-element list. + +@ +a = 1 +b = 'asdf' +@ + +@ +-- MyConfig 1 "asdf" +MyConfig \<$> getField "a" \<*> getField "b" +@ +-} +getField :: DecodeTOML a => Text -> Decoder a +getField = getFieldWith tomlDecoder + +-- | Same as 'getField', except with the given 'Decoder'. +getFieldWith :: Decoder a -> Text -> Decoder a +getFieldWith decoder key = getFieldsWith decoder [key] + +{- | +Decode a field in a TOML Value, or Nothing if the field doesn't exist. +Equivalent to 'getFieldsOpt' with a single-element list. + +@ +a = 1 +@ + +@ +-- MyConfig (Just 1) Nothing +MyConfig \<$> getFieldOpt "a" \<*> getFieldOpt "b" +@ +-} +getFieldOpt :: DecodeTOML a => Text -> Decoder (Maybe a) +getFieldOpt = getFieldOptWith tomlDecoder + +-- | Same as 'getFieldOpt', except with the given 'Decoder'. +getFieldOptWith :: Decoder a -> Text -> Decoder (Maybe a) +getFieldOptWith decoder key = getFieldsOptWith decoder [key] + +{- | +Decode a nested field in a TOML Value. + +@ +a.b = 1 +@ + +@ +-- MyConfig 1 +MyConfig \<$> getFields ["a", "b"] +@ +-} +getFields :: DecodeTOML a => [Text] -> Decoder a +getFields = getFieldsWith tomlDecoder + +-- | Same as 'getFields', except with the given 'Decoder'. +getFieldsWith :: Decoder a -> [Text] -> Decoder a +getFieldsWith decoder = makeDecoder . go + where + go [] v = runDecoder decoder v + go (k : ks) v = + case v of + Table o -> + addContextItem (Key k) $ + case Map.lookup k o of + Just v' -> go ks v' + Nothing -> decodeError MissingField + _ -> typeMismatch v + +{- | +Decode a nested field in a TOML Value, or 'Nothing' if any of the fields don't exist. + +@ +a.b = 1 +@ + +@ +-- MyConfig (Just 1) Nothing Nothing +MyConfig + \<$> getFieldsOpt ["a", "b"] + \<*> getFieldsOpt ["a", "c"] + \<*> getFieldsOpt ["b", "c"] +@ +-} +getFieldsOpt :: DecodeTOML a => [Text] -> Decoder (Maybe a) +getFieldsOpt = getFieldsOptWith tomlDecoder + +-- | Same as 'getFieldsOpt', except with the given 'Decoder'. +getFieldsOptWith :: Decoder a -> [Text] -> Decoder (Maybe a) +getFieldsOptWith decoder keys = + makeDecoder $ \v -> + DecodeM $ \ctx -> + case (`unDecodeM` ctx) . (`runDecoder` v) $ getFieldsWith decoder keys of + Left (_, MissingField) -> Right Nothing + Left (ctx', e) -> Left (ctx', e) + Right x -> Right $ Just x + +{- | +Decode a list of values using the given 'Decoder'. + +@ +[[a]] +b = 1 + +[[a]] +b = 2 +@ + +@ +-- MyConfig [1, 2] +MyConfig + \<$> getFieldWith (getArrayOf (getField "b")) "a" +@ +-} +getArrayOf :: Decoder a -> Decoder [a] +getArrayOf decoder = + makeDecoder $ \case + Array vs -> zipWithM (\i -> addContextItem (Index i) . runDecoder decoder) [0 ..] vs + v -> typeMismatch v + +{--- DecodeTOML ---} + +{- | +A type class containing the default 'Decoder' for the given type. + +See the docs for 'Decoder' for examples. +-} +class DecodeTOML a where + tomlDecoder :: Decoder a + +instance DecodeTOML Value where + tomlDecoder = Decoder pure + +instance DecodeTOML Void where + tomlDecoder = makeDecoder typeMismatch +instance DecodeTOML Bool where + tomlDecoder = + makeDecoder $ \case + Boolean x -> pure x + v -> typeMismatch v + +instance DecodeTOML Integer where + tomlDecoder = + makeDecoder $ \case + Integer x -> pure x + v -> typeMismatch v + +tomlDecoderInt :: forall a. Num a => Decoder a +tomlDecoderInt = fromInteger <$> tomlDecoder + +tomlDecoderBoundedInt :: forall a. (Integral a, Bounded a) => Decoder a +tomlDecoderBoundedInt = + tomlDecoder >>= \case + x + | x < toInteger (minBound @a) -> makeDecoder $ invalidValue "Underflow" + | x > toInteger (maxBound @a) -> makeDecoder $ invalidValue "Overflow" + | otherwise -> pure $ fromInteger x + +instance DecodeTOML Int where + tomlDecoder = tomlDecoderBoundedInt +instance DecodeTOML Int8 where + tomlDecoder = tomlDecoderBoundedInt +instance DecodeTOML Int16 where + tomlDecoder = tomlDecoderBoundedInt +instance DecodeTOML Int32 where + tomlDecoder = tomlDecoderBoundedInt +instance DecodeTOML Int64 where + tomlDecoder = tomlDecoderBoundedInt +instance DecodeTOML Word where + tomlDecoder = tomlDecoderBoundedInt +instance DecodeTOML Word8 where + tomlDecoder = tomlDecoderBoundedInt +instance DecodeTOML Word16 where + tomlDecoder = tomlDecoderBoundedInt +instance DecodeTOML Word32 where + tomlDecoder = tomlDecoderBoundedInt +instance DecodeTOML Word64 where + tomlDecoder = tomlDecoderBoundedInt +instance DecodeTOML Natural where + tomlDecoder = + tomlDecoder >>= \case + x + | x >= 0 -> pure $ fromInteger x + | otherwise -> makeDecoder $ invalidValue "Got negative number" + +instance DecodeTOML Double where + tomlDecoder = + makeDecoder $ \case + Float x -> pure x + v -> typeMismatch v + +tomlDecoderFrac :: Fractional a => Decoder a +tomlDecoderFrac = realToFrac <$> tomlDecoder @Double + +instance DecodeTOML Float where + tomlDecoder = tomlDecoderFrac +instance Integral a => DecodeTOML (Ratio a) where + tomlDecoder = tomlDecoderFrac +instance HasResolution a => DecodeTOML (Fixed a) where + tomlDecoder = tomlDecoderFrac + +instance DecodeTOML Char where + tomlDecoder = + tomlDecoder >>= \case + s + | Text.length s == 1 -> pure $ Text.head s + | otherwise -> makeDecoder $ invalidValue "Expected single character string" +instance {-# OVERLAPPING #-} DecodeTOML String where + tomlDecoder = Text.unpack <$> tomlDecoder +instance DecodeTOML Text where + tomlDecoder = + makeDecoder $ \case + String s -> pure s + v -> typeMismatch v +instance DecodeTOML Lazy.Text where + tomlDecoder = Text.Lazy.fromStrict <$> tomlDecoder + +instance DecodeTOML Time.ZonedTime where + tomlDecoder = + makeDecoder $ \case + OffsetDateTime (lt, tz) -> pure $ Time.ZonedTime lt tz + v -> typeMismatch v +instance DecodeTOML Time.UTCTime where + tomlDecoder = Time.zonedTimeToUTC <$> tomlDecoder +instance DecodeTOML Time.SystemTime where + tomlDecoder = Time.utcToSystemTime . Time.zonedTimeToUTC <$> tomlDecoder +instance DecodeTOML Time.LocalTime where + tomlDecoder = + makeDecoder $ \case + LocalDateTime dt -> pure dt + v -> typeMismatch v +instance DecodeTOML Time.Day where + tomlDecoder = + makeDecoder $ \case + LocalDate d -> pure d + v -> typeMismatch v +instance DecodeTOML Time.TimeOfDay where + tomlDecoder = + makeDecoder $ \case + LocalTime t -> pure t + v -> typeMismatch v +#if MIN_VERSION_time(1,9,0) +instance DecodeTOML Time.DayOfWeek where + tomlDecoder = toDayOfWeek . Text.toLower =<< tomlDecoder + where + toDayOfWeek = \case + "monday" -> pure Time.Monday + "tuesday" -> pure Time.Tuesday + "wednesday" -> pure Time.Wednesday + "thursday" -> pure Time.Thursday + "friday" -> pure Time.Friday + "saturday" -> pure Time.Saturday + "sunday" -> pure Time.Sunday + _ -> makeDecoder $ invalidValue "Invalid day of week" +#endif + +instance DecodeTOML Time.DiffTime where + tomlDecoder = tomlDecoderInt <|> tomlDecoderFrac +instance DecodeTOML Time.NominalDiffTime where + tomlDecoder = tomlDecoderInt <|> tomlDecoderFrac +#if MIN_VERSION_time(1,9,0) +instance DecodeTOML Time.CalendarDiffTime where + tomlDecoder = + Time.CalendarDiffTime + <$> getField "months" + <*> getField "time" +instance DecodeTOML Time.CalendarDiffDays where + tomlDecoder = + Time.CalendarDiffDays + <$> getField "months" + <*> getField "days" +#endif + +instance DecodeTOML Version where + tomlDecoder = go . readP_to_S parseVersion =<< tomlDecoder + where + go ((v, []) : _) = pure v + go (_ : vs) = go vs + go [] = makeDecoder $ invalidValue "Invalid Version" +instance DecodeTOML Ordering where + tomlDecoder = + tomlDecoder @Text >>= \case + "LT" -> pure LT + "EQ" -> pure EQ + "GT" -> pure GT + _ -> makeDecoder $ invalidValue "Invalid Ordering" + +instance DecodeTOML a => DecodeTOML (Identity a) where + tomlDecoder = Identity <$> tomlDecoder +instance DecodeTOML (Proxy a) where + tomlDecoder = pure Proxy +instance DecodeTOML a => DecodeTOML (Const a b) where + tomlDecoder = Const <$> tomlDecoder + +{- | +Since TOML doesn't support literal NULLs, this will only ever return 'Just'. +To get the absence of a field, use 'getFieldOpt' or one of its variants. +-} +instance DecodeTOML a => DecodeTOML (Maybe a) where + tomlDecoder = Just <$> tomlDecoder + +instance (DecodeTOML a, DecodeTOML b) => DecodeTOML (Either a b) where + tomlDecoder = (Right <$> tomlDecoder) <|> (Left <$> tomlDecoder) + +instance DecodeTOML a => DecodeTOML (Monoid.First a) where + tomlDecoder = Monoid.First <$> tomlDecoder +instance DecodeTOML a => DecodeTOML (Monoid.Last a) where + tomlDecoder = Monoid.Last <$> tomlDecoder +instance DecodeTOML a => DecodeTOML (Semigroup.First a) where + tomlDecoder = Semigroup.First <$> tomlDecoder +instance DecodeTOML a => DecodeTOML (Semigroup.Last a) where + tomlDecoder = Semigroup.Last <$> tomlDecoder +instance DecodeTOML a => DecodeTOML (Semigroup.Max a) where + tomlDecoder = Semigroup.Max <$> tomlDecoder +instance DecodeTOML a => DecodeTOML (Semigroup.Min a) where + tomlDecoder = Semigroup.Min <$> tomlDecoder +instance DecodeTOML a => DecodeTOML (Monoid.Dual a) where + tomlDecoder = Monoid.Dual <$> tomlDecoder + +instance DecodeTOML a => DecodeTOML [a] where + tomlDecoder = getArrayOf tomlDecoder +instance (IsString k, Ord k, DecodeTOML v) => DecodeTOML (Map k v) where + tomlDecoder = + makeDecoder $ \case + Table o -> Map.mapKeys (fromString . Text.unpack) <$> mapM (runDecoder tomlDecoder) o + v -> typeMismatch v +instance DecodeTOML a => DecodeTOML (NonEmpty a) where + tomlDecoder = maybe raiseEmpty pure . NonEmpty.nonEmpty =<< tomlDecoder + where + raiseEmpty = makeDecoder $ invalidValue "Got empty list" +instance DecodeTOML IntSet where + tomlDecoder = IntSet.fromList <$> tomlDecoder +instance (DecodeTOML a, Ord a) => DecodeTOML (Set a) where + tomlDecoder = Set.fromList <$> tomlDecoder +instance DecodeTOML a => DecodeTOML (IntMap a) where + tomlDecoder = IntMap.fromList <$> tomlDecoder +instance DecodeTOML a => DecodeTOML (Seq a) where + tomlDecoder = Seq.fromList <$> tomlDecoder + +tomlDecoderTuple :: ([Value] -> Maybe (DecodeM a)) -> Decoder a +tomlDecoderTuple f = + makeDecoder $ \case + Array vs | Just decodeM <- f vs -> decodeM + v -> typeMismatch v +decodeElem :: DecodeTOML a => Int -> Value -> DecodeM a +decodeElem i v = addContextItem (Index i) (runDecoder tomlDecoder v) +instance DecodeTOML () where + tomlDecoder = tomlDecoderTuple $ \case + [] -> Just $ pure () + _ -> Nothing +instance (DecodeTOML a, DecodeTOML b) => DecodeTOML (a, b) where + tomlDecoder = tomlDecoderTuple $ \case + [a, b] -> + Just $ + (,) + <$> decodeElem 0 a + <*> decodeElem 1 b + _ -> Nothing +instance (DecodeTOML a, DecodeTOML b, DecodeTOML c) => DecodeTOML (a, b, c) where + tomlDecoder = tomlDecoderTuple $ \case + [a, b, c] -> + Just $ + (,,) + <$> decodeElem 0 a + <*> decodeElem 1 b + <*> decodeElem 2 c + _ -> Nothing +instance (DecodeTOML a, DecodeTOML b, DecodeTOML c, DecodeTOML d) => DecodeTOML (a, b, c, d) where + tomlDecoder = tomlDecoderTuple $ \case + [a, b, c, d] -> + Just $ + (,,,) + <$> decodeElem 0 a + <*> decodeElem 1 b + <*> decodeElem 2 c + <*> decodeElem 3 d + _ -> Nothing diff --git a/src/TOML/Error.hs b/src/TOML/Error.hs new file mode 100644 --- /dev/null +++ b/src/TOML/Error.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module TOML.Error ( + TOMLError (..), + NormalizeError (..), + DecodeContext, + ContextItem (..), + DecodeError (..), + renderTOMLError, +) where + +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Text (Text) +import qualified Data.Text as Text + +import TOML.Value (Table, Value (..), renderValue) + +data TOMLError + = ParseError Text + | NormalizeError NormalizeError + | DecodeError DecodeContext DecodeError + deriving (Show, Eq) + +data NormalizeError + = -- | When a key is defined twice, e.g. + -- + -- @ + -- name = 'First' + -- name = 'Second' + -- @ + DuplicateKeyError + { _path :: NonEmpty Text + , _existingValue :: Value + , _valueToSet :: Value + } + | -- | When a section is defined twice, e.g. + -- + -- @ + -- [foo] + -- a = 1 + -- + -- [foo] + -- b = 2 + -- @ + DuplicateSectionError + { _sectionKey :: NonEmpty Text + } + | -- | When a key attempts to extend an invalid table + -- + -- @ + -- a = {} + -- [a.b] + -- + -- b = {} + -- b.a = 1 + -- + -- c.x.x = 1 + -- [c.a] + -- @ + ExtendTableError + { _path :: NonEmpty Text + , _originalKey :: NonEmpty Text + } + | -- | When a section attempts to extend a table within an inline array + -- + -- @ + -- a = [{ b = 1 }] + -- [a.c] + -- @ + ExtendTableInInlineArrayError + { _path :: NonEmpty Text + , _originalKey :: NonEmpty Text + } + | -- | When a key is already defined, but attempting to create an + -- implicit array at the same key, e.g. + -- + -- @ + -- list = [1, 2, 3] + -- + -- [[list]] + -- a = 1 + -- @ + ImplicitArrayForDefinedKeyError + { _path :: NonEmpty Text + , _existingValue :: Value + , _tableSection :: Table + } + | -- | When a non-table value is already defined in a nested key, e.g. + -- + -- @ + -- a.b = 1 + -- a.b.c.d = 2 + -- @ + NonTableInNestedKeyError + { _path :: NonEmpty Text + , _existingValue :: Value + , _originalKey :: NonEmpty Text + , _originalValue :: Value + } + | -- | When a non-table value is already defined in a nested implicit array, e.g. + -- + -- @ + -- a.b = 1 + -- + -- [[a.b.c]] + -- d = 2 + -- @ + NonTableInNestedImplicitArrayError + { _path :: NonEmpty Text + , _existingValue :: Value + , _sectionKey :: NonEmpty Text + , _tableSection :: Table + } + deriving (Show, Eq) + +type DecodeContext = [ContextItem] + +data ContextItem = Key Text | Index Int + deriving (Show, Eq) + +data DecodeError + = MissingField + | InvalidValue Text Value + | TypeMismatch Value + | OtherDecodeError Text + deriving (Show, Eq) + +renderTOMLError :: TOMLError -> Text +renderTOMLError = \case + ParseError s -> s + NormalizeError DuplicateKeyError{..} -> + Text.unlines + [ "Could not add value to path " <> showPath _path <> ":" + , " Existing value: " <> renderValue _existingValue + , " Value to set: " <> renderValue _valueToSet + ] + NormalizeError DuplicateSectionError{..} -> "Found duplicate section: " <> showPath _sectionKey + NormalizeError ExtendTableError{..} -> + Text.unlines + [ "Invalid table key: " <> showPath _originalKey + , " Table already statically defined at " <> showPath _path + ] + NormalizeError ExtendTableInInlineArrayError{..} -> + Text.unlines + [ "Invalid table key: " <> showPath _originalKey + , " Table defined in inline array at " <> showPath _path + ] + NormalizeError ImplicitArrayForDefinedKeyError{..} -> + Text.unlines + [ "Could not create implicit array at path " <> showPath _path <> ":" + , " Existing value: " <> renderValue _existingValue + , " Array table section: " <> renderValue (Table _tableSection) + ] + NormalizeError NonTableInNestedKeyError{..} -> + Text.unlines + [ "Found non-Table at path " <> showPath _path <> " when defining nested key " <> showPath _originalKey <> ":" + , " Existing value: " <> renderValue _existingValue + , " Original value: " <> renderValue _originalValue + ] + NormalizeError NonTableInNestedImplicitArrayError{..} -> + Text.unlines + [ "Found non-Table at path " <> showPath _path <> " when initializing implicit array at path " <> showPath _sectionKey <> ":" + , " Existing value: " <> renderValue _existingValue + , " Array table section: " <> renderValue (Table _tableSection) + ] + DecodeError ctx e -> "Decode error at '" <> renderDecodeContext ctx <> "': " <> renderDecodeError e + where + showPath path = "\"" <> Text.intercalate "." (NonEmpty.toList path) <> "\"" + + renderDecodeError = \case + MissingField -> "Field does not exist" + InvalidValue msg v -> "Invalid value: " <> msg <> ": " <> renderValue v + TypeMismatch v -> "Type mismatch, got: " <> renderValue v + OtherDecodeError msg -> msg + + renderDecodeContext = Text.concat . map renderContextItem + renderContextItem = \case + Key k -> "." <> k + Index i -> "[" <> Text.pack (show i) <> "]" diff --git a/src/TOML/Parser.hs b/src/TOML/Parser.hs new file mode 100644 --- /dev/null +++ b/src/TOML/Parser.hs @@ -0,0 +1,854 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +{- | +Parse a TOML document. + +References: + +* https://toml.io/en/v1.0.0 +* https://github.com/toml-lang/toml/blob/1.0.0/toml.abnf +-} +module TOML.Parser ( + parseTOML, +) where + +import Control.Monad (guard, unless, void, when) +import Control.Monad.Combinators.NonEmpty (sepBy1) +import Data.Bifunctor (bimap) +import Data.Char (chr, isDigit, isSpace, ord) +import Data.Fixed (Fixed (..)) +import Data.Foldable (foldl', foldlM) +import Data.Functor (($>)) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time (Day, LocalTime, TimeOfDay, TimeZone) +import qualified Data.Time as Time +import Data.Void (Void) +import qualified Numeric +import Text.Megaparsec hiding (sepBy1) +import Text.Megaparsec.Char hiding (space, space1) +import qualified Text.Megaparsec.Char.Lexer as L + +import TOML.Error (NormalizeError (..), TOMLError (..)) +import TOML.Utils.Map (getPathLens) +import TOML.Value (Table, Value (..)) + +parseTOML :: + -- | Name of file (for error messages) + String -> + -- | Input + Text -> + Either TOMLError Value +parseTOML filename input = + case runParser parseTOMLDocument filename input of + Left e -> Left $ ParseError $ Text.pack $ errorBundlePretty e + Right result -> Table <$> normalize result + +-- 'Value' generalized to allow for unnormalized + annotated Values. +data GenericValue map key tableMeta arrayMeta + = GenericTable tableMeta (map key (GenericValue map key tableMeta arrayMeta)) + | GenericArray arrayMeta [GenericValue map key tableMeta arrayMeta] + | GenericString Text + | GenericInteger Integer + | GenericFloat Double + | GenericBoolean Bool + | GenericOffsetDateTime (LocalTime, TimeZone) + | GenericLocalDateTime LocalTime + | GenericLocalDate Day + | GenericLocalTime TimeOfDay + +fromGenericValue :: + (map key (GenericValue map key tableMeta arrayMeta) -> Table) -> + GenericValue map key tableMeta arrayMeta -> + Value +fromGenericValue fromGenericTable = \case + GenericTable _ t -> Table $ fromGenericTable t + GenericArray _ vs -> Array $ map (fromGenericValue fromGenericTable) vs + GenericString x -> String x + GenericInteger x -> Integer x + GenericFloat x -> Float x + GenericBoolean x -> Boolean x + GenericOffsetDateTime x -> OffsetDateTime x + GenericLocalDateTime x -> LocalDateTime x + GenericLocalDate x -> LocalDate x + GenericLocalTime x -> LocalTime x + +{--- Parse raw document ---} + +type Parser = Parsec Void Text + +-- | An unannotated, unnormalized value. +type RawValue = GenericValue LookupMap Key () () + +type Key = NonEmpty Text +type RawTable = LookupMap Key RawValue +newtype LookupMap k v = LookupMap {unLookupMap :: [(k, v)]} + +data TOMLDoc = TOMLDoc + { rootTable :: RawTable + , subTables :: [TableSection] + } + +data TableSection = TableSection + { tableSectionHeader :: TableSectionHeader + , tableSectionTable :: RawTable + } + +data TableSectionHeader = SectionTable Key | SectionTableArray Key + +parseTOMLDocument :: Parser TOMLDoc +parseTOMLDocument = do + emptyLines + rootTable <- parseRawTable + emptyLines + subTables <- many parseTableSection + emptyLines + eof + return TOMLDoc{..} + +parseRawTable :: Parser RawTable +parseRawTable = fmap LookupMap $ many $ parseKeyValue <* endOfLine <* emptyLines + +parseTableSection :: Parser TableSection +parseTableSection = do + tableSectionHeader <- + choice + [ SectionTableArray <$> parseHeader "[[" "]]" + , SectionTable <$> parseHeader "[" "]" + ] + endOfLine + emptyLines + tableSectionTable <- parseRawTable + emptyLines + return TableSection{..} + where + parseHeader brackStart brackEnd = hsymbol brackStart *> parseKey <* hsymbol brackEnd + +parseKeyValue :: Parser (Key, RawValue) +parseKeyValue = do + key <- parseKey + hsymbol "=" + value <- parseValue + pure (key, value) + +parseKey :: Parser Key +parseKey = + (`sepBy1` try (hsymbol ".")) . choice $ + [ parseBasicString + , parseLiteralString + , parseUnquotedKey + ] + where + parseUnquotedKey = + takeWhile1P + (Just "[A-Za-z0-9_-]") + (`elem` ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] ++ "-_") + +parseValue :: Parser RawValue +parseValue = + choice + [ try $ GenericTable () <$> label "table" parseInlineTable + , try $ GenericArray () <$> label "array" parseInlineArray + , try $ GenericString <$> label "string" parseString + , try $ GenericOffsetDateTime <$> label "offset-datetime" parseOffsetDateTime + , try $ GenericLocalDateTime <$> label "local-datetime" parseLocalDateTime + , try $ GenericLocalDate <$> label "local-date" parseLocalDate + , try $ GenericLocalTime <$> label "local-time" parseLocalTime + , try $ GenericFloat <$> label "float" parseFloat + , try $ GenericInteger <$> label "integer" parseInteger + , try $ GenericBoolean <$> label "boolean" parseBoolean + ] + +parseInlineTable :: Parser RawTable +parseInlineTable = do + hsymbol "{" + kvs <- parseKeyValue `sepBy` try (hsymbol ",") + hsymbol "}" + return $ LookupMap kvs + +parseInlineArray :: Parser [RawValue] +parseInlineArray = do + _ <- char '[' <* emptyLines + vs <- (parseValue <* emptyLines) `sepEndBy` (char ',' <* emptyLines) + _ <- char ']' + return vs + +parseString :: Parser Text +parseString = + choice + [ try parseMultilineBasicString + , try parseMultilineLiteralString + , try parseBasicString + , parseLiteralString + ] + +-- | A string in double quotes. +parseBasicString :: Parser Text +parseBasicString = + label "double-quoted string" $ + between (char '"') (char '"') $ + fmap Text.pack . many . choice $ + [ satisfy isBasicChar + , parseEscaped + ] + +-- | A string in single quotes. +parseLiteralString :: Parser Text +parseLiteralString = + label "single-quoted string" $ + between (char '\'') (char '\'') $ + takeWhileP (Just "literal-char") isLiteralChar + +-- | A multiline string with three double quotes. +parseMultilineBasicString :: Parser Text +parseMultilineBasicString = + label "double-quoted multiline string" $ do + _ <- string "\"\"\"" *> optional eol + lineContinuation + Text.concat <$> manyTill (mlBasicContent <* lineContinuation) (exactly 3 '"') + where + mlBasicContent = + choice + [ Text.singleton <$> try parseEscaped + , Text.singleton <$> satisfy isBasicChar + , parseMultilineDelimiter '"' + , eol + ] + lineContinuation = many (try $ char '\\' *> hspace *> eol *> space) *> pure () + +-- | A multiline string with three single quotes. +parseMultilineLiteralString :: Parser Text +parseMultilineLiteralString = + label "single-quoted multiline string" $ do + _ <- string "'''" *> optional eol + Text.concat <$> manyTill mlLiteralContent (exactly 3 '\'') + where + mlLiteralContent = + choice + [ Text.singleton <$> satisfy isLiteralChar + , parseMultilineDelimiter '\'' + , eol + ] + +parseEscaped :: Parser Char +parseEscaped = char '\\' *> parseEscapedChar + where + parseEscapedChar = + choice + [ char '"' + , char '\\' + , char 'b' $> '\b' + , char 'f' $> '\f' + , char 'n' $> '\n' + , char 'r' $> '\r' + , char 't' $> '\t' + , char 'u' *> unicodeHex 4 + , char 'U' *> unicodeHex 8 + ] + + unicodeHex n = do + code <- readHex . Text.pack <$> count n hexDigitChar + guard $ isUnicodeScalar code + pure $ chr code + +{- | +Parse the multiline delimiter (" in """ quotes, or ' in ''' quotes), unless +the delimiter indicates the end of the multiline string. + +i.e. parse 1 or 2 delimiters, or 4 or 5, which is 1 or 2 delimiters at the +end of a multiline string (then backtrack 3 to mark the end). +-} +parseMultilineDelimiter :: Char -> Parser Text +parseMultilineDelimiter delim = + choice + [ exactly 1 delim + , exactly 2 delim + , do + _ <- lookAhead (exactly 4 delim) + Text.pack <$> count 1 (char delim) + , do + _ <- lookAhead (exactly 5 delim) + Text.pack <$> count 2 (char delim) + ] + +isBasicChar :: Char -> Bool +isBasicChar c = + case c of + ' ' -> True + '\t' -> True + _ | 0x21 <= code && code <= 0x7E -> c /= '"' && c /= '\\' + _ | isNonAscii c -> True + _ -> False + where + code = ord c + +isLiteralChar :: Char -> Bool +isLiteralChar c = + case c of + ' ' -> True + '\t' -> True + _ | 0x21 <= code && code <= 0x7E -> c /= '\'' + _ | isNonAscii c -> True + _ -> False + where + code = ord c + +parseOffsetDateTime :: Parser (LocalTime, TimeZone) +parseOffsetDateTime = (,) <$> parseLocalDateTime <*> parseTimezone + where + parseTimezone = + choice + [ char' 'Z' $> Time.utc + , do + applySign <- parseSign + h <- parseHours + _ <- char ':' + m <- parseMinutes + return $ Time.minutesToTimeZone $ applySign $ h * 60 + m + ] + +parseLocalDateTime :: Parser LocalTime +parseLocalDateTime = do + d <- parseLocalDate + _ <- char' 'T' <|> char ' ' + t <- parseLocalTime + return $ Time.LocalTime d t + +parseLocalDate :: Parser Day +parseLocalDate = do + y <- parseDecDigits 4 + _ <- char '-' + m <- parseDecDigits 2 + _ <- char '-' + d <- parseDecDigits 2 + maybe empty return $ Time.fromGregorianValid y m d + +parseLocalTime :: Parser TimeOfDay +parseLocalTime = do + h <- parseHours + _ <- char ':' + m <- parseMinutes + _ <- char ':' + sInt <- parseSeconds + sFracRaw <- optional $ fmap Text.pack $ char '.' >> some digitChar + let sFrac = MkFixed $ maybe 0 readPicoDigits sFracRaw + return $ Time.TimeOfDay h m (fromIntegral sInt + sFrac) + where + readPicoDigits s = readDec $ Text.take 12 (s <> Text.replicate 12 "0") + +parseHours :: Parser Int +parseHours = do + h <- parseDecDigits 2 + guard $ 0 <= h && h < 24 + return h + +parseMinutes :: Parser Int +parseMinutes = do + m <- parseDecDigits 2 + guard $ 0 <= m && m < 60 + return m + +parseSeconds :: Parser Int +parseSeconds = do + s <- parseDecDigits 2 + guard $ 0 <= s && s <= 60 -- include 60 for leap seconds + return s + +parseFloat :: Parser Double +parseFloat = do + applySign <- parseSign + num <- + choice + [ try normalFloat + , try $ string "inf" $> inf + , try $ string "nan" $> nan + ] + pure $ applySign num + where + normalFloat = do + intPart <- parseDecIntRaw + (fracPart, expPart) <- + choice + [ try $ (,) <$> pure "" <*> parseExp + , (,) <$> parseFrac <*> optionalOr "" parseExp + ] + pure $ readFloat $ intPart <> fracPart <> expPart + + parseExp = + fmap Text.concat . sequence $ + [ string' "e" + , parseSignRaw + , parseNumRaw digitChar digitChar + ] + parseFrac = + fmap Text.concat . sequence $ + [ string "." + , parseNumRaw digitChar digitChar + ] + + inf = read "Infinity" + nan = read "NaN" + +parseInteger :: Parser Integer +parseInteger = + choice + [ try parseBinInt + , try parseOctInt + , try parseHexInt + , parseSignedDecInt + ] + where + parseSignedDecInt = do + applySign <- parseSign + num <- readDec <$> parseDecIntRaw + pure $ applySign num + parseHexInt = + parsePrefixedInt readHex "0x" hexDigitChar + parseOctInt = + parsePrefixedInt readOct "0o" octDigitChar + parseBinInt = + parsePrefixedInt readBin "0b" binDigitChar + + parsePrefixedInt readInt prefix parseDigit = do + _ <- string prefix + readInt <$> parseNumRaw parseDigit parseDigit + +parseBoolean :: Parser Bool +parseBoolean = + choice + [ True <$ string "true" + , False <$ string "false" + ] + +{--- Normalize into Value ---} + +-- | An annotated, normalized Value +type AnnValue = GenericValue Map Text TableMeta ArrayMeta + +type AnnTable = Map Text AnnValue + +unannotateTable :: AnnTable -> Table +unannotateTable = fmap unannotateValue + +unannotateValue :: AnnValue -> Value +unannotateValue = fromGenericValue unannotateTable + +data TableType + = -- | An inline table, e.g. "a.b" in: + -- + -- @ + -- a.b = { c = 1 } + -- @ + InlineTable + | -- | A table created implicitly from a nested key, e.g. "a" in: + -- + -- @ + -- a.b = 1 + -- @ + ImplicitKey + | -- | An explicitly named section, e.g. "a.b.c" and "a.b" but not "a" in: + -- + -- @ + -- [a.b.c] + -- [a.b] + -- @ + ExplicitSection + | -- | An implicitly created section, e.g. "a" in: + -- + -- @ + -- [a.b] + -- @ + -- + -- Can later be converted into an explicit section + ImplicitSection + deriving (Eq) + +data TableMeta = TableMeta + { tableType :: TableType + } + +data ArrayMeta = ArrayMeta + { isStaticArray :: Bool + } + +newtype NormalizeM a = NormalizeM + { runNormalizeM :: Either NormalizeError a + } + +instance Functor NormalizeM where + fmap f = NormalizeM . fmap f . runNormalizeM +instance Applicative NormalizeM where + pure = NormalizeM . pure + NormalizeM f <*> NormalizeM x = NormalizeM (f <*> x) +instance Monad NormalizeM where + m >>= f = NormalizeM $ runNormalizeM . f =<< runNormalizeM m + +normalizeError :: NormalizeError -> NormalizeM a +normalizeError = NormalizeM . Left + +normalize :: TOMLDoc -> Either TOMLError Table +normalize = bimap NormalizeError unannotateTable . runNormalizeM . normalize' + +normalize' :: TOMLDoc -> NormalizeM AnnTable +normalize' TOMLDoc{..} = do + root <- flattenTable rootTable + foldlM mergeTableSection root subTables + where + mergeTableSection :: AnnTable -> TableSection -> NormalizeM AnnTable + mergeTableSection baseTable TableSection{..} = do + case tableSectionHeader of + SectionTable key -> + mergeTableSectionTable key tableSectionTable baseTable + SectionTableArray key -> + mergeTableSectionArray key tableSectionTable baseTable + +mergeTableSectionTable :: Key -> RawTable -> AnnTable -> NormalizeM AnnTable +mergeTableSectionTable sectionKey table baseTable = + setValueAtPath valueAtPathOptions sectionKey baseTable $ \mVal -> do + tableToExtend <- + case mVal of + -- if a value doesn't already exist, initialize an empty Map + Nothing -> pure Map.empty + -- if a Table already exists at the path ... + Just existingValue@(GenericTable meta existingTable) -> + case tableType meta of + -- ... and is an inline table, error + InlineTable -> duplicateKeyError existingValue + -- ... and was created as a nested key elsewhere, error + ImplicitKey -> extendTableError + -- ... and was created as a Table section explicitly defined elsewhere, error + ExplicitSection -> duplicateSectionError + -- ... otherwise, return the existing table + _ -> pure existingTable + -- if some other Value already exists at the path, error + Just existingValue -> duplicateKeyError existingValue + + mergedTable <- + mergeRawTable + MergeOptions{recurseImplicitSections = False} + tableToExtend + table + + let newTableMeta = TableMeta{tableType = ExplicitSection} + pure $ GenericTable newTableMeta mergedTable + where + valueAtPathOptions = + ValueAtPathOptions + { shouldRecurse = \case + InlineTable -> False + ImplicitKey -> False + ExplicitSection -> True + ImplicitSection -> True + , implicitType = ImplicitSection + , makeMidPathNotTableError = nonTableInNestedKeyError sectionKey table + } + duplicateKeyError existingValue = + normalizeError + DuplicateKeyError + { _path = sectionKey + , _existingValue = unannotateValue existingValue + , _valueToSet = Table $ rawTableToApproxTable table + } + extendTableError = + normalizeError + ExtendTableError + { _path = sectionKey + , _originalKey = sectionKey + } + duplicateSectionError = + normalizeError + DuplicateSectionError + { _sectionKey = sectionKey + } + +mergeTableSectionArray :: Key -> RawTable -> AnnTable -> NormalizeM AnnTable +mergeTableSectionArray sectionKey table baseTable = do + setValueAtPath valueAtPathOptions sectionKey baseTable $ \mVal -> do + (meta, currArray) <- + case mVal of + -- if nothing exists, initialize an empty array + Nothing -> do + let meta = ArrayMeta{isStaticArray = False} + pure (meta, []) + -- if an array exists, insert table to the end of the array + Just (GenericArray meta existingArray) + | not (isStaticArray meta) -> + pure (meta, existingArray) + -- otherwise, error + Just existingValue -> + normalizeError + ImplicitArrayForDefinedKeyError + { _path = sectionKey + , _existingValue = unannotateValue existingValue + , _tableSection = rawTableToApproxTable table + } + + let newTableMeta = TableMeta{tableType = ExplicitSection} + newTable <- GenericTable newTableMeta <$> flattenTable table + pure $ GenericArray meta $ currArray <> [newTable] + where + valueAtPathOptions = + ValueAtPathOptions + { shouldRecurse = \case + InlineTable -> False + ImplicitKey -> False + ExplicitSection -> True + ImplicitSection -> True + , implicitType = ImplicitSection + , makeMidPathNotTableError = \history existingValue -> + NonTableInNestedImplicitArrayError + { _path = history + , _existingValue = unannotateValue existingValue + , _sectionKey = sectionKey + , _tableSection = rawTableToApproxTable table + } + } + +flattenTable :: RawTable -> NormalizeM AnnTable +flattenTable = + mergeRawTable + MergeOptions{recurseImplicitSections = True} + Map.empty + +data MergeOptions = MergeOptions + { recurseImplicitSections :: Bool + } + +mergeRawTable :: MergeOptions -> AnnTable -> RawTable -> NormalizeM AnnTable +mergeRawTable MergeOptions{..} baseTable table = foldlM insertRawValue baseTable (unLookupMap table) + where + insertRawValue accTable (key, rawValue) = do + let valueAtPathOptions = + ValueAtPathOptions + { shouldRecurse = \case + InlineTable -> False + ImplicitKey -> True + ExplicitSection -> True + ImplicitSection -> recurseImplicitSections + , implicitType = ImplicitKey + , makeMidPathNotTableError = nonTableInNestedKeyError key table + } + setValueAtPath valueAtPathOptions key accTable $ \case + Nothing -> fromRawValue rawValue + Just existingValue -> + normalizeError + DuplicateKeyError + { _path = key + , _existingValue = unannotateValue existingValue + , _valueToSet = rawValueToApproxValue rawValue + } + + fromRawValue = \case + GenericTable _ rawTable -> do + let meta = TableMeta{tableType = InlineTable} + GenericTable meta <$> flattenTable rawTable + GenericArray _ rawValues -> do + let meta = ArrayMeta{isStaticArray = True} + GenericArray meta <$> mapM fromRawValue rawValues + GenericString x -> pure (GenericString x) + GenericInteger x -> pure (GenericInteger x) + GenericFloat x -> pure (GenericFloat x) + GenericBoolean x -> pure (GenericBoolean x) + GenericOffsetDateTime x -> pure (GenericOffsetDateTime x) + GenericLocalDateTime x -> pure (GenericLocalDateTime x) + GenericLocalDate x -> pure (GenericLocalDate x) + GenericLocalTime x -> pure (GenericLocalTime x) + +data ValueAtPathOptions = ValueAtPathOptions + { shouldRecurse :: TableType -> Bool + , implicitType :: TableType + , makeMidPathNotTableError :: Key -> AnnValue -> NormalizeError + } + +-- | Implementation for makeMidPathNotTableError for NonTableInNestedKeyError +nonTableInNestedKeyError :: Key -> RawTable -> (Key -> AnnValue -> NormalizeError) +nonTableInNestedKeyError key table = \history existingValue -> + NonTableInNestedKeyError + { _path = history + , _existingValue = unannotateValue existingValue + , _originalKey = key + , _originalValue = Table $ rawTableToApproxTable table + } + +setValueAtPath :: + ValueAtPathOptions -> + Key -> + AnnTable -> + (Maybe AnnValue -> NormalizeM AnnValue) -> + NormalizeM AnnTable +setValueAtPath ValueAtPathOptions{..} fullKey initialTable f = do + (mValue, setValue) <- getPathLens doRecurse fullKey initialTable + setValue <$> f mValue + where + doRecurse history = \case + -- If nothing exists, recurse into a new empty Map + Nothing -> do + let newTableMeta = TableMeta{tableType = implicitType} + pure (Map.empty, GenericTable newTableMeta) + -- If a Table exists, recurse into it + Just (GenericTable meta subTable) -> do + unless (shouldRecurse $ tableType meta) $ + normalizeError + ExtendTableError + { _path = history + , _originalKey = fullKey + } + pure (subTable, GenericTable meta) + -- If an Array exists, recurse into the last Table, per spec: + -- Any reference to an array of tables points to the + -- most recently defined table element of the array. + Just (GenericArray aMeta vs) + | Just vs' <- NonEmpty.nonEmpty vs + , GenericTable tMeta subTable <- NonEmpty.last vs' -> do + when (isStaticArray aMeta) $ + normalizeError $ + ExtendTableInInlineArrayError history fullKey + pure (subTable, GenericArray aMeta . snoc (NonEmpty.init vs') . GenericTable tMeta) + -- If something else exists, throw error with makeMidPathNotTableError + Just v -> normalizeError $ makeMidPathNotTableError history v + + snoc xs x = xs <> [x] + +-- | Convert a RawTable into a Table, for use in errors + debugging. +rawTableToApproxTable :: RawTable -> Table +rawTableToApproxTable = + Map.fromList + . map (\(k, v) -> (Text.intercalate "." $ NonEmpty.toList k, rawValueToApproxValue v)) + . unLookupMap + +-- | Convert a RawValue into a Value, for use in errors + debugging. +rawValueToApproxValue :: RawValue -> Value +rawValueToApproxValue = fromGenericValue rawTableToApproxTable + +{--- Parser Helpers ---} + +-- | https://github.com/toml-lang/toml/blob/1.0.0/toml.abnf#L38 +isNonAscii :: Char -> Bool +isNonAscii c = (0x80 <= code && code <= 0xD7FF) || (0xE000 <= code && code <= 0x10FFFF) + where + code = ord c + +-- | https://unicode.org/glossary/#unicode_scalar_value +isUnicodeScalar :: Int -> Bool +isUnicodeScalar code = (0x0 <= code && code <= 0xD7FF) || (0xE000 <= code && code <= 0x10FFFF) + +-- | Returns "", "-", or "+" +parseSignRaw :: Parser Text +parseSignRaw = optionalOr "" (string "-" <|> string "+") + +parseSign :: Num a => Parser (a -> a) +parseSign = do + sign <- parseSignRaw + pure $ if sign == "-" then negate else id + +parseDecIntRaw :: Parser Text +parseDecIntRaw = + choice + [ try $ parseNumRaw (satisfy $ \c -> isDigit c && c /= '0') digitChar + , Text.singleton <$> digitChar + ] + +parseDecDigits :: (Show a, Num a, Eq a) => Int -> Parser a +parseDecDigits n = readDec . Text.pack <$> count n digitChar + +parseNumRaw :: Parser Char -> Parser Char -> Parser Text +parseNumRaw parseLeadingDigit parseDigit = do + leading <- parseLeadingDigit + rest <- many $ optional (char '_') *> parseDigit + pure $ Text.pack $ leading : rest + +{--- Parser Utilities ---} + +hsymbol :: Text -> Parser () +hsymbol s = hspace >> string s >> hspace >> pure () + +-- | Parse trailing whitespace/trailing comments + newline +endOfLine :: Parser () +endOfLine = L.space hspace1 skipComments empty >> (void eol <|> eof) >> pure () + +-- | Parse spaces, newlines, and comments +emptyLines :: Parser () +emptyLines = L.space space1 skipComments empty + +skipComments :: Parser () +skipComments = do + _ <- string "#" + void . many $ do + c <- satisfy (/= '\n') + let code = ord c + case c of + '\r' -> void $ lookAhead (char '\n') + _ + | (0x00 <= code && code <= 0x08) || (0x0A <= code && code <= 0x1F) || code == 0x7F -> + fail $ "Comment has invalid character: \\" <> show code + _ -> pure () + +space, space1 :: Parser () +space = void $ many parseSpace +space1 = void $ some parseSpace + +-- | TOML does not support bare '\r' without '\n'. +parseSpace :: Parser () +parseSpace = void (satisfy (\c -> isSpace c && c /= '\r')) <|> void (string "\r\n") + +#if !MIN_VERSION_megaparsec(9,0,0) +hspace :: Parser () +hspace = void $ takeWhileP (Just "white space") isHSpace + +hspace1 :: Parser () +hspace1 = void $ takeWhile1P (Just "white space") isHSpace + +isHSpace :: Char -> Bool +isHSpace x = isSpace x && x /= '\n' && x /= '\r' +#endif + +optionalOr :: a -> Parser a -> Parser a +optionalOr def = fmap (fromMaybe def) . optional + +exactly :: Int -> Char -> Parser Text +exactly n c = try $ Text.pack <$> count n (char c) <* notFollowedBy (char c) + +{--- Read Helpers ---} + +-- | Assumes string satisfies @all isDigit@. +readFloat :: (Show a, RealFrac a) => Text -> a +readFloat = runReader Numeric.readFloat + +-- | Assumes string satisfies @all isDigit@. +readDec :: (Show a, Num a, Eq a) => Text -> a +readDec = runReader Numeric.readDec + +-- | Assumes string satisfies @all isHexDigit@. +readHex :: (Show a, Num a, Eq a) => Text -> a +readHex = runReader Numeric.readHex + +-- | Assumes string satisfies @all isOctDigit@. +readOct :: (Show a, Num a, Eq a) => Text -> a +readOct = runReader Numeric.readOct + +-- | Assumes string satisfies @all (`elem` "01")@. +readBin :: (Show a, Num a) => Text -> a +readBin = foldl' go 0 . Text.unpack + where + go acc x = + let digit + | x == '0' = 0 + | x == '1' = 1 + | otherwise = error $ "readBin got unexpected digit: " <> show x + in 2 * acc + digit + +runReader :: Show a => ReadS a -> Text -> a +runReader rdr digits = + case rdr $ Text.unpack digits of + [(x, "")] -> x + result -> error $ "Unexpectedly unable to parse " <> show digits <> ": " <> show result diff --git a/src/TOML/Utils/Map.hs b/src/TOML/Utils/Map.hs new file mode 100644 --- /dev/null +++ b/src/TOML/Utils/Map.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE RecordWildCards #-} + +module TOML.Utils.Map ( + getPathLens, + getPath, +) where + +import Data.Foldable (foldlM) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map + +import TOML.Utils.NonEmpty (zipHistory) + +{- | +For a non-empty list of keys, iterate through the given 'Map' and return +the possibly missing value at the path and a function to set the value at +the given path and return the modified input 'Map'. + +@ +let obj = undefined -- { "a": { "b": { "c": 1 } } } +(mValue, setValue) <- getPathLens doRecurse ["a", "b", "c"] obj + +print mValue -- Just 1 +print (setValue 2) -- { "a": { "b": { "c": 2 } } } +@ +-} +getPathLens :: + (Monad m, Ord k) => + -- | How to get and set the next Map from the possibly missing value. + -- Passes in the path taken so far. + (NonEmpty k -> Maybe v -> m (Map k v, Map k v -> v)) -> + NonEmpty k -> + Map k v -> + m (Maybe v, v -> Map k v) +getPathLens = + getPathLensWith (\setVal fromMap -> mkSetter (setVal . fromMap)) (mkSetter id) + where + mkSetter setMap k kvs = \v -> setMap $ Map.insert k v kvs + +-- | Same as 'getPathLens', except without the setter. +getPath :: + (Monad m, Ord k) => + (NonEmpty k -> Maybe v -> m (Map k v)) -> + NonEmpty k -> + Map k v -> + m (Maybe v) +getPath doRecurse path originalMap = + fst <$> getPathLensWith (\_ _ _ _ -> ()) (\_ _ -> ()) doRecurse' path originalMap + where + doRecurse' history mVal = do + x <- doRecurse history mVal + pure (x, ()) + +getPathLensWith :: + (Monad m, Ord k) => + (b -> a -> (k -> Map k v -> b)) -> + (k -> Map k v -> b) -> + (NonEmpty k -> Maybe v -> m (Map k v, a)) -> + NonEmpty k -> + Map k v -> + m (Maybe v, b) +getPathLensWith mkAnn mkFirstAnn doRecurse path originalMap = + let (_, k) :| ks = zipHistory path + in foldlM go (buildLens k mkFirstAnn originalMap) ks + where + go (mVal, b) (history, k) = do + (nextMap, a) <- doRecurse history mVal + pure $ buildLens k (mkAnn b a) nextMap + + buildLens k mkAnn' kvs = (Map.lookup k kvs, mkAnn' k kvs) diff --git a/src/TOML/Utils/NonEmpty.hs b/src/TOML/Utils/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/src/TOML/Utils/NonEmpty.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE TupleSections #-} + +module TOML.Utils.NonEmpty ( + zipHistory, +) where + +import Data.List (scanl') +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NonEmpty + +{- | +Annotates each element with the history of all past elements. + +>>> zipHistory ["a", "b", "c"] +[(["a"], "a"), (["a", "b"], "b"), (["a", "b", "c"], "c")] +-} +zipHistory :: NonEmpty a -> NonEmpty (NonEmpty a, a) +zipHistory (a :| as) = + NonEmpty.fromList $ + scanl' + (\(history, _) x -> (append history x, x)) + (singleton a, a) + as + where + append xs x = xs <> singleton x + -- NonEmpty.singleton was added in base 4.15 + singleton x = x :| [] diff --git a/src/TOML/Value.hs b/src/TOML/Value.hs new file mode 100644 --- /dev/null +++ b/src/TOML/Value.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module TOML.Value ( + Value (..), + renderValue, + Table, +) where + +import Control.DeepSeq (NFData) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time (Day, LocalTime, TimeOfDay, TimeZone) +import GHC.Generics (Generic) + +type Table = Map Text Value + +data Value + = Table Table + | Array [Value] + | String Text + | Integer Integer + | Float Double + | Boolean Bool + | OffsetDateTime (LocalTime, TimeZone) + | LocalDateTime LocalTime + | LocalDate Day + | LocalTime TimeOfDay + deriving (Show, Eq, Generic, NFData) + +-- | Render a Value in pseudo-JSON format. +renderValue :: Value -> Text +renderValue = \case + Table kvs -> "{" <> Text.intercalate ", " (map renderKeyValue $ Map.toList kvs) <> "}" + Array vs -> "[" <> Text.intercalate ", " (map renderValue vs) <> "]" + String s -> showT s + Integer x -> showT x + Float x -> showT x + Boolean b -> if b then "true" else "false" + OffsetDateTime x -> showT x + LocalDateTime x -> showT x + LocalDate x -> showT x + LocalTime x -> showT x + where + renderKeyValue (k, v) = showT k <> ": " <> renderValue v + + showT :: Show a => a -> Text + showT = Text.pack . show diff --git a/test/tasty/Main.hs b/test/tasty/Main.hs new file mode 100644 --- /dev/null +++ b/test/tasty/Main.hs @@ -0,0 +1,16 @@ +import Test.Tasty + +import qualified TOML.DecodeTest +import qualified TOML.ErrorTest +import qualified TOML.Utils.MapTest +import qualified TOML.Utils.NonEmptyTest + +main :: IO () +main = + defaultMain $ + testGroup "toml-reader" $ + [ TOML.Utils.MapTest.test + , TOML.Utils.NonEmptyTest.test + , TOML.ErrorTest.test + , TOML.DecodeTest.test + ] diff --git a/test/tasty/TOML/DecodeTest.hs b/test/tasty/TOML/DecodeTest.hs new file mode 100644 --- /dev/null +++ b/test/tasty/TOML/DecodeTest.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module TOML.DecodeTest (test) where + +import Data.Int (Int8) +import qualified Data.Text as Text +import qualified Data.Time as Time +import Numeric.Natural (Natural) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit + +import TOML.Decode ( + DecodeTOML, + Decoder, + decodeWith, + getArrayOf, + getField, + getFieldOpt, + getFieldOptWith, + getFieldWith, + getFields, + getFieldsOpt, + getFieldsOptWith, + getFieldsWith, + tomlDecoder, + ) +import TOML.Error ( + ContextItem (..), + DecodeError (..), + TOMLError (..), + ) +import TOML.Value (Value (..)) + +test :: TestTree +test = + testGroup "TOML.Decode" . concat $ + [ getFieldTests + , [decoderInstanceTests] + ] + +getFieldTests :: [TestTree] +getFieldTests = + [ testGroup + "getField" + [ testCase "decodes field" $ + decodeWith (getField @Int "a") "a = 1" @?= Right 1 + , testCase "errors if field does not exist" $ + decodeWith (getField @Int "a") "" @?= Left (DecodeError [Key "a"] MissingField) + , testCase "errors if field is the wrong type" $ + decodeWith (getField @Int "a") "a = true" @?= Left (DecodeError [Key "a"] (TypeMismatch (Boolean True))) + ] + , testGroup + "getFieldOpt" + [ testCase "decodes field" $ + decodeWith (getFieldOpt @Int "a") "a = 1" @?= Right (Just 1) + , testCase "returns Nothing if field does not exist" $ + decodeWith (getFieldOpt @Int "a") "" @?= Right Nothing + , testCase "errors if field is the wrong type" $ + decodeWith (getFieldOpt @Int "a") "a = true" @?= Left (DecodeError [Key "a"] (TypeMismatch (Boolean True))) + ] + , testGroup + "getFieldWith" + [ testCase "decodes field" $ + decodeWith (getFieldWith @Int succDecoder "a") "a = 1" @?= Right 2 + , testCase "errors if field does not exist" $ + decodeWith (getFieldWith @Int succDecoder "a") "" @?= Left (DecodeError [Key "a"] MissingField) + , testCase "errors if field is the wrong type" $ + decodeWith (getFieldWith @Int succDecoder "a") "a = true" @?= Left (DecodeError [Key "a"] (TypeMismatch (Boolean True))) + ] + , testGroup + "getFieldOptWith" + [ testCase "decodes field" $ + decodeWith (getFieldOptWith @Int succDecoder "a") "a = 1" @?= Right (Just 2) + , testCase "returns Nothing if field does not exist" $ + decodeWith (getFieldOptWith @Int succDecoder "a") "" @?= Right Nothing + , testCase "errors if field is the wrong type" $ + decodeWith (getFieldOptWith @Int succDecoder "a") "a = true" @?= Left (DecodeError [Key "a"] (TypeMismatch (Boolean True))) + ] + , testGroup + "getFields" + [ testCase "decodes field" $ + decodeWith (getFields @Int ["a", "b"]) "a = { b = 1 }" @?= Right 1 + , testCase "errors if field does not exist" $ + decodeWith (getFields @Int ["a", "b"]) "a = {}" @?= Left (DecodeError [Key "a", Key "b"] MissingField) + , testCase "errors if intermediate field does not exist" $ + decodeWith (getFields @Int ["a", "b", "c"]) "a = {}" @?= Left (DecodeError [Key "a", Key "b"] MissingField) + , testCase "errors if field is the wrong type" $ + decodeWith (getFields @Int ["a", "b"]) "a = { b = true }" @?= Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) + , testCase "errors if intermediate field is the wrong type" $ + decodeWith (getFields @Int ["a", "b", "c"]) "a = { b = true }" @?= Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) + ] + , testGroup + "getFieldsOpt" + [ testCase "decodes field" $ + decodeWith (getFieldsOpt @Int ["a", "b"]) "a = { b = 1 }" @?= Right (Just 1) + , testCase "returns Nothing if field does not exist" $ + decodeWith (getFieldsOpt @Int ["a", "b"]) "a = {}" @?= Right Nothing + , testCase "returns Nothing if intermediate field does not exist" $ + decodeWith (getFieldsOpt @Int ["a", "b", "c"]) "a = {}" @?= Right Nothing + , testCase "errors if field is the wrong type" $ + decodeWith (getFieldsOpt @Int ["a", "b"]) "a = { b = true }" @?= Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) + , testCase "errors if intermediate field is the wrong type" $ + decodeWith (getFieldsOpt @Int ["a", "b", "c"]) "a = { b = true }" @?= Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) + ] + , testGroup + "getFieldsWith" + [ testCase "decodes field" $ + decodeWith (getFieldsWith @Int succDecoder ["a", "b"]) "a = { b = 1 }" @?= Right 2 + , testCase "errors if field does not exist" $ + decodeWith (getFieldsWith @Int succDecoder ["a", "b"]) "a = {}" @?= Left (DecodeError [Key "a", Key "b"] MissingField) + , testCase "errors if intermediate field does not exist" $ + decodeWith (getFieldsWith @Int succDecoder ["a", "b", "c"]) "a = {}" @?= Left (DecodeError [Key "a", Key "b"] MissingField) + , testCase "errors if field is the wrong type" $ + decodeWith (getFieldsWith @Int succDecoder ["a", "b"]) "a = { b = true }" @?= Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) + , testCase "errors if intermediate field is the wrong type" $ + decodeWith (getFieldsWith @Int succDecoder ["a", "b", "c"]) "a = { b = true }" @?= Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) + ] + , testGroup + "getFieldsOptWith" + [ testCase "decodes field" $ + decodeWith (getFieldsOptWith @Int succDecoder ["a", "b"]) "a = { b = 1 }" @?= Right (Just 2) + , testCase "returns Nothing if field does not exist" $ + decodeWith (getFieldsOptWith @Int succDecoder ["a", "b"]) "a = {}" @?= Right Nothing + , testCase "returns Nothing if intermediate field does not exist" $ + decodeWith (getFieldsOptWith @Int succDecoder ["a", "b", "c"]) "a = {}" @?= Right Nothing + , testCase "errors if field is the wrong type" $ + decodeWith (getFieldsOptWith @Int succDecoder ["a", "b"]) "a = { b = true }" @?= Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) + , testCase "errors if intermediate field is the wrong type" $ + decodeWith (getFieldsOptWith @Int succDecoder ["a", "b", "c"]) "a = { b = true }" @?= Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) + ] + , testGroup + "getArrayOf" + [ testCase "decodes field" $ + decodeWith (getFieldWith (getArrayOf @Int succDecoder) "a") "a = [1, 2]" @?= Right [2, 3] + , testCase "errors if value is the wrong type" $ + decodeWith (getFieldWith (getArrayOf @Int succDecoder) "a") "a = true" @?= Left (DecodeError [Key "a"] (TypeMismatch (Boolean True))) + , testCase "errors if value in array is the wrong type" $ + decodeWith (getFieldWith (getArrayOf @Int succDecoder) "a") "a = [1, 2, true]" @?= Left (DecodeError [Key "a", Index 2] (TypeMismatch (Boolean True))) + ] + , testCase "Decoding multiple fields at once" $ do + let decoder :: Decoder (Int, Maybe String, Maybe Int, Bool) + decoder = + (,,,) + <$> getField "a" + <*> getFieldOpt "b" + <*> getFieldOpt "missing" + <*> getFields ["c", "d"] + doc = + Text.unlines + [ "a = 1" + , "b = \"hello\"" + , "[c]" + , "d = true" + ] + decodeWith decoder doc @?= Right (1, Just "hello", Nothing, True) + ] + where + succDecoder :: (Enum a, DecodeTOML a) => Decoder a + succDecoder = succ <$> tomlDecoder + +decoderInstanceTests :: TestTree +decoderInstanceTests = + testGroup + "DecodeTOML instances" + [ testCase "Bool" $ do + decodeWith (getField @Bool "a") "a = true" @?= Right True + decodeWith (getField @Bool "a") "a = false" @?= Right False + , testCase "String" $ do + decodeWith (getField @String "a") "a = 'z'" @?= Right "z" + decodeWith (getField @String "a") "a = 'asdf'" @?= Right "asdf" + , testCase "Char" $ + decodeWith (getField @Char "a") "a = 'z'" @?= Right 'z' + , testCase "Char errors with multi-character string" $ + assertInvalidValue "Expected single character string" $ + decodeWith (getField @Char "a") "a = 'asdf'" + , testCase "Int" $ do + decodeWith (getField @Int "a") "a = 42" @?= Right 42 + decodeWith (getField @Int "a") "a = -13" @?= Right (-13) + , testCase "Natural" $ + decodeWith (getField @Natural "a") "a = 42" @?= Right 42 + , testCase "Natural errors with negative numbers" $ + assertInvalidValue "Got negative number" $ + decodeWith (getField @Natural "a") "a = -13" + , testCase "Int8" $ do + decodeWith (getField @Int8 "a") "a = 127" @?= Right 127 + decodeWith (getField @Int8 "a") "a = 42" @?= Right 42 + decodeWith (getField @Int8 "a") "a = -13" @?= Right (-13) + decodeWith (getField @Int8 "a") "a = -128" @?= Right (-128) + , testCase "Int8 errors with underflow/overflow" $ do + assertInvalidValue "Overflow" $ + decodeWith (getField @Int8 "a") "a = 128" + assertInvalidValue "Underflow" $ + decodeWith (getField @Int8 "a") "a = -129" + , testCase "Double" $ do + decodeWith (getField @Double "a") "a = 42.0" @?= Right 42.0 + decodeWith (getField @Double "a") "a = -13.2" @?= Right (-13.2) + , testCase "Array" $ + decodeWith (getField @[Int] "a") "a = [1, 2]" @?= Right [1, 2] + , testCase "UTCTime" $ + decodeWith (getField @Time.UTCTime "a") "a = 2020-01-31T00:00:01-01:00" + @?= Right (Time.UTCTime (Time.fromGregorian 2020 1 31) 3601) + , testCase "ZonedTime" $ + -- ZonedTime does not have an Eq instance + case decodeWith (getField @Time.ZonedTime "a") "a = 2020-01-31T00:00:01-01:00" of + Right (Time.ZonedTime (Time.LocalTime day time) (Time.TimeZone (-60) _ _)) + | day == Time.fromGregorian 2020 1 31 + , time == Time.TimeOfDay 0 0 1 -> + return () + result -> unexpectedResult result + , testCase "LocalTime" $ + decodeWith (getField @Time.LocalTime "a") "a = 2020-01-31T00:00:01" + @?= Right (Time.LocalTime (Time.fromGregorian 2020 1 31) (Time.TimeOfDay 0 0 1)) + , testCase "Day" $ + decodeWith (getField @Time.Day "a") "a = 2020-01-31" + @?= Right (Time.fromGregorian 2020 1 31) + , testCase "TimeOfDay" $ + decodeWith (getField @Time.TimeOfDay "a") "a = 07:32:59.1" + @?= Right (Time.TimeOfDay 7 32 59.1) + , testCase "Maybe" $ + decodeWith (getField @(Maybe Int) "a") "a = 1" @?= Right (Just 1) + , testCase "Either" $ do + decodeWith (getField @(Either Int Double) "a") "a = 1" @?= Right (Left 1) + decodeWith (getField @(Either Int Double) "a") "a = 1.0" @?= Right (Right 1) + , testCase "()" $ + decodeWith (getField @() "a") "a = []" @?= Right () + , testCase "(a, b)" $ + decodeWith (getField @(Int, Double) "a") "a = [1, 2.5]" @?= Right (1, 2.5) + , testCase "Tuples show errors with index" $ + case decodeWith (getField @(Int, Double) "a") "a = [1, true]" of + Left (DecodeError [Key "a", Index 1] _) -> return () + result -> unexpectedResult result + ] + where + assertInvalidValue expected result = + case result of + Left (DecodeError _ (InvalidValue actual _)) -> actual @?= expected + _ -> unexpectedResult result + + unexpectedResult result = assertFailure $ "Got unexpected result: " <> show result diff --git a/test/tasty/TOML/ErrorTest.hs b/test/tasty/TOML/ErrorTest.hs new file mode 100644 --- /dev/null +++ b/test/tasty/TOML/ErrorTest.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TOML.ErrorTest (test) where + +import Control.Monad (unless) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text +import qualified Data.Text.Lazy as TextL +import qualified Data.Text.Lazy.Encoding as TextL +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Golden +import Test.Tasty.HUnit + +import TOML.Error ( + ContextItem (..), + DecodeError (..), + NormalizeError (..), + TOMLError (..), + renderTOMLError, + ) +import TOML.Value (Value (..)) + +test :: TestTree +test = + testGroup + "TOML.Error" + [ renderTOMLErrorTests + ] + +renderTOMLErrorTests :: TestTree +renderTOMLErrorTests = + testGroup + "renderTOMLError" + [ testGroup "renders errors correctly" $ + flip map allErrors $ \(label, e) -> + goldenVsString label ("test/tasty/goldens/renderTOMLError/" <> label <> ".golden") $ + pure (TextL.encodeUtf8 . TextL.fromStrict . renderTOMLError $ e) + , testCase "renders context items correctly" $ do + let msg = renderTOMLError (DecodeError [Key "a", Index 1, Key "b"] MissingField) + let expectedPrefix = "Decode error at '.a[1].b':" + unless (expectedPrefix `Text.isPrefixOf` msg) $ + assertFailure $ + "Expected message to start with prefix: " <> show expectedPrefix <> ", got: " <> Text.unpack msg + ] + where + allErrors = + [ ("ParseError", ParseError "megaparsec error") + , + ( "NormalizeError.DuplicateKeyError" + , NormalizeError + DuplicateKeyError + { _path = fullPath + , _existingValue = value1 + , _valueToSet = value2 + } + ) + , + ( "NormalizeError.DuplicateSectionError" + , NormalizeError + DuplicateSectionError + { _sectionKey = fullPath + } + ) + , + ( "NormalizeError.ExtendTableError" + , NormalizeError + ExtendTableError + { _path = subPath + , _originalKey = fullPath + } + ) + , + ( "NormalizeError.ExtendTableInInlineArrayError" + , NormalizeError + ExtendTableInInlineArrayError + { _path = subPath + , _originalKey = fullPath + } + ) + , + ( "NormalizeError.ImplicitArrayForDefinedKeyError" + , NormalizeError + ImplicitArrayForDefinedKeyError + { _path = fullPath + , _existingValue = Array [value1] + , _tableSection = Map.fromList [("a", value2)] + } + ) + , + ( "NormalizeError.NonTableInNestedKeyError" + , NormalizeError + NonTableInNestedKeyError + { _path = subPath + , _existingValue = value1 + , _originalKey = fullPath + , _originalValue = value2 + } + ) + , + ( "NormalizeError.NonTableInNestedImplicitArrayError" + , NormalizeError + NonTableInNestedImplicitArrayError + { _path = subPath + , _existingValue = value1 + , _sectionKey = fullPath + , _tableSection = Map.fromList [("a", value2)] + } + ) + , ("DecodeError.MissingField", DecodeError ctx MissingField) + , ("DecodeError.InvalidValue", DecodeError ctx $ InvalidValue "bad value" value1) + , ("DecodeError.TypeMismatch", DecodeError ctx $ TypeMismatch value1) + , ("DecodeError.OtherDecodeError", DecodeError ctx $ OtherDecodeError "decode failure") + ] + fullPath = NonEmpty.fromList ["a", "b"] + subPath = NonEmpty.fromList ["a"] + value1 = Boolean True + value2 = Integer 1 + ctx = [Key "a", Key "b"] diff --git a/test/tasty/TOML/Utils/MapTest.hs b/test/tasty/TOML/Utils/MapTest.hs new file mode 100644 --- /dev/null +++ b/test/tasty/TOML/Utils/MapTest.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE LambdaCase #-} + +module TOML.Utils.MapTest (test) where + +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit + +import TOML.Utils.Map (getPath, getPathLens) + +test :: TestTree +test = + testGroup + "TOML.Utils.Map" + [ getPathLensTest + , getPathTest + ] + +data MapOrInt = Map [(String, MapOrInt)] | Int Int + deriving (Show, Eq) + +recurseMapOrInt :: + NonEmpty String -> + Maybe MapOrInt -> + Either String (Map String MapOrInt, Map String MapOrInt -> MapOrInt) +recurseMapOrInt _ = \case + Nothing -> Right (Map.empty, fromMap) + Just (Map kvs) -> Right (Map.fromList kvs, fromMap) + Just (Int x) -> Left $ "Could not recurse on: " ++ show x + where + fromMap = Map . Map.toList + +getPathLensTest :: TestTree +getPathLensTest = + testGroup + "getPathLens" + [ testCase "gets and sets value at path" $ do + let obj = Map.fromList [("a", Map [("b", Map [("c", Int 1)])])] + + Right (mValue, setValue) <- pure $ getPathLens recurseMapOrInt (NonEmpty.fromList ["a", "b", "c"]) obj + + mValue @?= Just (Int 1) + + let newVal = Map [("foo", Int 100)] + setValue newVal @?= Map.fromList [("a", Map [("b", Map [("c", newVal)])])] + ] + +getPathTest :: TestTree +getPathTest = + testGroup + "getPath" + [ testCase "gets value at path" $ do + let obj = Map.fromList [("a", Map [("b", Map [("c", Int 1)])])] + + let doRecurse history = fmap fst . recurseMapOrInt history + Right mValue <- pure $ getPath doRecurse (NonEmpty.fromList ["a", "b", "c"]) obj + + mValue @?= Just (Int 1) + ] diff --git a/test/tasty/TOML/Utils/NonEmptyTest.hs b/test/tasty/TOML/Utils/NonEmptyTest.hs new file mode 100644 --- /dev/null +++ b/test/tasty/TOML/Utils/NonEmptyTest.hs @@ -0,0 +1,31 @@ +module TOML.Utils.NonEmptyTest (test) where + +import qualified Data.List.NonEmpty as NonEmpty +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit + +import TOML.Utils.NonEmpty (zipHistory) + +test :: TestTree +test = + testGroup + "TOML.Utils.NonEmpty" + [ zipHistoryTest + ] + +zipHistoryTest :: TestTree +zipHistoryTest = + testGroup + "zipHistory" + [ testCase "should zip already-seen keys with each key" $ + zipHistory (ne ["a", "b", "c"]) + @?= ne + [ (ne ["a"], "a") + , (ne ["a", "b"], "b") + , (ne ["a", "b", "c"], "c") + ] + , testCase "works with one-element list" $ + zipHistory (ne ["a"]) @?= ne [(ne ["a"], "a")] + ] + where + ne = NonEmpty.fromList diff --git a/test/tasty/goldens/renderTOMLError/DecodeError.InvalidValue.golden b/test/tasty/goldens/renderTOMLError/DecodeError.InvalidValue.golden new file mode 100644 --- /dev/null +++ b/test/tasty/goldens/renderTOMLError/DecodeError.InvalidValue.golden @@ -0,0 +1,1 @@ +Decode error at '.a.b': Invalid value: bad value: true diff --git a/test/tasty/goldens/renderTOMLError/DecodeError.MissingField.golden b/test/tasty/goldens/renderTOMLError/DecodeError.MissingField.golden new file mode 100644 --- /dev/null +++ b/test/tasty/goldens/renderTOMLError/DecodeError.MissingField.golden @@ -0,0 +1,1 @@ +Decode error at '.a.b': Field does not exist diff --git a/test/tasty/goldens/renderTOMLError/DecodeError.OtherDecodeError.golden b/test/tasty/goldens/renderTOMLError/DecodeError.OtherDecodeError.golden new file mode 100644 --- /dev/null +++ b/test/tasty/goldens/renderTOMLError/DecodeError.OtherDecodeError.golden @@ -0,0 +1,1 @@ +Decode error at '.a.b': decode failure diff --git a/test/tasty/goldens/renderTOMLError/DecodeError.TypeMismatch.golden b/test/tasty/goldens/renderTOMLError/DecodeError.TypeMismatch.golden new file mode 100644 --- /dev/null +++ b/test/tasty/goldens/renderTOMLError/DecodeError.TypeMismatch.golden @@ -0,0 +1,1 @@ +Decode error at '.a.b': Type mismatch, got: true diff --git a/test/tasty/goldens/renderTOMLError/NormalizeError.DuplicateKeyError.golden b/test/tasty/goldens/renderTOMLError/NormalizeError.DuplicateKeyError.golden new file mode 100644 --- /dev/null +++ b/test/tasty/goldens/renderTOMLError/NormalizeError.DuplicateKeyError.golden @@ -0,0 +1,3 @@ +Could not add value to path "a.b": + Existing value: true + Value to set: 1 diff --git a/test/tasty/goldens/renderTOMLError/NormalizeError.DuplicateSectionError.golden b/test/tasty/goldens/renderTOMLError/NormalizeError.DuplicateSectionError.golden new file mode 100644 --- /dev/null +++ b/test/tasty/goldens/renderTOMLError/NormalizeError.DuplicateSectionError.golden @@ -0,0 +1,1 @@ +Found duplicate section: "a.b" diff --git a/test/tasty/goldens/renderTOMLError/NormalizeError.ExtendTableError.golden b/test/tasty/goldens/renderTOMLError/NormalizeError.ExtendTableError.golden new file mode 100644 --- /dev/null +++ b/test/tasty/goldens/renderTOMLError/NormalizeError.ExtendTableError.golden @@ -0,0 +1,2 @@ +Invalid table key: "a.b" + Table already statically defined at "a" diff --git a/test/tasty/goldens/renderTOMLError/NormalizeError.ExtendTableInInlineArrayError.golden b/test/tasty/goldens/renderTOMLError/NormalizeError.ExtendTableInInlineArrayError.golden new file mode 100644 --- /dev/null +++ b/test/tasty/goldens/renderTOMLError/NormalizeError.ExtendTableInInlineArrayError.golden @@ -0,0 +1,2 @@ +Invalid table key: "a.b" + Table defined in inline array at "a" diff --git a/test/tasty/goldens/renderTOMLError/NormalizeError.ImplicitArrayForDefinedKeyError.golden b/test/tasty/goldens/renderTOMLError/NormalizeError.ImplicitArrayForDefinedKeyError.golden new file mode 100644 --- /dev/null +++ b/test/tasty/goldens/renderTOMLError/NormalizeError.ImplicitArrayForDefinedKeyError.golden @@ -0,0 +1,3 @@ +Could not create implicit array at path "a.b": + Existing value: [true] + Array table section: {"a": 1} diff --git a/test/tasty/goldens/renderTOMLError/NormalizeError.NonTableInNestedImplicitArrayError.golden b/test/tasty/goldens/renderTOMLError/NormalizeError.NonTableInNestedImplicitArrayError.golden new file mode 100644 --- /dev/null +++ b/test/tasty/goldens/renderTOMLError/NormalizeError.NonTableInNestedImplicitArrayError.golden @@ -0,0 +1,3 @@ +Found non-Table at path "a" when initializing implicit array at path "a.b": + Existing value: true + Array table section: {"a": 1} diff --git a/test/tasty/goldens/renderTOMLError/NormalizeError.NonTableInNestedKeyError.golden b/test/tasty/goldens/renderTOMLError/NormalizeError.NonTableInNestedKeyError.golden new file mode 100644 --- /dev/null +++ b/test/tasty/goldens/renderTOMLError/NormalizeError.NonTableInNestedKeyError.golden @@ -0,0 +1,3 @@ +Found non-Table at path "a" when defining nested key "a.b": + Existing value: true + Original value: 1 diff --git a/test/tasty/goldens/renderTOMLError/ParseError.golden b/test/tasty/goldens/renderTOMLError/ParseError.golden new file mode 100644 --- /dev/null +++ b/test/tasty/goldens/renderTOMLError/ParseError.golden @@ -0,0 +1,1 @@ +megaparsec error diff --git a/test/toml-test/ValidateParser.hs b/test/toml-test/ValidateParser.hs new file mode 100644 --- /dev/null +++ b/test/toml-test/ValidateParser.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +import Data.Aeson ((.=)) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy.Char8 as Char8 +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Data.Time (ZonedTime (..)) +import qualified Data.Vector as Vector +import System.Directory (findExecutable) +import System.Environment (getArgs, getExecutablePath) +import System.Exit (exitFailure) +import System.IO (stderr) +import System.Process (callProcess) + +import TOML (Value (..), renderTOMLError) +import TOML.Parser (parseTOML) + +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.Key as Key +import Data.Aeson.KeyMap (KeyMap) +import qualified Data.Aeson.KeyMap as KeyMap +#else +import qualified Data.HashMap.Lazy as HashMap +#endif + +#if MIN_VERSION_time(1,9,0) +import Data.Time.Format.ISO8601 (iso8601Show) +#else +import Data.Time (Day, LocalTime, TimeOfDay) +import Data.Time.Format (defaultTimeLocale, formatTime, iso8601DateFormat) +#endif + +main :: IO () +main = + getArgs >>= \case + ["--check"] -> checkTOML + args -> runTomlTest args + +-- | Run 'toml-test -- $0 --check' +runTomlTest :: [String] -> IO () +runTomlTest args = do + thisExe <- getExecutablePath + findExecutable "toml-test" >>= \case + Nothing -> + -- don't error, so that Hackage's test run doesn't fail + putStrLn "WARNING: toml-test not installed. Skipping test suite..." + Just tomlTestExe -> + callProcess tomlTestExe $ + args ++ ["-color", "always", "--", thisExe, "--check"] + +-- | Parse TOML data in stdin. +checkTOML :: IO () +checkTOML = do + input <- Text.getContents + output <- either handleError return $ parseTOML "" input + Char8.putStrLn $ Aeson.encode $ toTaggedJSON output + where + handleError e = do + Text.hPutStrLn stderr $ renderTOMLError e + exitFailure + +toTaggedJSON :: Value -> Aeson.Value +toTaggedJSON = \case + Table o -> Aeson.Object $ toKeyMap $ toTaggedJSON <$> o + Array vs -> Aeson.Array $ Vector.fromList $ map toTaggedJSON vs + String x -> tagged "string" (Text.unpack x) + Integer x -> tagged "integer" (show x) + Float x -> tagged "float" (showFloat x) + Boolean x -> tagged "bool" $ if x then "true" else "false" + OffsetDateTime (lt, tz) -> tagged "datetime" $ iso8601Show (ZonedTime lt tz) + LocalDateTime x -> tagged "datetime-local" $ iso8601Show x + LocalDate x -> tagged "date-local" $ iso8601Show x + LocalTime x -> tagged "time-local" $ iso8601Show x + where + tagged :: String -> String -> Aeson.Value + tagged ty v = Aeson.object ["type" .= ty, "value" .= v] + + showFloat x + | isNaN x = "nan" + | isInfinite x = if x < 0 then "-inf" else "inf" + | otherwise = show x + +#if MIN_VERSION_aeson(2,0,0) +toKeyMap :: Map Text Aeson.Value -> KeyMap Aeson.Value +toKeyMap = KeyMap.fromMap . Map.mapKeys Key.fromText +#else +toKeyMap :: Map Text Aeson.Value -> Aeson.Object +toKeyMap = HashMap.fromList . Map.toList +#endif + +#if !MIN_VERSION_time(1,9,0) +class ISO8601 a where + iso8601Show :: a -> String +instance ISO8601 ZonedTime where + iso8601Show = formatTime defaultTimeLocale (iso8601DateFormat $ Just "%T%Q%Z") +instance ISO8601 LocalTime where + iso8601Show = formatTime defaultTimeLocale (iso8601DateFormat $ Just "%T%Q") +instance ISO8601 Day where + iso8601Show = formatTime defaultTimeLocale (iso8601DateFormat Nothing) +instance ISO8601 TimeOfDay where + iso8601Show = formatTime defaultTimeLocale "%T%Q" +#endif diff --git a/toml-reader.cabal b/toml-reader.cabal new file mode 100644 --- /dev/null +++ b/toml-reader.cabal @@ -0,0 +1,112 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: toml-reader +version: 0.1.0.0 +synopsis: TOML format parser compliant with v1.0.0. +description: TOML format parser compliant with v1.0.0. See README.md for more details. +category: TOML, Text, Configuration +homepage: https://github.com/brandonchinn178/toml-reader#readme +bug-reports: https://github.com/brandonchinn178/toml-reader/issues +author: Brandon Chinn +maintainer: Brandon Chinn +license: BSD3 +license-file: LICENSE.md +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + test/tasty/goldens/renderTOMLError/DecodeError.InvalidValue.golden + test/tasty/goldens/renderTOMLError/DecodeError.MissingField.golden + test/tasty/goldens/renderTOMLError/DecodeError.OtherDecodeError.golden + test/tasty/goldens/renderTOMLError/DecodeError.TypeMismatch.golden + test/tasty/goldens/renderTOMLError/NormalizeError.DuplicateKeyError.golden + test/tasty/goldens/renderTOMLError/NormalizeError.DuplicateSectionError.golden + test/tasty/goldens/renderTOMLError/NormalizeError.ExtendTableError.golden + test/tasty/goldens/renderTOMLError/NormalizeError.ExtendTableInInlineArrayError.golden + test/tasty/goldens/renderTOMLError/NormalizeError.ImplicitArrayForDefinedKeyError.golden + test/tasty/goldens/renderTOMLError/NormalizeError.NonTableInNestedImplicitArrayError.golden + test/tasty/goldens/renderTOMLError/NormalizeError.NonTableInNestedKeyError.golden + test/tasty/goldens/renderTOMLError/ParseError.golden + +source-repository head + type: git + location: https://github.com/brandonchinn178/toml-reader + +library + exposed-modules: + TOML + TOML.Decode + TOML.Error + TOML.Parser + TOML.Utils.Map + TOML.Utils.NonEmpty + TOML.Value + other-modules: + Paths_toml_reader + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >=4.9 && <5 + , containers >=0.6.0.1 && <0.7 + , deepseq >=1.4.4.0 && <1.5 + , megaparsec >=7.0.5 && <9.3 + , parser-combinators >=1.1.0 && <1.4 + , text >=1.2.3.1 && <1.3 + , time >=1.8.0.2 && <1.12 + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances + default-language: Haskell2010 + +test-suite parser-validator + type: exitcode-stdio-1.0 + main-is: ValidateParser.hs + other-modules: + Paths_toml_reader + hs-source-dirs: + test/toml-test + ghc-options: -Wall + build-depends: + aeson + , base + , bytestring + , containers + , directory + , process + , text + , time + , toml-reader + , unordered-containers + , vector + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances + default-language: Haskell2010 + +test-suite toml-reader-tests + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + TOML.DecodeTest + TOML.ErrorTest + TOML.Utils.MapTest + TOML.Utils.NonEmptyTest + Paths_toml_reader + hs-source-dirs: + test/tasty + ghc-options: -Wall + build-depends: + base + , containers + , tasty + , tasty-golden + , tasty-hunit + , text + , time + , toml-reader + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances + default-language: Haskell2010