htoml-parse (empty) → 0.1
raw patch · 3 files changed
+584/−0 lines, 3 filesdep +basedep +comonaddep +containers
Dependencies added: base, comonad, containers, dlist, htoml-megaparsec, mtl, prettyprinter, prettyprinter-combinators, text, time, unordered-containers, vector
Files
- LICENSE +13/−0
- htoml-parse.cabal +77/−0
- src/Data/Toml/Parse.hs +494/−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.
+ htoml-parse.cabal view
@@ -0,0 +1,77 @@+cabal-version: 3.0++name:+ htoml-parse+version:+ 0.1+synopsis:+ Parse TOML values produced by htoml-megaparsec package.++description:+ Package definecs 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/htoml-parse+source-repository head+ type: git+ location: https://github.com/sergv/htoml-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:+ Data.Toml.Parse+ hs-source-dirs:+ src+ build-depends:+ base >= 4.9 && < 5,+ comonad,+ containers,+ dlist,+ htoml-megaparsec >= 2.1,+ mtl,+ prettyprinter >= 1.7,+ prettyprinter-combinators,+ text,+ time,+ unordered-containers,+ vector
+ src/Data/Toml/Parse.hs view
@@ -0,0 +1,494 @@+----------------------------------------------------------------------------+-- |+-- 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 #-}++module Data.Toml.Parse+ ( Node(..)+ , Parser+ , runParser+ , mkTomlError+ , AtomicTomlError(..)+ , TomlError+ , (<?>)+ , L+ , extract+ , TomlParse(..)+ , FromToml(..)+ , Index(..)+ , (.!=)+ , pTable+ , pKey+ , pKeyMaybe+ , pStr+ , pStrL+ , pBool+ , pInt+ , pIntL+ , pDouble+ , pDoubleL+ , pDatetime+ , pDatetimeL+ , pTArray+ , pArray+ , pCases++ , ppToml+ ) where++import Control.Applicative+import Control.Comonad+import Control.Monad.Except++import Data.Bifunctor+import Data.DList (DList)+import Data.DList qualified as DL+import Data.Foldable+import Data.HashMap.Strict qualified as HM+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 (UTCTime)+import Data.Time.Format.ISO8601+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 Text.Toml++import Unsafe.Coerce++data TomlType+ = TTable+ | TTArray+ | TString+ | TInteger+ | TFloat+ | TBoolean+ | TDatetime+ | TArray+ deriving (Eq, Ord, Show, Generic)++getType :: Node -> TomlType+getType = \case+ VTable{} -> TTable+ VTArray{} -> TTArray+ VString{} -> TString+ VInteger{} -> TInteger+ VFloat{} -> TFloat+ VBoolean{} -> TBoolean+ VDatetime{} -> TDatetime+ VArray{} -> TArray++ppTomlType :: TomlType -> (Doc ann, Doc ann)+ppTomlType = \case+ TTable -> ("a", "table")+ TTArray -> ("a", "table array")+ 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+ Node -- ^ Got+ | MissingKey !Text Table+ | IndexOutOfBounds !Int Node+ | OtherError (Doc Void)+ deriving (Show, Generic)++-- | Prettyprint toml value.+ppToml :: Node -> Doc ann+ppToml = \case+ VTable x -> ppHashMapWith pretty ppToml x+ VTArray xs -> ppVectorWith (ppHashMapWith pretty ppToml) xs+ VString x -> pretty x+ VInteger x -> pretty x+ VFloat x -> pretty x+ VBoolean x -> pretty x+ VDatetime x -> pretty $ iso8601Show x+ VArray xs -> ppVectorWith ppToml xs++instance Pretty AtomicTomlError where+ pretty = \case+ UnexpectedType expected got ->+ "Expected to find" <+> article <+> typ <+> "but found" <+> article' <+> typ' <> "." <+>+ "Node:" ## ppToml got+ where+ (article, typ) = ppTomlType expected+ (article', typ') = ppTomlType $ getType got+ MissingKey key tab -> "Missing key" <+> squotes (pretty key) <+> "in table:" ## ppHashMapWith 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 Node String where+ {-# INLINE fromToml #-}+ fromToml = fmap T.unpack . pStr++instance FromToml Node Text where+ {-# INLINE fromToml #-}+ fromToml = pStr++instance FromToml Node Bool where+ {-# INLINE fromToml #-}+ fromToml = pBool++instance FromToml Node Int where+ {-# INLINE fromToml #-}+ fromToml = pInt++instance FromToml Node Double where+ {-# INLINE fromToml #-}+ fromToml = pDouble++instance FromToml Node UTCTime where+ {-# INLINE fromToml #-}+ fromToml = pDatetime++instance (Ord k, FromToml Text k, FromToml Node v) => FromToml Node (Map k v) where+ fromToml = pTable >=> fromToml++instance (Ord k, FromToml Text k, FromToml Node v) => FromToml Table (Map k v) where+ fromToml (L env y) = do+ ys <- for (HM.toList y) $ \(k, v) ->+ (,)+ <$> fromToml (L env k)+ <*> fromToml (L (inside (PathKey k) env) v)+ pure $ M.fromList ys++instance FromToml Node a => FromToml Node (Vector a) where+ fromToml = pArray >=> traverse fromToml++instance FromToml Node a => FromToml Node (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 Node b => a -> Text -> Parser b+ (.:?) :: FromToml Node 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 Node) where+ {-# INLINE (.:) #-}+ {-# INLINE (.:?) #-}+ (.:) x key = pTable x >>= pKey key >>= fromToml+ (.:?) x key = pTable x >>= traverse fromToml . liftMaybe . pKeyMaybe key++instance a ~ L Node => 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 Node -> m (L Table)+pTable = \case+ L env (VTable x) -> pure $ L env x+ other@(L _ other') -> throwParseError other $ UnexpectedType TTable other'++pKey :: TomlParse m => Text -> L Table -> m (L Node)+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 Node)+pKeyMaybe key (L env tab) = L (inside (PathKey key) env) $ HM.lookup key tab++pStr :: TomlParse m => L Node -> m Text+pStr = fmap extract . pStrL++pStrL :: TomlParse m => L Node -> m (L Text)+pStrL = \case+ L env (VString x) -> pure $ L env x+ other@(L _ other') -> throwParseError other $ UnexpectedType TString other'++pBool :: TomlParse m => L Node -> m Bool+pBool = \case+ L _ (VBoolean x) -> pure x+ other@(L _ other') -> throwParseError other $ UnexpectedType TBoolean other'++pInt :: TomlParse m => L Node -> m Int+pInt = fmap extract . pIntL++pIntL :: TomlParse m => L Node -> m (L Int)+pIntL = \case+ L env (VInteger x) -> pure $ L env $ fromIntegral x+ other@(L _ other') -> throwParseError other $ UnexpectedType TInteger other'++pDouble :: TomlParse m => L Node -> m Double+pDouble = fmap extract . pDoubleL++pDoubleL :: TomlParse m => L Node -> m (L Double)+pDoubleL = \case+ L env (VFloat x) -> pure $ L env x+ other@(L _ other') -> throwParseError other $ UnexpectedType TFloat other'++pDatetime :: TomlParse m => L Node -> m UTCTime+pDatetime = fmap extract . pDatetimeL++pDatetimeL :: TomlParse m => L Node -> m (L UTCTime)+pDatetimeL = \case+ L env (VDatetime x) -> pure $ L env x+ other@(L _ other') -> throwParseError other $ UnexpectedType TDatetime other'++pTArray :: TomlParse m => L Node -> m (Vector (L Table))+pTArray = \case+ L env (VTArray x) -> pure $ (\(n, x') -> L (inside (PathIndex n) env) x') <$> V.indexed x+ other@(L _ other') -> throwParseError other $ UnexpectedType TTArray other'++pArray :: TomlParse m => L Node -> m (Vector (L Node))+pArray = \case+ L env (VArray x) -> pure $ (\(n, x') -> L (inside (PathIndex n) env) x') <$> V.indexed x+ other@(L _ other') -> throwParseError other $ UnexpectedType TArray other'++{-# INLINE pCases #-}+pCases :: (Ord k, FromToml Node k, Pretty k) => Map k v -> L Node -> 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