toml-parser 1.3.1.1 → 1.3.1.2

raw patch · 5 files changed

+100/−46 lines, 5 filesdep ~basedep ~timenew-component:exe:toml-benchmarkerPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, time

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• benchmarker/benchmarker.hs +19/−0
• src/Toml/Semantics.hs +58/−45
• test/TomlSpec.hs +10/−0
• toml-parser.cabal +8/−1

@@ -1,5 +1,10 @@ # Revision history for toml-parser +## 1.3.1.2++* Bugfix: In some cases overlapping keys in inline tables could throw an exception+  instead instead of returning the proper semantic error value.+ ## 1.3.1.1  * Ensure years are rendered zero-padded

@@ -0,0 +1,19 @@+++import Control.Exception (evaluate)+import Data.Time (diffUTCTime, getCurrentTime)+import System.Environment (getArgs)+import Toml (parse)++main :: IO ()+main =+ do args <- getArgs+    filename <- case args of+      [filename] -> pure filename+      _ -> fail "Usage: benchmarker <file.toml>"+    txt <- readFile filename+    evaluate (length txt) -- readFile uses lazy IO, force it to load+    start <- getCurrentTime+    evaluate (parse txt)+    stop <- getCurrentTime+    print (stop `diffUTCTime` start)

@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use list literal" #-} {-|-Module      : Toml.Sematics+Module      : Toml.Semantics Description : Semantic interpretation of raw TOML expressions Copyright   : (c) Eric Mertens, 2023 License     : ISC@@ -14,9 +14,7 @@ -} module Toml.Semantics (SemanticError(..), SemanticErrorKind(..), semantics) where -import Control.Applicative ((<|>)) import Control.Monad (foldM)-import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty((:|))) import Data.List.NonEmpty qualified as NonEmpty import Data.Map (Map)@@ -25,8 +23,8 @@ import Toml.Parser.Types (SectionKind(..), Key, Val(..), Expr(..)) import Toml.Value (Table, Value(..)) --- | The type of errors that can be generated when resolving all the key--- used in a TOML document. These errors always pertain to some key to+-- | The type of errors that can be generated when resolving all the keys+-- used in a TOML document. These errors always pertain to some key that -- caused one of three conflicts. -- -- @since 1.3.0.0@@ -56,7 +54,7 @@ -- or report a semantic error. -- -- @since 1.3.0.0-semantics :: [Expr] -> Either (Located SemanticError) Table+semantics :: [Expr] -> M Table semantics exprs =  do let (topKVs, tables) = gather exprs     m1 <- assignKeyVals topKVs Map.empty@@ -82,22 +80,37 @@         goTable kind key acc (ArrayTableExpr k   : exprs) = (kind, key, reverse acc) : goTable ArrayTableKind k [] exprs         goTable kind key acc (KeyValExpr     k v : exprs) = goTable kind key ((k,v):acc) exprs --- | Frames help distinguish tables and arrays written in block and inline--- syntax. This allows us to enforce that inline tables and arrays can not--- be extended by block syntax.+-- | A top-level table used to distinguish top-level defined arrays+-- and tables from inline values.+type FrameTable = Map String Frame++-- | M is the error-handling monad used through this module for+-- propagating semantic errors through the 'semantics' function.+type M = Either (Located SemanticError)++-- | Frames are the top-level skeleton of the TOML file that mirror the+-- subset of values that can be constructed with with top-level syntax.+-- TOML syntax makes a distinction between tables and arrays that are+-- defined at the top-level and those defined with inline syntax. This+-- separate type keeps these syntactic differences separate while table+-- and array resolution is still happening. data Frame-    = FrameTable FrameKind (Map String Frame)-    | FrameArray (NonEmpty (Map String Frame)) -- stored in reverse order for easy "append"+    = FrameTable FrameKind FrameTable+    | FrameArray (NonEmpty FrameTable) -- stored in reverse order for easy "append"     | FrameValue Value     deriving Show +-- | Top-level tables can be in various states of completeness. This type+-- keeps track of the current state of a top-level defined table. data FrameKind     = Open   -- ^ table implicitly defined as supertable of [x.y.z]     | Dotted -- ^ table implicitly defined using dotted key assignment     | Closed -- ^ table closed to further extension     deriving Show -framesToTable :: Map String Frame -> Table+-- | Convert a top-level table "frame" representation into the plain Value+-- representation once the distinction is no longer needed.+framesToTable :: FrameTable -> Table framesToTable =     fmap \case         FrameTable _ t -> Table (framesToTable t)@@ -107,41 +120,34 @@         -- reverses the list while converting the frames to tables         toArray = foldl (\acc frame -> Table (framesToTable frame) : acc) [] -constructTable :: [(Key, Value)] -> Either (Located SemanticError) Table-constructTable entries =-    case findBadKey (map fst entries) of-        Just bad -> invalidKey bad AlreadyAssigned-        Nothing -> Right (Map.unionsWith merge [singleValue (locThing k) (locThing <$> ks) v | (k:|ks, v) <- entries])+-- | Build a 'Table' value out of a list of key-value pairs. These keys are+-- checked to not overlap. In the case of overlap a 'SemanticError' is returned.+constructTable :: [(Key, Value)] -> M Table+constructTable = foldM (uncurry . addEntry) Map.empty     where-        merge (Table x) (Table y) = Table (Map.unionWith merge x y)-        merge _ _ = error "constructFrame:merge: panic"+        -- turns x.y.z = v into a nested table of one leaf value+        singleCase = foldr (\k v -> Table (Map.singleton (locThing k) v)) -        singleValue k []      v = Map.singleton k v-        singleValue k (k1:ks) v = Map.singleton k (Table (singleValue k1 ks v))+        addEntry tab (key :| subkey) val = Map.alterF f (locThing key) tab+            where+                -- no existing assignment at this parent key - no more validation needed+                f Nothing = pure (Just (singleCase val subkey)) --- | Finds a key that overlaps with another in the same list-findBadKey :: [Key] -> Maybe (Located String)-findBadKey = check . sortOn (fmap locThing)-    where-        check :: [Key] -> Maybe (Located String)-        check (x:y:z) = check1 x y <|> check (y:z)-        check _ = Nothing+                -- there's already a table at this parent key, attempt to extend it+                f (Just (Table subtab)) | Just subkey' <- NonEmpty.nonEmpty subkey =+                    Just . Table <$> addEntry subtab subkey' val -        check1 (x :| xs) (y1 :| y2 : ys)-            | locThing x == locThing y1 =-                case xs of-                    [] -> Just y1-                    x' : xs' -> check1 (x' :| xs') (y2 :| ys)-        check1 _ _ = Nothing+                -- attempted to overwrite an existing assignment, abort+                f _ = invalidKey key AlreadyAssigned  -- | Attempts to insert the key-value pairs given into a new section -- located at the given key-path in a frame map. addSection ::-    SectionKind                      {- ^ section kind        -} ->-    KeyVals                          {- ^ values to install   -} ->-    Key                              {- ^ section key         -} ->-    Map String Frame                 {- ^ local frame map     -} ->-    Either (Located SemanticError) (Map String Frame) {- ^ error message or updated local frame map -}+    SectionKind  {- ^ section kind                               -} ->+    KeyVals      {- ^ values to install                          -} ->+    Key          {- ^ section key                                -} ->+    FrameTable   {- ^ local frame map                            -} ->+    M FrameTable {- ^ error message or updated local frame table -} addSection kind kvs = walk     where         walk (k1 :| []) = flip Map.alterF (locThing k1) \case@@ -179,20 +185,23 @@                 go g t = Just . g <$> walk (k2 :| ks) t  -- | Close all of the tables that were implicitly defined with--- dotted prefixes.-closeDots :: Map String Frame -> Map String Frame+-- dotted prefixes. These tables are only eligible for extension+-- within the @[table]@ section in which they were introduced.+closeDots :: FrameTable -> FrameTable closeDots =     fmap \case         FrameTable Dotted t -> FrameTable Closed (closeDots t)         frame               -> frame -assignKeyVals :: KeyVals -> Map String Frame -> Either (Located SemanticError) (Map String Frame)+-- | Extend the given frame table with a list of key-value pairs.+-- Either the updated frame table will be returned+assignKeyVals :: KeyVals -> FrameTable -> M FrameTable assignKeyVals kvs t = closeDots <$> foldM f t kvs     where         f m (k,v) = assign k v m  -- | Assign a single dotted key in a frame.-assign :: Key -> Val -> Map String Frame -> Either (Located SemanticError) (Map String Frame)+assign :: Key -> Val -> FrameTable -> M FrameTable  assign (key :| []) val = flip Map.alterF (locThing key) \case     Nothing -> Just . FrameValue <$> valToValue val@@ -210,7 +219,7 @@  -- | Convert 'Val' to 'Value' potentially raising an error if -- it has inline tables with key-conflicts.-valToValue :: Val -> Either (Located SemanticError) Value+valToValue :: Val -> M Value valToValue = \case     ValInteger   x    -> Right (Integer   x)     ValFloat     x    -> Right (Float     x)@@ -224,5 +233,9 @@     ValTable kvs      -> do entries <- (traverse . traverse) valToValue kvs                             Table <$> constructTable entries -invalidKey :: Located String -> SemanticErrorKind -> Either (Located SemanticError) a+-- | Abort validation by reporting an error about the given key.+invalidKey ::+    Located String    {- ^ subkey     -} ->+    SemanticErrorKind {- ^ error kind -} ->+    M a invalidKey key kind = Left ((`SemanticError` kind) <$> key)

@@ -557,6 +557,16 @@             type = { edible = false }  # INVALID|]           `shouldBe` Left "3:1: key error: type is already assigned" +        it "checks that inline keys aren't reassigned" $+          parse [quoteStr|+            x = {a = 1, a = 2}|]+          `shouldBe` Left "1:13: key error: a is already assigned"++        it "checks that inline keys don't overlap with implicit inline tables" $+          parse [quoteStr|+            x = {a.b = 1, a = 2}|]+          `shouldBe` Left "1:15: key error: a is already assigned"+     describe "array of tables"      do it "supports array of tables syntax" $           decode [quoteStr|

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               toml-parser-version:            1.3.1.1+version:            1.3.1.2 synopsis:           TOML 1.0.0 parser description:     TOML parser using generated lexers and parsers with@@ -124,3 +124,10 @@         template-haskell ^>= {2.16, 2.17, 2.18, 2.19, 2.20, 2.21},     build-tool-depends:         markdown-unlit:markdown-unlit ^>= {0.5.1, 0.6.0},++executable toml-benchmarker+    buildable: False+    main-is: benchmarker.hs+    default-language: Haskell2010+    build-depends: base, toml-parser, time+    hs-source-dirs: benchmarker