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.127 +cabal install --overwrite-policy=always phino-0.0.128 phino --version ``` @@ -900,55 +900,55 @@ === parse/phi === warmup: 3 iterations batches: 10 x 1 - total: 1796596.921 μs - avg: 179659.692 μs - min: 164919.877 μs - max: 207942.466 μs - std dev: 16799.590 μs + total: 1234878.258 μs + avg: 123487.826 μs + min: 114898.378 μs + max: 147448.578 μs + std dev: 12608.859 μs === parse/xmir === warmup: 3 iterations batches: 10 x 1 - total: 7612275.214 μs - avg: 761227.521 μs - min: 709200.274 μs - max: 813312.545 μs - std dev: 30787.560 μs + total: 6115346.630 μs + avg: 611534.663 μs + min: 553273.770 μs + max: 658997.433 μs + std dev: 26432.183 μs === rewrite/normalize === warmup: 3 iterations batches: 10 x 1 - total: 641726.516 μs - avg: 64172.652 μs - min: 59940.799 μs - max: 76191.091 μs - std dev: 4666.243 μs + total: 521385.086 μs + avg: 52138.509 μs + min: 46636.826 μs + max: 63889.183 μs + std dev: 5808.082 μs === print/sweet/multiline === warmup: 3 iterations batches: 10 x 1 - total: 4232626.830 μs - avg: 423262.683 μs - min: 402756.415 μs - max: 452617.626 μs - std dev: 15405.204 μs + total: 3741073.589 μs + avg: 374107.359 μs + min: 344671.911 μs + max: 406026.195 μs + std dev: 18304.000 μs === print/sweet/flat === warmup: 3 iterations batches: 10 x 1 - total: 4143560.984 μs - avg: 414356.098 μs - min: 398710.605 μs - max: 431760.505 μs - std dev: 10740.809 μs + total: 3807236.850 μs + avg: 380723.685 μs + min: 366420.230 μs + max: 395219.831 μs + std dev: 9900.160 μs === print/salty/multiline === warmup: 3 iterations batches: 10 x 1 - total: 14017459.280 μs - avg: 1401745.928 μs - min: 1380342.970 μs - max: 1418756.423 μs - std dev: 14496.070 μs + total: 11573351.855 μs + avg: 1157335.186 μs + min: 1122778.266 μs + max: 1213750.752 μs + std dev: 26107.625 μs ``` The results were calculated in [this GHA job][benchmark-gha] -on 2026-09-11 at 08:17, +on 2026-09-11 at 18:19, on Linux with 4 CPUs. @@ -997,4 +997,4 @@ [jna]: https://github.com/java-native-access/jna [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 -[benchmark-gha]: https://github.com/objectionary/phino/actions/runs/34577695934 +[benchmark-gha]: https://github.com/objectionary/phino/actions/runs/34632126707 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.128 +version: 0.0.129 license: MIT synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions description: Please see the README on GitHub at diff --git a/src/Dataize.hs b/src/Dataize.hs --- a/src/Dataize.hs +++ b/src/Dataize.hs @@ -142,22 +142,28 @@ isLambda (BiLambda _) = True isLambda _ = False --- The same as 'lambda', but only for a formation that is saturated: one with no --- void binding left in it. A void is an argument the program has not given yet, --- so such a formation is a method waiting to be applied rather than an --- application waiting to be computed, and firing it would hand the atom a ∅ --- where it expects a value. 𝔻 needs no such guard, since it fires only what --- dataization demands and nothing demands a method; the deep walk meets every --- one a program declares — the method table of the object model above all — so --- it asks first (see 'deepened'). +-- The same as 'lambda', but only for a formation that is saturated: one with +-- every binding of it filled (see 'filled'). A void is an argument the program +-- has not given yet, so such a formation is a method waiting to be applied +-- rather than an application waiting to be computed, and firing it would hand +-- the atom a ∅ where it expects a value. 𝔻 needs no such guard, since it +-- fires only what dataization demands and nothing demands a method; the deep +-- walk meets every one a program declares — the method table of the object +-- model above all — so it asks first (see 'deepened'). saturated :: [Binding] -> Maybe (T.Text, Expression) saturated bds = case lambda bds of Just (func, ExFormation rest) | all filled rest -> Just (func, ExFormation rest) _ -> Nothing - where - filled :: Binding -> Bool - filled (BiVoid _) = False - filled _ = True + +-- Whether a binding hands the formation something to work with. A void does +-- not: it names an argument the program has still to supply. Neither does ⊥: +-- the deep walk reduces a body in the scope of the formation around it, and a +-- formation standing unapplied still holds ρ ↦ ∅, so a ξ.ρ in that body comes +-- back as ⊥ rather than as the object the next dispatch supplies (#1196). +filled :: Binding -> Bool +filled (BiVoid _) = False +filled (BiTau _ ExTermination) = False +filled _ = True -- Run one frame of the 𝕄/𝔻 spine, attaching its derivation to a stuck atom or -- an exhausted budget escaping it. 'Stuck' is raised deep inside an atom, which diff --git a/src/Merge.hs b/src/Merge.hs --- a/src/Merge.hs +++ b/src/Merge.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT @@ -45,7 +46,17 @@ ys' = [y | y <- ys, attributeFromBinding y `notElem` as] collisions = [(x, y) | x <- xs, y <- ys, attributeFromBinding x == attributeFromBinding y] ws <- mapM (uncurry mergeBinding) collisions - pure (xs' <> ys' <> ws) + pure (unmarked (xs' <> ys' <> ws)) + where + -- A 'Package' λ marks a pure path segment; when only one side carries it, + -- the other side is a real object and the marker goes away (#1197) + unmarked :: [Binding] -> [Binding] + unmarked bindings + | any marker xs == any marker ys = bindings + | otherwise = filter (not . marker) bindings + marker :: Binding -> Bool + marker (BiLambda (Function "Package")) = True + marker _ = False merge' :: [Expression] -> IO Expression merge' [] = throwIO EmptyExpressionList diff --git a/test/DataizeSpec.hs b/test/DataizeSpec.hs --- a/test/DataizeSpec.hs +++ b/test/DataizeSpec.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT @@ -10,18 +13,23 @@ import Atoms (Registry, emptyRegistry, readRegistry) import Control.Exception (SomeException) import Control.Monad +import Data.Aeson (FromJSON) import Data.IORef (modifyIORef', newIORef, readIORef) import Data.List (find, isInfixOf, nub) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (fromMaybe, isJust) +import Data.Yaml qualified as Decode import Dataize (DataizeContext (..), Outcome (..), Steps (..), dataize, dataize', emptyState, execBuildTerm, insideUniverse, morph, morph') import Deps (Evaluation (..), Term (TeExpression), dontSaveEval, dontSaveStep) +import Files (allPathsIn) import Fixtures (fixtureRegistry, withNode, withServing, withShell) import Functions (buildTerm) +import GHC.Generics (Generic) import Matcher (substEmpty) import Parser (parseExpressionThrows) import Rewriter (Rewritten) import Rule (RuleContext (RuleContext), matchExpressionWithRule') +import System.FilePath (makeRelative) import Test.Hspec import Yaml (ExtraArgument (..)) import Yaml qualified @@ -71,20 +79,47 @@ (morphed, _) <- morph expr (defaultDataizeContext loc') morphed `shouldBe` expected --- The same as 'testMorph', with the deep walk on ('_deep') and the fixture λ --- functions registered, since a case that reduces anything has to fire one: it --- is pending where 'node' is not installed. -testDeep :: Registry -> [(String, String, String, String)] -> Spec -testDeep registry useCases = - forM_ useCases $ \(name, loc, src, res) -> - it name $ - withNode $ do - expr <- parseExpressionThrows src - loc' <- parseExpressionThrows loc - expected <- parseExpressionThrows res - (morphed, _) <- morph expr (withAtoms registry (defaultDataizeContext loc')){_deep = True} - morphed `shouldBe` expected +-- One case of the deep walk, as a pack of 'test-resources/morph-deep-packs' +-- spells it: the program under 'input', wrapped in the fixture object model +-- where 'model' says so and run against the fixture λ functions where 'atoms' +-- does, entered at 'location' and answering either the program under 'result' +-- or the failure under 'fails'. +data DeepPack = DeepPack + { location :: Maybe String + , input :: String + , model :: Maybe Bool + , atoms :: Maybe Bool + , partial :: Maybe Bool + , result :: Maybe String + , fails :: Maybe String + } + deriving (Generic, Show, FromJSON) +-- Walk one such pack with '_deep' on and check what it answers. A pack that +-- registers the fixture λ functions fires one under 'node', so it is pending +-- where 'node' is not installed. +testDeep :: Registry -> FilePath -> Expectation +testDeep registry pth = do + DeepPack{..} <- Decode.decodeFileThrow pth + expr <- parseExpressionThrows (if model == Just True then primitives input else input) + loc <- parseExpressionThrows (fromMaybe "Q" location) + let ctx = + (defaultDataizeContext loc) + { _deep = True + , _partial = partial == Just True + , _atoms = if atoms == Just True then registry else emptyRegistry + } + checked :: Expectation + checked = case (result, fails) of + (Just res, Nothing) -> do + expected <- parseExpressionThrows res + (morphed, _) <- morph expr ctx + morphed `shouldBe` expected + (Nothing, Just message) -> + morph expr ctx `shouldThrow` (\err -> message `isInfixOf` show (err :: SomeException)) + _ -> expectationFailure "The pack holds neither a single 'result' nor a single 'fails'" + if atoms == Just True then withNode checked else checked + -- The EO objects the fixture λ functions answer for, declared the way -- 'number.eo' and 'bytes.eo' declare them, so a case below only has to spell -- the expression under φ. 'number.eq' is the one operation with no atom of its @@ -216,76 +251,9 @@ -- atom touched keeps the shape it was written in and the answer stays a -- program. describe "morph with '_deep'" $ do - testDeep - registry - [ - ( "stands the answer of the λ that 'mf' left bare in its place" - , "Q.@" - , primitives "[[ x -> 5.plus( 6 ) ]]" - , "[[ x -> Q.number( φ -> Φ.bytes( φ ↦ ⟦ Δ ⤍ 40-26-00-00-00-00-00-00 ⟧ ) ) ]]" - ) - , - ( "fires the atom nested in the argument of the atom it fires" - , "Q.@" - , primitives "[[ x -> 5.plus( 6.plus( 7 ) ) ]]" - , "[[ x -> Q.number( φ -> Φ.bytes( φ ↦ ⟦ Δ ⤍ 40-32-00-00-00-00-00-00 ⟧ ) ) ]]" - ) - , - ( "keeps the answer of the last atom fired along one chain of them" - , "Q.@" - , primitives "[[ x -> 5.plus( 6 ).plus( 7 ) ]]" - , "[[ x -> Q.number( φ -> Φ.bytes( φ ↦ ⟦ Δ ⤍ 40-32-00-00-00-00-00-00 ⟧ ) ) ]]" - ) - , - ( "resolves the ξ of a binding against the formation that holds it" - , "Q.@" - , primitives "[[ n -> 5, x -> $.n.plus( 6 ) ]]" - , "[[ n -> 5, x -> Q.number( φ -> Φ.bytes( φ ↦ ⟦ Δ ⤍ 40-26-00-00-00-00-00-00 ⟧ ) ) ]]" - ) - , -- The registry carries no 'L_number_nope', so there is nothing to fire - -- and the binding keeps the name it was written under - - ( "leaves the λ the registry does not serve as it was written" - , "Q.@" - , primitives "[[ x -> 5.nope ]]" - , "[[ x -> 5.nope ]]" - ) - , -- A λ-formation whose bindings are still void is a method waiting to be - -- applied, not an application waiting to be computed: nothing demands - -- one, so 𝔻 never meets one, while the walk meets every one the object - -- model declares. Both the void ρ of 'not' and the void 'b' of 'eq' - -- keep their atoms unfired here. - - ( "leaves a λ-formation still waiting for its arguments alone" - , "Q.bytes" - , primitives "[[ ]]" - , "[[ φ -> ?, not -> [[ L> L_bytes_not ]], eq -> [[ b -> ?, L> L_bytes_eq ]] ]]" - ) - , -- Nothing demands the argument of an atom that cannot fire, so 𝔻 never - -- reaches it; the walk does, and the atom around it stays in place - - ( "walks into the argument of an atom it cannot fire" - , "Q.@" - , primitives "[[ x -> [[ y -> ?, L> L_bar ]]( y -> 6.plus( 7 ) ) ]]" - , "[[ x -> [[ y -> ?, L> L_bar ]]( y -> Q.number( φ -> Φ.bytes( φ ↦ ⟦ Δ ⤍ 40-2A-00-00-00-00-00-00 ⟧ ) ) ) ]]" - ) - ] - - -- An atom deeper on a binding's spine gets stuck exactly as it does under - -- 𝕄 alone: the run fails, unless '_partial' parks it, and then the binding - -- stays as it was written and the walk goes on - describe "a stuck atom on the spine of a binding" $ do - let stuck :: IO Expression - stuck = parseExpressionThrows "[[ x -> [[ L> Sym_arg_0 ]].foo ]]" - it "fails the run without '_partial'" $ do - expr <- stuck - morph expr (defaultDataizeContext ExRoot){_deep = True} - `shouldThrow` (\e -> "Atom 'Sym_arg_0' does not exist" `isInfixOf` show (e :: SomeException)) - - it "leaves the binding as it was written under '_partial'" $ do - expr <- stuck - (morphed, _) <- morph expr (defaultDataizeContext ExRoot){_deep = True, _partial = True} - morphed `shouldBe` expr + let resources = "test-resources/morph-deep-packs" + packs <- runIO (allPathsIn resources) + forM_ packs (\pth -> it (makeRelative resources pth) (testDeep registry pth)) -- The walk enters a dispatch through its target and fires the box it finds -- there before 𝕄 is ever asked about the dispatch, while 'ml' demands that diff --git a/test/MergeSpec.hs b/test/MergeSpec.hs --- a/test/MergeSpec.hs +++ b/test/MergeSpec.hs @@ -1,95 +1,77 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} + -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT +{- | Tests for the Merge module that unites a few top level formations +into a single one. +-} module MergeSpec where import AST (Expression) import Control.Exception (SomeException, try) import Control.Monad (forM_) -import Data.List (intercalate) +import Data.Aeson +import Data.Yaml qualified as Yaml +import Files (allPathsIn) +import GHC.Generics (Generic) import Merge (merge) import Parser (parseExpressionThrows) -import Test.Hspec (Spec, anyException, describe, it, shouldBe, shouldContain, shouldThrow) +import Printer (printExpression) +import System.FilePath +import Test.Hspec +import Text.Printf (printf) +data YamlPack = YamlPack + { left :: String + , right :: String + , result :: Maybe String + , fails :: Maybe String + } + deriving (Generic, Show, FromJSON) + +yamlPack :: FilePath -> IO YamlPack +yamlPack = Yaml.decodeFileThrow + spec :: Spec spec = do - describe "merge expressions" $ - forM_ - [ - ( ["[[ x -> 1 ]]", "[[ y -> 2 ]]"] - , "[[ x -> 1, y -> 2 ]]" - ) - , - ( ["[[ x -> [[ y -> 1 ]] ]]", "[[ x -> [[ z -> 2 ]] ]]"] - , "[[ x -> [[ y -> 1, z -> 2 ]] ]]" - ) - , - ( ["[[ x -> 1 ]]", "[[ x -> 1]]"] - , "[[ x -> 1]]" - ) - , - ( ["[[ org -> [[ eolang -> [[ number -> [[ ]] ]] ]] ]]", "[[ org -> [[ eolang -> [[ bytes -> [[ ]] ]] ]] ]]"] - , "[[ org -> [[ eolang -> [[ number -> [[ ]], bytes -> [[ ]] ]] ]] ]]" - ) - , - ( ["[[ x -> 1 ]]", "[[ y -> 2 ]]", "[[ z -> 3 ]]"] - , "[[ x -> 1, y -> 2, z -> 3 ]]" - ) - , - ( ["[[ x -> ? ]]", "[[ x -> ? ]]"] - , "[[ x -> ? ]]" - ) - , - ( ["[[ D> 42-, x -> [[ ]] ]]", "[[ D> 42-, y -> [[ ]] ]]"] - , "[[ x -> [[ ]], y -> [[ ]], D> 42- ]]" - ) - ] - ( \(exprs, res) -> it res $ do - parsed <- mapM parseExpressionThrows exprs - merged <- merge parsed - res' <- parseExpressionThrows res - merged `shouldBe` res' - ) - - describe "fails to merge" $ + describe "merge packs" $ do + let resources = "test-resources/merge-packs" + packs <- runIO (allPathsIn resources) forM_ - [ ["Q", "$"] - , ["[[ x -> 1]]", "[[ x -> 2 ]]"] - , ["[[ x -> [[ y -> Q ]] ]]", "[[ x -> [[ y -> $ ]] ]]"] - ] - ( \exprs -> it (intercalate " and " exprs) $ do - parsed <- mapM parseExpressionThrows exprs - merge parsed `shouldThrow` anyException + packs + ( \pth -> it (makeRelative resources pth) $ do + YamlPack{..} <- yamlPack pth + parsed <- mapM parseExpressionThrows [left, right] + case (result, fails) of + (Just expected, Nothing) -> do + merged <- merge parsed + expected' <- parseExpressionThrows expected + merged `shouldBe` expected' + (Nothing, Just message) -> do + thrown <- try (merge parsed) :: IO (Either SomeException Expression) + case thrown of + Left err -> show err `shouldContain` message + Right merged -> expectationFailure (printf "Merge united the sides into %s, while the pack expects it to fail" (printExpression merged)) + _ -> expectationFailure "The pack holds neither a single 'result' nor a single 'fails'" ) - describe "merge exception messages" $ - forM_ - [ - ( "EmptyExpressionList explains there is nothing to merge" - , [] - , "Nothing to merge: provide at least one expression" - ) - , - ( "WrongExpressionFormat renders the offending non-formation expression" - , ["Q"] - , "Invalid expression format" - ) - , - ( "CanNotMergeBinding renders both conflicting bindings" - , ["[[ x -> 1 ]]", "[[ x -> 2 ]]"] - , "Can't merge two bindings, conflict found" - ) - ] - ( \(desc, exprs, message) -> it desc $ do - parsed <- mapM parseExpressionThrows exprs - result <- try (merge parsed) :: IO (Either SomeException Expression) - case result of - Left err -> show err `shouldContain` message - Right _ -> fail ("expected merge to throw for: " ++ desc) - ) + describe "merges a list of any length" $ do + it "unites three formations into one" $ do + parsed <- mapM parseExpressionThrows ["[[ x -> 1 ]]", "[[ y -> 2 ]]", "[[ z -> 3 ]]"] + merged <- merge parsed + expected <- parseExpressionThrows "[[ x -> 1, y -> 2, z -> 3 ]]" + merged `shouldBe` expected - describe "merge of a single expression" $ - it "returns that expression unchanged" $ do + it "returns a lonely formation untouched" $ do parsed <- parseExpressionThrows "[[ x -> 1 ]]" merged <- merge [parsed] merged `shouldBe` parsed + + it "dont accept an empty list of expressions" $ do + thrown <- try (merge []) :: IO (Either SomeException Expression) + case thrown of + Left err -> show err `shouldContain` "Nothing to merge: provide at least one expression" + Right merged -> expectationFailure (printf "Merge answered %s, while an empty list has nothing to unite" (printExpression merged))