diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -34,7 +34,7 @@ ```bash cabal update -cabal install --overwrite-policy=always phino-0.0.133 +cabal install --overwrite-policy=always phino-0.0.134 phino --version ``` @@ -1191,9 +1191,9 @@ * `contextualize` - function of two arguments, that rewrites given expression depending on provided context according to the contextualization [rules](assets/contextualize.jpg) -* `random-tau` - creates attribute with random unique name. Accepts bindings, - and attributes. Ensures that created attribute is not present in list of - provided attributes and does not exist as attribute in provided bindings. +* `random-tau` - creates an attribute with a random unique name. It accepts no + arguments; uniqueness is guaranteed across all names already taken in the + document. * `dataize` - dataizes given expression and returns bytes. * `concat` - accepts bytes or dataizable expressions as arguments, concatenates them into single sequence and convert it to expression @@ -1317,103 +1317,103 @@ === parse/phi === warmup: 3 iterations batches: 10 x 1 - total: 1785285.297 μs - avg: 178528.530 μs - min: 164868.992 μs - max: 209121.132 μs - std dev: 15515.800 μs + total: 1821425.151 μs + avg: 182142.515 μs + min: 170750.493 μs + max: 209499.629 μs + std dev: 15132.778 μs === parse/xmir === warmup: 3 iterations batches: 10 x 1 - total: 7506298.288 μs - avg: 750629.829 μs - min: 683506.496 μs - max: 819105.157 μs - std dev: 44112.176 μs + total: 7708084.189 μs + avg: 770808.419 μs + min: 701670.454 μs + max: 827995.748 μs + std dev: 39123.293 μs === rewrite/normalize === warmup: 3 iterations batches: 10 x 1 - total: 495636.638 μs - avg: 49563.664 μs - min: 48083.779 μs - max: 51678.568 μs - std dev: 1163.452 μs + total: 507305.249 μs + avg: 50730.525 μs + min: 48912.624 μs + max: 54335.144 μs + std dev: 1596.161 μs === print/sweet/multiline === warmup: 3 iterations batches: 10 x 1 - total: 4148167.742 μs - avg: 414816.774 μs - min: 390353.762 μs - max: 438468.832 μs - std dev: 15702.253 μs + total: 4188218.626 μs + avg: 418821.863 μs + min: 403263.572 μs + max: 449353.774 μs + std dev: 14512.853 μs === print/sweet/flat === warmup: 3 iterations batches: 10 x 1 - total: 4103860.150 μs - avg: 410386.015 μs - min: 400487.779 μs - max: 422099.714 μs - std dev: 6878.840 μs + total: 4025720.702 μs + avg: 402572.070 μs + min: 382540.835 μs + max: 428138.472 μs + std dev: 11933.717 μs === print/salty/multiline === warmup: 3 iterations batches: 10 x 1 - total: 13505706.601 μs - avg: 1350570.660 μs - min: 1323552.942 μs - max: 1388589.251 μs - std dev: 22111.111 μs + total: 14045902.469 μs + avg: 1404590.247 μs + min: 1384313.216 μs + max: 1438197.181 μs + std dev: 15501.328 μs === morph/symbolic/demo/e1 === warmup: 3 iterations batches: 10 x 1 - total: 16623322.804 μs - avg: 1662332.280 μs - min: 1634287.226 μs - max: 1712122.691 μs - std dev: 26925.390 μs + total: 880309.436 μs + avg: 88030.944 μs + min: 86359.252 μs + max: 90267.072 μs + std dev: 1248.861 μs === morph/symbolic/demo/e2 === - warmup: 2 iterations - batches: 4 x 1 - total: 18971323.304 μs - avg: 4742830.826 μs - min: 4710439.768 μs - max: 4785557.203 μs - std dev: 31923.645 μs + warmup: 3 iterations + batches: 10 x 1 + total: 1215850.964 μs + avg: 121585.096 μs + min: 117038.580 μs + max: 138033.783 μs + std dev: 5877.028 μs === morph/symbolic/demo/e3 === warmup: 3 iterations batches: 10 x 1 - total: 9393523.305 μs - avg: 939352.330 μs - min: 926573.125 μs - max: 955737.287 μs - std dev: 9251.489 μs + total: 1844780.073 μs + avg: 184478.007 μs + min: 180633.446 μs + max: 192191.924 μs + std dev: 3471.827 μs === morph/symbolic/demo/e4 === warmup: 3 iterations batches: 10 x 1 - total: 6172093.232 μs - avg: 617209.323 μs - min: 609699.156 μs - max: 622461.534 μs - std dev: 3958.833 μs + total: 617914.516 μs + avg: 61791.452 μs + min: 60976.930 μs + max: 62245.020 μs + std dev: 354.771 μs === morph/symbolic/demo/e5 === warmup: 3 iterations batches: 10 x 1 - total: 657478.162 μs - avg: 65747.816 μs - min: 64867.966 μs - max: 66985.074 μs - std dev: 698.720 μs + total: 185308.236 μs + avg: 18530.824 μs + min: 17898.792 μs + max: 19243.924 μs + std dev: 442.924 μs === morph/symbolic/native/e5 === - warmup: 0 iterations - batches: 1 x 1 - total: 24700300.710 μs - avg: 24700300.710 μs - min: 24700300.710 μs - max: 24700300.710 μs - std dev: 0.000 μs + warmup: 2 iterations + batches: 4 x 1 + total: 18057164.992 μs + avg: 4514291.248 μs + min: 4280917.084 μs + max: 4860213.506 μs + std dev: 215452.202 μs ``` The results were calculated in [this GHA job][benchmark-gha] -on 2026-09-18 at 21:12, +on 2026-09-20 at 06:19, on Linux with 4 CPUs. @@ -1463,4 +1463,4 @@ [jna-native]: https://github.com/java-native-access/jna/blob/master/src/com/sun/jna/Native.java [jeo]: https://github.com/objectionary/jeo-maven-plugin [issue-1291]: https://github.com/objectionary/phino/issues/1291 -[benchmark-gha]: https://github.com/objectionary/phino/actions/runs/35395119960 +[benchmark-gha]: https://github.com/objectionary/phino/actions/runs/35493401441 diff --git a/phino.cabal b/phino.cabal --- a/phino.cabal +++ b/phino.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: phino -version: 0.0.134 +version: 0.0.135 license: MIT synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions description: Please see the README on GitHub at diff --git a/src/Builder.hs b/src/Builder.hs --- a/src/Builder.hs +++ b/src/Builder.hs @@ -158,6 +158,9 @@ dispatched <- buildExpression ex subst at' <- buildAttribute at subst Right (ExDispatch dispatched at') +buildExpression (ExApplication ExRoot (ArTau AtRho expr)) subst = do + _ <- buildExpression expr subst + Right ExRoot buildExpression (ExApplication expr arg) subst = do applied <- buildExpression expr subst arg' <- buildArgument arg subst diff --git a/src/Files.hs b/src/Files.hs --- a/src/Files.hs +++ b/src/Files.hs @@ -10,7 +10,7 @@ import Control.Exception (Exception, onException, throwIO) import Control.Monad (forM, when) -import System.Directory (copyPermissions, doesDirectoryExist, doesFileExist, listDirectory, removeFile, renameFile) +import System.Directory (copyPermissions, doesDirectoryExist, doesFileExist, listDirectory, pathIsSymbolicLink, removeFile, renameFile) import System.FilePath (takeDirectory, takeFileName, ()) import System.IO (Handle, hClose, hPutStr, hSetEncoding, openTempFileWithDefaultPermissions, utf8) import Text.Printf (printf) @@ -53,9 +53,13 @@ forM nested ( \path -> do + isLink <- pathIsSymbolicLink path isDir <- doesDirectoryExist path - if isDir - then allPathsIn path - else return [path] + if isLink + then return [] + else + if isDir + then allPathsIn path + else return [path] ) return (concat paths) diff --git a/src/Lambdas.hs b/src/Lambdas.hs --- a/src/Lambdas.hs +++ b/src/Lambdas.hs @@ -271,9 +271,10 @@ readLambdas path = do entries <- Yaml.decodeFileEither path >>= either broken pure mapM_ (unique entries) entries - registered <- Lambdas <$> mapM keyed entries + registered <- mapM keyed entries + overlaps path registered logDebug (printf "Loaded %d λ function(s) from '%s'" (length entries) path) - pure registered + pure (Lambdas registered) where broken :: Yaml.ParseException -> IO [Lambda] broken failure = throwIO (BrokenLambdas path (Yaml.prettyPrintParseException failure)) @@ -294,6 +295,25 @@ unreadable :: Text -> (a, String) -> IO b unreadable key (_, failure) = throwIO (BrokenLambdas path (printf "the key '%s' is not a regular expression: %s" (T.unpack key) failure)) + + overlaps :: FilePath -> [(Regex, Lambda)] -> IO () + overlaps file = check + where + check :: [(Regex, Lambda)] -> IO () + check [] = pure () + check ((first, left) : rest) = do + mapM_ (pair first left) rest + check rest + pair :: Regex -> Lambda -> (Regex, Lambda) -> IO () + pair first left (second, right) + | matchTest first (encodeUtf8 right._key) + || matchTest second (encodeUtf8 left._key) = + throwIO + ( BrokenLambdas + file + (printf "the keys '%s' and '%s' match some of the same lambda names" (T.unpack left._key) (T.unpack right._key)) + ) + | otherwise = pure () -- The entry whose key matches the whole λ name, if any. There is at most one: -- the keys are unique, so a name either has a λ function or has none at all. diff --git a/src/Regexp.hs b/src/Regexp.hs --- a/src/Regexp.hs +++ b/src/Regexp.hs @@ -6,8 +6,9 @@ import Control.Exception import Data.Array (bounds, (!)) import qualified Data.ByteString.Char8 as B -import Data.Char (isDigit) +import Data.Char (isDigit, ord) import Data.Maybe (fromMaybe) +import Text.Read (readMaybe) import qualified Text.Regex.PCRE.ByteString as R compile :: B.ByteString -> IO R.Regex @@ -51,8 +52,9 @@ in if null digits then B.singleton '$' : go rest else - let idx = read digits - val = fromMaybe (B.pack ('$' : digits)) (safeIndex idx groups) + let val = case readMaybe digits of + Nothing -> B.pack ('$' : digits) + Just idx -> fromMaybe (B.pack ('$' : digits)) (safeIndex idx groups) in val : go afterDigits go (c : rest) = B.singleton c : go rest safeIndex :: Int -> [B.ByteString] -> Maybe B.ByteString @@ -91,8 +93,25 @@ let replacement = substituteGroups rep groups if len == 0 then - let next = B.take 1 rest2 + let next = B.take (utf8Width rest2) rest2 in if B.null next then return $ B.concat [acc, before, replacement] - else go (B.drop 1 rest2) (B.concat [acc, before, replacement, next]) + else go (B.drop (B.length next) rest2) (B.concat [acc, before, replacement, next]) else go rest2 (B.concat [acc, before, replacement]) + utf8Width :: B.ByteString -> Int + utf8Width bytes = + case B.uncons bytes of + Nothing -> 0 + Just (lead, rest) + | ord lead < 0xC0 -> 1 + | ord lead < 0xE0 -> continuationWidth 2 rest + | ord lead < 0xF0 -> continuationWidth 3 rest + | ord lead < 0xF8 -> continuationWidth 4 rest + | otherwise -> 1 + continuationWidth :: Int -> B.ByteString -> Int + continuationWidth width rest = + if B.length rest >= width - 1 && B.all isContinuation (B.take (width - 1) rest) + then width + else 1 + isContinuation :: Char -> Bool + isContinuation byte = ord byte >= 0x80 && ord byte < 0xC0 diff --git a/src/XMIR.hs b/src/XMIR.hs --- a/src/XMIR.hs +++ b/src/XMIR.hs @@ -160,7 +160,9 @@ formationBinding (BiTau AtRho expr) ctx = Just <$> namedBinding (show AtRho) expr ctx formationBinding (BiTau AtPhi expr) ctx = Just <$> namedBinding (show AtPhi) expr ctx formationBinding (BiDelta bytes) _ = pure (Just (NodeContent (T.pack (printBytes bytes)))) -formationBinding (BiLambda (Function name)) _ = pure (Just (object [("name", show AtLambda)] [NodeContent name])) +formationBinding (BiLambda (Function name)) _ + | "Φ." `T.isPrefixOf` name = pure (Just (object [("atom", T.unpack name), ("name", show AtLambda)] [])) + | otherwise = pure (Just (object [("name", show AtLambda)] [NodeContent name])) formationBinding (BiVoid AtRho) _ = pure Nothing formationBinding (BiVoid AtPhi) _ = pure (Just (object [("name", show AtPhi), ("base", "∅")] [])) formationBinding (BiVoid (AtLabel label)) _ = pure (Just (object [("name", T.unpack label), ("base", "∅")] [])) @@ -481,7 +483,7 @@ | not (hasAttr "base" cur) = do name <- getAttr "name" cur case name of - "λ" -> BiLambda . Function <$> lambdaFunction + "λ" -> BiLambda . Function <$> atomOrLambda ('α' : _) -> throwIO (InvalidXMIRFormat "Formation child @name can't start with α" cur) "φ" -> BiTau AtPhi <$> xmirToFormation cur (name : fqn) "ρ" -> BiTau AtRho <$> xmirToFormation cur (name : fqn) @@ -503,6 +505,11 @@ -- The λ function name is carried by the text of the marker element. XMIR -- coming from elsewhere holds no name, so fall back to the position in the -- tree, which is the only hint left + atomOrLambda :: IO T.Text + atomOrLambda + | hasAttr "atom" cur = T.pack <$> getAttr "atom" cur + | otherwise = lambdaFunction + lambdaFunction :: IO T.Text lambdaFunction | hasText cur = T.strip . T.pack <$> getText cur @@ -641,5 +648,5 @@ getText :: C.Cursor -> IO String getText cur = case [t | c <- C.child cur, NodeContent t <- [C.node c]] of - (t : _) -> pure (T.unpack t) [] -> throwIO (InvalidXMIRFormat "Text content inside element can't be empty" cur) + texts -> pure (T.unpack (T.concat texts)) diff --git a/src/Yaml.hs b/src/Yaml.hs --- a/src/Yaml.hs +++ b/src/Yaml.hs @@ -99,61 +99,59 @@ ] instance FromJSON Condition where - parseJSON = - withObject - "Condition" - ( \v -> do - validateYamlObject v ["and", "or", "not", "nf", "absolute", "eq", "gt", "in", "matches", "part-of", "disjoint", "formation"] - asum - [ do - conds <- v .: "and" - if null conds - then fail "The 'and' condition requires at least one element" - else pure (And conds) - , do - conds <- v .: "or" - if null conds - then fail "The 'or' condition requires at least one element" - else pure (Or conds) - , Not <$> v .: "not" - , NF <$> v .: "nf" - , Absolute <$> v .: "absolute" - , IsFormation <$> v .: "formation" - , do - vals <- v .: "disjoint" - case vals of - [attrs_, bds_] -> Disjoint <$> parseJSON attrs_ <*> parseJSON bds_ - _ -> fail "'disjoint' expects exactly two arguments" - , do - vals <- v .: "eq" - case vals of - [left_, right_] -> Eq <$> parseJSON left_ <*> parseJSON right_ - _ -> fail "'eq' expects exactly two arguments" - , do - vals <- v .: "gt" - case vals of - [left_, right_] -> Gt <$> parseJSON left_ <*> parseJSON right_ - _ -> fail "'gt' expects exactly two arguments" - , do - vals <- v .: "in" - case vals of - [attr_, binding_] -> do - attr <- parseJSON attr_ - bd <- parseJSON binding_ - pure (In attr bd) - _ -> fail "'in' expects exactly two arguments" - , do - vals <- v .: "matches" - case vals of - [pat, ex] -> Matches <$> parseJSON pat <*> parseJSON ex - _ -> fail "'matches' expects exactly two arguments" - , do - vals <- v .: "part-of" - case vals of - [ex, bd] -> PartOf <$> parseJSON ex <*> parseJSON bd - _ -> fail "'part-of' expects exactly two arguments" - ] - ) + parseJSON = withObject "Condition" parseCondition + +parseCondition :: Object -> Parser Condition +parseCondition v = do + validateYamlObject v ["and", "or", "not", "nf", "absolute", "eq", "gt", "in", "matches", "part-of", "disjoint", "formation"] + case KeyMap.keys v of + [key] -> case Key.toString key of + "and" -> do + conds <- v .: "and" + if null conds + then fail "The 'and' condition requires at least one element" + else pure (And conds) + "or" -> do + conds <- v .: "or" + if null conds + then fail "The 'or' condition requires at least one element" + else pure (Or conds) + "not" -> Not <$> v .: "not" + "nf" -> NF <$> v .: "nf" + "absolute" -> Absolute <$> v .: "absolute" + "formation" -> IsFormation <$> v .: "formation" + "disjoint" -> do + vals <- v .: "disjoint" + case vals of + [attrs_, bds_] -> Disjoint <$> parseJSON attrs_ <*> parseJSON bds_ + _ -> fail "'disjoint' expects exactly two arguments" + "eq" -> do + vals <- v .: "eq" + case vals of + [left_, right_] -> Eq <$> parseJSON left_ <*> parseJSON right_ + _ -> fail "'eq' expects exactly two arguments" + "gt" -> do + vals <- v .: "gt" + case vals of + [left_, right_] -> Gt <$> parseJSON left_ <*> parseJSON right_ + _ -> fail "'gt' expects exactly two arguments" + "in" -> do + vals <- v .: "in" + case vals of + [attr_, binding_] -> In <$> parseJSON attr_ <*> parseJSON binding_ + _ -> fail "'in' expects exactly two arguments" + "matches" -> do + vals <- v .: "matches" + case vals of + [pat, ex] -> Matches <$> parseJSON pat <*> parseJSON ex + _ -> fail "'matches' expects exactly two arguments" + "part-of" -> do + vals <- v .: "part-of" + case vals of + [ex, bd] -> PartOf <$> parseJSON ex <*> parseJSON bd + _ -> fail "'part-of' expects exactly two arguments" + _ -> fail "Unknown condition type" + _ -> fail "Exactly one condition type is expected" instance FromJSON ExtraArgument where parseJSON v = diff --git a/test/BuilderSpec.hs b/test/BuilderSpec.hs --- a/test/BuilderSpec.hs +++ b/test/BuilderSpec.hs @@ -246,3 +246,10 @@ buildBinding (BiMeta "B") (substSingle "B" (MvBindings [BiVoid AtRho, BiVoid AtRho])) `shouldSatisfy` isLeft it "build formation with duplicates" $ buildExpression (ExMeta "e") (substSingle "e" (MvExpression (ExFormation [BiVoid AtRho, BiVoid AtRho]))) `shouldSatisfy` isLeft + + describe "buildExpression" $ + it "does not leave an invalid global application around rho" $ + buildExpression + (ExApplication ExRoot (ArTau AtRho (ExFormation [BiVoid AtRho]))) + substEmpty + `shouldBe` Right ExRoot diff --git a/test/FilesSpec.hs b/test/FilesSpec.hs --- a/test/FilesSpec.hs +++ b/test/FilesSpec.hs @@ -13,6 +13,7 @@ import Files (FsException (..), allPathsIn, ensuredFile, overwrite) import System.Directory ( createDirectoryIfMissing + , createDirectoryLink , executable , getPermissions , getTemporaryDirectory @@ -92,6 +93,18 @@ it "returns an empty list for an empty directory" $ withScratchDir $ \dir -> do paths <- allPathsIn dir paths `shouldBe` [] + + it "does not follow symbolic links to directories" $ withScratchDir $ \dir -> do + let nested = dir "nested" + link = nested "back" + createDirectoryIfMissing True nested + writeFile (dir "top.txt") "top" + if os == "mingw32" + then pendingWith "Windows does not create directory symbolic links without elevated privileges" + else do + createDirectoryLink ".." link + paths <- allPathsIn dir + sort paths `shouldBe` [dir "top.txt"] describe "FsException" $ do forM_ diff --git a/test/LambdasSpec.hs b/test/LambdasSpec.hs --- a/test/LambdasSpec.hs +++ b/test/LambdasSpec.hs @@ -138,6 +138,11 @@ , ("an entry with no answer at all", "- λ: L_pair\n", "cannot be read") , ("an entry whose answer is no term of the calculus", "- λ: L_pair\n 𝑛: ⟦ λ ⤍\n", "cannot be read") , ("two entries under one key", entry "L_pair" <> entry "L_pair", "is used by more than one entry") + , + ( "two entries with overlapping regular expressions" + , entry "L_(foo|bar)" <> entry "L_foo" + , "match some of the same lambda names" + ) , ("a key which is no regular expression", entry "L_[pair", "is not a regular expression") , ("an operand of 'dataize' which is no bytes meta", "- λ: L_pair\n dataize:\n 𝑛1: $.x\n 𝑛: ⟦ λ ⤍ 𝜎 ⟧\n", "is not a bytes meta") , ("an operand of 'morph' which is no expression meta", "- λ: L_pair\n morph:\n 𝛿1: $.x\n 𝑛: ⟦ λ ⤍ 𝜎 ⟧\n", "is not an expression meta") diff --git a/test/RegexpSpec.hs b/test/RegexpSpec.hs --- a/test/RegexpSpec.hs +++ b/test/RegexpSpec.hs @@ -77,6 +77,12 @@ , ("substitutes multiple groups", "$1-$2", ["full", "a", "b"], "a-b") , ("keeps dollar sign when no digits follow", "$ test", ["x"], "$ test") , ("keeps original reference for out of bounds index", "$9", ["only"], "$9") + , + ( "keeps an oversized group reference literal" + , "$999999999999999999999999999999999999999999" + , ["only"] + , "$999999999999999999999999999999999999999999" + ) , ("handles replacement without group references", "plain", ["x"], "plain") , ("handles empty replacement", "", ["x"], "") , ("handles empty groups list with reference", "$0", [], "$0") @@ -128,6 +134,7 @@ , ("handles word boundary", "\\bword\\b", "WORD", "word in a word", "WORD in a WORD") , ("terminates on an empty-match pattern (anchored ^)", "^", "X", "hello", "XhXeXlXlXoX") , ("terminates on an empty regex pattern", "", "X", "hello", "XhXeXlXlXoX") + , ("keeps UTF-8 characters together after an empty match", "(?=.)", "X", "é", "Xé") ] ( \(desc, pattern, replacement, input, expected) -> it desc $ do regex <- R.compile (B.pack pattern) diff --git a/test/XMIRSpec.hs b/test/XMIRSpec.hs --- a/test/XMIRSpec.hs +++ b/test/XMIRSpec.hs @@ -233,6 +233,15 @@ expr <- xmirToPhi doc parseExpressionThrows (printExpression expr) `shouldReturn` expr + describe "atom result types in XMIR" $ + it "survives a round trip through a λ marker" $ do + doc <- parseXMIRThrows "" + expr <- xmirToPhi doc + result <- expressionToXMIR expr defaultXmirContext + let printed = printXMIR result + printed `shouldContain` "atom=\"Φ.number\"" + printed `shouldNotContain` "" + describe "--hide-rho in XMIR" $ it "drops every bound ρ from the printed document" $ do expr <- parseExpressionThrows "[[ x -> 4, ^ -> [[ y -> 5 ]] ]]" @@ -373,6 +382,13 @@ expr <- parseExpressionThrows "[[ x -> \"foo\" ]]" xmir' <- expressionToXMIR expr commentedContext printXMIR xmir' `shouldContain` "" + + it "keeps text on both sides of a comment inside an object" $ do + split <- parseXMIRThrows "foobar" + joined <- parseXMIRThrows "foobar" + actual <- xmirToPhi split + expected <- xmirToPhi joined + actual `shouldBe` expected describe "XMIR printing edge cases" $ do it "wraps a chained dispatch on a formation literal with a @base attribute" $ do diff --git a/test/YamlSpec.hs b/test/YamlSpec.hs --- a/test/YamlSpec.hs +++ b/test/YamlSpec.hs @@ -247,19 +247,15 @@ Right _ -> expectationFailure "expected decoding to fail" describe "rejects a condition whose arguments count is wrong" $ - -- 'asum' discards each branch's specific failure message once every - -- branch has failed, so only the overall Left/Right outcome (not the - -- message text) is observable from here; each case still exercises the - -- condition's own "expects exactly two arguments" guard internally. forM_ - [ ("'eq' with a single argument", "eq: [1]") - , ("'gt' with a single argument", "gt: [1]") - , ("'in' with a single argument", "in: ['!t']") - , ("'matches' with a single argument", "matches: ['hi']") - , ("'part-of' with a single argument", "part-of: ['!e']") - , ("'disjoint' with a single argument", "disjoint: [[]]") + [ ("'eq' with a single argument", "eq: [1]", "'eq' expects exactly two arguments") + , ("'gt' with a single argument", "gt: [1]", "'gt' expects exactly two arguments") + , ("'in' with a single argument", "in: ['!t']", "'in' expects exactly two arguments") + , ("'matches' with a single argument", "matches: ['hi']", "'matches' expects exactly two arguments") + , ("'part-of' with a single argument", "part-of: ['!e']", "'part-of' expects exactly two arguments") + , ("'disjoint' with a single argument", "disjoint: [[]]", "'disjoint' expects exactly two arguments") ] - (\(desc, yaml) -> it desc ((decodeYaml' yaml :: Either Yaml.ParseException Condition) `shouldSatisfy` isLeft)) + (\(desc, yaml, message) -> it desc ((decodeYaml' yaml :: Either Yaml.ParseException Condition) `shouldSatisfy` failsWith message)) describe "rejects a malformed premise" $ forM_