toml-reader-parse (empty) → 0.1.0.0
raw patch · 3 files changed
+599/−0 lines, 3 filesdep +basedep +comonaddep +containers
Dependencies added: base, comonad, containers, deepseq, dlist, mtl, prettyprinter, prettyprinter-combinators, text, time, toml-reader, vector
Files
- LICENSE +13/−0
- src/TOML/Parse.hs +509/−0
- toml-reader-parse.cabal +77/−0
+ LICENSE view
@@ -0,0 +1,13 @@+Copyright 2022 Sergey Vinokurov++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.
+ src/TOML/Parse.hs view
@@ -0,0 +1,509 @@+----------------------------------------------------------------------------+-- |+-- Module : Data.Toml.Parse+-- Copyright : (c) Sergey Vinokurov 2018+-- License : Apache-2.0 (see LICENSE)+-- Maintainer : serg.foo@gmail.com+----------------------------------------------------------------------------++{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module TOML.Parse+ ( Value(..)+ , Parser+ , runParser+ , mkTomlError+ , AtomicTomlError(..)+ , TomlError+ , (<?>)+ , L+ , extract+ , TomlParse(..)+ , FromToml(..)+ , Index(..)+ , (.!=)+ , pTable+ , pKey+ , pKeyMaybe+ , pStr+ , pStrL+ , pBool+ , pInt+ , pIntL+ , pDouble+ , pDoubleL+ , pArray+ , TomlDateTime(..)+ , pDatetime+ , pDatetimeL+ , pCases+ , ppToml+ ) where++import Control.Applicative+import Control.Comonad+import Control.DeepSeq+import Control.Monad.Except++import Data.Bifunctor+import Data.DList (DList)+import Data.DList qualified as DL+import Data.Foldable+import Data.List.NonEmpty (NonEmpty(..))+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as M+import Data.Maybe+import Data.Text (Text)+import Data.Text qualified as T+import Data.Time qualified as Time+import Data.Time.Format.ISO8601 qualified as Time+import Data.Traversable+import Data.Vector (Vector)+import Data.Vector qualified as V+import Data.Void (Void, vacuous)+import Prettyprinter+import Prettyprinter.Combinators+import Prettyprinter.Generics++import TOML++import Unsafe.Coerce++data TomlType+ = TTable+ | TArray+ | TString+ | TInteger+ | TFloat+ | TBoolean+ | TDatetime+ deriving (Eq, Ord, Show, Generic)++getType :: Value -> TomlType+getType = \case+ Table{} -> TTable+ Array{} -> TArray+ String{} -> TString+ Integer{} -> TInteger+ Float{} -> TFloat+ Boolean{} -> TBoolean+ OffsetDateTime{} -> TDatetime+ LocalDateTime{} -> TDatetime+ LocalDate{} -> TDatetime+ LocalTime{} -> TDatetime++ppTomlType :: TomlType -> (Doc ann, Doc ann)+ppTomlType = \case+ TTable -> ("a", "table")+ TString -> ("a", "string")+ TInteger -> ("an", "integer")+ TFloat -> ("a", "float")+ TBoolean -> ("a", "boolean")+ TDatetime -> ("a", "datetime")+ TArray -> ("an", "array")++data TomlPath+ = PathIndex !Int+ | PathKey !Text+ | PathOther !Text+ deriving (Eq, Ord, Show, Generic)++instance Pretty TomlPath where+ pretty = \case+ PathIndex n -> "In array element" <+> pretty n+ PathKey str -> "In table key" <+> squotes (pretty str)+ PathOther thing -> "While parsing" <+> pretty thing++data AtomicTomlError+ = UnexpectedType+ !TomlType -- ^ Expected+ Value -- ^ Got+ | MissingKey !Text Table+ | IndexOutOfBounds !Int Value+ | OtherError (Doc Void)+ deriving (Show, Generic)++-- | Prettyprint toml value.+ppToml :: Value -> Doc ann+ppToml = \case+ Table x -> ppMapWith pretty ppToml x+ String x -> pretty x+ Integer x -> pretty x+ Float x -> pretty x+ Boolean x -> pretty x+ LocalDateTime x -> pretty $ TomlLocalDateTime x+ OffsetDateTime x -> pretty $ TomlOffsetDateTime x+ LocalDate x -> pretty $ TomlLocalDate x+ LocalTime x -> pretty $ TomlLocalTime x+ Array xs -> ppListWith ppToml xs++instance Pretty AtomicTomlError where+ pretty = \case+ UnexpectedType expected got ->+ "Expected to find" <+> article <+> typ <+> "but found" <+> article' <+> typ' <> "." <+>+ "Value:" ## ppToml got+ where+ (article, typ) = ppTomlType expected+ (article', typ') = ppTomlType $ getType got+ MissingKey key tab -> "Missing key" <+> squotes (pretty key) <+> "in table:" ## ppMapWith pretty ppToml tab+ IndexOutOfBounds ix node -> "Index" <+> pretty ix <+> "is out of bounds in array:" ## ppToml node+ OtherError err -> "Other error:" ## vacuous err++data TomlError+ = ErrorEmpty+ | ErrorAtomic !AtomicTomlError+ -- | Invariant: children of ErrorAnd never share common prefix.+ | ErrorAnd TomlError TomlError+ -- | Invariant: children of ErrorOr never share common prefix.+ | ErrorOr TomlError TomlError+ | ErrorPrefix (NonEmpty TomlPath) TomlError+ deriving (Show, Generic)++instance Pretty TomlError where+ pretty = \case+ ErrorEmpty -> "Control.Applicative.empty"+ ErrorAtomic err -> pretty err+ ErrorAnd x y -> "AND" ## align (vsep $ map pretty $ toList $ collectConjuctions x y)+ ErrorOr x y -> "OR" ## align (vsep $ map pretty $ toList $ collectDisjunctions x y)+ ErrorPrefix ps e -> foldr (\p acc -> pretty p ## acc) (pretty e) ps+ where+ collectConjuctions :: TomlError -> TomlError -> DList TomlError+ collectConjuctions (ErrorAnd a b) (ErrorAnd c d) = collectConjuctions a b <> collectConjuctions c d+ collectConjuctions (ErrorAnd a b) c = collectConjuctions a b <> DL.singleton c+ collectConjuctions a (ErrorAnd c d) = DL.singleton a <> collectConjuctions c d+ collectConjuctions a c = DL.fromList [a, c]++ collectDisjunctions :: TomlError -> TomlError -> DList TomlError+ collectDisjunctions (ErrorOr a b) (ErrorOr c d) = collectDisjunctions a b <> collectDisjunctions c d+ collectDisjunctions (ErrorOr a b) c = collectDisjunctions a b <> DL.singleton c+ collectDisjunctions a (ErrorOr c d) = DL.singleton a <> collectDisjunctions c d+ collectDisjunctions a c = DL.fromList [a, c]++-- NB order of constructors is important+data IsCommitted = Uncommitted | Committed+ deriving (Eq, Ord, Show, Enum, Bounded)++instance Semigroup IsCommitted where+ {-# INLINE (<>) #-}+ (<>) = max++newtype Validation a = Validation+ { unValidation :: Either (IsCommitted, TomlError) a }+ deriving (Functor)++zipErrors+ :: (TomlError -> TomlError -> TomlError)+ -> TomlError+ -> TomlError+ -> TomlError+zipErrors f x y = case commonPrefix x y of+ Nothing -> f x y+ Just (common, x', y') ->+ ErrorPrefix common (f x' y')++commonPrefix+ :: TomlError+ -> TomlError+ -> Maybe (NonEmpty TomlPath, TomlError, TomlError)+commonPrefix x y = case (x, y) of+ (ErrorPrefix px x', ErrorPrefix py y') ->+ flip fmap (go px py) $ \(common, px', py') ->+ let prefix [] err = err+ prefix (p : ps) err = ErrorPrefix (p :| ps) err+ in (common, prefix px' x', prefix py' y')+ _ -> Nothing+ where+ go :: NonEmpty TomlPath -> NonEmpty TomlPath -> Maybe (NonEmpty TomlPath, [TomlPath], [TomlPath])+ go xs ys =+ case go' [] (toList xs) (toList ys) of+ (c : cs, xs', ys') -> Just (c :| cs, xs', ys')+ _ -> Nothing+ go' :: Eq a => [a] -> [a] -> [a] -> ([a], [a], [a])+ go' common (a : as) (b : bs)+ | a == b = go' (a : common) as bs+ go' common as bs = (reverse common, as, bs)++instance Applicative Validation where+ {-# INLINE pure #-}+ pure = Validation . pure+ {-# NOINLINE (<*>) #-}+ (<*>) vf'@(Validation vf) vx'@(Validation vx) =+ case (vf, vx) of+ (Left (cf, ef), Left (cx, ex)) -> Validation $ Left (cf <> cx, zipErrors ErrorAnd ef ex)+ (Left _, _) -> unsafeCoerce vf'+ (_, Left _) -> unsafeCoerce vx'+ (Right f, Right x) -> Validation $ Right $ f x++instance Alternative Validation where+ {-# INLINE empty #-}+ empty = Validation $ Left (Uncommitted, ErrorEmpty)+ {-# NOINLINE (<|>) #-}+ (<|>) x'@(Validation x) y'@(Validation y) =+ case (x, y) of+ (Right _, _) -> x'+ (_, Right _) -> y'+ (Left (cf, ef), Left (cx, ex)) ->+ case (cf, cx) of+ (Committed, Uncommitted) -> x'+ (Uncommitted, Committed) -> y'+ _ -> Validation $ Left (cf <> cx, zipErrors ErrorOr ef ex)++instance Monad Validation where+ {-# INLINE (>>=) #-}+ {-# INLINE (>>) #-}+ (>>=) x'@(Validation x) f =+ case x of+ Left _ -> unsafeCoerce x'+ Right y -> commit $ f y+ where+ commit (Validation (Left (_, err))) = Validation $ Left (Committed, err)+ commit z@(Validation (Right _)) = z+ (>>) = (*>)++instance MonadPlus Validation++newtype ParseEnv = ParseEnv { unParseEnv :: [TomlPath] }+ deriving (Eq, Ord, Show, Generic, Pretty)++newtype Parser a = Parser+ { unParser :: Validation a }+ deriving (Functor, Applicative, Alternative, MonadPlus)++instance Monad Parser where+ {-# INLINE (>>=) #-}+ {-# INLINE (>>) #-}+ (>>=) (Parser x) f = Parser $ do+ x' <- x+ unParser $ f x'+ (>>) = (*>)++infixl 9 <?>++-- | Add textual annotation to the provided located thing. The annotation will+-- be shows as part of error message if the location ultimately gets passed to+-- 'throwParseError'.+(<?>) :: L a -> Text -> L a+(<?>) (L env x) y = L (inside (PathOther y) env) x++instance TomlParse Parser where+ throwParseError loc err = Parser $ Validation $ Left (Uncommitted, mkTomlError' loc err)++runParser :: a -> (L a -> Parser b) -> Either (Doc Void) b+runParser x f+ = first (("Error while parsing:" ##) . pretty . snd)+ $ unValidation+ $ unParser+ $ f+ $ L (ParseEnv []) x++mkTomlError :: L a -> Doc Void -> TomlError+mkTomlError loc = mkTomlError' loc . OtherError++mkTomlError' :: L a -> AtomicTomlError -> TomlError+mkTomlError' (L env _) err = case reverse $ unParseEnv env of+ [] -> ErrorAtomic err+ p : ps -> ErrorPrefix (p :| ps) $ ErrorAtomic err++-- | Adds to 'a' its provenance in the toml file.+data L a = L ParseEnv a+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic)++instance Pretty a => Pretty (L a) where pretty = ppGeneric++instance Comonad L where+ {-# INLINE extract #-}+ {-# INLINE duplicate #-}+ extract (L _ x) = x+ duplicate orig@(L env _) = L env orig++{-# INLINE inside #-}+inside :: TomlPath -> ParseEnv -> ParseEnv+inside x (ParseEnv xs) = ParseEnv (x : xs)++class (Applicative m, Alternative m) => TomlParse m where+ throwParseError :: L b -> AtomicTomlError -> m a++class FromToml a b where+ fromToml :: L a -> Parser b++instance FromToml a (L a) where+ {-# INLINE fromToml #-}+ fromToml = pure++instance FromToml a a where+ {-# INLINE fromToml #-}+ fromToml = pure . extract++instance FromToml Value String where+ {-# INLINE fromToml #-}+ fromToml = fmap T.unpack . pStr++instance FromToml Value Text where+ {-# INLINE fromToml #-}+ fromToml = pStr++instance FromToml Value Bool where+ {-# INLINE fromToml #-}+ fromToml = pBool++instance FromToml Value Int where+ {-# INLINE fromToml #-}+ fromToml = pInt++instance FromToml Value Double where+ {-# INLINE fromToml #-}+ fromToml = pDouble++instance (Ord k, FromToml Text k, FromToml Value v) => FromToml Value (Map k v) where+ fromToml = pTable >=> fromToml++instance (Ord k, FromToml Text k, FromToml Value v) => FromToml Table (Map k v) where+ fromToml (L env y) = do+ ys <- for (M.toList y) $ \(k, v) ->+ (,)+ <$> fromToml (L env k)+ <*> fromToml (L (inside (PathKey k) env) v)+ pure $ M.fromList ys++instance FromToml Value a => FromToml Value (Vector a) where+ fromToml = pArray >=> traverse fromToml . V.fromList++instance FromToml Value a => FromToml Value [a] where+ fromToml = pArray >=> traverse fromToml++instance FromToml Value a => FromToml Value (NonEmpty a) where+ fromToml x = do+ ys <- pArray x+ case toList ys of+ [] -> throwParseError x $ OtherError "Expected a non-empty list"+ z : zs -> (:|) <$> fromToml z <*> traverse fromToml zs++infixl 5 .:, .:?, .!=++class Index a where+ (.:) :: FromToml Value b => a -> Text -> Parser b+ (.:?) :: FromToml Value b => a -> Text -> Parser (Maybe b)++instance Index (L Table) where+ {-# INLINE (.:) #-}+ {-# INLINE (.:?) #-}+ (.:) x key = pKey key x >>= fromToml+ (.:?) x key = traverse fromToml $ liftMaybe $ pKeyMaybe key x++instance Index (L Value) where+ {-# INLINE (.:) #-}+ {-# INLINE (.:?) #-}+ (.:) x key = pTable x >>= pKey key >>= fromToml+ (.:?) x key = pTable x >>= traverse fromToml . liftMaybe . pKeyMaybe key++instance a ~ L Value => Index (Parser a) where+ {-# INLINE (.:) #-}+ {-# INLINE (.:?) #-}+ (.:) x key = x >>= pTable >>= pKey key >>= fromToml+ (.:?) x key = x >>= pTable >>= traverse fromToml . liftMaybe . pKeyMaybe key++-- | Assign default value to a parser that produces 'Maybe'. Typically used together with '.:?':+--+-- > foo .:? "bar" .!= 10+{-# INLINE (.!=) #-}+(.!=) :: Functor m => m (Maybe a) -> a -> m a+(.!=) action def = fromMaybe def <$> action++pTable :: TomlParse m => L Value -> m (L Table)+pTable = \case+ L env (Table x) -> pure $ L env x+ other@(L _ other') -> throwParseError other $ UnexpectedType TTable other'++pKey :: TomlParse m => Text -> L Table -> m (L Value)+pKey key tab'@(L _ tab) = case liftMaybe $ pKeyMaybe key tab' of+ Just x -> pure x+ Nothing -> throwParseError tab' $ MissingKey key tab++pKeyMaybe :: Text -> L Table -> L (Maybe Value)+pKeyMaybe key (L env tab) = L (inside (PathKey key) env) $ M.lookup key tab++pStr :: TomlParse m => L Value -> m Text+pStr = fmap extract . pStrL++pStrL :: TomlParse m => L Value -> m (L Text)+pStrL = \case+ L env (String x) -> pure $ L env x+ other@(L _ other') -> throwParseError other $ UnexpectedType TString other'++pBool :: TomlParse m => L Value -> m Bool+pBool = \case+ L _ (Boolean x) -> pure x+ other@(L _ other') -> throwParseError other $ UnexpectedType TBoolean other'++pInt :: TomlParse m => L Value -> m Int+pInt = fmap extract . pIntL++pIntL :: TomlParse m => L Value -> m (L Int)+pIntL = \case+ L env (Integer x) -> pure $ L env $ fromIntegral x+ other@(L _ other') -> throwParseError other $ UnexpectedType TInteger other'++pDouble :: TomlParse m => L Value -> m Double+pDouble = fmap extract . pDoubleL++pDoubleL :: TomlParse m => L Value -> m (L Double)+pDoubleL = \case+ L env (Float x) -> pure $ L env x+ other@(L _ other') -> throwParseError other $ UnexpectedType TFloat other'++data TomlDateTime+ = TomlLocalDateTime Time.LocalTime+ | TomlOffsetDateTime (Time.LocalTime, Time.TimeZone)+ | TomlLocalDate Time.Day+ | TomlLocalTime Time.TimeOfDay+ deriving (Eq, Ord, Show, Generic)++instance NFData TomlDateTime++instance Pretty TomlDateTime where+ pretty (TomlLocalDateTime t) = pretty $ Time.iso8601Show t+ pretty (TomlOffsetDateTime (t, tz)) = pretty $ Time.iso8601Show $ Time.localTimeToUTC tz t+ pretty (TomlLocalDate t) = pretty $ Time.iso8601Show t+ pretty (TomlLocalTime t) = pretty $ Time.iso8601Show t++pDatetime :: TomlParse m => L Value -> m TomlDateTime+pDatetime = fmap extract . pDatetimeL++pDatetimeL :: TomlParse m => L Value -> m (L TomlDateTime)+pDatetimeL = \case+ L env (LocalDateTime x) -> pure $ L env $ TomlLocalDateTime x+ L env (OffsetDateTime x) -> pure $ L env $ TomlOffsetDateTime x+ L env (LocalDate x) -> pure $ L env $ TomlLocalDate x+ L env (LocalTime x) -> pure $ L env $ TomlLocalTime x+ other@(L _ other') -> throwParseError other $ UnexpectedType TDatetime other'++pArray :: TomlParse m => L Value -> m [L Value]+pArray = \case+ L env (Array x) -> pure $ (\(n, x') -> L (inside (PathIndex n) env) x') <$> zip [0..] x+ other@(L _ other') -> throwParseError other $ UnexpectedType TArray other'++{-# INLINE pCases #-}+pCases :: (Ord k, FromToml Value k, Pretty k) => Map k v -> L Value -> Parser v+pCases env = \x -> do+ k <- fromToml x+ case M.lookup k env of+ Just v -> pure v+ Nothing -> throwParseError x $ OtherError $+ "Unexpected value" <+> squotes (pretty k) <> "." <+>+ "Expected one of" <+> vsep (punctuate "," (map pretty (M.keys env)))++liftMaybe :: L (Maybe a) -> Maybe (L a)+liftMaybe (L env x) = L env <$> x
+ toml-reader-parse.cabal view
@@ -0,0 +1,77 @@+cabal-version: 3.0++name:+ toml-reader-parse+version:+ 0.1.0.0+synopsis:+ Alternative parser for TOML values produced by the toml-reader package.++description:+ Package defines a set of parser combinators that allows analyzing arbitrary TOML structures.+ Includes formatted errors that keep track of where in the original TOML file a value+ came from.++category: Data, TOML++license:+ Apache-2.0+license-file:+ LICENSE++author:+ Sergey Vinokurov+maintainer:+ Sergey Vinokurov <serg.foo@gmail.com>++build-type:+ Simple++homepage: https://github.com/sergv/toml-reader-parse+source-repository head+ type: git+ location: https://github.com/sergv/toml-reader-parse.git++common ghc-options+ default-language:+ Haskell2010++ ghc-options:+ -Weverything+ -Wno-type-defaults+ -Wno-implicit-prelude+ -Wno-missing-local-signatures+ -Wno-missing-import-lists+ -Wno-missed-specialisations+ -Wno-all-missed-specialisations+ -Wno-safe+ -Wno-missing-safe-haskell-mode+ -Wno-unsafe++ if impl(ghc >= 8.8)+ ghc-options:+ -Wno-missing-deriving-strategies++ if impl(ghc >= 9.2)+ ghc-options:+ -Wno-missing-kind-signatures++library+ import: ghc-options+ exposed-modules:+ TOML.Parse+ hs-source-dirs:+ src+ build-depends:+ , base >= 4.14 && < 5+ , comonad+ , containers+ , deepseq+ , dlist+ , toml-reader >= 0.1+ , mtl+ , prettyprinter >= 1.7+ , prettyprinter-combinators+ , text+ , time+ , vector