phino 0.0.140 → 0.0.141
raw patch · 85 files changed
+3572/−979 lines, 85 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- AST: ExApplication :: Expression -> Argument -> Expression
- AST: ExDispatch :: Expression -> Attribute -> Expression
- AST: ExFormation :: [Binding] -> Expression
- AST: instance GHC.Generics.Generic AST.Expression
- Deps: EvRaiseIf :: Int -> Maybe (Either Int Bytes) -> Text -> Text -> Evaluation
- Evaluate: lambda :: [Binding] -> Maybe (Text, Expression)
- Matcher: matchArgumentExpression :: Argument -> Expression -> [Subst]
- Matcher: matchBindingExpression :: Binding -> Expression -> [Subst]
- Morph: [_dataized] :: ReduceContext -> Seen
- Morph: [_seen] :: ReduceContext -> Seen
- Morph: unvisited :: Expression -> ReduceContext -> IO ReduceContext
- Rule: matchExpressionWithRuleIn :: Maybe Expression -> Expression -> Rule -> RuleContext -> IO [Subst]
- Rule: newtype RuleContext
+ AST: alike :: Expression -> Expression -> Bool
+ AST: attributeFromBinding :: Binding -> Maybe Attribute
+ AST: distinct :: Expression -> Bool
+ AST: hashShape :: Expression -> Int
+ AST: hashSkeleton :: Expression -> Int
+ AST: inert :: Expression -> Bool
+ AST: pattern ExApplication :: Expression -> Argument -> Expression
+ AST: pattern ExDispatch :: Expression -> Attribute -> Expression
+ AST: pattern ExFormation :: [Binding] -> Expression
+ AST: repeated :: [Binding] -> Maybe Attribute
+ AST: within :: Expression -> Expression -> Bool
+ Abridge: abridged :: EXPRESSION -> EXPRESSION
+ Builder: buildBindingUnchecked :: Binding -> Subst -> Built [Binding]
+ Builder: pathOf :: Expression -> Expression -> Expression
+ Bytes: InvalidNumberLength :: Int -> BytesException
+ Bytes: instance GHC.Classes.Eq Bytes.BytesException
+ Bytes: instance GHC.Exception.Type.Exception Bytes.BytesException
+ Bytes: instance GHC.Show.Show Bytes.BytesException
+ Bytes: newtype BytesException
+ CLI.Helpers: hidden :: PrintContext -> SugarType -> EXPRESSION -> EXPRESSION
+ CLI.Helpers: withEvalFunc' :: Maybe FilePath -> PrintContext -> (SaveEvalFunc -> IO a) -> IO a
+ CLI.Parsers: optAbridged :: Parser Bool
+ CLI.Parsers: optMaxFirings :: Parser (Maybe Int)
+ CLI.Types: [_abridged] :: OptsMorph -> Bool
+ CLI.Types: [_maxFirings] :: OptsMorph -> Maybe Int
+ CST: BT_CUT :: [String] -> Int -> BYTES
+ CST: CO_SUBSET :: [ATTRIBUTE] -> BELONGING -> [BINDING] -> CONDITION
+ CST: PA_FOLDED :: Int -> PAIR
+ CST: [count] :: PAIR -> Int
+ Deps: EvFormation :: Int -> Expression -> Expression -> Evaluation
+ Deps: EvLooped :: Int -> Judgment -> Acyclic -> Expression -> Expression -> Evaluation
+ Deps: EvTerminate :: Int -> Maybe (Either Int Bytes) -> Text -> Text -> Evaluation
+ Deps: Plausible :: Acyclic
+ Deps: Progress :: Double -> Maybe Double -> Int -> Int -> Progress
+ Deps: Proven :: Acyclic
+ Deps: [_began] :: Progress -> Double
+ Deps: [_firings] :: Progress -> Int
+ Deps: [_formations] :: Progress -> Int
+ Deps: [_told] :: Progress -> Maybe Double
+ Deps: certainty :: Acyclic -> String
+ Deps: data Acyclic
+ Deps: data Progress
+ Deps: emptyProgress :: Double -> Progress
+ Deps: instance GHC.Classes.Eq Deps.Acyclic
+ Deps: instance GHC.Enum.Bounded Deps.Acyclic
+ Deps: instance GHC.Enum.Enum Deps.Acyclic
+ Deps: instance GHC.Show.Show Deps.Acyclic
+ Deps: progressed :: IORef Progress -> Double -> (Expression -> IO String) -> SaveEvalFunc -> SaveEvalFunc
+ Functions: buildFunctions :: [String]
+ Functions: nameOf :: Maybe Expression -> BuildTermMethod
+ Logger: INFO :: LogLevel
+ Logger: logInfo :: String -> IO ()
+ Logger: logging :: LogLevel -> IO Bool
+ Matcher: fitting :: Expression -> Expression -> Bool
+ Matcher: matchExpressionDeep' :: Bool -> MatchExpressionFunc
+ Matcher: pinned :: Attribute -> Attribute -> Expression -> Expression
+ Matcher: reachable :: Expression -> Expression -> Bool
+ Matcher: reachable' :: Bool -> Expression -> Expression -> Bool
+ Morph: Answered :: Answer -> Kept
+ Morph: Looped :: Expression -> Kept
+ Morph: Memo :: IORef (Store Kept) -> IORef (Set (Expression, Attribute)) -> Memo
+ Morph: Tally :: Int -> IORef Int -> Tally
+ Morph: [_ceiling] :: Tally -> Int
+ Morph: [_count] :: Tally -> IORef Int
+ Morph: [_entered] :: ReduceContext -> Seen
+ Morph: [_memo] :: ReduceContext -> Maybe Memo
+ Morph: [_tally] :: ReduceContext -> Maybe Tally
+ Morph: boxed :: [Binding] -> Bool
+ Morph: charged :: ReduceContext -> IO ()
+ Morph: data Kept
+ Morph: data Memo
+ Morph: data Tally
+ Morph: enter :: Expression -> ReduceContext -> IO ReduceContext
+ Morph: entering :: Expression -> ReduceContext -> IO ReduceContext
+ Morph: isLambda :: Binding -> Bool
+ Morph: lambda :: [Binding] -> Maybe (Text, Expression)
+ Morph: memoized :: Maybe Acyclic -> IO (Maybe Memo)
+ Morph: recalled :: Maybe Memo -> Expression -> IO (Maybe Kept)
+ Morph: retained :: Maybe Memo -> Expression -> Kept -> IO ()
+ Morph: tallied :: Maybe Int -> IO (Maybe Tally)
+ Morph: type Answer = (Expression, Expression)
+ Printer: printExpressionWith :: (SugarType -> EXPRESSION -> EXPRESSION) -> Expression -> PrintConfig -> String
+ Render: union :: [BINDING] -> Text
+ Rule: [_universe] :: RuleContext -> Maybe Expression
+ Rule: data RuleContext
+ Rule: redex :: Rule -> Bool
+ Yaml: universeless :: String -> Value -> Parser ()
- CLI.Parsers: optAcyclic :: Parser Bool
+ CLI.Parsers: optAcyclic :: Parser (Maybe Acyclic)
- CLI.Types: OptsDataize :: LogLevel -> Int -> IOFormat -> IOFormat -> SugarType -> Bool -> LineFormat -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Int -> Bool -> Bool -> Bool -> Bool -> Int -> Int -> Int -> Int -> Maybe Int -> Maybe Int -> [String] -> [String] -> String -> String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe FilePath -> Maybe FilePath -> Maybe FilePath -> Maybe FilePath -> OptsDataize
+ CLI.Types: OptsDataize :: LogLevel -> Int -> IOFormat -> IOFormat -> SugarType -> Bool -> LineFormat -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Int -> Bool -> Bool -> Maybe Acyclic -> Bool -> Int -> Int -> Int -> Maybe Int -> Int -> Maybe Int -> Maybe Int -> [String] -> [String] -> String -> String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe FilePath -> Maybe FilePath -> Bool -> Maybe FilePath -> Maybe FilePath -> OptsDataize
- CLI.Types: OptsMorph :: LogLevel -> Int -> IOFormat -> IOFormat -> SugarType -> Bool -> LineFormat -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Int -> Bool -> Bool -> Bool -> Bool -> Bool -> Int -> Int -> Int -> Int -> Maybe Int -> Maybe Int -> [String] -> [String] -> String -> String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe FilePath -> Maybe FilePath -> Maybe FilePath -> Maybe FilePath -> OptsMorph
+ CLI.Types: OptsMorph :: LogLevel -> Int -> IOFormat -> IOFormat -> SugarType -> Bool -> LineFormat -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Int -> Bool -> Bool -> Bool -> Maybe Acyclic -> Bool -> Int -> Int -> Int -> Maybe Int -> Int -> Maybe Int -> Maybe Int -> [String] -> [String] -> String -> String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe FilePath -> Maybe FilePath -> Bool -> Maybe FilePath -> Maybe FilePath -> OptsMorph
- CLI.Types: PrintCtx :: SugarType -> Bool -> LineFormat -> Int -> XmirContext -> Bool -> Bool -> Bool -> Bool -> Bool -> Int -> Int -> Expression -> Maybe String -> Maybe String -> Maybe String -> IOFormat -> PrintContext
+ CLI.Types: PrintCtx :: SugarType -> Bool -> Bool -> LineFormat -> Int -> XmirContext -> Bool -> Bool -> Bool -> Bool -> Bool -> Int -> Int -> Expression -> Maybe String -> Maybe String -> Maybe String -> IOFormat -> PrintContext
- CLI.Types: [_acyclic] :: OptsMorph -> Bool
+ CLI.Types: [_acyclic] :: OptsMorph -> Maybe Acyclic
- Deps: EvMinted :: Int -> Int -> Evaluation
+ Deps: EvMinted :: Int -> Int -> [Either Int Bytes] -> Evaluation
- Morph: OutOfSteps :: Int -> ReduceException
+ Morph: OutOfSteps :: Budget -> ReduceException
- Morph: OutOfStepsAt :: Int -> NonEmpty Rewritten -> State -> ReduceException
+ Morph: OutOfStepsAt :: Budget -> NonEmpty Rewritten -> State -> ReduceException
- Morph: ReduceContext :: Expression -> Expression -> Maybe Expression -> Int -> Int -> Steps -> Int -> Bool -> Bool -> Bool -> Bool -> Bool -> Judgment -> [Text] -> Seen -> Seen -> Lambdas -> BuildTermFunc -> ReductionFunc -> EvaluationFunc -> FiringFunc -> SaveStepFunc -> SaveEvalFunc -> ReduceContext
+ Morph: ReduceContext :: Expression -> Expression -> Maybe Expression -> Int -> Int -> Steps -> Maybe Tally -> Maybe Memo -> Int -> Bool -> Bool -> Bool -> Bool -> Maybe Acyclic -> Judgment -> [Text] -> Seen -> Lambdas -> BuildTermFunc -> ReductionFunc -> EvaluationFunc -> FiringFunc -> SaveStepFunc -> SaveEvalFunc -> ReduceContext
- Morph: [_acyclic] :: ReduceContext -> Bool
+ Morph: [_acyclic] :: ReduceContext -> Maybe Acyclic
- Rule: RuleContext :: BuildTermFunc -> RuleContext
+ Rule: RuleContext :: BuildTermFunc -> Maybe Expression -> RuleContext
- Yaml: In :: Attribute -> Binding -> Condition
+ Yaml: In :: [Attribute] -> [Binding] -> Condition
- Yaml: Rule :: String -> Maybe String -> Maybe String -> Expression -> Maybe Expression -> Expression -> Maybe Condition -> Maybe [Extra] -> Maybe Condition -> Rule
+ Yaml: Rule :: String -> Maybe String -> Maybe String -> Expression -> Expression -> Maybe Condition -> Maybe [Extra] -> Maybe Condition -> Rule
Files
- README.md +602/−183
- benchmark/Main.hs +48/−13
- benchmark/accum.phi +8/−0
- benchmark/accum.yaml +50/−0
- phino.cabal +4/−2
- resources/dataization/box.yaml +2/−2
- resources/dataization/delta.yaml +2/−2
- resources/dataization/fire.yaml +2/−2
- resources/dataization/none.yaml +2/−2
- resources/dataization/norm.yaml +2/−2
- resources/morphing/dead.yaml +2/−2
- resources/morphing/ma.yaml +2/−2
- resources/morphing/maa.yaml +2/−2
- resources/morphing/maad.yaml +2/−2
- resources/morphing/mad.yaml +2/−2
- resources/morphing/md.yaml +2/−2
- resources/morphing/mf.yaml +2/−2
- resources/morphing/mg.yaml +2/−2
- resources/morphing/ml.yaml +2/−2
- resources/morphing/mphi.yaml +5/−10
- resources/morphing/universe.yaml +2/−2
- resources/morphing/xi.yaml +2/−2
- resources/normalize/dl.yaml +3/−7
- resources/normalize/dot.yaml +24/−24
- resources/normalize/dotg.yaml +0/−37
- resources/normalize/skip.yaml +4/−4
- resources/normalize/stop.yaml +3/−13
- src/AST.hs +397/−23
- src/Abridge.hs +101/−0
- src/Builder.hs +113/−20
- src/Bytes.hs +14/−6
- src/CLI/Helpers.hs +51/−13
- src/CLI/Parsers.hs +34/−4
- src/CLI/Runners.hs +15/−5
- src/CLI/Types.hs +8/−2
- src/CST.hs +8/−8
- src/Condition.hs +1/−1
- src/Dataize.hs +30/−17
- src/Deps.hs +150/−25
- src/Encoding.hs +1/−0
- src/Evaluate.hs +85/−44
- src/Files.hs +2/−1
- src/Functions.hs +17/−1
- src/LaTeX.hs +6/−4
- src/Lambdas.hs +6/−5
- src/Lining.hs +1/−0
- src/Logger.hs +14/−3
- src/Matcher.hs +116/−17
- src/Misc.hs +1/−19
- src/Morph.hs +368/−87
- src/Parser.hs +7/−3
- src/Printer.hs +1/−0
- src/Random.hs +9/−9
- src/Render.hs +15/−10
- src/Replacer.hs +10/−4
- src/Rewriter.hs +7/−7
- src/Rule.hs +79/−48
- src/Sugar.hs +3/−5
- src/XMIR.hs +4/−1
- src/Yaml.hs +26/−21
- test/ASTSpec.hs +101/−0
- test/AbridgeSpec.hs +75/−0
- test/BuilderSpec.hs +7/−0
- test/BytesSpec.hs +3/−2
- test/CLIHelpersSpec.hs +1/−1
- test/CLISpec.hs +491/−157
- test/CSTSpec.hs +12/−2
- test/ConditionSpec.hs +2/−2
- test/DataizeSpec.hs +24/−18
- test/DepsSpec.hs +48/−6
- test/EvaluateSpec.hs +15/−6
- test/Fixtures.hs +2/−1
- test/LaTeXSpec.hs +28/−6
- test/LambdasSpec.hs +2/−1
- test/LoggerSpec.hs +14/−1
- test/MatcherSpec.hs +86/−0
- test/MiscSpec.hs +1/−12
- test/MorphSpec.hs +14/−2
- test/ParserSpec.hs +13/−0
- test/PrinterSpec.hs +1/−1
- test/RenderSpec.hs +6/−0
- test/ReplacerSpec.hs +19/−0
- test/RuleSpec.hs +60/−10
- test/SugarSpec.hs +49/−1
- test/YamlSpec.hs +15/−12
README.md view
@@ -34,7 +34,7 @@ ```bash cabal update-cabal install --overwrite-policy=always phino-0.0.137+cabal install --overwrite-policy=always phino-0.0.140 phino --version ``` @@ -292,8 +292,8 @@ has a perfectly good value on the other. The join then mints nothing, binds its meta to the other term as it stands and writes on which side the program raises, naming the condition by what the first `dataize` operand of the entry-came down to, as `raise-if(𝔻(𝜎2:λ), right) # 𝑛4` in the text format and-`<raise-if symbol="𝜎2" branch="right"/>` in the markup. The deep walk fires+came down to, as `terminate(𝔻(𝜎2:λ), right) # 𝑛4` in the text format and+`<terminate symbol="𝜎2" branch="right"/>` in the markup. The deep walk fires such a fork too, since that `⊥` is an argument the program wrote rather than one the reduction made. @@ -364,7 +364,9 @@ Every λ function fired on the way to the answer may be recorded in a machine-readable protocol, with the `--protocol` option. The protocol is a tree: the run at the top, one block per firing under it, and inside the block-the operands the firing bound and the term it answered with.+the operands the firing bound and the term it answered with. A formation that+dataization gets into opens a block too, and what fires inside it stands under+it. <!-- markdownlint-disable MD013 --> @@ -373,11 +375,17 @@ --sweet --hide-rho sum.phi $ cat atoms.txt 𝔻(Φ)- 𝔼(L_number_plus) # 𝔻(Φ)- 𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ξ.ρ)- 𝛿2.1 := 40-18-00-00-00-00-00-00 # 𝔻(ξ.x)- 𝑛.1.1 := Φ.number( φ ↦ 𝜎1:λ ) # 𝑛- 𝑛.1.2 := ⟦ φ ↦ 𝜎1:λ, plus(x) ↦ ⟦ λ ⤍ L_number_plus ⟧ ⟧ # 𝕄(𝑛.1.1)+ formation(⟦ bytes(φ) ↦ ⟦⟧, number(φ) ↦ ⟦ plus(x) ↦ L_number_plus:λ ⟧, φ ↦ 5.plus( 6 ) ⟧) # 𝔻(Φ)+ 𝔼(L_number_plus) # 𝔻(Φ)+ formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-14-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ ⟧) # 𝔻(Φ.a🌵0)+ formation(40-14-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵0)+ 𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ξ.ρ)+ formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-18-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ ⟧) # 𝔻(Φ.a🌵1)+ formation(40-18-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵1)+ 𝛿2.1 := 40-18-00-00-00-00-00-00 # 𝔻(ξ.x)+ 𝑛.1.1 := Φ.number( φ ↦ 𝜎1:λ ) # 𝑛+ 𝑛.1.2 := ⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ ⟧ # 𝕄(𝑛.1.1)+ formation(⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ ⟧) # 𝔻(Φ) ``` <!-- markdownlint-enable MD013 -->@@ -395,6 +403,21 @@ share a number, so every one of these names stands on exactly one line of the file and a line naming another one points at it and no other. +`formation(…)` is a formation 𝔻 got into through its `box` rule, which+dataizes the `φ` of a formation carrying neither `Δ` nor `λ`. It is commented+with `𝔻` and the site it was entered at, the way a firing is, and what the `φ`+body does stands one level deeper under it: the firings its dataization+demands, and the formations it gets into in turn. A reader therefore sees which+object a firing was made on the way into, rather than a flat list of firings.+Only `box` writes one, since 𝕄 stops at a formation without getting into it+and a formation whose λ is fired is already an `𝔼(…)` block. The line is no+firing: it binds no meta and takes no number, so the metas of the firings under+it are numbered as if it were not there. In the run above 𝔻 gets into the+program itself, since `Φ` binds `φ`; then into each number the entry brings+down, and through its `φ` into the bytes that number holds; and last into the+number the entry answered, whose `φ` is the symbol `𝜎1`, so nothing fires under+that one.+ An answer stands on two lines and not one. A firing answers the term its entry wrote and `phino` morphs that term before standing it back into the program, so `𝑛.1.1` is what the entry wrote, with the symbols this firing minted already in@@ -482,12 +505,17 @@ [ERROR]: No entry of --symbolic answers the λ function 'L_number_nope' $ cat atoms.txt 𝔻(Φ)- 𝔼(L_number_plus) # 𝕄(Φ)- 𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ξ.ρ)- 𝛿2.1 := 40-18-00-00-00-00-00-00 # 𝔻(ξ.x)- 𝑛.1.1 := Φ.number( φ ↦ 𝜎1:λ ) # 𝑛- 𝑛.1.2 := ⟦ φ ↦ 𝜎1:λ, plus(x) ↦ ⟦ λ ⤍ L_number_plus ⟧, nope ↦ L_number_nope:λ ⟧ # 𝕄(𝑛.1.1)- ?(L_number_nope) # 𝔻(L_number_nope:λ)+ formation(⟦ bytes(φ) ↦ ⟦⟧, number(φ) ↦ ⟦ plus(x) ↦ L_number_plus:λ, nope ↦ L_number_nope:λ ⟧, φ ↦ 5.plus( 6 ).nope ⟧) # 𝔻(Φ)+ 𝔼(L_number_plus) # 𝕄(Φ)+ formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-14-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ, nope ↦ L_number_nope:λ ⟧) # 𝔻(Φ.a🌵0)+ formation(40-14-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵0)+ 𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ξ.ρ)+ formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-18-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ, nope ↦ L_number_nope:λ ⟧) # 𝔻(Φ.a🌵1)+ formation(40-18-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵1)+ 𝛿2.1 := 40-18-00-00-00-00-00-00 # 𝔻(ξ.x)+ 𝑛.1.1 := Φ.number( φ ↦ 𝜎1:λ ) # 𝑛+ 𝑛.1.2 := ⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ, nope ↦ L_number_nope:λ ⟧ # 𝕄(𝑛.1.1)+ ?(L_number_nope) # 𝔻(L_number_nope:λ) ``` <!-- markdownlint-enable MD013 -->@@ -546,38 +574,51 @@ $ cat fork.txt 𝕄(Φ.demo.a) 𝔼(L_gt) # 𝕄(Φ.demo.a.φ)+ formation(⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_plus:λ, gt(x) ↦ L_gt:λ ⟧) # 𝔻(Φ.a🌵0) 𝛿1.1 := 𝔻(𝜎1:λ) # 𝔻(ξ.ρ)+ formation(⟦ φ ↦ Φ.bytes( φ ↦ 00-00-00-00-00-00-00-00:Δ ), plus(x) ↦ L_plus:λ, gt(x) ↦ L_gt:λ ⟧) # 𝔻(Φ.a🌵1)+ formation(00-00-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵1) 𝛿2.1 := 00-00-00-00-00-00-00-00 # 𝔻(ξ.x)- 𝑛.1.1 := Φ.bool( if ↦ ⟦ λ ⤍ L_fork, then ↦ ∅, else ↦ ∅, φ ↦ 𝜎2:λ ⟧ ) # 𝑛- 𝑛.1.2 := ⟦ λ ⤍ L_fork, then ↦ ∅, else ↦ ∅, φ ↦ 𝜎2:λ ⟧:if # 𝕄(𝑛.1.1)+ 𝑛.1.1 := Φ.bool( if(then, else) ↦ ⟦ λ ⤍ L_fork, φ ↦ 𝜎2:λ ⟧ ) # 𝑛+ 𝑛.1.2 := ⟦ if(then, else) ↦ ⟦ λ ⤍ L_fork, φ ↦ 𝜎2:λ ⟧ ⟧ # 𝕄(𝑛.1.1) 𝔼(L_plus) # 𝕄(Φ.demo.a.φ)+ formation(⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_plus:λ, gt(x) ↦ L_gt:λ ⟧) # 𝔻(Φ.a🌵2) 𝛿1.2 := 𝔻(𝜎1:λ) # 𝔻(ξ.ρ)+ formation(⟦ φ ↦ Φ.bytes( φ ↦ 3F-F0-00-00-00-00-00-00:Δ ), plus(x) ↦ L_plus:λ, gt(x) ↦ L_gt:λ ⟧) # 𝔻(Φ.a🌵3)+ formation(3F-F0-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵3) 𝛿2.2 := 3F-F0-00-00-00-00-00-00 # 𝔻(ξ.x) 𝑛.2.1 := Φ.number( φ ↦ 𝜎3:λ ) # 𝑛- 𝑛.2.2 := ⟦ φ ↦ 𝜎3:λ, plus(x) ↦ ⟦ λ ⤍ L_plus ⟧, gt(x) ↦ ⟦ λ ⤍ L_gt ⟧ ⟧ # 𝕄(𝑛.2.1)+ 𝑛.2.2 := ⟦ φ ↦ 𝜎3:λ, plus(x) ↦ L_plus:λ, gt(x) ↦ L_gt:λ ⟧ # 𝕄(𝑛.2.1) 𝔼(L_plus) # 𝕄(Φ.demo.a.φ)+ formation(⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_plus:λ, gt(x) ↦ L_gt:λ ⟧) # 𝔻(Φ.a🌵4) 𝛿1.3 := 𝔻(𝜎1:λ) # 𝔻(ξ.ρ)+ formation(⟦ φ ↦ 𝜎3:λ, plus(x) ↦ L_plus:λ, gt(x) ↦ L_gt:λ ⟧) # 𝔻(Φ.a🌵5) 𝛿2.3 := 𝔻(𝜎3:λ) # 𝔻(ξ.x) 𝑛.3.1 := Φ.number( φ ↦ 𝜎4:λ ) # 𝑛- 𝑛.3.2 := ⟦ φ ↦ 𝜎4:λ, plus(x) ↦ ⟦ λ ⤍ L_plus ⟧, gt(x) ↦ ⟦ λ ⤍ L_gt ⟧ ⟧ # 𝕄(𝑛.3.1)+ 𝑛.3.2 := ⟦ φ ↦ 𝜎4:λ, plus(x) ↦ L_plus:λ, gt(x) ↦ L_gt:λ ⟧ # 𝕄(𝑛.3.1) 𝔼(L_plus) # 𝕄(Φ.demo.a.φ)+ formation(⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_plus:λ, gt(x) ↦ L_gt:λ ⟧) # 𝔻(Φ.a🌵6) 𝛿1.4 := 𝔻(𝜎1:λ) # 𝔻(ξ.ρ)+ formation(⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_plus:λ, gt(x) ↦ L_gt:λ ⟧) # 𝔻(Φ.a🌵7) 𝛿2.4 := 𝔻(𝜎1:λ) # 𝔻(ξ.x) 𝑛.4.1 := Φ.number( φ ↦ 𝜎5:λ ) # 𝑛- 𝑛.4.2 := ⟦ φ ↦ 𝜎5:λ, plus(x) ↦ ⟦ λ ⤍ L_plus ⟧, gt(x) ↦ ⟦ λ ⤍ L_gt ⟧ ⟧ # 𝕄(𝑛.4.1)+ 𝑛.4.2 := ⟦ φ ↦ 𝜎5:λ, plus(x) ↦ L_plus:λ, gt(x) ↦ L_gt:λ ⟧ # 𝕄(𝑛.4.1) 𝔼(L_fork) # 𝕄(Φ.demo.a.φ) 𝛿1.5 := 𝔻(𝜎2:λ) # 𝔻(ξ.φ) 𝑛1.5 := 𝑛.3.2 # 𝕄(ξ.then) 𝑛2.5 := 𝑛.4.2 # 𝕄(ξ.else) 𝔻(𝜎6:λ) ∈ { 𝔻(𝜎4:λ), 𝔻(𝜎5:λ) }- 𝑛3.5 := ⟦ φ ↦ 𝜎6:λ, plus(x) ↦ ⟦ λ ⤍ L_plus ⟧, gt(x) ↦ ⟦ λ ⤍ L_gt ⟧ ⟧ # [𝑛1, 𝑛2]+ 𝑛3.5 := ⟦ φ ↦ 𝜎6:λ, plus(x) ↦ L_plus:λ, gt(x) ↦ L_gt:λ ⟧ # [𝑛1, 𝑛2] 𝑛.5.1 := 𝑛3.5 # 𝑛 𝑛.5.2 := 𝑛3.5 # 𝕄(𝑛.5.1) 𝔼(L_plus) # 𝕄(Φ.demo.a.φ)+ formation(⟦ φ ↦ 𝜎6:λ, plus(x) ↦ L_plus:λ, gt(x) ↦ L_gt:λ ⟧) # 𝔻(Φ.a🌵11) 𝛿1.6 := 𝔻(𝜎6:λ) # 𝔻(ξ.ρ)+ formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-14-00-00-00-00-00-00:Δ ), plus(x) ↦ L_plus:λ, gt(x) ↦ L_gt:λ ⟧) # 𝔻(Φ.a🌵12)+ formation(40-14-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵12) 𝛿2.6 := 40-14-00-00-00-00-00-00 # 𝔻(ξ.x) 𝑛.6.1 := Φ.number( φ ↦ 𝜎7:λ ) # 𝑛- 𝑛.6.2 := ⟦ φ ↦ 𝜎7:λ, plus(x) ↦ ⟦ λ ⤍ L_plus ⟧, gt(x) ↦ ⟦ λ ⤍ L_gt ⟧ ⟧ # 𝕄(𝑛.6.1)+ 𝑛.6.2 := ⟦ φ ↦ 𝜎7:λ, plus(x) ↦ L_plus:λ, gt(x) ↦ L_gt:λ ⟧ # 𝕄(𝑛.6.1) ``` <!-- markdownlint-enable MD013 -->@@ -618,29 +659,51 @@ file called `atoms.xml` and gets text back has been told nothing useful. Here is the run at the top of this section again: +<!-- markdownlint-disable MD013 -->+ ```bash $ phino dataize --symbolic=atoms.yaml --protocol=atoms.xml --quiet \ --sweet --hide-rho sum.phi $ cat atoms.xml <?xml version="1.0" encoding="UTF-8"?>-<dataize locator="Φ">- <evaluate λ="L_number_plus" id="1" judgment="dataize" locator="Φ">- <bind meta="𝛿1.1">40-14-00-00-00-00-00-00</bind>- <bind meta="𝛿2.1">40-18-00-00-00-00-00-00</bind>- <minted>𝜎1</minted>- <built meta="𝑛.1.1">Φ.number( φ ↦ 𝜎1:λ )</built>- <answer meta="𝑛.1.2">⟦ φ ↦ 𝜎1:λ, plus(x) ↦ ⟦ λ ⤍ L_number_plus ⟧ ⟧</answer>- </evaluate>+<dataize at="Φ">+ <formation at="Φ" term="⟦ bytes(φ) ↦ ⟦⟧, number(φ) ↦ ⟦ plus(x) ↦ L_number_plus:λ ⟧, φ ↦ 5.plus( 6 ) ⟧">+ <evaluate λ="L_number_plus" by="dataize" at="Φ">+ <formation at="Φ.a🌵0" term="⟦ φ ↦ Φ.bytes( φ ↦ 40-14-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ ⟧">+ <formation at="Φ.a🌵0" term="40-14-00-00-00-00-00-00:Δ:φ">+ </formation>+ </formation>+ <bind meta="𝛿1.1">40-14-00-00-00-00-00-00</bind>+ <formation at="Φ.a🌵1" term="⟦ φ ↦ Φ.bytes( φ ↦ 40-18-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ ⟧">+ <formation at="Φ.a🌵1" term="40-18-00-00-00-00-00-00:Δ:φ">+ </formation>+ </formation>+ <bind meta="𝛿2.1">40-18-00-00-00-00-00-00</bind>+ <minted symbol="𝜎1">40-14-00-00-00-00-00-00 40-18-00-00-00-00-00-00</minted>+ <built meta="𝑛.1.1">Φ.number( φ ↦ 𝜎1:λ )</built>+ <answer meta="𝑛.1.2">⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ ⟧</answer>+ </evaluate>+ <formation at="Φ" term="⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ ⟧">+ </formation>+ </formation> </dataize> ``` +<!-- markdownlint-enable MD013 -->+ The root is the run itself, named after the judgment it ran — `<dataize>` for a-𝔻, `<morph>` for a 𝕄 — with `locator` naming the term it was aimed at, which is+𝔻, `<morph>` for a 𝕄 — with `at` naming the term it was aimed at, which is what the text format opens with as `𝔻(Φ)`. `<evaluate>` is one firing of 𝔼, `λ`-naming the entry that answered it, `id` numbering it within the run, `judgment`-naming the one that asked for the firing — the same word the root and a-`<stuck>` carry — and `locator` naming the site it was fired at. The text-format writes those two as the comment of its line, `𝔻(Φ)`.+naming the entry that answered it, `by` naming the judgment that asked for the+firing — the same word the root is named after and a `<stuck>` carries — and+`at` naming the site it was fired at. The text format writes those two as the+comment of its line, `𝔻(Φ)`.+`<formation at="Φ" term="⟦ … ⟧">` is a formation 𝔻 got into through `box`,+which the text format writes as `formation(⟦ … ⟧) # 𝔻(Φ)`: `at` names the+site it was entered at and `term` holds the formation. Whatever the `φ` body+does is written inside the element, so it closes where the text format drops+back to the indentation it opened at, and like the text line it counts nothing+and names no meta. `<bind>` is one meta the firing bound, `meta` naming it the same way the text format names it, counter and all, and the element holding the value it took: a term where the operand was reduced with 𝕄, the datum itself where a `dataize`@@ -649,7 +712,7 @@ the formation that unknown names rather than the 42 standing for it: a `𝜎` is the name of a λ function and no term of its own, so what 𝔻 was applied to is `𝜎2:λ` and never `𝜎2` alone. It carries `meta` where the root carries-`locator`, the same difference the text format draws between `𝔻(Φ)` at the top+`at`, the same difference the text format draws between `𝔻(Φ)` at the top and `𝛿1.2 := 𝔻(…)` in a block. The name of the element is what tells a manufactured datum from data, the way `𝔻(…)` does in the text format, so nothing has to be read off the presence of an attribute. `<answer>` holds the@@ -674,21 +737,29 @@ none. The meta the line binds is a `<bind>` like every other meta of the firing. -`<minted>𝜎1</minted>` is one symbol the firing minted, one element per bare `𝜎`-the entry wrote its answer with, standing inside the block ahead of the-`<built>` carrying them. That is the edge a reader joins on: a later-`<dataize meta="𝛿1.5">𝜎2:λ</dataize>` names the symbol the firing that-wrote `<minted>𝜎2</minted>` handed out. A firing minting two symbols writes two-elements and one minting none writes none, which no attribute on the answer-could say: a term may carry several symbols, or carry one where the value it-stands for is not a symbol at all. In the fork above, `𝔼(L_gt)` writes-`<minted>𝜎2</minted>` although `𝜎2` sits under `if` and not where the value of-the term is, while `𝔼(L_fork)` writes none at all, since the symbol it answers-with comes from a `join` line and stands in a `<joined>` of its own.+`<minted symbol="𝜎1">40-14-… 40-18-…</minted>` is one symbol the firing+minted, one element per bare `𝜎` the entry wrote its answer with, standing+inside the block ahead of the `<built>` carrying them. The symbol stands in+`symbol`, the way `<known>` and `<joined>` put theirs, and the text is what is+known about it: the values the `dataize` lines of the entry took, in the order+the entry declares them, each spelled as its own line spells it — the bytes+for a datum, `𝜎1` for a symbol — and separated by a space the way `<joined>`+lists its pair. With the `λ` of the block the element reads as the fact+`𝔻(𝜎1:λ) == L_number_plus(40-14-…, 40-18-…)`, and a firing of an entry with+no `dataize` line writes `<minted symbol="𝜎1"/>`. The symbol is also the edge+a reader joins on: a later `<dataize meta="𝛿1.5">𝜎2:λ</dataize>` names the+symbol the firing that wrote `<minted symbol="𝜎2">` handed out. A firing+minting two symbols writes two elements and one minting none writes none,+which no attribute on the answer could say: a term may carry several symbols,+or carry one where the value it stands for is not a symbol at all. In the fork+above, `𝔼(L_gt)` writes `<minted symbol="𝜎2">` although `𝜎2` sits under `if`+and not where the value of the term is, while `𝔼(L_fork)` writes none at all,+since the symbol it answers with comes from a `join` line and stands in a+`<joined>` of its own. A λ name no entry answers is `<stuck λ="…">`, standing where its `<evaluate>` would have stood with the formation 𝔼 was fired against as its text and the-judgment that asked in its `judgment` attribute, where the text format writes+judgment that asked in its `by` attribute, where the text format writes the letter of it. A firing that happened while an operand of another was being reduced is an `<evaluate>` inside the one that asked, which is what the deeper indentation means in the text. Elements are written as the run goes and@@ -703,20 +774,61 @@ [ERROR]: No entry of --symbolic answers the λ function 'L_number_nope' $ cat atoms.xml <?xml version="1.0" encoding="UTF-8"?>-<dataize locator="Φ">- <evaluate λ="L_number_plus" id="1" judgment="morph" locator="Φ">- <bind meta="𝛿1.1">40-14-00-00-00-00-00-00</bind>- <bind meta="𝛿2.1">40-18-00-00-00-00-00-00</bind>- <minted>𝜎1</minted>- <built meta="𝑛.1.1">Φ.number( φ ↦ 𝜎1:λ )</built>- <answer meta="𝑛.1.2">⟦ φ ↦ 𝜎1:λ, plus(x) ↦ ⟦ λ ⤍ L_number_plus ⟧, nope ↦ L_number_nope:λ ⟧</answer>- </evaluate>- <stuck λ="L_number_nope" judgment="dataize">L_number_nope:λ</stuck>+<dataize at="Φ">+ <formation at="Φ" term="⟦ bytes(φ) ↦ ⟦⟧, number(φ) ↦ ⟦ plus(x) ↦ L_number_plus:λ, nope ↦ L_number_nope:λ ⟧, φ ↦ 5.plus( 6 ).nope ⟧">+ <evaluate λ="L_number_plus" by="morph" at="Φ">+ <formation at="Φ.a🌵0" term="⟦ φ ↦ Φ.bytes( φ ↦ 40-14-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ, nope ↦ L_number_nope:λ ⟧">+ <formation at="Φ.a🌵0" term="40-14-00-00-00-00-00-00:Δ:φ">+ </formation>+ </formation>+ <bind meta="𝛿1.1">40-14-00-00-00-00-00-00</bind>+ <formation at="Φ.a🌵1" term="⟦ φ ↦ Φ.bytes( φ ↦ 40-18-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ, nope ↦ L_number_nope:λ ⟧">+ <formation at="Φ.a🌵1" term="40-18-00-00-00-00-00-00:Δ:φ">+ </formation>+ </formation>+ <bind meta="𝛿2.1">40-18-00-00-00-00-00-00</bind>+ <minted symbol="𝜎1">40-14-00-00-00-00-00-00 40-18-00-00-00-00-00-00</minted>+ <built meta="𝑛.1.1">Φ.number( φ ↦ 𝜎1:λ )</built>+ <answer meta="𝑛.1.2">⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ, nope ↦ L_number_nope:λ ⟧</answer>+ </evaluate>+ <stuck λ="L_number_nope" by="dataize">L_number_nope:λ</stuck>+ </formation> </dataize> ``` <!-- markdownlint-enable MD013 --> +### Abridging the protocol++A formation carrying a whole object is written flat on one line, so a real+run fills the protocol with lines tens of thousands of characters long. The+`--abridged` option shortens every term the protocol writes, in the text and+the XML alike: a formation longer than sixty characters keeps its `φ`, `Δ` and+`λ` bindings and folds the rest into a count, and a byte string longer than+eight bytes keeps its first four bytes and its length. The result the run+prints stays whole, and the option is refused without `--protocol`:++<!-- markdownlint-disable MD013 -->++```bash+$ cat wide.phi+⟦+ t ↦ ⟦+ φ ↦ ⟦ Δ ⤍ 48-65-6C-6C-6F-2C-20-77-6F-72-6C-64 ⟧,+ left ↦ ξ.right,+ right ↦ ξ.left,+ middle ↦ ξ.left+ ⟧+⟧+$ phino dataize --locator=Q.t --protocol=wide.txt --abridged --quiet \+ --sweet --hide-rho wide.phi+$ cat wide.txt+𝔻(Φ.t)+ formation(⟦ φ ↦ 48-65-6C-6C-...(12b):Δ, +3 attrs ⟧) # 𝔻(Φ.t)+```++<!-- markdownlint-enable MD013 -->+ ### Reducing a term inside a universe A term that is no part of the program may still be reduced against it, with the@@ -780,17 +892,25 @@ --sweet --hide-rho partial.phi $ cat atoms.txt 𝔻(Φ)- 𝔼(L_number_times) # 𝕄(Φ)- 𝛿1.1 := 40-00-00-00-00-00-00-00 # 𝔻(ξ.ρ)- 𝛿2.1 := 40-08-00-00-00-00-00-00 # 𝔻(ξ.x)- 𝑛.1.1 := Φ.number( φ ↦ 𝜎1:λ ) # 𝑛- 𝑛.1.2 := ⟦ φ ↦ 𝜎1:λ, plus(x) ↦ ⟦ λ ⤍ L_number_plus ⟧, times(x) ↦ ⟦ λ ⤍ L_number_times ⟧, as-bool ↦ L_number_as_bool:λ ⟧ # 𝕄(𝑛.1.1)- 𝔼(L_number_plus) # 𝕄(Φ)- 𝛿1.2 := 𝔻(𝜎1:λ) # 𝔻(ξ.ρ)- 𝛿2.2 := 40-10-00-00-00-00-00-00 # 𝔻(ξ.x)- 𝑛.2.1 := Φ.number( φ ↦ 𝜎2:λ ) # 𝑛- 𝑛.2.2 := ⟦ φ ↦ 𝜎2:λ, plus(x) ↦ ⟦ λ ⤍ L_number_plus ⟧, times(x) ↦ ⟦ λ ⤍ L_number_times ⟧, as-bool ↦ L_number_as_bool:λ ⟧ # 𝕄(𝑛.2.1)- ?(L_number_as_bool) # 𝔻(L_number_as_bool:λ)+ formation(⟦ bytes(φ) ↦ ⟦⟧, number(φ) ↦ ⟦ plus(x) ↦ L_number_plus:λ, times(x) ↦ L_number_times:λ, as-bool ↦ L_number_as_bool:λ ⟧, φ ↦ 2.times( 3 ).plus( 4 ).as-bool ⟧) # 𝔻(Φ)+ 𝔼(L_number_times) # 𝕄(Φ)+ formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-00-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ, times(x) ↦ L_number_times:λ, as-bool ↦ L_number_as_bool:λ ⟧) # 𝔻(Φ.a🌵0)+ formation(40-00-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵0)+ 𝛿1.1 := 40-00-00-00-00-00-00-00 # 𝔻(ξ.ρ)+ formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-08-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ, times(x) ↦ L_number_times:λ, as-bool ↦ L_number_as_bool:λ ⟧) # 𝔻(Φ.a🌵1)+ formation(40-08-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵1)+ 𝛿2.1 := 40-08-00-00-00-00-00-00 # 𝔻(ξ.x)+ 𝑛.1.1 := Φ.number( φ ↦ 𝜎1:λ ) # 𝑛+ 𝑛.1.2 := ⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ, times(x) ↦ L_number_times:λ, as-bool ↦ L_number_as_bool:λ ⟧ # 𝕄(𝑛.1.1)+ 𝔼(L_number_plus) # 𝕄(Φ)+ formation(⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ, times(x) ↦ L_number_times:λ, as-bool ↦ L_number_as_bool:λ ⟧) # 𝔻(Φ.a🌵2)+ 𝛿1.2 := 𝔻(𝜎1:λ) # 𝔻(ξ.ρ)+ formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-10-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ, times(x) ↦ L_number_times:λ, as-bool ↦ L_number_as_bool:λ ⟧) # 𝔻(Φ.a🌵3)+ formation(40-10-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵3)+ 𝛿2.2 := 40-10-00-00-00-00-00-00 # 𝔻(ξ.x)+ 𝑛.2.1 := Φ.number( φ ↦ 𝜎2:λ ) # 𝑛+ 𝑛.2.2 := ⟦ φ ↦ 𝜎2:λ, plus(x) ↦ L_number_plus:λ, times(x) ↦ L_number_times:λ, as-bool ↦ L_number_as_bool:λ ⟧ # 𝕄(𝑛.2.1)+ ?(L_number_as_bool) # 𝔻(L_number_as_bool:λ) ``` <!-- markdownlint-enable MD013 -->@@ -817,6 +937,26 @@ [ERROR]: Dataization did not finish before reaching the limit of steps: --max-steps=50 ``` +That budget bounds how deep one branch goes, not how much the whole run does.+An entry that reduces two operands, each firing it again, doubles its work at+every level and still never gets deep, so no `--max-steps` stops it. The+`--max-firings` option counts every λ function the run fires and fails the+run once the count is spent; `--partial` parks it instead, the way it parks a+spent `--max-steps`. There is no limit unless the option is given:++```bash+$ cat split.yaml+- λ: L_split+ morph:+ 𝑛1: Φ.s.foo+ 𝑛2: Φ.s.foo+ 𝑛: ⟦ l ↦ 𝑛1, r ↦ 𝑛2 ⟧+$ cat split.phi+⟦ s ↦ ⟦ λ ⤍ L_split ⟧, x ↦ Φ.s.foo ⟧+$ phino morph --symbolic=split.yaml --locator=Q.x --max-firings=64 split.phi+[ERROR]: Evaluation did not finish before reaching the limit of firings: --max-firings=64+```+ ## Morph Dataization insists on bytes. Morphing 𝕄 asks a different question: evaluate@@ -880,7 +1020,7 @@ ⟦ n ↦ 3, φ ↦ Φ.bar( n.times( 5 ).times( 7 ) ) ⟧ $ phino morph --deep --symbolic=atoms.yaml --inside='Q.demo.foo' \ --sweet --hide-rho gap.phi-⟦ n ↦ 3, φ ↦ Φ.bar( ⟦ φ ↦ 𝜎2:λ, times(x) ↦ ⟦ λ ⤍ L_number_times ⟧ ⟧ ) ⟧+⟦ n ↦ 3, φ ↦ Φ.bar( ⟦ φ ↦ 𝜎2:λ, times(x) ↦ L_number_times:λ ⟧ ) ⟧ ``` Every binding of the formation is entered, recursively. 𝕄 is asked about the@@ -908,7 +1048,7 @@ answer therefore taints its own binding and not the whole run. A formation still holding a void binding is not fired either: the void is an argument the program has not given-yet, so `times(x) ↦ ⟦ λ ⤍ L_number_times ⟧` is a method waiting to be applied,+yet, so `times(x) ↦ L_number_times:λ` is a method waiting to be applied, not an application waiting to be computed. Walking the whole program therefore folds what it can and leaves the object model as it was declared: @@ -916,12 +1056,9 @@ $ phino morph --deep --symbolic=atoms.yaml --sweet --hide-rho gap.phi ⟦ bytes(φ) ↦ ⟦⟧,- number(φ) ↦ ⟦ times(x) ↦ ⟦ λ ⤍ L_number_times ⟧ ⟧,- bar(x) ↦ ⟦ λ ⤍ L_bar ⟧,- demo ↦ ⟦- n ↦ 3,- φ ↦ Φ.bar( ⟦ φ ↦ 𝜎2:λ, times(x) ↦ ⟦ λ ⤍ L_number_times ⟧ ⟧ )- ⟧:foo+ number(φ) ↦ ⟦ times(x) ↦ L_number_times:λ ⟧,+ bar(x) ↦ L_bar:λ,+ demo ↦ ⟦ n ↦ 3, φ ↦ Φ.bar( ⟦ φ ↦ 𝜎2:λ, times(x) ↦ L_number_times:λ ⟧ ) ⟧:foo ⟧ ``` @@ -943,51 +1080,319 @@ [ERROR]: Dataization did not finish before reaching the limit of steps: --max-steps=40 ``` -The `--acyclic` flag makes a reduction notice. Every frame of 𝕄 and of 𝔻-remembers the terms the frames above it are reducing, and a term that comes-back is a question only ever answered by asking it again, so the flag stops-there and parks the site the way `--partial` parks a λ function that cannot-fire: the answer is the term the spine had reached, left where it stood, and-the command exits successfully.+The `--acyclic=<mode>` option makes a reduction notice. Every frame of 𝕄 and+of 𝔻 remembers the formations the frames above it have entered, and only four+places enter one: `fire` of 𝔻 and `ml` of 𝕄, which fire the λ function of a+formation, the walk of `--deep`, which fires the λ function of every formation+𝕄 leaves bare, and `box` of 𝔻, which gets into the `φ` body of a formation+carrying no λ and no `Δ`. A frame about to enter a formation one of the frames+above it has already entered is asking a question only ever answered by asking+it again, so the option stops there and parks the site the way `--partial`+parks a λ function that cannot fire: the answer is the term the spine had+reached, left where it stood, and the command exits successfully. ```bash-$ phino morph --symbolic=loop.yaml --locator='Q.x' --acyclic \+$ phino morph --symbolic=loop.yaml --locator='Q.x' --acyclic=proven \ --max-steps=40 --hide-rho loop.phi ⟦ λ ⤍ L_loop ⟧.foo ``` -Each judgment keeps its own memory, since 𝕄 and 𝔻 call each other on the very-term they were asked about and that handover is no loop. A body dispatching the-object it stands in is one 𝔻 walks round on its own — 𝕄 stops at a formation-every round and never sees the same term twice — so `dataize` takes the flag-too, and so does the run of 𝔻 a λ function's `dataize` operand is brought down-with:+𝕄 and 𝔻 share that one memory. They call each other on the very term they+were asked about, and that handover is no loop, but it enters no formation+either, so it is never remembered and never mistaken for one. A body+dispatching the object it stands in is a loop 𝔻 walks round on its own — 𝕄+stops at a formation every round, and `box` gets into it again — so `dataize`+takes the option too, and so does the run of 𝔻 a λ function's `dataize` operand+is brought down with: ```bash $ cat cyc.phi ⟦ cyc ↦ ⟦ x ↦ ∅, φ ↦ Φ.cyc( ξ.x ) ⟧, t ↦ Φ.cyc( ⟦⟧ ) ⟧-$ phino dataize --locator='Q.t' --acyclic --partial \+$ phino dataize --locator='Q.t' --acyclic=proven --partial \ --sweet --hide-rho --flat cyc.phi-⟦ cyc(x) ↦ ⟦ φ ↦ Φ.cyc( x ) ⟧, t ↦ ⟦ x ↦ ⟦⟧, φ ↦ Φ.cyc( x ) ⟧ ⟧+⟦ cyc(x) ↦ Φ.cyc( x ):φ, t ↦ Φ.cyc( ⟦⟧ ) ⟧ ``` -𝔻 insists on bytes and a parked term carries none, so under `dataize` the flag+𝔻 insists on bytes and a parked term carries none, so under `dataize` the option wants `--partial` to have something to print: the residual program, exactly the one it prints for a λ function that cannot fire. Without it the run stops on-the loop all the same, naming the term it came back to instead of running the-budget down. Under `morph` nothing is asked for: 𝕄 always has a term to answer-with, a loop 𝔻 meets under a firing parks the site the firing stands at, and-the walk of `--deep` goes on to the next binding.+the loop all the same, naming the formation it entered again instead of running+the budget down. Under `morph` nothing is asked for: 𝕄 always has a term to+answer with, a loop 𝔻 meets under a firing parks the site the firing stands at,+and the walk of `--deep` goes on to the next binding. +The mode says what "the same formation" means, and there is no default, since+no answer is right for every run. Under `proven` it means the same up to a+renaming of symbols: two+formations are one where some one-to-one pairing of the symbols of the first+with those of the second makes them equal, so `𝜎5` may stand where `𝜎3` stood+as long as it does so everywhere and no other symbol stands there too. Data,+attribute names and λ names must still match exactly. That is what catches a+recursion over an unknown, which never repeats a term: every round mints fresh+symbols, so the formation it enters on the second round is the one it entered+on the first with new names for the unknowns. The renaming is sound because a+symbol is an opaque value nobody worked out — every one of them dataizes to the+same manufactured datum and no entry of `--symbolic` answers one — so a+formation entered again with nothing but its symbols renamed replays the round+it is inside forever. Data still tells rounds apart: a formation entered with+`n ↦ 3` and then with `n ↦ 2` is two formations, so a recursion over data is+not cut while it goes on computing. Take a factorial over a symbolic argument,+with `fact.yaml` answering `L_zero`, `L_dec` and `L_mul` with a fresh symbol+each and `L_if` a fork joining its two branches:++<!-- markdownlint-disable MD013 -->++```bash+$ cat fact.phi+⟦+ if ↦ ⟦ c ↦ ∅, left ↦ ∅, right ↦ ∅, λ ⤍ L_if ⟧,+ zero ↦ ⟦ x ↦ ∅, λ ⤍ L_zero ⟧,+ dec ↦ ⟦ x ↦ ∅, λ ⤍ L_dec ⟧,+ mul ↦ ⟦ a ↦ ∅, b ↦ ∅, λ ⤍ L_mul ⟧,+ fact ↦ ⟦ n ↦ ∅, φ ↦ Φ.if( c ↦ Φ.zero( x ↦ ξ.n ), left ↦ ⟦ Δ ⤍ 01- ⟧, right ↦ Φ.mul( a ↦ ξ.n, b ↦ Φ.fact( n ↦ Φ.dec( x ↦ ξ.n ) ) ) ) ⟧,+ x ↦ Φ.fact( n ↦ ⟦ λ ⤍ 𝜎1 ⟧ )+⟧+$ cat fact.yaml+- λ: L_zero+ dataize:+ 𝛿1: $.x+ 𝑛: ⟦ λ ⤍ 𝜎 ⟧+- λ: L_dec+ dataize:+ 𝛿1: $.x+ 𝑛: ⟦ λ ⤍ 𝜎 ⟧+- λ: L_mul+ dataize:+ 𝛿1: $.a+ 𝛿2: $.b+ 𝑛: ⟦ λ ⤍ 𝜎 ⟧+- λ: L_if+ dataize:+ 𝛿1: $.c+ morph:+ 𝑛1: $.left+ 𝑛2: $.right+ symbolize:+ 𝑛3: 𝑛1+ 𝑛4: 𝑛2+ join:+ 𝑛5: [𝑛3, 𝑛4]+ 𝑛: 𝑛5+$ phino morph --deep --acyclic=proven --partial --sweet --hide-rho --flat \+ --symbolic=fact.yaml --locator='Q.x' --protocol=fact.txt fact.phi+⟦ n ↦ 𝜎1:λ, φ ↦ Φ.if( c ↦ 𝜎2:λ, left ↦ 01-:Δ, right ↦ Φ.mul( a ↦ n, b ↦ Φ.fact( n ↦ 𝜎3:λ ) ) ) ⟧+$ cat fact.txt+𝕄(Φ.x)+ 𝔼(L_zero) # 𝕄(Φ.x.φ)+ 𝛿1.1 := 𝔻(𝜎1:λ) # 𝔻(ξ.x)+ 𝑛.1.1 := 𝜎2:λ # 𝑛+ 𝑛.1.2 := 𝜎2:λ # 𝕄(𝑛.1.1)+ 𝔼(L_dec) # 𝕄(Φ.x.φ)+ 𝛿1.2 := 𝔻(𝜎1:λ) # 𝔻(ξ.x)+ 𝑛.2.1 := 𝜎3:λ # 𝑛+ 𝑛.2.2 := 𝜎3:λ # 𝕄(𝑛.2.1)+ 𝔼(L_mul) # 𝕄(Φ.x.φ)+ 𝛿1.3 := 𝔻(𝜎1:λ) # 𝔻(ξ.a)+ formation(⟦ n ↦ 𝜎3:λ, φ ↦ Φ.if( c ↦ Φ.zero( x ↦ n ), left ↦ 01-:Δ, right ↦ Φ.mul( a ↦ n, b ↦ Φ.fact( n ↦ Φ.dec( x ↦ n ) ) ) ) ⟧) # 𝔻(Φ.a🌵3)+ 𝔼(L_if) # 𝔻(Φ.a🌵3)+ 𝔼(L_zero) # 𝔻(Φ.a🌵4)+ 𝛿1.5 := 𝔻(𝜎3:λ) # 𝔻(ξ.x)+ 𝑛.5.1 := 𝜎4:λ # 𝑛+ 𝑛.5.2 := 𝜎4:λ # 𝕄(𝑛.5.1)+ 𝛿1.4 := 𝔻(𝜎4:λ) # 𝔻(ξ.c)+ 𝑛1.4 := 01-:Δ # 𝕄(ξ.left)+ 𝔼(L_dec) # 𝕄(Φ.a🌵7.b)+ 𝛿1.6 := 𝔻(𝜎3:λ) # 𝔻(ξ.x)+ 𝑛.6.1 := 𝜎5:λ # 𝑛+ 𝑛.6.2 := 𝜎5:λ # 𝕄(𝑛.6.1)+ looped(⟦ a ↦ 𝜎1:λ, b ↦ Φ.fact( n ↦ 𝜎3:λ ), λ ⤍ L_mul ⟧) # 𝕄(Φ.a🌵7), proven+ 𝑛2.4 := ⟦ a ↦ 𝜎3:λ, b ↦ Φ.fact( n ↦ 𝜎5:λ ), λ ⤍ L_mul ⟧ # 𝕄(ξ.right)+ 𝔻(𝜎6:λ) == 01-+ 𝑛3.4 := 𝜎6:λ # 𝑛1+ 𝑛4.4 := ⟦ a ↦ 𝜎3:λ, b ↦ Φ.fact( n ↦ 𝜎5:λ ), λ ⤍ L_mul ⟧ # 𝑛2+ 𝔼(L_if) # 𝕄(Φ.x.φ)+ 𝛿1.7 := 𝔻(𝜎2:λ) # 𝔻(ξ.c)+ 𝑛1.7 := 01-:Δ # 𝕄(ξ.left)+ 𝔼(L_mul) # 𝕄(Φ.a🌵11)+ 𝛿1.8 := 𝔻(𝜎1:λ) # 𝔻(ξ.a)+ formation(⟦ n ↦ 𝜎3:λ, φ ↦ Φ.if( c ↦ Φ.zero( x ↦ n ), left ↦ 01-:Δ, right ↦ Φ.mul( a ↦ n, b ↦ Φ.fact( n ↦ Φ.dec( x ↦ n ) ) ) ) ⟧) # 𝔻(Φ.a🌵13)+ 𝔼(L_if) # 𝔻(Φ.a🌵13)+ 𝔼(L_zero) # 𝔻(Φ.a🌵14)+ 𝛿1.10 := 𝔻(𝜎3:λ) # 𝔻(ξ.x)+ 𝑛.10.1 := 𝑛.5.2 # 𝑛+ 𝑛.10.2 := 𝑛.5.2 # 𝕄(𝑛.10.1)+ 𝛿1.9 := 𝔻(𝜎4:λ) # 𝔻(ξ.c)+ 𝑛1.9 := 01-:Δ # 𝕄(ξ.left)+ 𝔼(L_dec) # 𝕄(Φ.a🌵17.b)+ 𝛿1.11 := 𝔻(𝜎3:λ) # 𝔻(ξ.x)+ 𝑛.11.1 := 𝑛.6.2 # 𝑛+ 𝑛.11.2 := 𝑛.6.2 # 𝕄(𝑛.11.1)+ looped(⟦ a ↦ 𝜎1:λ, b ↦ Φ.fact( n ↦ 𝜎3:λ ), λ ⤍ L_mul ⟧) # 𝕄(Φ.a🌵17), proven+ 𝑛2.9 := ⟦ a ↦ 𝜎3:λ, b ↦ Φ.fact( n ↦ 𝜎5:λ ), λ ⤍ L_mul ⟧ # 𝕄(ξ.right)+ 𝔻(𝜎6:λ) == 01-+ 𝑛3.9 := 𝑛3.4 # 𝑛1+ 𝑛4.9 := ⟦ a ↦ 𝜎3:λ, b ↦ Φ.fact( n ↦ 𝜎5:λ ), λ ⤍ L_mul ⟧ # 𝑛2+ 𝑛2.7 := ⟦ a ↦ 𝜎1:λ, b ↦ Φ.fact( n ↦ 𝜎3:λ ), λ ⤍ L_mul ⟧ # 𝕄(ξ.right)+ 𝔻(𝜎4:λ) == 01-+ 𝑛3.7 := 𝑛.10.2 # 𝑛1+ 𝑛4.7 := ⟦ a ↦ 𝜎1:λ, b ↦ Φ.fact( n ↦ 𝜎3:λ ), λ ⤍ L_mul ⟧ # 𝑛2+```++<!-- markdownlint-enable MD013 -->++The first `L_mul` brings its `b` down, and that gets 𝔻 into `fact` with+`n ↦ 𝜎3`, the `formation(…)` line under it. Inside, the fork reduces its right+branch, and the walk of `--deep` over it would fire `L_mul` with `a ↦ 𝜎3` and+`b ↦ Φ.fact( n ↦ 𝜎5 )`: the formation the first `L_mul` was fired with, `𝜎3`+standing where `𝜎1` stood and `𝜎5` where `𝜎3` stood, so the firing is cut+before it opens. The cut is the `looped(…)` line under `𝑛.6.2`, standing where+the block of the cut firing would have stood and commented with the judgment+the frame belonged to, the site it was cut at and the mode that cut it. What it+carries is the formation the frame above entered, as that frame had it, so the+two are paired by their terms and no reader has to rename symbols by eye or+find the cut in the residue. Nothing runs under a cut, so no block opens under+the line. In the XML protocol it is a self-closing element,+`<looped by="morph" match="proven" at="Φ.a🌵7" term="…"/>`, with the+attributes a `<formation>` carries and the mode. Without the option the same+run nests one round inside another until `--max-steps` runs out.+ What a frame remembers is the branch from the run down to it, never everything-the run has touched, so two sibling subterms that happen to be written alike-stay two terms and only a term genuinely reached from itself is a loop. The cut-costs one lookup and fires on the turn the repeat appears, so raising-`--max-steps` from 40 to a million changes neither the answer nor the time. The-flag promises nothing about programs that loop without ever repeating a term —-a body that grows on every round rather than coming back still ends on the-budget.+the run has touched, so two siblings entering one formation enter it twice and+only a formation entered from inside itself is a loop: the fork at `Φ.x.φ`+above gets into `fact` with `n ↦ 𝜎3` once more, on a branch of its own, and is+not cut there. The cut costs one lookup and fires on the turn the repeat+appears, so raising `--max-steps` from 40 to a million changes neither the+answer nor the time. +What `proven` cannot see is a recursion that never comes back to the same+formation: one whose accumulator grows by a wrapper every round. Give the+factorial an `acc` it builds a `pair` onto, drop `L_mul` from `fact.yaml`, and+under `proven` the run nests deeper until `--max-steps` runs out, since no+renaming of symbols turns a longer chain of pairs into a shorter one:++<!-- markdownlint-disable MD013 -->++```bash+$ cat facta.phi+⟦+ if ↦ ⟦ c ↦ ∅, left ↦ ∅, right ↦ ∅, λ ⤍ L_if ⟧,+ zero ↦ ⟦ x ↦ ∅, λ ⤍ L_zero ⟧,+ dec ↦ ⟦ x ↦ ∅, λ ⤍ L_dec ⟧,+ pair ↦ ⟦ head ↦ ∅, tail ↦ ∅ ⟧,+ fact ↦ ⟦ n ↦ ∅, acc ↦ ∅, φ ↦ Φ.if( c ↦ Φ.zero( x ↦ ξ.n ), left ↦ ξ.acc, right ↦ Φ.fact( n ↦ Φ.dec( x ↦ ξ.n ), acc ↦ Φ.pair( head ↦ ξ.n, tail ↦ ξ.acc ) ) ) ⟧,+ x ↦ Φ.fact( n ↦ ⟦ λ ⤍ 𝜎1 ⟧, acc ↦ ⟦ Δ ⤍ 00- ⟧ )+⟧+$ phino morph --deep --acyclic=plausible --partial --sweet --hide-rho --flat \+ --symbolic=facta.yaml --locator='Q.x' --protocol=facta.txt facta.phi+⟦ n ↦ 𝜎1:λ, acc ↦ 00-:Δ, φ ↦ Φ.if( c ↦ 𝜎2:λ, left ↦ acc, right ↦ Φ.fact( n ↦ 𝜎3:λ, acc ↦ Φ.pair( head ↦ n, tail ↦ acc ) ) ) ⟧+$ grep looped facta.txt+looped(⟦ c ↦ 𝜎2:λ, left ↦ 00-:Δ, right ↦ Φ.fact( n ↦ 𝜎3:λ, acc ↦ Φ.pair( head ↦ 𝜎1:λ, tail ↦ 00-:Δ ) ), λ ⤍ L_if ⟧) # 𝕄(Φ.a🌵4.φ), plausible+```++<!-- markdownlint-enable MD013 -->++Under `plausible` the same formation means one the formation entered earlier+is embedded in: the two have the same attributes, data and λ function at the+top, and every term the earlier one bound there is found again in the later+one, as it stands or somewhere below a wrapper it gained. Any symbol stands for+any other, and nothing is looked for under a `ρ`, which holds the object a term+came from rather than a term it grew into. The second `if` above holds the+first under one more `pair`, so it is cut, and its `looped(…)` line says+`plausible`. A call nested in its own operand, such as a sum of sums, is never+cut, since the inner call is smaller than the outer one and cannot hold it.+The mode is not sound, though: a recursion whose argument grows on its way to+stopping is cut too, which is why the line names the mode that made the cut.++The mode also fires every formation once. Every use of a binding copies the+term bound to it, so a program reading `truncated ↦ ρ.abs.floor` in five+places fires `abs` and `floor` five times over and mints five symbols for one+value, and a guard written that way spends its whole budget saying the same+thing again. 𝔼 is a function of the formation it fires: the entry that+answers is found by the λ name the formation carries, every operand is+reduced from its bindings inside the one universe of the run, and the answer+is built from what they came down to. So a run under `plausible` keeps what+every firing answered, by the formation it fired, and a later firing of the+same formation takes that answer, with the very symbols the first one minted,+instead of making it again. Two bindings spelling one term then come to one+symbol:++```bash+$ cat twins.phi+⟦+ bytes ↦ ⟦ φ ↦ ∅ ⟧,+ number ↦ ⟦ φ ↦ ∅, plus(ρ, x) ↦ ⟦ λ ⤍ L_number_plus ⟧ ⟧,+ a ↦ 7.plus( 5.plus( 6 ) ),+ b ↦ 7.plus( 5.plus( 6 ) )+⟧+$ phino morph --symbolic=atoms.yaml --acyclic=plausible --deep --sweet \+ --hide-rho twins.phi+⟦+ bytes(φ) ↦ ⟦⟧,+ number(φ) ↦ ⟦ plus(x) ↦ L_number_plus:λ ⟧,+ a ↦ ⟦ φ ↦ 𝜎2:λ, plus(x) ↦ L_number_plus:λ ⟧,+ b ↦ ⟦ φ ↦ 𝜎2:λ, plus(x) ↦ L_number_plus:λ ⟧+⟧+```++Under `proven` `b` lands on `𝜎4`, since the walk over it fires the inner sum+and the outer one once more. The protocol of the run above still holds four+firings, two under `a` and two under `b`, since it records where 𝔼 was asked+and what it answered there; the two under `b` carry the answer lines of the+two under `a` and no operand line, since nothing was reduced for them, and+they are not charged to `--max-firings`, which counts the firings the run+made. The formation is compared with everything it carries, `ρ` included, so+a firing on another object is another firing, and a firing that got stuck+keeps nothing, since nothing was answered. A firing cut by the mode on its+way to an answer keeps the cut, and the next firing of the same formation is+cut at its own site without reducing anything first.++The mode also walks a binding of the world once. Every dispatch on an object+of the world copies it, and `--deep` walks every copy, so the tests of an+object are reduced once per copy of it the program holds. A copy goes by a+name in the world, such as `Φ.num( φ ↦ ⟦ Δ ⤍ 2A- ⟧ )`, the name `dot` writes+into its `ρ`, and that name without its application, `Φ.num`, stands for every+copy. So a run under `plausible` enters `test` of `Φ.num` in the first copy it+meets and leaves it as written in every later one:++```bash+$ cat atoms.yaml+- λ: L_id+ morph:+ 𝑛1: $.x+ 𝑛: 𝑛1+- λ: L_twice+ dataize:+ 𝛿1: $.ρ+ 𝑛: Φ.num( φ ↦ ⟦ λ ⤍ 𝜎 ⟧ )+$ cat world.phi+⟦+ num ↦ ⟦+ φ ↦ ∅,+ twice ↦ ⟦ ρ ↦ ∅, λ ⤍ L_twice ⟧,+ test ↦ Φ.num( φ ↦ ⟦ Δ ⤍ 01- ⟧ ).twice+ ⟧,+ a ↦ ⟦ λ ⤍ L_id, x ↦ Φ.num( φ ↦ ⟦ Δ ⤍ 2A- ⟧ ) ⟧,+ b ↦ ⟦ λ ⤍ L_id, x ↦ Φ.num( φ ↦ ⟦ Δ ⤍ 2B- ⟧ ) ⟧+⟧+$ phino morph --symbolic=atoms.yaml --acyclic=plausible --deep --partial \+ --sweet --hide-rho world.phi+⟦+ num(φ) ↦ ⟦ twice ↦ L_twice:λ, test ↦ Φ.num( φ ↦ 01-:Δ ).twice ⟧,+ a ↦ ⟦+ φ ↦ 2A-:Δ,+ twice ↦ L_twice:λ,+ test ↦ ⟦ φ ↦ 𝜎1:λ, twice ↦ L_twice:λ, test ↦ Φ.num( φ ↦ 01-:Δ ).twice ⟧+ ⟧,+ b ↦ ⟦ φ ↦ 2B-:Δ, twice ↦ L_twice:λ, test ↦ Φ.num( φ ↦ 01-:Δ ).twice ⟧+⟧+```++A binding the copy filled, such as `φ` above, belongs to that copy alone and+is entered every time. A binding left out is never replaced by what an earlier+copy came to, since a method may read the `ρ` or the `φ` of the copy it+stands in, and so a recursion over copies of one object stops after its first+round, with the second one as written.+ ## Rewrite You can rewrite this expression with the help of [rules](#rule-structure)@@ -1073,8 +1478,9 @@ The colon binds as tightly as a dot, so `ξ.a:φ.b` is `⟦ φ ↦ ξ.a ⟧.b`. With `--sweet`, `phino` prints every such formation this way, so-`⟦ x ↦ ⟦ φ ↦ ξ.a ⟧ ⟧` comes out as `a:φ:x`. A formation-with inline voids keeps its brackets, as in `x(a) ↦ ⟦ φ ↦ a ⟧`, and so does+`⟦ x ↦ ⟦ φ ↦ ξ.a ⟧ ⟧` comes out as `a:φ:x` and `⟦ x(a) ↦ ⟦ φ ↦ a ⟧ ⟧`+as `⟦ x(a) ↦ a:φ ⟧`: the formation inline voids open takes the sugar,+while the one holding the voids keeps its brackets, and so does every formation in the salty syntax and in [LaTeX][latex]. A formation has a receiver `ρ` only when it declares one among its voids, the@@ -1113,10 +1519,7 @@ $ phino merge bytes.phi number.phi minus.phi --sweet ⟦ bytes(φ) ↦ ⟦⟧,- number(φ) ↦ ⟦- plus(x) ↦ ⟦ λ ⤍ L_number_plus ⟧,- minus(x) ↦ ⟦ λ ⤍ L_number_minus ⟧- ⟧+ number(φ) ↦ ⟦ plus(x) ↦ L_number_plus:λ, minus(x) ↦ L_number_minus:λ ⟧ ⟧ ``` @@ -1155,7 +1558,7 @@ \phinoNormalizationRule{stop} { [[ B ]] . \tau } { T }- { $ \tau \notin B \;\text{and}\; @ \notin B \;\text{and}\; L \notin B $ }+ { $ [ \tau \char44{} @ \char44{} L ] \cap B = \emptyset $ } { } \end{tabular} ```@@ -1233,9 +1636,9 @@ | eq: # compare two comparable objects - Comparable - Comparable- | in: # check if attributes exist in bindings- - Attribute'- - Binding'+ | in: # returns True if every given attribute exists in+ - Attribute' | [Attribute'] # the union of the given bindings+ - Binding' | [Binding'] | nf: Expression' # returns True if given expression in normal form # which means that no more other normalization rules # can be applied@@ -1374,7 +1777,7 @@ would be rejected as a duplicated attribute. Nothing can refer to an anonymous meta, since it has no name to be referred to-by. Writing one outside a `pattern` (or the `match`, `e-match` and `c-match` of+by. Writing one outside a `pattern` (or the `match`, `universe` and `c-match` of an inference rule) is a mistake in the rule and is reported as the rule loads. A positional (α) application argument is written as `α0`, `~0` (ASCII), or@@ -1418,103 +1821,119 @@ === parse/phi === warmup: 3 iterations batches: 10 x 1- total: 1768043.411 μs- avg: 176804.341 μs- min: 164618.314 μs- max: 199224.069 μs- std dev: 13380.573 μs+ total: 1235604.619 μs+ avg: 123560.462 μs+ min: 112999.536 μs+ max: 146848.289 μs+ std dev: 13523.687 μs === parse/xmir === warmup: 3 iterations batches: 10 x 1- total: 7486501.601 μs- avg: 748650.160 μs- min: 678843.922 μs- max: 882138.403 μs- std dev: 54979.122 μs+ total: 6181027.602 μs+ avg: 618102.760 μs+ min: 562545.414 μs+ max: 682531.677 μs+ std dev: 33378.489 μs === rewrite/normalize === warmup: 3 iterations batches: 10 x 1- total: 580244.769 μs- avg: 58024.477 μs- min: 53745.242 μs- max: 67886.567 μs- std dev: 3972.462 μs+ total: 14.492 μs+ avg: 1.449 μs+ min: 1.221 μs+ max: 1.863 μs+ std dev: 0.164 μs === print/sweet/multiline === warmup: 3 iterations batches: 10 x 1- total: 3581738.830 μs- avg: 358173.883 μs- min: 353632.119 μs- max: 364450.476 μs- std dev: 3758.053 μs+ total: 3687452.277 μs+ avg: 368745.228 μs+ min: 340283.380 μs+ max: 395918.805 μs+ std dev: 19962.268 μs === print/sweet/flat === warmup: 3 iterations batches: 10 x 1- total: 3586003.643 μs- avg: 358600.364 μs- min: 348511.573 μs- max: 363372.650 μs- std dev: 4666.744 μs+ total: 3607637.694 μs+ avg: 360763.769 μs+ min: 340150.409 μs+ max: 401378.260 μs+ std dev: 20648.726 μs === print/salty/multiline === warmup: 3 iterations batches: 10 x 1- total: 13668454.509 μs- avg: 1366845.451 μs- min: 1331880.047 μs- max: 1392431.918 μs- std dev: 20241.996 μs+ total: 10349170.023 μs+ avg: 1034917.002 μs+ min: 1011977.349 μs+ max: 1103222.564 μs+ std dev: 28732.304 μs === morph/symbolic/demo/e1 === warmup: 3 iterations- batches: 10 x 1- total: 902246.384 μs- avg: 90224.638 μs- min: 88957.751 μs- max: 91781.678 μs- std dev: 808.904 μs+ batches: 10 x 3+ total: 129778.599 μs+ avg: 4325.953 μs+ min: 4287.416 μs+ max: 4382.296 μs+ std dev: 30.864 μs === morph/symbolic/demo/e2 === warmup: 3 iterations- batches: 10 x 1- total: 1221686.976 μs- avg: 122168.698 μs- min: 119410.311 μs- max: 123946.713 μs- std dev: 1478.809 μs+ batches: 10 x 5+ total: 201800.582 μs+ avg: 4036.012 μs+ min: 3982.252 μs+ max: 4124.524 μs+ std dev: 43.136 μs === morph/symbolic/demo/e3 === warmup: 3 iterations- batches: 10 x 1- total: 1867130.933 μs- avg: 186713.093 μs- min: 182254.442 μs- max: 199500.578 μs- std dev: 4421.828 μs+ batches: 10 x 3+ total: 174129.187 μs+ avg: 5804.306 μs+ min: 5765.516 μs+ max: 5875.392 μs+ std dev: 31.510 μs === morph/symbolic/demo/e4 === warmup: 3 iterations- batches: 10 x 1- total: 638270.776 μs- avg: 63827.078 μs- min: 62286.130 μs- max: 64675.326 μs- std dev: 647.450 μs+ batches: 10 x 5+ total: 195942.319 μs+ avg: 3918.846 μs+ min: 3416.828 μs+ max: 7676.874 μs+ std dev: 1255.938 μs === morph/symbolic/demo/e5 === warmup: 3 iterations- batches: 10 x 1- total: 189257.666 μs- avg: 18925.767 μs- min: 18570.345 μs- max: 19165.345 μs- std dev: 197.617 μs+ batches: 10 x 15+ total: 184899.602 μs+ avg: 1232.664 μs+ min: 1224.459 μs+ max: 1242.434 μs+ std dev: 5.749 μs === morph/symbolic/native/e5 ===- warmup: 2 iterations- batches: 4 x 1- total: 17870892.725 μs- avg: 4467723.181 μs- min: 4368895.499 μs- max: 4581076.732 μs- std dev: 95768.713 μs+ warmup: 3 iterations+ batches: 10 x 1+ total: 192336.003 μs+ avg: 19233.600 μs+ min: 18688.555 μs+ max: 19909.284 μs+ std dev: 427.461 μs+=== morph/symbolic/accum/0 ===+ warmup: 3 iterations+ batches: 10 x 2+ total: 211409.497 μs+ avg: 10570.475 μs+ min: 10490.484 μs+ max: 10743.310 μs+ std dev: 66.154 μs+=== morph/symbolic/accum/400 ===+ warmup: 3 iterations+ batches: 10 x 1+ total: 361054.043 μs+ avg: 36105.404 μs+ min: 35194.312 μs+ max: 41143.240 μs+ std dev: 1694.561 μs ``` The results were calculated in [this GHA job][benchmark-gha]-on 2026-09-23 at 19:07,+on 2026-09-27 at 05:24, on Linux with 4 CPUs. <!-- benchmark_end -->@@ -1564,4 +1983,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/35906648654+[benchmark-gha]: https://github.com/objectionary/phino/actions/runs/36296915429
benchmark/Main.hs view
@@ -3,14 +3,15 @@ module Main where -import AST (Expression (ExRoot), hashExpression)+import AST (Attribute (AtLabel), Binding (BiTau), Expression (ExFormation, ExRoot), hashExpression) import CLI.Helpers (started) import Control.Exception (evaluate) import Control.Monad (replicateM, replicateM_) import qualified Data.Map.Strict as Map+import Data.String (fromString) import Data.Time.Clock import Dataize (reduction)-import Deps (Judgment (Morphing), dontSaveEval, dontSaveStep)+import Deps (Acyclic (Plausible, Proven), Judgment (Morphing), dontSaveEval, dontSaveStep) import Encoding (Encoding (UNICODE)) import Evaluate (evaluation, fired) import Functions (buildTerm)@@ -18,7 +19,7 @@ import Lining (LineFormat (MULTILINE, SINGLELINE)) import Margin (defaultMargin) import Merge (merge)-import Morph (ReduceContext (ReduceContext), Steps (Steps), morph)+import Morph (Memo, ReduceContext (ReduceContext), Steps (Steps), memoized, morph) import Must (Must (MtDisabled)) import Parser (parseExpressionThrows) import Printer (printExpression')@@ -70,12 +71,12 @@ -- the regression was seen under: '--deep', so a λ function standing anywhere -- inside the term is fired and not only the one on the spine; '--acyclic', so -- a term coming back to itself parks instead of spending the whole step--- budget; and '--partial', so a λ function no entry answers parks too and the+-- budget, under whichever mode the case asks for; and '--partial', so a λ function no entry answers parks too and the -- run still reaches an answer to measure. Nothing is written anywhere: the -- protocol of '--protocol' and the steps of '--steps-dir' are files, and a -- benchmark measuring the calculus has no business measuring the disk.-symbolicCtx :: Lambdas -> Expression -> ReduceContext-symbolicCtx lambdas locator =+symbolicCtx :: Acyclic -> Maybe Memo -> Lambdas -> Expression -> ReduceContext+symbolicCtx acyclic memo lambdas locator = ReduceContext locator -- _locator locator -- _site@@ -83,16 +84,17 @@ 25 -- _maxDepth 25 -- _maxCycles (Steps 1000 0) -- _steps+ Nothing -- _tally+ memo -- _memo 1 -- _nesting False -- _depthSensitive False -- _shuffle True -- _partial True -- _deep- True -- _acyclic+ (Just acyclic) -- _acyclic Morphing -- _judgment [] -- _parked- Map.empty -- _seen- Map.empty -- _dataized+ Map.empty -- _entered lambdas -- _symbolic buildTerm -- _buildTerm reduction -- _reduce@@ -150,6 +152,10 @@ demo <- parseExpressionThrows dsrc merged <- merge [demo, expr] lambdas <- readLambdas "benchmark/atoms.yaml"+ asrc <- readFile "benchmark/accum.phi"+ accum <- parseExpressionThrows asrc+ method <- parseExpressionThrows "⟦ b ↦ ∅, φ ↦ ξ.ρ.plus( b ↦ ξ.b ), ρ ↦ ∅ ⟧"+ counters <- readLambdas "benchmark/accum.yaml" runBench "parse/phi" (parseExpressionThrows src) runBench "parse/xmir" (parseXMIRThrows xsrc >>= xmirToPhi) runBench "rewrite/normalize" (rewrite expr normalizationRules rewriteCtx)@@ -164,6 +170,7 @@ (evaluate (length (printExpression' expr (SALTY, UNICODE, MULTILINE, defaultMargin)))) mapM_ (aimed "demo" demo lambdas) entries aimed "native" merged lambdas probe+ mapM_ (\count -> looped count (padded method count accum) counters) paddings where -- The entries of the demo world, each one term the λ functions of -- 'benchmark/atoms.yaml' answer and each one case of the suite, so that a@@ -186,15 +193,43 @@ aimed :: String -> Expression -> Lambdas -> String -> IO () aimed label universe lambdas name = do locator <- parseExpressionThrows ("Φ.l🌵." ++ name)- runBench (printf "morph/symbolic/%s/%s" label name) (symbolic universe lambdas locator)+ runBench (printf "morph/symbolic/%s/%s" label name) (symbolic Proven universe lambdas locator)+ -- How many methods 'number' of 'benchmark/accum.phi' gets that the loop+ -- never calls. A step of the loop should cost the redex it rewrites and+ -- not the objects standing around it, so the two numbers should be close,+ -- and they were sixteen-fold apart before #1453 made them so.+ paddings :: [Int]+ paddings = [0, 400]+ -- One case of the accumulator suite: the loop of #1453 over a 'number'+ -- carrying so many unused methods, cut by '--acyclic=plausible'.+ looped :: Int -> Expression -> Lambdas -> IO ()+ looped count universe counters = do+ locator <- parseExpressionThrows "Φ.l🌵"+ runBench (printf "morph/symbolic/accum/%d" count) (symbolic Plausible universe counters locator)+ -- The world with 'number' declaring the given number of copies of the+ -- method besides its own, each under a name of its own. They are made+ -- here rather than checked in, since four hundred of them are a file+ -- nobody would read.+ padded :: Expression -> Int -> Expression -> Expression+ padded method count (ExFormation bds) = ExFormation (map grown bds)+ where+ grown :: Binding -> Binding+ grown (BiTau attr (ExFormation inner))+ | attr == AtLabel (fromString "number") =+ BiTau attr (ExFormation (inner ++ map copy [1 .. count]))+ grown binding = binding+ copy :: Int -> Binding+ copy index = BiTau (AtLabel (fromString (printf "m%d" index))) method+ padded _ _ universe = universe -- One symbolic morphing of one entry, the way the 'morph' command runs it: -- the 𝜏-labels of the universe are scanned once, the run starts from the -- state that world already carries and 𝕄 is aimed at the entry. The answer -- is hashed rather than merely forced to weak head normal form, since a -- term left as a thunk is work the benchmark asked for and did not wait -- for.- symbolic :: Expression -> Lambdas -> Expression -> IO Int- symbolic universe lambdas locator = do+ symbolic :: Acyclic -> Expression -> Lambdas -> Expression -> IO Int+ symbolic acyclic universe lambdas locator = do seedTaus universe- (answer, _, _) <- morph universe (started universe) (symbolicCtx lambdas locator)+ memo <- memoized (Just acyclic)+ (answer, _, _) <- morph universe (started universe) (symbolicCtx acyclic memo lambdas locator) pure (hashExpression answer)
+ benchmark/accum.phi view
@@ -0,0 +1,8 @@+⟦+ number ↦ ⟦ φ ↦ ∅, gt ↦ ⟦ b ↦ ∅, λ ⤍ L_number_gt, ρ ↦ ∅ ⟧, plus ↦ ⟦ b ↦ ∅, λ ⤍ L_number_plus, ρ ↦ ∅ ⟧ ⟧,+ bytes ↦ ⟦ φ ↦ ∅, size ↦ ⟦ λ ⤍ L_bytes_size, ρ ↦ ∅ ⟧, concat ↦ ⟦ b ↦ ∅, λ ⤍ L_bytes_concat, ρ ↦ ∅ ⟧ ⟧,+ bool ↦ ⟦ if ↦ ∅, φ ↦ ξ.if( left ↦ Φ.bytes( φ ↦ ⟦ Δ ⤍ FF- ⟧ ), right ↦ Φ.bytes( φ ↦ ⟦ Δ ⤍ 00- ⟧ ) ) ⟧,+ hex ↦ ⟦ x ↦ ∅, φ ↦ ξ.rec( index ↦ 0, acc ↦ Φ.bytes( φ ↦ ⟦ Δ ⤍ 00- ⟧ ) ), rec ↦ ⟦ index ↦ ∅, acc ↦ ∅, ρ ↦ ∅, φ ↦ ξ.ρ.x.size.gt( b ↦ ξ.index ).if( left ↦ ξ.ρ.rec( index ↦ ξ.index.plus( b ↦ 1 ), acc ↦ ξ.acc.concat( b ↦ ξ.ρ.x ) ), right ↦ ξ.acc ) ⟧ ⟧,+ l🌵 ↦ ⟦ mark ↦ ⟦ n ↦ ∅, v ↦ ∅, λ ⤍ L_entry ⟧, root ↦ ⟦ v ↦ ∅, λ ⤍ L_root ⟧,+ e1 ↦ Φ.l🌵.mark( n ↦ 1 )( v ↦ Φ.hex( x ↦ Φ.bytes( φ ↦ ⟦ λ ⤍ 𝜎1 ⟧ ) ) ) ⟧+⟧
+ benchmark/accum.yaml view
@@ -0,0 +1,50 @@+# SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+# SPDX-License-Identifier: MIT+---+# yamllint disable rule:line-length+# The λ functions the accumulator cases of the benchmark fire over+# 'benchmark/accum.phi', the loop of #1453. Every entry answers symbolically,+# 'gt' with a fork the 'L_fork' entry joins, so the loop never learns where it+# stops and '--acyclic=plausible' is what cuts it, after the same twenty-six+# firings however many methods 'number' declares.+- λ: L_bytes_size+ dataize:+ 𝛿1: $.ρ+ 𝑛: Φ.number( φ ↦ Φ.bytes( φ ↦ ⟦ λ ⤍ 𝜎 ⟧ ) )+- λ: L_number_plus+ dataize:+ 𝛿1: $.ρ+ 𝛿2: $.b+ 𝑛: Φ.number( φ ↦ Φ.bytes( φ ↦ ⟦ λ ⤍ 𝜎 ⟧ ) )+- λ: L_bytes_concat+ dataize:+ 𝛿1: $.ρ+ 𝛿2: $.b+ 𝑛: Φ.bytes( φ ↦ ⟦ λ ⤍ 𝜎 ⟧ )+- λ: L_number_gt+ dataize:+ 𝛿1: $.ρ+ 𝛿2: $.b+ 𝑛: Φ.bool( if ↦ ⟦ λ ⤍ L_fork, left ↦ ∅, right ↦ ∅, φ ↦ ⟦ λ ⤍ 𝜎 ⟧ ⟧ )+- λ: L_fork+ dataize:+ 𝛿1: $.φ+ morph:+ 𝑛1: $.left+ 𝑛2: $.right+ symbolize:+ 𝑛3: 𝑛1+ 𝑛4: 𝑛2+ join:+ 𝑛5: [𝑛3, 𝑛4]+ 𝑛: 𝑛5+- λ: L_entry+ dataize:+ 𝛿1: $.n+ morph:+ 𝑛1: $.v.φ+ 𝑛: Φ.l🌵.root( 𝑛1 )+- λ: L_root+ dataize:+ 𝛿1: $.v+ 𝑛: ⟦ ⟧
phino.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: phino-version: 0.0.140+version: 0.0.141 license: MIT synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions description: Please see the README on GitHub at <https://github.com/objectionary/phino#readme>@@ -12,7 +12,7 @@ copyright: 2025 Objectionary.com category: Language, Code Analysis build-type: Simple-extra-source-files: resources/normalize/*.yaml resources/morphing/*.yaml resources/dataization/*.yaml resources/contextualization/*.yaml benchmark/demo.phi benchmark/atoms.yaml+extra-source-files: resources/normalize/*.yaml resources/morphing/*.yaml resources/dataization/*.yaml resources/contextualization/*.yaml benchmark/demo.phi benchmark/atoms.yaml benchmark/accum.phi benchmark/accum.yaml extra-doc-files: README.md source-repository head@@ -34,6 +34,7 @@ library import: warnings exposed-modules:+ Abridge AST Builder Bytes@@ -129,6 +130,7 @@ main-is: Main.hs hs-source-dirs: test other-modules:+ AbridgeSpec ASTSpec BuilderSpec BytesSpec
resources/dataization/box.yaml view
@@ -3,8 +3,8 @@ --- name: box match: ⟦𝐵1, φ ↦ 𝑒2, 𝐵2⟧-e-match: 𝑒1-d-result: 𝛿1+universe: 𝑒1+conclusion: 𝛿1 when: disjoint: - [Δ, λ]
resources/dataization/delta.yaml view
@@ -4,5 +4,5 @@ name: delta label: \Delta match: ⟦𝐵1, Δ ⤍ 𝛿1, 𝐵2⟧-e-match: 𝑒1-d-result: 𝛿1+universe: 𝑒1+conclusion: 𝛿1
resources/dataization/fire.yaml view
@@ -3,8 +3,8 @@ --- name: fire match: ⟦𝐵1, λ ⤍ 𝑓1, 𝐵2⟧-e-match: 𝑒1-d-result: 𝛿1+universe: 𝑒1+conclusion: 𝛿1 premises: - n-result: 𝑛1 evaluate:
resources/dataization/none.yaml view
@@ -3,8 +3,8 @@ --- name: none match: ⟦𝐵1⟧-e-match: 𝑒1-d-result: 𝛿1+universe: 𝑒1+conclusion: 𝛿1 when: disjoint: - [Δ, λ, φ]
resources/dataization/norm.yaml view
@@ -3,8 +3,8 @@ --- name: norm match: 𝑛1-e-match: 𝑒1-d-result: 𝛿1+universe: 𝑒1+conclusion: 𝛿1 when: and: - not:
resources/morphing/dead.yaml view
@@ -3,5 +3,5 @@ --- name: dead match: ⊥-e-match: 𝑒1-n-result: ⊥+universe: 𝑒1+conclusion: ⊥
resources/morphing/ma.yaml view
@@ -3,8 +3,8 @@ --- name: ma match: '𝑛1(𝜏1 ↦ 𝑘1)'-e-match: 𝑒1-n-result: 𝑛4+universe: 𝑒1+conclusion: 𝑛4 premises: - n-result: 𝑛2 morph: 𝑛1
resources/morphing/maa.yaml view
@@ -3,8 +3,8 @@ --- name: maa match: '𝑛1(α𝑖1 ↦ 𝑘1)'-e-match: 𝑒1-n-result: 𝑛4+universe: 𝑒1+conclusion: 𝑛4 premises: - n-result: 𝑛2 morph: 𝑛1
resources/morphing/maad.yaml view
@@ -3,8 +3,8 @@ --- name: maad match: '𝑛(α𝑖 ↦ 𝑛1)'-e-match: 𝑒1-n-result: 𝑛2+universe: 𝑒1+conclusion: 𝑛2 when: not: absolute: 𝑛1
resources/morphing/mad.yaml view
@@ -3,8 +3,8 @@ --- name: mad match: '𝑛(𝜏 ↦ 𝑛1)'-e-match: 𝑒1-n-result: 𝑛2+universe: 𝑒1+conclusion: 𝑛2 when: not: absolute: 𝑛1
resources/morphing/md.yaml view
@@ -3,8 +3,8 @@ --- name: md match: '𝑛1.𝜏1'-e-match: 𝑒1-n-result: 𝑛4+universe: 𝑒1+conclusion: 𝑛4 when: not: formation: 𝑛1
resources/morphing/mf.yaml view
@@ -3,5 +3,5 @@ --- name: mf match: ⟦𝐵1⟧-e-match: 𝑒1-n-result: ⟦𝐵1⟧+universe: 𝑒1+conclusion: ⟦𝐵1⟧
resources/morphing/mg.yaml view
@@ -3,8 +3,8 @@ --- name: mg match: Φ-e-match: Φ-n-result: 𝑛1+universe: Φ+conclusion: 𝑛1 premises: - n-result: 𝑛1 morph: ⊥
resources/morphing/ml.yaml view
@@ -4,8 +4,8 @@ name: ml label: \lambda match: '⟦𝐵1, λ ⤍ 𝑓1, 𝐵2⟧.𝜏1'-e-match: 𝑒1-n-result: 𝑛3+universe: 𝑒1+conclusion: 𝑛3 premises: - n-result: 𝑛1 evaluate:
resources/morphing/mphi.yaml view
@@ -4,21 +4,16 @@ name: mphi label: \varphi match: ⟦𝐵1⟧.𝜏1-e-match: 𝑒1-n-result: 𝑛2+universe: 𝑒1+conclusion: 𝑛2 when: and: - in: - φ - 𝐵1- - not:- in:- - 𝜏1- - 𝐵1- - not:- in:- - λ- - 𝐵1+ - disjoint:+ - [𝜏1, λ]+ - [𝐵1] premises: - n-result: 𝑛1 normalize: ⟦𝐵1⟧.φ.𝜏1
resources/morphing/universe.yaml view
@@ -4,8 +4,8 @@ name: universe label: \Phi match: Φ-e-match: 𝑒1-n-result: 𝑛2+universe: 𝑒1+conclusion: 𝑛2 when: not: eq:
resources/morphing/xi.yaml view
@@ -3,8 +3,8 @@ --- name: xi match: ξ-e-match: 𝑒1-n-result: 𝑛1+universe: 𝑒1+conclusion: 𝑛1 premises: - n-result: 𝑛1 morph: ⊥
resources/normalize/dl.yaml view
@@ -5,10 +5,6 @@ pattern: ⟦𝐵1, λ ⤍ 𝑓, 𝐵2⟧ result: ⊥ when:- or:- - in:- - Δ- - 𝐵1- - in:- - Δ- - 𝐵2+ in:+ - Δ+ - [𝐵1, 𝐵2]
resources/normalize/dot.yaml view
@@ -10,35 +10,35 @@ # ⟦…, 𝜏1 ↦ 𝑛1, …⟧.𝜏1 term and looping forever. ρ on line 'result' still binds # the full formation, so sibling and φ-decoration references stay intact — only # the self-ξ path narrows, keeping normalization (near-)total.-# The formation the dispatch stands on is the whole program here and not a part-# of it; the 'dotg' sibling writes that one, and the two together cover every-# dispatch this one covered alone. Where no universe is known — the 'rewrite'-# command, and 'isNF' asking about a term on its own — 𝑒1 binds nothing, the-# guard cannot hold, and this rule answers every dispatch as it always did.-# Neither rule dispatches on a formation holding both λ and Δ: 'dl' says such a-# formation is ⊥, and carrying it out into ρ would leave a ρ ↦ ⊥ in a normal-# form that 'dl' firing first reduces to ⊥ outright, so the answer would hang-# on rule order (#1395).+# The rule does not dispatch on a formation holding both λ and Δ: 'dl' says+# such a formation is ⊥, and carrying it out into ρ would leave a ρ ↦ ⊥ in a+# normal form that 'dl' firing first reduces to ⊥ outright, so the answer would+# hang on rule order (#1395).+# The ρ carries the name of the formation where it has one: the whole program+# is 'Φ', and a formation reached as 'Φ.number', or as 'Φ.number( φ ↦ 𝑘 )', is+# an object of the immutable world, so the 'named' function writes that name+# back instead of the object, and a dispatch off it does not copy the program+# or every method the object declares into the term (#1318, #1446). The world+# 'named' looks the name up in is phino's to know, not the rule's: the rule is+# about a term alone and never binds the world itself (#1460). Where the+# formation has no name, or no world is known — the 'rewrite' command, and+# 'isNF' asking about a term on its own — 'named' answers with the formation+# itself and the ρ holds it. name: dot pattern: ⟦𝐵1, 𝜏1 ↦ 𝑛1, 𝐵2⟧.𝜏1-e-match: 𝑒1 when:- and:- - not:- eq:- - ⟦𝐵1, 𝜏1 ↦ 𝑛1, 𝐵2⟧- - 𝑒1- - or:- - disjoint:- - [λ]- - [𝐵1, 𝐵2]- - disjoint:- - [Δ]- - [𝐵1, 𝐵2]-result: 𝑒2(ρ ↦ ⟦𝐵1, 𝜏1 ↦ 𝑛1, 𝐵2⟧)+ not:+ in:+ - [Δ, λ]+ - [𝐵1, 𝐵2]+result: 𝑒1(ρ ↦ 𝑒2) where:- - meta: 𝑒2+ - meta: 𝑒1 function: contextualize args: - 𝑛1 - ⟦𝐵1, 𝐵2⟧+ - meta: 𝑒2+ function: named+ args:+ - ⟦𝐵1, 𝜏1 ↦ 𝑛1, 𝐵2⟧
− resources/normalize/dotg.yaml
@@ -1,37 +0,0 @@-# SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com-# SPDX-License-Identifier: MIT-----# The 'dot' rule where the formation dispatched on is the whole program. Φ is-# the name of that formation, so the body is decorated with the name and not-# with the program: writing the program out copies it into the term, and into-# every term that term then dispatches, so the copies compound until one term-# weighs hundreds of times what the program does (#1318). Whoever reads the ρ-# resolves Φ through the 'universe' morphing rule, which answers with the-# program in normal form — the very formation that would have stood here, since-# a dispatch reaches this rule only once Φ has already been resolved that way.-# Everything else is 'dot': the same pattern, the same contextualization-# context, and a guard that is the exact complement of the one there, so the-# two never both answer a dispatch and never both refuse one, save a formation-# holding both λ and Δ, which both refuse and leave to 'dl' (#1395).-name: dotg-pattern: ⟦𝐵1, 𝜏1 ↦ 𝑛1, 𝐵2⟧.𝜏1-e-match: 𝑒1-when:- and:- - eq:- - ⟦𝐵1, 𝜏1 ↦ 𝑛1, 𝐵2⟧- - 𝑒1- - or:- - disjoint:- - [λ]- - [𝐵1, 𝐵2]- - disjoint:- - [Δ]- - [𝐵1, 𝐵2]-result: 𝑒2(ρ ↦ Φ)-where:- - meta: 𝑒2- function: contextualize- args:- - 𝑛1- - ⟦𝐵1, 𝐵2⟧
resources/normalize/skip.yaml view
@@ -1,10 +1,10 @@ # SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com # SPDX-License-Identifier: MIT ----# A formation that declares no ρ has no receiver, so the ρ 'dot' and 'dotg'-# hand every dispatched body is dropped once that body turns out to be such a-# formation. 'copy' fills a ρ the formation declares void, and 'stay' keeps one-# it has already bound (#1407).+# A formation that declares no ρ has no receiver, so the ρ 'dot' hands every+# dispatched body is dropped once that body turns out to be such a formation.+# 'copy' fills a ρ the formation declares void, and 'stay' keeps one it has+# already bound (#1407). name: skip pattern: ⟦𝐵1⟧(ρ ↦ 𝑒1) result: ⟦𝐵1⟧
resources/normalize/stop.yaml view
@@ -5,16 +5,6 @@ pattern: ⟦𝐵1⟧.𝜏1 result: ⊥ when:- and:- - not:- in:- - 𝜏1- - 𝐵1- - not:- in:- - φ- - 𝐵1- - not:- in:- - λ- - 𝐵1+ disjoint:+ - [𝜏1, φ, λ]+ - [𝐵1]
src/AST.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-}@@ -8,13 +9,45 @@ -- SPDX-License-Identifier: MIT -- This module represents AST tree for parsed phi-calculus expression-module AST where+module AST+ ( Slot (..)+ , Expression (ExFormation, ExXi, ExRoot, ExTermination, ExApplication, ExDispatch, ExMeta, ExAny, ExPhiMeet, ExPhiAgain, ExBytes)+ , Argument (..)+ , Alpha (..)+ , Binding (..)+ , Bytes (..)+ , Attribute (..)+ , Function (..)+ , hashExpression+ , hashShape+ , hashSkeleton+ , inert+ , distinct+ , repeated+ , attributeFromBinding+ , alike+ , within+ , symbols+ , denoted+ , countNodes+ , matchBaseObject+ , pattern BaseObject+ , matchDataObject+ , pattern DataString+ , pattern DataNumber+ , pattern DataObject+ , dataBytes+ )+where import Data.Bits (xor)+import qualified Data.IntMap.Strict as IntMap import Data.List (foldl')-import Data.Maybe (listToMaybe)+import qualified Data.Map.Strict as Map+import Data.Maybe (isJust, isNothing, listToMaybe) import Data.Text (Text) import qualified Data.Text as T+import GHC.Exts (isTrue#, reallyUnsafePtrEquality#) import GHC.Generics (Generic) -- An anonymous meta-variable, written bare — 𝜏, 𝐵, 𝑒, 𝑛, 𝑘, 𝛿, 𝑓, 𝜎 or 𝑖@@ -25,13 +58,21 @@ data Slot = Slot Text Int deriving (Eq, Ord, Show) +-- A formation, an application and a dispatch are the nodes a term is built of,+-- and each of them carries what has been worked out about the term it heads:+-- its digest, its size and whether it is inert. They are worked out once per+-- node, from what its children carry, the first time anybody asks, so a node+-- shared by many terms, as the objects of the world are, is walked once and+-- never again. The three nodes are reached through the patterns+-- 'ExFormation', 'ExApplication' and 'ExDispatch', which build and read them+-- like constructors and never show what they carry (#1453). data Expression- = ExFormation [Binding]+ = Formed Facts [Binding] | ExXi | ExRoot | ExTermination- | ExApplication Expression Argument- | ExDispatch Expression Attribute+ | Applied Facts Expression Argument+ | Dispatched Facts Expression Attribute | ExMeta Text | ExAny Slot | ExPhiMeet (Maybe String) Int Expression@@ -43,8 +84,116 @@ matcher, builder or the dataization relation. -} ExBytes Bytes- deriving (Eq, Ord, Show, Generic) +-- What is worked out about the term a node heads: its digest (see+-- 'hashExpression'), the number of nodes it counts (see 'countNodes'),+-- whether it is inert (see 'inert') and whether its attributes are distinct+-- (see 'distinct'). The size and the distinctness are worked out only when+-- asked for, since only a few terms are ever asked for them.+data Facts = Facts !Int Int !Bool Bool++{-# COMPLETE ExFormation, ExXi, ExRoot, ExTermination, ExApplication, ExDispatch, ExMeta, ExAny, ExPhiMeet, ExPhiAgain, ExBytes #-}++pattern ExFormation :: [Binding] -> Expression+pattern ExFormation bds <- Formed _ bds+ where+ ExFormation bds = cached (`Formed` bds)++pattern ExApplication :: Expression -> Argument -> Expression+pattern ExApplication expr arg <- Applied _ expr arg+ where+ ExApplication expr arg = cached (\facts -> Applied facts expr arg)++pattern ExDispatch :: Expression -> Attribute -> Expression+pattern ExDispatch expr attr <- Dispatched _ expr attr+ where+ ExDispatch expr attr = cached (\facts -> Dispatched facts expr attr)++-- The node made of the given constructor and of what is worked out about the+-- node itself, which is left to be worked out when first asked for.+cached :: (Facts -> Expression) -> Expression+cached node = let term = node (established term) in term++-- What is known about a term: what its top node carries, or what is worked+-- out on the spot for a term whose top node carries nothing.+known :: Expression -> Facts+known (Formed facts _) = facts+known (Applied facts _ _) = facts+known (Dispatched facts _ _) = facts+known term = established term++-- What is worked out about a term from what is known about its children,+-- without walking any deeper than them.+established :: Expression -> Facts+established term = Facts (layer id hashExpression term) (tally term) (calm term) (unrepeated term)++-- Two terms are equal when they are the very same node, or when they are+-- built alike and hold equal children. Two nodes carrying different digests+-- are told apart without walking either, and two terms sharing+-- their children compare the children by identity, so comparing a term with+-- what a rewriting step made of it costs the part the step rebuilt.+instance Eq Expression where+ left == right = isTrue# (reallyUnsafePtrEquality# left right) || congruent left right+ where+ congruent :: Expression -> Expression -> Bool+ congruent (Formed facts bds) (Formed facts' bds') = alongside facts facts' && bds == bds'+ congruent (Applied facts expr arg) (Applied facts' expr' arg') = alongside facts facts' && expr == expr' && arg == arg'+ congruent (Dispatched facts expr attr) (Dispatched facts' expr' attr') = alongside facts facts' && attr == attr' && expr == expr'+ congruent ExXi ExXi = True+ congruent ExRoot ExRoot = True+ congruent ExTermination ExTermination = True+ congruent (ExMeta meta) (ExMeta meta') = meta == meta'+ congruent (ExAny slot) (ExAny slot') = slot == slot'+ congruent (ExPhiMeet prefix idx expr) (ExPhiMeet prefix' idx' expr') = prefix == prefix' && idx == idx' && expr == expr'+ congruent (ExPhiAgain prefix idx expr) (ExPhiAgain prefix' idx' expr') = prefix == prefix' && idx == idx' && expr == expr'+ congruent (ExBytes bts) (ExBytes bts') = bts == bts'+ congruent _ _ = False+ alongside :: Facts -> Facts -> Bool+ alongside (Facts digest _ _ _) (Facts digest' _ _ _) = digest == digest'++-- Terms are ordered by their constructors, in the order they are declared,+-- and then by what they hold, never by what is worked out about them.+instance Ord Expression where+ compare (ExFormation bds) (ExFormation bds') = compare bds bds'+ compare (ExApplication expr arg) (ExApplication expr' arg') = compare expr expr' <> compare arg arg'+ compare (ExDispatch expr attr) (ExDispatch expr' attr') = compare expr expr' <> compare attr attr'+ compare (ExMeta meta) (ExMeta meta') = compare meta meta'+ compare (ExAny slot) (ExAny slot') = compare slot slot'+ compare (ExPhiMeet prefix idx expr) (ExPhiMeet prefix' idx' expr') = compare prefix prefix' <> compare idx idx' <> compare expr expr'+ compare (ExPhiAgain prefix idx expr) (ExPhiAgain prefix' idx' expr') = compare prefix prefix' <> compare idx idx' <> compare expr expr'+ compare (ExBytes bts) (ExBytes bts') = compare bts bts'+ compare left right = compare (rank left) (rank right)+ where+ rank :: Expression -> Int+ rank = \case+ ExFormation _ -> 0+ ExXi -> 1+ ExRoot -> 2+ ExTermination -> 3+ ExApplication _ _ -> 4+ ExDispatch _ _ -> 5+ ExMeta _ -> 6+ ExAny _ -> 7+ ExPhiMeet{} -> 8+ ExPhiAgain{} -> 9+ ExBytes _ -> 10++-- A term is shown the way its constructors are written, without what is+-- worked out about it.+instance Show Expression where+ showsPrec prec = \case+ ExFormation bds -> showParen (prec > 10) (showString "ExFormation " . showsPrec 11 bds)+ ExXi -> showString "ExXi"+ ExRoot -> showString "ExRoot"+ ExTermination -> showString "ExTermination"+ ExApplication expr arg -> showParen (prec > 10) (showString "ExApplication " . showsPrec 11 expr . showChar ' ' . showsPrec 11 arg)+ ExDispatch expr attr -> showParen (prec > 10) (showString "ExDispatch " . showsPrec 11 expr . showChar ' ' . showsPrec 11 attr)+ ExMeta meta -> showParen (prec > 10) (showString "ExMeta " . showsPrec 11 meta)+ ExAny slot -> showParen (prec > 10) (showString "ExAny " . showsPrec 11 slot)+ ExPhiMeet prefix idx expr -> showParen (prec > 10) (showString "ExPhiMeet " . showsPrec 11 prefix . showChar ' ' . showsPrec 11 idx . showChar ' ' . showsPrec 11 expr)+ ExPhiAgain prefix idx expr -> showParen (prec > 10) (showString "ExPhiAgain " . showsPrec 11 prefix . showChar ' ' . showsPrec 11 idx . showChar ' ' . showsPrec 11 expr)+ ExBytes bts -> showParen (prec > 10) (showString "ExBytes " . showsPrec 11 bts)+ data Argument = ArTau Attribute Expression | ArAlpha Alpha Expression@@ -117,10 +266,49 @@ -- A cheap, fixed-size digest of an expression, used for fast (dirty) equality -- checks during loop detection. Equal expressions always produce the same -- digest, but distinct expressions may collide, so a positive digest match--- must always be confirmed with a full structural (==) comparison.+-- must always be confirmed with a full structural (==) comparison. A node+-- carries its digest, mixed of the digests its children carry, so asking for+-- it costs nothing once the node has been asked once (#1453). hashExpression :: Expression -> Int-hashExpression = goExpr fnvOffset+hashExpression term = case known term of+ Facts digest _ _ _ -> digest++-- The same digest, blind to which symbol stands where: every symbol is hashed+-- as the same one, so two terms that are 'alike' always produce the same+-- digest, while data, names and shape still tell terms apart. It is what keys+-- a store of terms compared up to a renaming of symbols, and like+-- 'hashExpression' a positive match must be confirmed, by 'alike' here.+hashShape :: Expression -> Int+hashShape = layer (const 0) hashShape++-- The same digest again, blind as well to every term the top of a term holds:+-- a formation is hashed by the names of its attributes, in order, with its data+-- and the λ function it names, and anything else by the constructor at its top+-- and the attribute or index it carries. Two terms one of which is 'within' the+-- other always produce the same digest, so it keys a store of terms compared by+-- embedding, and a positive match must be confirmed by 'within'.+hashSkeleton :: Expression -> Int+hashSkeleton =+ hashShape . \case+ ExFormation bds -> ExFormation (map bare bds)+ ExApplication _ (ArTau attr _) -> ExApplication ExXi (ArTau attr ExXi)+ ExApplication _ (ArAlpha alpha _) -> ExApplication ExXi (ArAlpha alpha ExXi)+ ExDispatch _ attr -> ExDispatch ExXi attr+ ExPhiMeet prefix idx _ -> ExPhiMeet prefix idx ExXi+ ExPhiAgain prefix idx _ -> ExPhiAgain prefix idx ExXi+ term -> term where+ bare :: Binding -> Binding+ bare (BiTau attr _) = BiTau attr ExXi+ bare binding = binding++-- The digest of the top node of a term, the one both 'hashExpression' and+-- 'hashShape' compute, with the index of every symbol passed through the first+-- function before it is mixed in, and every term the node holds mixed in as+-- the digest the second function gives it.+layer :: (Int -> Int) -> (Expression -> Int) -> Expression -> Int+layer symbol child = goExpr fnvOffset+ where fnvPrime, fnvOffset :: Int fnvPrime = 1099511628211 fnvOffset = 14695981039@@ -142,16 +330,16 @@ ExXi -> step h 2 ExRoot -> step h 3 ExTermination -> step h 4- ExApplication ex arg -> goArgument (goExpr (step h 5) ex) arg- ExDispatch ex at -> goAttribute (goExpr (step h 6) ex) at+ ExApplication ex arg -> goArgument (step (step h 5) (child ex)) arg+ ExDispatch ex at -> goAttribute (step (step h 6) (child ex)) at ExMeta t -> hashText (step h 7) t ExAny slot -> goSlot (step h 32) slot- ExPhiMeet ms i ex -> goExpr (hashMaybeString (step (step h 9) i) ms) ex- ExPhiAgain ms i ex -> goExpr (hashMaybeString (step (step h 10) i) ms) ex+ ExPhiMeet ms i ex -> step (hashMaybeString (step (step h 9) i) ms) (child ex)+ ExPhiAgain ms i ex -> step (hashMaybeString (step (step h 10) i) ms) (child ex) ExBytes bts -> goBytes (step h 8) bts goBinding :: Int -> Binding -> Int goBinding h = \case- BiTau at ex -> goExpr (goAttribute (step h 11) at) ex+ BiTau at ex -> step (goAttribute (step h 11) at) (child ex) BiDelta bts -> goBytes (step h 12) bts BiVoid at -> goAttribute (step h 13) at BiLambda fn -> goFunction (step h 14) fn@@ -175,8 +363,8 @@ AtAny slot -> goSlot (step h 35) slot goArgument :: Int -> Argument -> Int goArgument h = \case- ArTau at ex -> goExpr (goAttribute (step h 22) at) ex- ArAlpha al ex -> goExpr (goAlpha (step h 30) al) ex+ ArTau at ex -> step (goAttribute (step h 22) at) (child ex)+ ArAlpha al ex -> step (goAlpha (step h 30) al) (child ex) goAlpha :: Int -> Alpha -> Int goAlpha h = \case Alpha idx -> step (step h 31) idx@@ -187,9 +375,95 @@ Function t -> hashText (step h 16) t FnMeta t -> hashText (step h 29) t FnAny slot -> goSlot (step h 37) slot- FnSymbol idx -> step (step h 38) idx+ FnSymbol idx -> step (step h 38) (symbol idx) FnFresh slot -> goSlot (step h 39) slot +-- Whether two terms are the same up to a bijective renaming of their symbols:+-- structurally equal once some one-to-one pairing of the symbols of one with+-- the symbols of the other is applied, so 𝜎3 may stand in one where 𝜎5 stands+-- in the other, as long as it does so everywhere and no other symbol stands+-- there too. Everything else — data, attribute names, λ names — has to match+-- exactly. A symbol is an opaque unknown nobody worked out, so two terms that+-- differ by nothing but which unknowns they carry reduce the same way, while+-- two that differ by a datum may not. The pairing is built as the two terms+-- are walked in lockstep and is kept in both directions, which is what refuses+-- one symbol standing for two and two standing for one.+alike :: Expression -> Expression -> Bool+alike one two = isJust (goExpr (Map.empty, Map.empty) one two)+ where+ goExpr :: (Map.Map Int Int, Map.Map Int Int) -> Expression -> Expression -> Maybe (Map.Map Int Int, Map.Map Int Int)+ goExpr pairing (ExFormation left) (ExFormation right) = goList goBinding pairing left right+ goExpr pairing (ExApplication left arg) (ExApplication right arg') = goExpr pairing left right >>= \next -> goArgument next arg arg'+ goExpr pairing (ExDispatch left attr) (ExDispatch right attr')+ | attr == attr' = goExpr pairing left right+ goExpr pairing (ExPhiMeet prefix idx left) (ExPhiMeet prefix' idx' right)+ | prefix == prefix' && idx == idx' = goExpr pairing left right+ goExpr pairing (ExPhiAgain prefix idx left) (ExPhiAgain prefix' idx' right)+ | prefix == prefix' && idx == idx' = goExpr pairing left right+ goExpr pairing left right = same pairing left right+ goBinding :: (Map.Map Int Int, Map.Map Int Int) -> Binding -> Binding -> Maybe (Map.Map Int Int, Map.Map Int Int)+ goBinding pairing (BiTau attr left) (BiTau attr' right)+ | attr == attr' = goExpr pairing left right+ goBinding pairing (BiLambda (FnSymbol left)) (BiLambda (FnSymbol right)) = paired pairing left right+ goBinding pairing left right = same pairing left right+ goArgument :: (Map.Map Int Int, Map.Map Int Int) -> Argument -> Argument -> Maybe (Map.Map Int Int, Map.Map Int Int)+ goArgument pairing (ArTau attr left) (ArTau attr' right)+ | attr == attr' = goExpr pairing left right+ goArgument pairing (ArAlpha alpha left) (ArAlpha alpha' right)+ | alpha == alpha' = goExpr pairing left right+ goArgument pairing left right = same pairing left right+ goList :: (pairing -> item -> item -> Maybe pairing) -> pairing -> [item] -> [item] -> Maybe pairing+ goList _ pairing [] [] = Just pairing+ goList walk pairing (left : lefts) (right : rights) = walk pairing left right >>= \next -> goList walk next lefts rights+ goList _ _ _ _ = Nothing+ same :: (Eq item) => pairing -> item -> item -> Maybe pairing+ same pairing left right+ | left == right = Just pairing+ | otherwise = Nothing+ paired :: (Map.Map Int Int, Map.Map Int Int) -> Int -> Int -> Maybe (Map.Map Int Int, Map.Map Int Int)+ paired (forward, backward) left right = case (Map.lookup left forward, Map.lookup right backward) of+ (Nothing, Nothing) -> Just (Map.insert left right forward, Map.insert right left backward)+ (Just right', Just _) | right' == right -> Just (forward, backward)+ _ -> Nothing++-- Whether the first term is embedded in the second: the two have the same+-- constructor, attributes, data and λ names at the top, and every term the+-- first holds there is embedded in the term the second holds at the same place,+-- either as it stands or somewhere below it. Deeper down a term may sit under+-- wrappers the other lacks, so a recursion whose argument gains one on every+-- round enters a formation the previous round is within, while a call nested+-- inside another is smaller and never holds it. Any symbol stands for any+-- other, since each is an opaque unknown. A ρ binding is never looked below,+-- since it holds the object a term was taken from and not a term it grew into.+within :: Expression -> Expression -> Bool+within = coupled+ where+ embedded :: Expression -> Expression -> Bool+ embedded inner outer = coupled inner outer || any (embedded inner) (children outer)+ coupled :: Expression -> Expression -> Bool+ coupled (ExFormation left) (ExFormation right) = length left == length right && and (zipWith goBinding left right)+ coupled (ExApplication left arg) (ExApplication right arg') = embedded left right && goArgument arg arg'+ coupled (ExDispatch left attr) (ExDispatch right attr') = attr == attr' && embedded left right+ coupled (ExPhiMeet prefix idx left) (ExPhiMeet prefix' idx' right) = prefix == prefix' && idx == idx' && embedded left right+ coupled (ExPhiAgain prefix idx left) (ExPhiAgain prefix' idx' right) = prefix == prefix' && idx == idx' && embedded left right+ coupled left right = left == right+ goBinding :: Binding -> Binding -> Bool+ goBinding (BiTau attr left) (BiTau attr' right) = attr == attr' && embedded left right+ goBinding (BiLambda (FnSymbol _)) (BiLambda (FnSymbol _)) = True+ goBinding left right = left == right+ goArgument :: Argument -> Argument -> Bool+ goArgument (ArTau attr left) (ArTau attr' right) = attr == attr' && embedded left right+ goArgument (ArAlpha alpha left) (ArAlpha alpha' right) = alpha == alpha' && embedded left right+ goArgument _ _ = False+ children :: Expression -> [Expression]+ children (ExFormation bds) = [expr | BiTau attr expr <- bds, attr /= AtRho]+ children (ExApplication expr (ArTau _ arg)) = [expr, arg]+ children (ExApplication expr (ArAlpha _ arg)) = [expr, arg]+ children (ExDispatch expr _) = [expr]+ children (ExPhiMeet _ _ expr) = [expr]+ children (ExPhiAgain _ _ expr) = [expr]+ children _ = []+ -- Every symbol a term carries, in the order it was written. A symbol is what -- makes the value a term stands for unknown, and the run reads the -- dependencies between its firings off them: a term carrying 𝜎4 is the term@@ -233,20 +507,120 @@ goBinding (BiTau AtPhi expr) = maybe [] pure (goExpr expr) goBinding _ = [] +-- The number of nodes a term counts, which a node carries once asked. countNodes :: Expression -> Int-countNodes (ExFormation bds) = 1 + sum (map nodesInBinding bds) + length bds+countNodes term = case known term of+ Facts _ size _ _ -> size++-- The number of nodes a term counts, from the numbers its children count.+tally :: Expression -> Int+tally (ExFormation bds) = 1 + sum (map nodesInBinding bds) + length bds where nodesInBinding :: Binding -> Int nodesInBinding (BiTau _ expr) = countNodes expr + 2 nodesInBinding (BiMeta _) = 1 nodesInBinding (BiAny _) = 1 nodesInBinding _ = 3-countNodes (ExApplication expr (ArTau _ expr')) = 4 + countNodes expr + countNodes expr'-countNodes (ExApplication expr (ArAlpha _ expr')) = 4 + countNodes expr + countNodes expr'-countNodes (ExDispatch expr' _) = 2 + countNodes expr'-countNodes (ExPhiMeet _ _ expr) = countNodes expr-countNodes (ExPhiAgain _ _ expr) = countNodes expr-countNodes _ = 1+tally (ExApplication expr (ArTau _ expr')) = 4 + countNodes expr + countNodes expr'+tally (ExApplication expr (ArAlpha _ expr')) = 4 + countNodes expr + countNodes expr'+tally (ExDispatch expr' _) = 2 + countNodes expr'+tally (ExPhiMeet _ _ expr) = countNodes expr+tally (ExPhiAgain _ _ expr) = countNodes expr+tally _ = 1++-- Whether no normalization rule can match anywhere in a term, judged by its+-- shape alone. Every such rule fires on one of four kinds of places: a+-- dispatch on a formation, an application of a formation, a dispatch or an+-- application of ⊥, and a formation holding both λ and Δ. A term is inert+-- when none of its places is of these kinds and it holds no meta-variable, so+-- ξ, Φ and ⊥ are inert, a formation is inert when its bodies are and it holds+-- not both λ and Δ, and a dispatch or an application is inert when its parts+-- are and its head is neither a formation nor ⊥. It says no more often than+-- it should, as '⟦ b ↦ ∅ ⟧( b ↦ ξ.x )' is normal but not inert, and that is+-- safe, since it only ever licenses skipping a term. A node carries the+-- answer once asked, so a term an earlier normalization produced is known to+-- be inert without being walked again (#1453).+inert :: Expression -> Bool+inert term = case known term of+ Facts _ _ still _ -> still++-- Whether no two bindings of a formation carry the same attribute, which a+-- node carries once asked, so an object carried from term to term is checked+-- once; any other term has no bindings to repeat one (#1453).+distinct :: Expression -> Bool+distinct term = case known term of+ Facts _ _ _ unique -> unique++-- Whether no two bindings of a formation carry the same attribute.+unrepeated :: Expression -> Bool+unrepeated (ExFormation bds) = isNothing (repeated bds)+unrepeated _ = True++-- The first attribute the bindings carry for the second time, if any. The+-- attributes seen so far are kept by a hash of their names and compared only+-- when two of them hash alike, which keeps checking a formation of hundreds of+-- bindings to one pass over them rather than one comparison of names after+-- another (#1453).+repeated :: [Binding] -> Maybe Attribute+repeated = go IntMap.empty+ where+ go :: IntMap.IntMap [Attribute] -> [Binding] -> Maybe Attribute+ go _ [] = Nothing+ go seen (bd : rest) = case attributeFromBinding bd of+ Just attr+ | attr `elem` IntMap.findWithDefault [] (key attr) seen -> Just attr+ | otherwise -> go (IntMap.insertWith (++) (key attr) [attr] seen) rest+ Nothing -> go seen rest+ key :: Attribute -> Int+ key (AtLabel label) = T.foldl' (\hash char -> (hash `xor` fromEnum char) * 1099511628211) 14695981039 label+ key (AtMeta meta) = T.length meta+ key _ = 0++-- Extract attribute from binding+attributeFromBinding :: Binding -> Maybe Attribute+attributeFromBinding (BiTau attr _) = Just attr+attributeFromBinding (BiVoid attr) = Just attr+attributeFromBinding (BiDelta _) = Just AtDelta+attributeFromBinding (BiLambda _) = Just AtLambda+attributeFromBinding (BiMeta _) = Nothing+attributeFromBinding (BiAny _) = Nothing++-- Whether a term is inert, from whether its children are.+calm :: Expression -> Bool+calm = \case+ ExFormation bds -> settled False False bds+ ExDispatch expr attr -> inert expr && headless expr && plain attr+ ExApplication expr (ArTau attr arg) -> inert expr && headless expr && plain attr && inert arg+ ExApplication expr (ArAlpha (Alpha _) arg) -> inert expr && headless expr && inert arg+ ExXi -> True+ ExRoot -> True+ ExTermination -> True+ _ -> False+ where+ settled :: Bool -> Bool -> [Binding] -> Bool+ settled _ _ [] = True+ settled lambda delta (bd : rest) =+ quiet bd && case bd of+ BiLambda _ -> not delta && settled True delta rest+ BiDelta _ -> not lambda && settled lambda True rest+ _ -> settled lambda delta rest+ quiet :: Binding -> Bool+ quiet (BiTau attr expr) = plain attr && inert expr+ quiet (BiVoid attr) = plain attr+ quiet (BiDelta (BtMeta _)) = False+ quiet (BiDelta (BtAny _)) = False+ quiet (BiDelta _) = True+ quiet (BiLambda (Function _)) = True+ quiet (BiLambda (FnSymbol _)) = True+ quiet _ = False+ headless :: Expression -> Bool+ headless (ExFormation _) = False+ headless ExTermination = False+ headless _ = True+ plain :: Attribute -> Bool+ plain (AtMeta _) = False+ plain (AtAny _) = False+ plain _ = True matchBaseObject :: Expression -> Maybe T.Text matchBaseObject (ExDispatch ExRoot (AtLabel label)) = Just label
+ src/Abridge.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE RecordWildCards #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++-- The spelling a term takes in a protocol written under '--abridged' (#1465).+-- A formation carrying a whole standard object flattens into a line tens of+-- thousands of characters long, and every short line of the protocol ends up+-- between two walls of text. So a formation whose flat spelling runs past+-- sixty characters keeps its salient bindings — φ, Δ and λ, the ones saying+-- what the object decorates, holds and fires — and folds the rest into a+-- count, '+34 attrs'; a shorter one says little enough to keep them all. A+-- byte string past eight bytes keeps its first four and its length, however+-- short the formation holding it, so a wide Δ never blows a line either. The+-- metas of a rule are kept, since they stand for bindings and are none. The+-- arguments of an application are never folded, since they are what the+-- object is applied to, not what it carries.+module Abridge (abridged) where++import CST+import qualified Data.Text as T+import Lining (toSingleLine)+import Render (render)++abridged :: EXPRESSION -> EXPRESSION+abridged = goExpr+ where+ goExpr :: EXPRESSION -> EXPRESSION+ goExpr expr@EX_FORMATION{..}+ | short expr = EX_FORMATION lsb eol tab (goIntact binding) eol' tab' rsb+ | otherwise = EX_FORMATION lsb eol tab (goBinding binding) eol' tab' rsb+ goExpr expr@EX_SINGLE{..}+ | short expr || salient pair = EX_SINGLE (goPair pair) (goExpr formation)+ | otherwise = goExpr formation+ goExpr EX_DISPATCH{..} = EX_DISPATCH (goExpr expr) space attr+ goExpr EX_APPLICATION{..} = EX_APPLICATION (goExpr expr) space eol tab (goArgument argument) eol' tab' indent+ goExpr EX_PHI_MEET{..} = EX_PHI_MEET prefix idx (goExpr expr)+ goExpr EX_PHI_AGAIN{..} = EX_PHI_AGAIN prefix idx (goExpr expr)+ goExpr EX_BYTES{..} = EX_BYTES (goBytes bytes)+ goExpr expr = expr+ -- The bindings of a long formation: the salient ones and the metas kept in+ -- their order, the rest counted into one folded pair closing the list.+ goBinding :: BINDING -> BINDING+ goBinding empty@BI_EMPTY{} = empty+ goBinding binding = headed (goBindings 0 (tail' binding))+ where+ -- The whole chain as a tail, so the head folds the same way every+ -- other binding does, and the tail made a head again once folded.+ tail' :: BINDING -> BINDINGS+ tail' BI_PAIR{..} = BDS_PAIR EOL tab pair bindings+ tail' BI_META{..} = BDS_META EOL tab meta bindings+ tail' BI_EMPTY{..} = BDS_EMPTY tab+ headed :: BINDINGS -> BINDING+ headed BDS_PAIR{..} = BI_PAIR pair bindings tab+ headed BDS_META{..} = BI_META meta bindings tab+ headed BDS_EMPTY{..} = BI_EMPTY tab+ goBindings :: Int -> BINDINGS -> BINDINGS+ goBindings folded BDS_PAIR{..}+ | salient pair = BDS_PAIR eol tab (goPair pair) (goBindings folded bindings)+ | otherwise = goBindings (folded + 1) bindings+ goBindings folded BDS_META{..} = BDS_META eol tab meta (goBindings folded bindings)+ goBindings 0 empty@BDS_EMPTY{} = empty+ goBindings folded empty@BDS_EMPTY{..} = BDS_PAIR EOL tab (PA_FOLDED folded) empty+ goPair :: PAIR -> PAIR+ goPair PA_TAU{..} = PA_TAU attr arrow (goExpr expr)+ goPair PA_ALPHA{..} = PA_ALPHA alpha arrow (goExpr expr)+ goPair PA_FORMATION{..} = PA_FORMATION attr voids arrow (goExpr expr)+ goPair PA_DELTA{..} = PA_DELTA (goBytes bytes)+ goPair pair = pair+ goArgument :: APP_ARGUMENT -> APP_ARGUMENT+ goArgument (AA_TAU APP_BINDING{..}) = AA_TAU (APP_BINDING (goPair pair))+ goArgument (AA_TAUS binding) = AA_TAUS (goIntact binding)+ goArgument (AA_EXPRS APP_ARG{..}) = AA_EXPRS (APP_ARG (goExpr expr) (goAppArgs args))+ -- The bindings of a short formation or of an application, every one kept.+ goIntact :: BINDING -> BINDING+ goIntact BI_PAIR{..} = BI_PAIR (goPair pair) (goIntacts bindings) tab+ goIntact BI_META{..} = BI_META meta (goIntacts bindings) tab+ goIntact empty = empty+ goIntacts :: BINDINGS -> BINDINGS+ goIntacts BDS_PAIR{..} = BDS_PAIR eol tab (goPair pair) (goIntacts bindings)+ goIntacts BDS_META{..} = BDS_META eol tab meta (goIntacts bindings)+ goIntacts empty = empty+ goAppArgs :: APP_ARGS -> APP_ARGS+ goAppArgs AAS_EXPR{..} = AAS_EXPR eol tab (goExpr expr) (goAppArgs args)+ goAppArgs AAS_EMPTY = AAS_EMPTY+ goBytes :: BYTES -> BYTES+ goBytes (BT_MANY bts)+ | length bts > 8 = BT_CUT (take 4 bts) (length bts)+ goBytes bts = bts+ -- Whether a formation spelled flat fits in sixty characters.+ short :: EXPRESSION -> Bool+ short expr = T.length (render (toSingleLine expr)) <= 60+ -- Whether a binding says what the object decorates, holds or fires.+ salient :: PAIR -> Bool+ salient PA_TAU{attr = AT_PHI{}} = True+ salient PA_FORMATION{attr = AT_PHI{}} = True+ salient PA_LAMBDA{} = True+ salient PA_META_LAMBDA{} = True+ salient PA_DELTA{} = True+ salient PA_META_DELTA{} = True+ salient _ = False
src/Builder.hs view
@@ -15,16 +15,21 @@ , buildAttributeThrows , buildBinding , buildBindingThrows+ , buildBindingUnchecked , buildBytes , buildBytesThrows , contextualize+ , pathOf , BuildException (..) ) where import AST import Control.Exception (Exception)+import Control.Monad (zipWithM)+import Data.List (find) import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Data.Text (Text) import qualified Data.Text as T import Matcher@@ -59,7 +64,7 @@ contextualize ExRoot _ = ExRoot contextualize ExXi ex = ex contextualize ExTermination _ = ExTermination-contextualize (ExFormation bds) _ = ExFormation bds+contextualize expr@(ExFormation _) _ = expr contextualize (ExDispatch ex at) context = ExDispatch (contextualize ex context) at contextualize (ExApplication ex arg) context = ExApplication (contextualize ex context) (contextualizeArg arg)@@ -97,36 +102,43 @@ -- Build binding -- The function returns [Binding] because the BiMeta is always attached--- to the list of bindings+-- to the list of bindings, and the bindings a meta stands for are checked to+-- carry no attribute twice buildBinding :: Binding -> Subst -> Built [Binding]-buildBinding (BiTau attr expr) subst = do+buildBinding bd subst = buildBindingUnchecked bd subst >>= uniqueBindings++-- Build binding without checking the bindings a meta stands for, which is+-- what a formation made of them does once for all of its bindings, and what a+-- condition reading their attributes has no need for (#1453)+buildBindingUnchecked :: Binding -> Subst -> Built [Binding]+buildBindingUnchecked (BiTau attr expr) subst = do attribute <- buildAttribute attr subst expression <- buildExpression expr subst Right [BiTau attribute expression]-buildBinding (BiVoid attr) subst = do+buildBindingUnchecked (BiVoid attr) subst = do attribute <- buildAttribute attr subst Right [BiVoid attribute]-buildBinding (BiMeta meta) (Subst mp) = case Map.lookup (Named meta) mp of- Just (MvBindings bds) -> uniqueBindings bds+buildBindingUnchecked (BiMeta meta) (Subst mp) = case Map.lookup (Named meta) mp of+ Just (MvBindings bds) -> Right bds _ -> Left (metaMsg meta)-buildBinding (BiAny slot) (Subst mp) = case Map.lookup (Anon slot) mp of- Just (MvBindings bds) -> uniqueBindings bds+buildBindingUnchecked (BiAny slot) (Subst mp) = case Map.lookup (Anon slot) mp of+ Just (MvBindings bds) -> Right bds _ -> Left (slotMsg slot)-buildBinding (BiDelta bytes) subst = do+buildBindingUnchecked (BiDelta bytes) subst = do bts <- buildBytes bytes subst Right [BiDelta bts]-buildBinding (BiLambda (FnMeta meta)) (Subst mp) = case Map.lookup (Named meta) mp of+buildBindingUnchecked (BiLambda (FnMeta meta)) (Subst mp) = case Map.lookup (Named meta) mp of Just (MvFunction func) -> Right [BiLambda func] _ -> Left (metaMsg meta)-buildBinding (BiLambda (FnAny slot)) (Subst mp) = case Map.lookup (Anon slot) mp of+buildBindingUnchecked (BiLambda (FnAny slot)) (Subst mp) = case Map.lookup (Anon slot) mp of Just (MvFunction func) -> Right [BiLambda func] _ -> Left (slotMsg slot) -- A bare 𝜎 asks for a symbol nothing has answered yet, and the one minted for -- the slot it was written at is bound the way any other anonymous meta is.-buildBinding (BiLambda (FnFresh slot)) (Subst mp) = case Map.lookup (Anon slot) mp of+buildBindingUnchecked (BiLambda (FnFresh slot)) (Subst mp) = case Map.lookup (Anon slot) mp of Just (MvFunction func) -> Right [BiLambda func] _ -> Left (slotMsg slot)-buildBinding binding _ = Right [binding]+buildBindingUnchecked binding _ = Right [binding] buildArgument :: Argument -> Subst -> Built Argument buildArgument (ArTau attr expr) subst = do@@ -142,14 +154,97 @@ buildBindings :: [Binding] -> Subst -> Built [Binding] buildBindings [] _ = Right [] buildBindings (bd : rest) subst = do- first <- buildBinding bd subst+ first <- buildBindingUnchecked bd subst bds <- buildBindings rest subst Right (first ++ bds) --- The bindings of a formation a meta was bound to are checked once more here,--- since a substitution may bring two of them together under one attribute.+-- The name a formation goes by in the world, where it has one: the path from Φ+-- it is reached by, applied to whatever its voids were filled with on the way.+-- The world is immutable, so an object of it copied into a term is a copy of a+-- constant, and a dispatch off 'Φ.number' that wrote 'number' out in full would+-- carry every method it declares — the whole of trigonometry to reach 'plus' —+-- into the term and into every term that one then dispatches (#1446). The name+-- is what 'dot' decorates a body with instead, and whoever reads the ρ resolves+-- it the way 'Φ' itself resolves, to the very formation that stood there.+--+-- Nothing is compared against the whole world to find it. The formation says+-- where it came from: a ρ holding 'Φ', or a path off 'Φ', names the object it+-- was dispatched off, and one declaring no ρ at all can only be a top-level+-- object, so only the objects that parent declares are candidates. A candidate+-- is the formation where the two agree binding by binding, save the voids of+-- the candidate the formation has filled: the ρ with exactly what the dispatch+-- off the parent hands it, and every other one with a closed term, which is an+-- argument of the application the name carries. The world itself is named 'Φ',+-- so a dispatch off the whole program does not copy the program into its ρ+-- (#1318). Anything else answers with the formation itself, and so does a+-- universe that is not a formation.+pathOf :: Expression -> Expression -> Expression+pathOf universe@(ExFormation world) form@(ExFormation bds)+ | form == universe = ExRoot+ | otherwise = maybe form found (parent (find rho bds))+ where+ found :: (Expression, [Binding]) -> Expression+ found (path, siblings) = fromMaybe form (listToMaybe (mapMaybe (candidate path) siblings))+ -- The path of the object the formation was dispatched off, together with+ -- the bindings of that object as the world declares them.+ parent :: Maybe Binding -> Maybe (Expression, [Binding])+ parent Nothing = Just (ExRoot, world)+ parent (Just (BiTau AtRho path)) = (,) path <$> declared path+ parent _ = Nothing+ -- The bindings of the object a path off Φ leads to, applications skipped:+ -- they fill voids and leave every other binding as the world wrote it.+ declared :: Expression -> Maybe [Binding]+ declared ExRoot = Just world+ declared (ExApplication target _) = declared target+ declared (ExDispatch target attr) = do+ outer <- declared target+ BiTau _ (ExFormation inner) <- find (tau attr) outer+ Just inner+ declared _ = Nothing+ candidate :: Expression -> Binding -> Maybe Expression+ candidate path (BiTau attr (ExFormation origin))+ | attr /= AtRho && length origin == length bds = do+ args <- zipWithM (argument path) origin bds+ Just (foldl ExApplication (ExDispatch path attr) (concat args))+ candidate _ _ = Nothing+ -- What one binding of the formation adds to the application: nothing where+ -- it is the binding the world declares, the argument where it fills a void.+ argument :: Expression -> Binding -> Binding -> Maybe [Argument]+ argument path (BiVoid AtRho) (BiTau AtRho value)+ | value == path = Just []+ argument _ (BiVoid attr) (BiTau attr' value)+ | attr == attr' && attr /= AtRho && closed value = Just [ArTau attr value]+ argument _ origin binding+ | origin == binding = Just []+ | otherwise = Nothing+ rho :: Binding -> Bool+ rho (BiTau AtRho _) = True+ rho (BiVoid AtRho) = True+ rho _ = False+ tau :: Attribute -> Binding -> Bool+ tau attr (BiTau attr' _) = attr == attr'+ tau _ _ = False+ -- A term with no ξ of its own, the only kind 'copy' ever fills a void with.+ closed :: Expression -> Bool+ closed (ExFormation _) = True+ closed ExRoot = True+ closed ExTermination = True+ closed (ExApplication target (ArTau _ value)) = closed target && closed value+ closed (ExApplication target (ArAlpha _ value)) = closed target && closed value+ closed (ExDispatch target _) = closed target+ closed _ = False+pathOf _ form = form++-- The bindings of a formation, whether a meta was bound to it or it was built+-- from a template, are checked here, since a substitution may bring two of+-- them together under one attribute. The formation itself is handed back, not+-- one rebuilt of its bindings, and it knows whether its attributes are+-- 'distinct' once it has been asked, so an object carried from term to term+-- is checked once (#1453). unique :: Expression -> Built Expression-unique (ExFormation bds) = uniqueBindings bds >> Right (ExFormation bds)+unique expr@(ExFormation bds)+ | distinct expr = Right expr+ | otherwise = uniqueBindings bds >> Right expr unique expr = Right expr -- Build meta expression with given substitution@@ -165,9 +260,7 @@ applied <- buildExpression expr subst arg' <- buildArgument arg subst Right (ExApplication applied arg')-buildExpression (ExFormation bds) subst = do- bds' <- buildBindings bds subst >>= uniqueBindings- Right (ExFormation bds')+buildExpression (ExFormation bds) subst = buildBindings bds subst >>= unique . ExFormation buildExpression (ExMeta meta) (Subst mp) = case Map.lookup (Named meta) mp of Just (MvExpression expr) -> unique expr _ -> Left (metaMsg meta)
src/Bytes.hs view
@@ -30,10 +30,12 @@ , btsToNonFinite , nonFiniteOf , NonFinite (..)+ , BytesException (..) ) where import AST+import Control.Exception (Exception, throw) import Data.Binary.IEEE754 import Data.Bits (Bits (complement, shiftL, shiftR), (.&.), (.|.)) import qualified Data.ByteString as B@@ -48,6 +50,12 @@ import Numeric (readHex) import Text.Printf (printf) +-- Errors raised while converting malformed byte values.+newtype BytesException = InvalidNumberLength Int+ deriving (Eq, Show)++instance Exception BytesException+ -- >>> btsToWord8 BtEmpty -- [] -- >>> btsToWord8 (BtOne "01")@@ -112,7 +120,7 @@ btsToNum hx = let bytes = btsToWord8 hx in if length bytes /= 8- then error $ "Expected 8 bytes for conversion, got " ++ show (length bytes)+ then throw (InvalidNumberLength (length bytes)) else let word = toWord64BE bytes val = wordToDouble word@@ -225,10 +233,10 @@ -- BtOne "01" bytesToBts :: String -> Bytes bytesToBts "--" = BtEmpty-bytesToBts str =- if length str == 3 && last str == '-'- then BtOne (init str)- else BtMany (map T.unpack (T.splitOn "-" (T.pack str)))+bytesToBts str+ | length str == 3 && last str == '-' = BtOne (init str)+ | not (null str) && last str == '-' = error $ "Invalid trailing separator in byte string; " ++ str+ | otherwise = BtMany (map T.unpack (T.splitOn "-" (T.pack str))) -- Convert hex string like "68-65-6C-6C-6F" to "hello" -- >>> btsToStr (BtMany ["68", "65", "6C", "6C", "6F"])@@ -317,7 +325,7 @@ [(code, "")] -> Just code _ -> Nothing escapes :: [(Char, Char)]- escapes = [('"', '"'), ('\\', '\\'), ('n', '\n'), ('t', '\t')]+ escapes = [('"', '"'), ('\\', '\\'), ('n', '\n'), ('t', '\t'), ('r', '\r'), ('b', '\b'), ('f', '\f')] -- >>> btsToUnescapedStr (BtMany ["01", "02"]) -- "\SOH\STX"
src/CLI/Helpers.hs view
@@ -8,8 +8,10 @@ module CLI.Helpers where import AST+import Abridge (abridged) import CLI.Types import CLI.Validators (invalidCLIArguments)+import CST (EXPRESSION) import Canonizer (canonize) import Control.Exception import Control.Monad ((>=>))@@ -20,10 +22,11 @@ import qualified Data.Map.Strict as M import Data.Maybe import qualified Data.Text as T-import Deps (Evaluation (EvRun), Judgment, SaveEvalFunc, SaveStepFunc, State (..), dontSaveEval, emptyNesting, emptyProtocol, endEvalXml, saveEval, saveEvalXml, saveStep)+import Deps (Evaluation (EvRun), Judgment, SaveEvalFunc, SaveStepFunc, State (..), dontSaveEval, emptyNesting, emptyProgress, emptyProtocol, endEvalXml, progressed, saveEval, saveEvalXml, saveStep) import Encoding import Files (ensuredFile, overwrite)-import Functions (execFunctions)+import Functions (buildFunctions, execFunctions)+import GHC.Clock (getMonotonicTime) import LaTeX (LatexContext (LatexContext), defaultMeetLength, defaultMeetPopularity, expressionToLaTeX, rewrittensToLatex) import Lambdas (Lambdas, emptyLambdas, readLambdas, taken) import Lining (LineFormat (SINGLELINE))@@ -34,7 +37,7 @@ import qualified Printer as P import qualified Random as R import Rewriter (Rewritten, Rewrittens', stepHeaders)-import Sugar (SugarType (SALTY))+import Sugar (SugarType (SALTY), withoutRho) import System.Directory (createDirectoryIfMissing) import System.FilePath (takeDirectory, takeExtension) import System.IO (Handle, IOMode (WriteMode), getContents', hClose, hSetEncoding, openFile, utf8)@@ -77,8 +80,24 @@ -- encoding is pinned to UTF-8 rather than taken from the locale, since the file -- is read back by other programs. withEvalFunc :: forall a. Maybe FilePath -> PrintContext -> (SaveEvalFunc -> IO a) -> IO a-withEvalFunc Nothing _ action = action dontSaveEval-withEvalFunc (Just file) ctx action = do+withEvalFunc target ctx action = withEvalFunc' target ctx (tracked >=> action)+ where+ -- Under '--log-level=INFO' every report also counts towards a line of+ -- progress printed every few seconds, whether or not a protocol is+ -- written (see 'progressed'); at any other level the reports go straight+ -- to the protocol, so a run that prints no progress pays nothing for it.+ tracked :: SaveEvalFunc -> IO SaveEvalFunc+ tracked record = do+ enabled <- logging INFO+ if enabled+ then do+ cursor <- newIORef . emptyProgress =<< getMonotonicTime+ pure (progressed cursor 5 (flattened ctx) record)+ else pure record++withEvalFunc' :: forall a. Maybe FilePath -> PrintContext -> (SaveEvalFunc -> IO a) -> IO a+withEvalFunc' Nothing _ action = action dontSaveEval+withEvalFunc' (Just file) ctx action = do createDirectoryIfMissing True (takeDirectory file) logDebug (printf "The option '--protocol' is specified, every firing will be recorded in '%s' as %s" file (if markup then "XML" else "text")) if markup then markedUp else plain@@ -142,8 +161,19 @@ -- sugar and the margin the run prints its own answer with. The protocol is a -- tree of one-line 𝜑 records whatever '--output' the run was given, so a -- program reading it back never has to know what the run printed.+--+-- Under '--abridged' a long formation is folded and a long byte string cut,+-- since a formation flattened whole can run for tens of thousands of+-- characters and bury every short line around it (see 'abridged'). Only the+-- protocol is spelled this way; the printed result stays whole. flattened :: PrintContext -> Expression -> IO String-flattened ctx = pure . printPhi ctx{_line = SINGLELINE}+flattened ctx@PrintCtx{..} expr =+ pure (P.printExpressionWith shaped expr (_sugar, UNICODE, SINGLELINE, _margin))+ where+ shaped :: SugarType -> EXPRESSION -> EXPRESSION+ shaped sugar+ | _abridged = abridged . hidden ctx sugar+ | otherwise = hidden ctx sugar -- The same, in canonical 𝜑 rather than in the sugar the run prints with. The -- operand a protocol line names is the term an entry of the '--symbolic' file@@ -237,9 +267,15 @@ -- Render an expression as PHI, dropping every ρ binding when '--hide-rho' is set. printPhi :: PrintContext -> Expression -> String-printPhi PrintCtx{..} expr =- (if _hideRho then P.printExpressionHidingRho' else P.printExpression') expr (_sugar, UNICODE, _line, _margin)+printPhi ctx@PrintCtx{..} expr = P.printExpressionWith (hidden ctx) expr (_sugar, UNICODE, _line, _margin) +-- The CST of a term with its ρ bindings dropped under '--hide-rho' and left as+-- it is otherwise.+hidden :: PrintContext -> SugarType -> EXPRESSION -> EXPRESSION+hidden PrintCtx{..} sugar+ | _hideRho = withoutRho sugar+ | otherwise = id+ printCtxToLatexCtx :: PrintContext -> LatexContext printCtxToLatexCtx PrintCtx{..} = LatexContext _sugar _line _margin _nonumber _compress _canonize _meetPopularity _meetLength _focus _expression _label _meetPrefix _headers@@ -277,11 +313,13 @@ validateRewriteRule :: Y.Rule -> IO Y.Rule validateRewriteRule rule = let used = maybe [] (map Y.function) rule.where_- in case filter (`elem` execFunctions) used of- [] -> pure rule- (fn : _) ->- invalidCLIArguments- (printf "Function '%s' in rule '%s' is available only for dataization and morphing, not for rewriting" fn rule.name)+ in case filter (\fn -> fn `notElem` (buildFunctions ++ execFunctions)) used of+ (fn : _) -> invalidCLIArguments (printf "Function '%s' in rule '%s' is not supported" fn rule.name)+ [] -> case filter (`elem` execFunctions) used of+ [] -> pure rule+ (fn : _) ->+ invalidCLIArguments+ (printf "Function '%s' in rule '%s' is available only for dataization and morphing, not for rewriting" fn rule.name) -- Output content printOut :: Maybe FilePath -> String -> IO ()
src/CLI/Parsers.hs view
@@ -7,6 +7,7 @@ import Data.Char (toLower, toUpper) import Data.List (intercalate) import Data.Version (showVersion)+import Deps (Acyclic, certainty) import LaTeX (defaultMeetLength, defaultMeetPopularity) import Lining (LineFormat (..)) import Logger@@ -28,7 +29,7 @@ parseLogLevel ( long "log-level" <> metavar "LEVEL"- <> help ("Log level (" <> intercalate ", " (map show [DEBUG, ERROR, NONE]) <> ")")+ <> help ("Log level (" <> intercalate ", " (map show [DEBUG, INFO, ERROR, NONE]) <> ")") <> value ERROR <> showDefault )@@ -36,6 +37,7 @@ parseLogLevel :: ReadM LogLevel parseLogLevel = eitherReader $ \lvl -> case map toUpper lvl of "DEBUG" -> Right DEBUG+ "INFO" -> Right INFO "ERROR" -> Right ERROR "ERR" -> Right ERROR "NONE" -> Right NONE@@ -87,6 +89,14 @@ (auto >>= validateIntOption (> 0) "--max-steps must be positive") (long "max-steps" <> metavar "STEPS" <> help "Maximum number of nested morphing and dataization steps" <> value 1000 <> showDefault) +optMaxFirings :: Parser (Maybe Int)+optMaxFirings =+ optional+ ( option+ (auto >>= validateIntOption (> 0) "--max-firings must be positive")+ (long "max-firings" <> metavar "FIRINGS" <> help "Maximum number of λ functions the whole run may fire, unlimited unless given")+ )+ optMargin :: Parser Int optMargin = option@@ -214,9 +224,15 @@ -- The step budget is otherwise the only thing that ends the 𝕄 and 𝔻 recursion, -- so a λ function answering with a firing of itself, or an object dataized -- through a body that comes back to itself, runs to the limit before it fails.--- This stops it the moment it comes back (see 'unvisited').-optAcyclic :: Parser Bool-optAcyclic = switch (long "acyclic" <> help "Stop reducing a term as soon as it comes back to one it is already reducing, instead of going round until --max-steps runs out, and leave that term in place the way --partial leaves a λ function that cannot fire")+-- This stops it the moment it enters a formation it is already inside, by the+-- mode the option names, since no mode is right for every run (see 'entering').+optAcyclic :: Parser (Maybe Acyclic)+optAcyclic = optional (option parseAcyclic (long "acyclic" <> metavar "MODE" <> help "Stop reducing as soon as the reduction enters a formation it is already inside (fires its λ function or dataizes its φ body again) instead of going round until --max-steps runs out, and leave the term in place the way --partial leaves a λ function that cannot fire; 'proven' takes it for the same one up to a renaming of symbols, 'plausible' also when it holds the earlier one under wrappers it gained, such as a growing accumulator"))+ where+ parseAcyclic :: ReadM Acyclic+ parseAcyclic = eitherReader $ \mode -> case filter ((== map toLower mode) . certainty) [minBound .. maxBound] of+ found : _ -> Right found+ [] -> Left (printf "The value '%s' can't be used for '--acyclic' option, use --help to check possible values" mode) -- Which λ functions this run may fire. phino implements none of them itself -- (see 'Lambdas'), so without this option every λ function a program names gets@@ -268,6 +284,16 @@ ) ) +optAbridged :: Parser Bool+optAbridged =+ switch+ ( long "abridged"+ <> help+ "Shorten every 𝜑-expression written to the --protocol file: a formation longer than sixty characters \+ \keeps its φ, Δ and λ bindings and folds the rest into a count, as '+34 attrs', and a byte string \+ \longer than eight bytes keeps its first four bytes and its length, as '00-00-00-00-...(45b)'"+ )+ optShuffle :: Parser Bool optShuffle = switch (long "shuffle" <> help "Shuffle rules before applying") @@ -363,6 +389,7 @@ <*> optMaxDepth <*> optMaxCycles <*> optMaxSteps+ <*> optMaxFirings <*> optMargin <*> optMeetPopularity <*> optMeetLength@@ -376,6 +403,7 @@ <*> optInside <*> optStepsDir <*> optProtocol+ <*> optAbridged <*> optSymbolic <*> argInputFile )@@ -408,6 +436,7 @@ <*> optMaxDepth <*> optMaxCycles <*> optMaxSteps+ <*> optMaxFirings <*> optMargin <*> optMeetPopularity <*> optMeetLength@@ -421,6 +450,7 @@ <*> optInside <*> optStepsDir <*> optProtocol+ <*> optAbridged <*> optSymbolic <*> argInputFile )
src/CLI/Runners.hs view
@@ -131,6 +131,7 @@ PrintCtx _sugarType _hideRho+ False _flat _margin xmirCtx@@ -164,6 +165,8 @@ exclude = (`F.exclude` excluded) include = (`F.include` included) save <- saveStepFunc _stepsDir printCtx+ tally <- tallied _maxFirings+ memo <- memoized _acyclic (outcome, chain, _) <- withEvalFunc _protocol@@ -172,8 +175,8 @@ -- The deep walk belongs to 𝕄 alone (the '--deep' of 'morph'), since 𝔻 -- reduces what dataization demands and ends in bytes, so it is off -- here; the cycle guard of '--acyclic' is not, since 𝔻 recurses into- -- itself and a term it comes back to is a loop of its own (#1290).- let ctx = ReduceContext loc loc Nothing _maxDepth _maxCycles (Steps _maxSteps 0) 1 _depthSensitive _shuffle _partial False _acyclic Dataization [] Map.empty Map.empty lambdas buildTerm reduction evaluation fired save record+ -- itself and a formation it enters again is a loop of its own (#1290).+ let ctx = ReduceContext loc loc Nothing _maxDepth _maxCycles (Steps _maxSteps 0) tally memo 1 _depthSensitive _shuffle _partial False _acyclic Dataization [] Map.empty lambdas buildTerm reduction evaluation fired save record (universe, aiming) <- aimed _inside expr ctx heading record printCtx Dataization aiming._locator dataize universe (started universe) aiming@@ -198,6 +201,7 @@ [(_meetPopularity, "meet-popularity"), (_meetLength, "meet-length")] validateXmirOptions _outputFormat [(_omitListing, "omit-listing"), (_omitComments, "omit-comments")] _focus when (length _show > 1) (invalidCLIArguments "The option --show can be used only once")+ when (_abridged && isNothing _protocol) (invalidCLIArguments "The option --abridged requires --protocol, since only the protocol is abridged") when (isJust _inside && _locator /= "Q") (invalidCLIArguments "The options --inside and --locator cannot be used together, since --inside aims the run at the binding it mints")@@ -206,6 +210,7 @@ PrintCtx _sugarType _hideRho+ _abridged _flat _margin (XmirContext _omitListing _omitComments _hideRho listing atoms)@@ -250,12 +255,14 @@ exclude = (`F.exclude` excluded) include = (`F.include` included) save <- saveStepFunc _stepsDir printCtx+ tally <- tallied _maxFirings+ memo <- memoized _acyclic (morphed, chain, _) <- withEvalFunc _protocol printCtx ( \record -> do- let ctx = ReduceContext loc loc Nothing _maxDepth _maxCycles (Steps _maxSteps 0) 1 _depthSensitive _shuffle _partial _deep _acyclic Morphing [] Map.empty Map.empty lambdas buildTerm reduction evaluation fired save record+ let ctx = ReduceContext loc loc Nothing _maxDepth _maxCycles (Steps _maxSteps 0) tally memo 1 _depthSensitive _shuffle _partial _deep _acyclic Morphing [] Map.empty lambdas buildTerm reduction evaluation fired save record (universe, aiming) <- aimed _inside expr ctx heading record printCtx Morphing aiming._locator morph universe (started universe) aiming@@ -272,6 +279,7 @@ [(_meetPopularity, "meet-popularity"), (_meetLength, "meet-length")] validateXmirOptions _outputFormat [(_omitListing, "omit-listing"), (_omitComments, "omit-comments")] _focus when (length _show > 1) (invalidCLIArguments "The option --show can be used only once")+ when (_abridged && isNothing _protocol) (invalidCLIArguments "The option --abridged requires --protocol, since only the protocol is abridged") when (isJust _inside && _locator /= "Q") (invalidCLIArguments "The options --inside and --locator cannot be used together, since --inside aims the run at the binding it mints")@@ -280,6 +288,7 @@ PrintCtx _sugarType _hideRho+ _abridged _flat _margin (XmirContext _omitListing _omitComments _hideRho listing atoms)@@ -347,6 +356,7 @@ PrintCtx _sugarType False+ False _flat _margin xmirCtx@@ -374,10 +384,10 @@ ptn <- parseExpressionThrows (fromJust _pattern) condition <- traverse parseConditionThrows _when traverse_ (throwIO . AnonymousMetaInCondition . T.unpack) (anonymous condition)- substs <- matchExpressionWithRule expr (rule ptn condition) (RuleContext buildTerm)+ substs <- matchExpressionWithRule expr (rule ptn condition) (RuleContext buildTerm Nothing) if null substs then throwIO EmptySubstsOnMatch else putStrLn (P.printSubsts' substs (_sugarType, UNICODE, _flat, defaultMargin)) where rule :: Expression -> Maybe Y.Condition -> Y.Rule- rule ptn cnd = Y.Rule "custom" Nothing Nothing ptn Nothing ExRoot cnd Nothing Nothing+ rule ptn cnd = Y.Rule "custom" Nothing Nothing ptn ExRoot cnd Nothing Nothing
src/CLI/Types.hs view
@@ -8,6 +8,7 @@ import AST import Control.Exception (Exception)+import Deps (Acyclic) import Lining (LineFormat) import Logger (LogLevel) import Must (Must)@@ -18,6 +19,7 @@ data PrintContext = PrintCtx { _sugar :: SugarType , _hideRho :: Bool+ , _abridged :: Bool , _line :: LineFormat , _margin :: Int , _xmirCtx :: XmirContext@@ -98,11 +100,12 @@ , _seed :: Int , _quiet :: Bool , _partial :: Bool- , _acyclic :: Bool+ , _acyclic :: Maybe Acyclic , _compress :: Bool , _maxDepth :: Int , _maxCycles :: Int , _maxSteps :: Int+ , _maxFirings :: Maybe Int , _margin :: Int , _meetPopularity :: Maybe Int , _meetLength :: Maybe Int@@ -116,6 +119,7 @@ , _inside :: Maybe String , _stepsDir :: Maybe FilePath , _protocol :: Maybe FilePath+ , _abridged :: Bool , _symbolic :: Maybe FilePath , _inputFile :: Maybe FilePath }@@ -144,11 +148,12 @@ , _quiet :: Bool , _partial :: Bool , _deep :: Bool- , _acyclic :: Bool+ , _acyclic :: Maybe Acyclic , _compress :: Bool , _maxDepth :: Int , _maxCycles :: Int , _maxSteps :: Int+ , _maxFirings :: Maybe Int , _margin :: Int , _meetPopularity :: Maybe Int , _meetLength :: Maybe Int@@ -162,6 +167,7 @@ , _inside :: Maybe String , _stepsDir :: Maybe FilePath , _protocol :: Maybe FilePath+ , _abridged :: Bool , _symbolic :: Maybe FilePath , _inputFile :: Maybe FilePath }
src/CST.hs view
@@ -76,6 +76,7 @@ | BT_MANY [String] | BT_META META | BT_PIPED BYTES -- bytes wrapped in vertical pipes, as the eolang LaTeX package expects+ | BT_CUT [String] Int -- the first bytes of a long string and its length in bytes, as '--abridged' spells it (#1465) deriving (Eq, Show) data META_HEAD@@ -136,6 +137,7 @@ | PA_DELTA' {bytes :: BYTES} -- ASCII version of PA_DELTA | PA_META_DELTA {meta :: META} | PA_META_DELTA' {meta :: META} -- ASCII version of PA_META_DELTA+ | PA_FOLDED {count :: Int} -- the bindings '--abridged' folded away, as '+34 attrs' (#1465) deriving (Eq, Show) newtype APP_BINDING = APP_BINDING {pair :: PAIR}@@ -244,6 +246,7 @@ | CO_MATCHES {regex :: String, expr :: EXPRESSION} | CO_PART_OF {expr :: EXPRESSION, binding :: BINDING} | CO_DISJOINT {attrs :: [ATTRIBUTE], groups :: [BINDING]}+ | CO_SUBSET {attrs :: [ATTRIBUTE], belongs :: BELONGING, groups :: [BINDING]} | CO_FORMATION {expr :: EXPRESSION} deriving (Eq, Show) @@ -531,13 +534,8 @@ attr' (map (`toCST` ctx) voids') ARROW- (unsugared (toCST (ExFormation (others ++ rest)) ctx))+ (toCST (ExFormation (others ++ rest)) ctx) where- -- Inline voids open a formation, which no one-binding sugar may stand- -- for, so 'x(a) ↦ ⟦ φ ↦ ξ.a ⟧' is never printed as 'x(a) ↦ a:φ'- unsugared :: EXPRESSION -> EXPRESSION- unsugared EX_SINGLE{..} = formation- unsugared expr = expr -- Neither λ nor Δ is an attribute, so neither holds a position among -- the voids, and 'x ↦ ⟦ λ ⤍ F, a ↦ ∅ ⟧' is still printed as 'x(a) ↦ ⟦ λ ⤍ F ⟧' positionless :: Binding -> Bool@@ -597,13 +595,15 @@ toCST (AlAny _) _ = AL_META ALPHA (anyMeta I) instance ToCST Y.Condition CONDITION where- toCST (Y.Not (Y.In attr binding)) _ = CO_BELONGS (attributeToCST attr) NOT_IN (ST_BINDING (bindingsToCST [binding]))+ toCST (Y.Not (Y.In [attr] [binding])) _ = CO_BELONGS (attributeToCST attr) NOT_IN (ST_BINDING (bindingsToCST [binding]))+ toCST (Y.Not (Y.In attrs groups)) _ = CO_SUBSET (map attributeToCST attrs) NOT_IN (map (\bd -> bindingsToCST [bd]) groups) toCST (Y.Not (Y.Eq left right)) _ = CO_COMPARE (comparableToCST left) NOT_EQUAL (comparableToCST right) toCST (Y.Not (Y.Gt left right)) _ = CO_COMPARE (comparableToCST left) NOT_GREATER (comparableToCST right) toCST (Y.Not (Y.Absolute expr)) _ = CO_ABSOLUTE (expressionToCST expr) NOT_IN toCST (Y.Absolute expr) _ = CO_ABSOLUTE (expressionToCST expr) IN toCST (Y.Disjoint attrs groups) _ = CO_DISJOINT (map attributeToCST attrs) (map (\bd -> bindingsToCST [bd]) groups)- toCST (Y.In attr binding) _ = CO_BELONGS (attributeToCST attr) IN (ST_BINDING (bindingsToCST [binding]))+ toCST (Y.In [attr] [binding]) _ = CO_BELONGS (attributeToCST attr) IN (ST_BINDING (bindingsToCST [binding]))+ toCST (Y.In attrs groups) _ = CO_SUBSET (map attributeToCST attrs) IN (map (\bd -> bindingsToCST [bd]) groups) toCST (Y.And conds) _ = case conds of [] -> CO_EMPTY _ -> CO_LOGIC (map toCST' conds) AND
src/Condition.hs view
@@ -98,7 +98,7 @@ _ <- comma bd <- _binding phiParser _ <- rparen- return (Y.In attr bd)+ return (Y.In [attr] [bd]) , do _ <- symbol "not" >> lparen cond <- condition
src/Dataize.hs view
@@ -25,7 +25,7 @@ import Deps (Evaluation (..), Judgment (..), State (..)) import Locator (locatedExpression) import Matcher (Subst, matchExpression')-import Morph (Morphed, ReduceContext (..), ReduceException (..), ReductionFunc, deeper, excluding, execBuildTerm, insideUniverse, leadsTo, morph', normalized, parking, producer, sidePremise, universed, unvisited, verb)+import Morph (Morphed, ReduceContext (..), ReduceException (..), ReductionFunc, boxed, deeper, entering, excluding, execBuildTerm, insideUniverse, leadsTo, morph', normalized, parking, producer, sidePremise, universed, verb) import Random (shuffle) import Rewriter (Rewritten) import Rule (RuleContext (RuleContext), matchExpressionWithRule')@@ -52,14 +52,14 @@ -- cannot fire fails the run, unless '_partial' is on: dataization is then a -- partial evaluation, and the run ends on the residual program the spine had -- reached (see 'StuckAt'), with the stuck application parked in it as a--- normal-form subterm, and the chain of steps that led there. A term '_acyclic'--- caught coming back to itself ends the run the same way, since 𝔻 has no bytes--- to give for a question it can only ever answer by asking again; where--- '_partial' is off the signal travels on instead, so a 𝔻 run reducing an--- operand of a firing leaves the loop to the 𝕄 spine around that firing, which--- parks on it with no '_partial' asked for (see 'morph', #1290). The state 𝑠--- goes in and comes back out, so a 𝔻 asked inside another judgment goes on--- minting symbols where that judgment left off.+-- normal-form subterm, and the chain of steps that led there. A formation+-- '_acyclic' caught being entered from inside itself ends the run the same+-- way, since 𝔻 has no bytes to give for a question it can only ever answer by+-- asking again; where '_partial' is off the signal travels on instead, so a 𝔻+-- run reducing an operand of a firing leaves the loop to the 𝕄 spine around+-- that firing, which parks on it with no '_partial' asked for (see 'morph',+-- #1290). The state 𝑠 goes in and comes back out, so a 𝔻 asked inside another+-- judgment goes on minting symbols where that judgment left off. dataize :: Expression -> State -> ReduceContext -> IO (Outcome, [Rewritten], State) dataize universe state ctx@ReduceContext{..} = do expr <- locatedExpression _locator universe@@ -95,14 +95,18 @@ -- The conclusion bytes 'dresult' are produced by a trailing 'dataize' premise; -- when its argument is bound by a 'morph' or 'normalize' premise, that step -- joins the spine, otherwise the premise is an isolated side-computation.--- Like 𝕄, every frame asks '_acyclic' whether the term it was handed is one a--- frame above it is already dataizing, before any rule is walked: 𝔻 recurses--- into itself through 'box' and 'fire' without 𝕄 ever seeing the same term--- twice, so a program cycling through dataization alone is a loop only this--- guard ends (#1290).+-- Like 𝕄, every frame asks '_acyclic' whether the formation it is about to+-- enter through 'box' or 'fire' is one a frame above it has already entered,+-- before any rule is walked: 𝔻 recurses into itself through those two rules+-- without 𝕄 ever seeing the same term twice, so a program cycling through+-- dataization alone is a loop only this guard ends (#1290, #1420). A formation+-- 'box' gets into is written to the protocol as the frame opens, whether or+-- not '_acyclic' is on, and the frame goes on one level deeper, so what the+-- φ body fires stands under the formation it was fired inside of. dataize' :: Dataizable -> Expression -> State -> ReduceContext -> IO (Dataized, State) dataize' (expr, seq) univ state caller = do- ctx <- deeper =<< unvisited expr =<< universed univ caller{_judgment = Dataization}+ guarded <- deeper =<< entering expr =<< universed univ caller{_judgment = Dataization}+ ctx <- inside guarded expr parking seq state $ case unknown expr of Just idx -> manufactured idx ctx Nothing -> do@@ -112,6 +116,15 @@ Just (rule, subst) -> reduce ctx rule subst Nothing -> throwIO (Undataizable expr state) where+ -- The context a frame opening on a formation 'box' gets into goes on+ -- with, once the formation is written to the protocol: one level deeper,+ -- so everything the φ body does stands under that record.+ inside :: ReduceContext -> Expression -> IO ReduceContext+ inside ctx (ExFormation bds)+ | boxed bds = do+ ctx._saveEval (EvFormation ctx._nesting expr ctx._site)+ pure ctx{_nesting = ctx._nesting + 1}+ inside ctx _ = pure ctx -- The symbol a formation carries in place of a λ name, if any. Such a -- formation is what a λ function answered with where it could not work the -- value out, so no entry of the '--symbolic' file answers it and firing it@@ -132,12 +145,12 @@ firstMatch :: ReduceContext -> [Y.DataizeRule] -> IO (Maybe (Y.DataizeRule, Subst)) firstMatch _ [] = pure Nothing firstMatch ctx (rule : rest) = do- substs <- matchExpressionWithRule' (matchExpression' rule.ematch univ) expr (asRule rule) (RuleContext (execBuildTerm univ ctx))+ substs <- matchExpressionWithRule' (matchExpression' rule.ematch univ) expr (asRule rule) (RuleContext (execBuildTerm univ ctx) (Just univ)) case substs of (subst : _) -> pure (Just (rule, subst)) [] -> firstMatch ctx rest asRule :: Y.DataizeRule -> Y.Rule- asRule rule = Y.Rule rule.name Nothing Nothing rule.match Nothing ExRoot rule.when Nothing Nothing+ asRule rule = Y.Rule rule.name Nothing Nothing rule.match ExRoot rule.when Nothing Nothing reduce :: ReduceContext -> Y.DataizeRule -> Subst -> IO (Dataized, State) reduce ctx rule subst = case bytesProducer rule.dresult rule.premises of Nothing -> do
src/Deps.hs view
@@ -19,7 +19,8 @@ import Data.Maybe (fromMaybe) import qualified Data.Text as T import Files (overwrite)-import Logger (logDebug)+import GHC.Clock (getMonotonicTime)+import Logger (logDebug, logInfo) import Matcher import Printer (printBytes, printFunction) import System.Directory (createDirectoryIfMissing)@@ -78,7 +79,7 @@ -- The judgment a run of the protocol records, which is the one thing the two -- formats spell in two ways: the text format writes the letter the calculus -- writes, '𝕄(Φ.x)', and the markup names the root after it, '<morph--- locator="Φ.x">', the way every record under it is named after the judgment it+-- at="Φ.x">', the way every record under it is named after the judgment it -- carries (#1279). A stuck site spells it the same two ways, since it too is a -- judgment asking and getting no answer (see 'EvStuck'); nothing else is -- spelled twice, since nothing else of a record is a name of the calculus.@@ -103,6 +104,25 @@ opened Morphing = "morph" opened Dataization = "dataize" +-- What '--acyclic' takes for the same formation entered again, which is how+-- sure a cut is that the recursion it stops would never have stopped. 'Proven'+-- takes a formation 'alike' one a frame above entered, the same up to a+-- renaming of symbols, and a formation like that replays its round forever.+-- 'Plausible' takes one the formation a frame above entered is 'within', with+-- the same attributes and λ function and every term the earlier one bound+-- there found again in it, maybe under wrappers it gained: it cuts a+-- recursion whose accumulator grows on every round as well, and now and then+-- one that would have stopped (#1451).+data Acyclic+ = Proven+ | Plausible+ deriving (Bounded, Enum, Eq, Show)++-- The word the command line and the protocol spell a mode of '--acyclic' with.+certainty :: Acyclic -> String+certainty Proven = "proven"+certainty Plausible = "plausible"+ -- One line of the protocol the '--protocol' option writes, which is a tree of -- the firings of the Evaluation function 𝔼 rather than a list of them. The run -- itself opens it — '𝕄(Q.φ)' for a morphing, '𝔻(Q)' for a dataization — and@@ -118,7 +138,10 @@ -- the term the entry wrote, then the normal form 𝕄 makes of it, so the -- morphing between them is a step a reader watches happen rather than a shape a -- term arrives in (#1298). A name no entry answers stands there as--- '?(L_number_nope)', where the block of its firing would have been.+-- '?(L_number_nope)', where the block of its firing would have been. A+-- formation 𝔻 gets into through its 'box' rule opens a block of its own,+-- 'formation(⟦ … ⟧) # 𝔻(Φ.x)', and what its φ body fires stands under it+-- (#1420). data Evaluation = -- The run and the term it was aimed at. EvRun Judgment T.Text@@ -136,6 +159,32 @@ -- that part of the program rather than leaving a locator to say it alone -- (#1306). EvFiring Int T.Text Judgment Expression+ | -- A formation 𝔻 got into through the 'box' rule, at the depth its nesting+ -- gives it, together with the site it was entered at (see '_site' in+ -- 'Morph'). The box rule is the one place a judgment gets into a formation+ -- without firing it: 𝕄 stops at a formation and hands it back, and a+ -- formation whose λ is fired is already an 'EvFiring'. Everything 𝔻 does+ -- inside the φ body, the firings its dataization demands above all, stands+ -- one level deeper, under this record, so a reader sees which object a+ -- firing was made on the way into rather than a flat list of firings. It+ -- opens a block the way a firing does, by indentation in the text format+ -- and by an element in the markup, but it is no firing: it counts nothing+ -- and names no meta, so the metas of the firings under it are numbered as+ -- if it were not there (#1420).+ EvFormation Int Expression Expression+ | -- A frame '--acyclic' cut as it opened, since a frame above it had already+ -- entered the formation it was about to enter, by the mode it was given:+ -- the depth the frame would have opened at, the judgment it belonged to,+ -- the mode that took the two formations for the same one, the formation+ -- the frame above entered, as that frame had it, and the site the cut was+ -- made at. It stands where the 'EvFormation' of the cut frame would have+ -- stood, and its term is the very term of the round that was kept, so a+ -- reader, or a program, pairs the two by their terms without renaming any+ -- symbol by eye, and sees the recursion cut at its site rather than+ -- reconstructing the cut from the residual. Nothing runs under a cut, so+ -- the line stands alone and no block opens under it, the way none opens+ -- under a stuck site (#1434).+ EvLooped Int Judgment Acyclic Expression Expression | -- A λ function no entry of the '--symbolic' file answers, at the depth the -- firing of it would have stood at, together with the judgment that asked -- for the firing and the formation 𝔼 was fired against, as it was handed@@ -195,12 +244,17 @@ -- the order the entry wrote the two metas, and the meta holding the ⊥. It -- stands ahead of the 'join' line, which binds the other side, so a reader -- renders the record as a throw on that side of the condition (#1405).- EvRaiseIf Int (Maybe (Either Int Bytes)) T.Text T.Text+ EvTerminate Int (Maybe (Either Int Bytes)) T.Text T.Text | -- A fresh symbol the answer of the firing asked for, one record per bare 𝜎 -- the entry wrote it with. It is a fact about the firing and no property of -- any one term of it, since an answer may carry several symbols or none and- -- no single one of them stands for the whole of it (#1280).- EvMinted Int Int+ -- no single one of them stands for the whole of it (#1280). It carries the+ -- values the 'dataize' operands of the entry came down to, in the order+ -- the entry declares them, a symbol or data each, since what the fresh+ -- symbol stands for is what the λ function makes of them, and a reader+ -- rendering the symbol back into a program reads that fact off the record+ -- rather than assembling it from the lines above it (#1421).+ EvMinted Int Int [Either Int Bytes] | -- The term the entry wrote as its answer, with the symbols the firing -- minted standing in it, before 𝕄 is asked about it. It is the first of -- the two records an answer is written as, and it is there because the@@ -225,7 +279,7 @@ -- The names the text protocol has given to the terms it has written out, -- keyed by a cheap fixed-size digest of the term (see 'hashExpression') the--- way 'Seen' keys the terms '--acyclic' has walked. A digest collision is+-- way 'Seen' keys the formations '--acyclic' has entered. A digest collision is -- resolved by an exact structural comparison, so the common case stays O(1) on -- the digest while a name still stands for the very term it was given to. -- Keying on the whole term and not on the first symbol it carries is what@@ -278,9 +332,9 @@ -- What the XML protocol has counted so far: how many firings the whole run -- has opened, the same single counter 'Protocol' keeps since #1261, which--- numbers the 'id' an element carries and, through '_openedAt', names a meta--- on this firing the way the text format names it and not with the bare--- spelling the entry's YAML gives it, an answer of it included (#1298); and+-- through '_openedAt' names a meta on this firing the way the text format+-- names it and not with the bare spelling the entry's YAML gives it, an answer+-- of it included (#1298), and which no element carries on its own (#1422); and -- the elements standing open around the record being written, innermost -- first, each with the depth it was opened at and the name it closes under. -- The text format needs no such stack, since indentation opens and closes@@ -346,6 +400,14 @@ where firings :: Int firings = protocol._fired + 1+ written (EvFormation depth self site) protocol = do+ form <- render self+ locator <- render site+ pure (protocol, Just (indented depth (printf "formation(%s) # %s(%s)" form (letter Dataization) locator)))+ written (EvLooped depth judgment mode self site) protocol = do+ form <- render self+ locator <- render site+ pure (protocol, Just (indented depth (printf "looped(%s) # %s(%s), %s" form (letter judgment) locator (certainty mode)))) written (EvStuck depth key judgment self) protocol = do form <- render self pure (protocol, Just (indented depth (printf "?(%s) # %s(%s)" (T.unpack key) (letter judgment) form)))@@ -379,14 +441,14 @@ left <- render (standing one) right <- render (standing two) pure (protocol, Just (indented depth (printf "𝔻(%s) ∈ { 𝔻(%s), 𝔻(%s) }" form left right)))- written (EvRaiseIf depth condition side raised) protocol = do+ written (EvTerminate depth condition side raised) protocol = do cond <- maybe (pure []) (fmap pure . spelled) condition- pure (protocol, Just (indented depth (printf "raise-if(%s) # %s" (intercalate ", " (cond ++ [T.unpack side])) (T.unpack raised))))+ pure (protocol, Just (indented depth (printf "terminate(%s) # %s" (intercalate ", " (cond ++ [T.unpack side])) (T.unpack raised)))) where spelled :: Either Int Bytes -> IO String spelled (Left symbol) = printf "𝔻(%s)" <$> render (standing symbol) spelled (Right bytes) = pure (printBytes bytes)- written (EvMinted _ _) protocol = pure (protocol, Nothing)+ written EvMinted{} protocol = pure (protocol, Nothing) written (EvBuilt depth term) protocol = do value <- borrowed protocol term pure (protocol, Just (indented depth (printf "%s.1 := %s # %s" (labelled protocol depth answer) value (T.unpack answer))))@@ -496,7 +558,7 @@ ( nesting{_closing = (0, opened judgment) : nesting._closing} , [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"- , printf "<%s locator=\"%s\">" (opened judgment) (quoted locator)+ , printf "<%s at=\"%s\">" (opened judgment) (quoted locator) ] ) elements (EvFiring depth key judgment site) nesting = do@@ -507,16 +569,26 @@ , _openedAt = Map.insert depth fires nesting._openedAt , _closing = (depth, "evaluate") : kept }- , closers ++ [indented depth (printf "<evaluate λ=\"%s\" id=\"%d\" judgment=\"%s\" locator=\"%s\">" (quoted key) fires (opened judgment) (escapeXML locator))]+ , closers ++ [indented depth (printf "<evaluate λ=\"%s\" by=\"%s\" at=\"%s\">" (quoted key) (opened judgment) (escapeXML locator))] ) where (kept, closers) = closed depth nesting._closing fires :: Int fires = nesting._fires + 1+ elements (EvFormation depth self site) nesting = do+ form <- render self+ locator <- render site+ let (kept, closers) = closed depth nesting._closing+ pure (nesting{_closing = (depth, "formation") : kept}, closers ++ [indented depth (printf "<formation at=\"%s\" term=\"%s\">" (escapeXML locator) (escapeXML form))])+ elements (EvLooped depth judgment mode self site) nesting = do+ form <- render self+ locator <- render site+ let (kept, closers) = closed depth nesting._closing+ pure (nesting{_closing = kept}, closers ++ [indented depth (printf "<looped by=\"%s\" match=\"%s\" at=\"%s\" term=\"%s\"/>" (opened judgment) (certainty mode) (escapeXML locator) (escapeXML form))]) elements (EvStuck depth key judgment self) nesting = do form <- render self let (kept, closers) = closed depth nesting._closing- pure (nesting{_closing = kept}, closers ++ [indented depth (printf "<stuck λ=\"%s\" judgment=\"%s\">%s</stuck>" (quoted key) (opened judgment) (escapeXMLText form))])+ pure (nesting{_closing = kept}, closers ++ [indented depth (printf "<stuck λ=\"%s\" by=\"%s\">%s</stuck>" (quoted key) (opened judgment) (escapeXMLText form))]) elements (EvData depth spelling _ value) nesting = do record <- stood value pure (nesting{_closing = kept}, closers ++ [indented depth record])@@ -564,21 +636,31 @@ (kept, closers) = closed depth nesting._closing joint :: String joint = printf "<joined symbol=\"%s\">%s %s</joined>" (sigma fresh) (sigma one) (sigma two)- elements (EvRaiseIf depth condition side _) nesting =- pure (nesting{_closing = kept}, closers ++ [indented depth raise])+ elements (EvTerminate depth condition side _) nesting =+ pure (nesting{_closing = kept}, closers ++ [indented depth terminal]) where (kept, closers) = closed depth nesting._closing -- The condition a symbol stands for is named by it, the way 'joined' -- names one, and data the condition came down to is the text.- raise :: String- raise = case condition of- Just (Left symbol) -> printf "<raise-if symbol=\"%s\" branch=\"%s\"/>" (sigma symbol) (quoted side)- Just (Right bytes) -> printf "<raise-if branch=\"%s\">%s</raise-if>" (quoted side) (escapeXMLText (printBytes bytes))- Nothing -> printf "<raise-if branch=\"%s\"/>" (quoted side)- elements (EvMinted depth symbol) nesting =- pure (nesting{_closing = kept}, closers ++ [indented depth (printf "<minted>%s</minted>" (sigma symbol))])+ terminal :: String+ terminal = case condition of+ Just (Left symbol) -> printf "<terminate symbol=\"%s\" branch=\"%s\"/>" (sigma symbol) (quoted side)+ Just (Right bytes) -> printf "<terminate branch=\"%s\">%s</terminate>" (quoted side) (escapeXMLText (printBytes bytes))+ Nothing -> printf "<terminate branch=\"%s\"/>" (quoted side)+ elements (EvMinted depth symbol operands) nesting =+ pure (nesting{_closing = kept}, closers ++ [indented depth mint]) where (kept, closers) = closed depth nesting._closing+ -- The symbol stands in 'symbol', the way 'known' and 'joined' put+ -- theirs, and the values the λ function was fired on are the text,+ -- each spelled the way its own line spells it (#1421).+ mint :: String+ mint+ | null operands = printf "<minted symbol=\"%s\"/>" (sigma symbol)+ | otherwise = printf "<minted symbol=\"%s\">%s</minted>" (sigma symbol) (escapeXMLText (unwords (map spelled operands)))+ spelled :: Either Int Bytes -> String+ spelled (Left fresh) = sigma fresh+ spelled (Right bytes) = printBytes bytes elements (EvBuilt depth term) nesting = do body <- render term let (kept, closers) = closed depth nesting._closing@@ -658,3 +740,46 @@ dontSaveEval :: SaveEvalFunc dontSaveEval _ = pure ()++-- What '--log-level=INFO' has counted of a run so far: when the run began and+-- when a line about it last reached the console, both on the monotonic clock in+-- seconds, and how many formations it has entered and how many λ functions it+-- has fired. A long run prints nothing else until it ends, so a stuck entry and+-- a slow one look the same from outside; the counts say whether it advances+-- and the site of the latest record says where it is (#1470).+data Progress = Progress+ { _began :: Double+ , _told :: Maybe Double+ , _formations :: Int+ , _firings :: Int+ }++-- The progress of a run that began at this moment and has done nothing yet.+emptyProgress :: Double -> Progress+emptyProgress began = Progress began Nothing 0 0++-- Record every report the way the wrapped function does and count the ones+-- that carry a site, which are the firings and the formations entered. Once+-- the given number of seconds has passed since the last line, and on the first+-- such report too, one line goes to the console naming the counts, the time+-- the run has taken and the site of the report, rendered only then, since a+-- run may make hundreds of thousands of them and prints one every few seconds.+progressed :: IORef Progress -> Double -> (Expression -> IO String) -> SaveEvalFunc -> SaveEvalFunc+progressed cursor interval render record evaluation = do+ record evaluation+ mapM_ reported (sited evaluation)+ where+ sited :: Evaluation -> Maybe (Progress -> Progress, Expression)+ sited (EvFiring _ _ _ site) = Just (\progress -> progress{_firings = progress._firings + 1}, site)+ sited (EvFormation _ _ site) = Just (\progress -> progress{_formations = progress._formations + 1}, site)+ sited _ = Nothing+ reported :: (Progress -> Progress, Expression) -> IO ()+ reported (counted, site) = do+ now <- getMonotonicTime+ progress <- counted <$> readIORef cursor+ if maybe True (\told -> now - told >= interval) progress._told+ then do+ locator <- render site+ logInfo (printf "Entered %d formations and fired %d λ functions in %.0fs, now at %s" progress._formations progress._firings (now - progress._began) locator)+ writeIORef cursor progress{_told = Just now}+ else writeIORef cursor progress
src/Encoding.hs view
@@ -110,6 +110,7 @@ toASCII CO_MATCHES{..} = CO_MATCHES regex (toASCII expr) toASCII CO_PART_OF{..} = CO_PART_OF (toASCII expr) (toASCII binding) toASCII CO_DISJOINT{..} = CO_DISJOINT (map toASCII attrs) (map toASCII groups)+ toASCII CO_SUBSET{..} = CO_SUBSET (map toASCII attrs) belongs (map toASCII groups) toASCII CO_FORMATION{..} = CO_FORMATION (toASCII expr) toASCII CO_EMPTY = CO_EMPTY
src/Evaluate.hs view
@@ -14,7 +14,7 @@ -- which this module imports. The edges pointing back the other way, 𝕄 asking -- 𝔼 to fire, are injected as '_evaluate' and '_fire' rather than imported, the -- way 'Dataize' hands 'Morph' its '_reduce' (see 'EvaluationFunc').-module Evaluate (evaluation, fired, lambda) where+module Evaluate (evaluation, fired) where import AST import Builder (buildExpressionThrows, contextualize)@@ -27,7 +27,7 @@ import Deps (BuildTermMethodS, Evaluation (..), State (..), Term (..)) import Lambdas (Lambda (..), Meta (..), joined, matched, minted, symbolized) import Matcher (MetaValue (..), Subst, combine, substEmpty, substSingle, substSlot)-import Morph (ReduceContext (..), ReduceException (..), deeper, morph', morphing, normalized, unparked)+import Morph (Answer, Kept (..), ReduceContext (..), ReduceException (..), charged, deeper, enter, isLambda, lambda, morph', morphing, normalized, recalled, retained, unparked) import Printer (printFunction) import Rule (RuleContext (RuleContext), matchExpressionWithRule') import Text.Printf (printf)@@ -122,22 +122,73 @@ -- is still standing in the residue the '_deep' walk goes over, so 𝔼 is fired on -- it again and again answers nothing, and a reader counting the '?(…)' lines -- counts the sites 𝔼 got stuck on rather than the passes the walk made over--- them (see '_parked', #1300).+-- them (see '_parked', #1300). A firing an entry answers is charged to the+-- '--max-firings' budget before it writes anything, so a run that spent the+-- budget leaves no firing open in the protocol (see 'charged', #1472).+--+-- A formation the run has fired already is not fired again where '_memo'+-- keeps what it answered (see 'Memo' in 'Morph'): the answer comes back as+-- the first firing left it, symbols and all, and nothing is charged, minted+-- or reduced. The firing is written all the same, at its own site and with+-- its answer, the way a fresh one is, since the protocol records where 𝔼 was+-- asked and what it said there; what it does not get is an operand line, or+-- a symbol of its own, since the run reduced and minted none for it. So the+-- 𝔼 lines of a run count the sites 𝔼 answered at, and the '--max-firings'+-- budget counts the firings it made. symbol :: T.Text -> Expression -> Expression -> Expression -> State -> ReduceContext -> IO (Expression, State) symbol func form self univ state caller = case matched caller._symbolic func of Nothing -> do unless (func `elem` caller._parked) (caller._saveEval (EvStuck caller._nesting func caller._judgment form)) throwIO (Stuck func) Just entry -> do- caller._saveEval (EvFiring caller._nesting func caller._judgment caller._site)- let ctx = caller{_nesting = caller._nesting + 1}- (bound, dataized, conditions) <- foldM (down ctx) (substEmpty, state, []) entry._dataized- (bound', morphed) <- foldM (through ctx) (bound, dataized) entry._morphed- rewrote <- foldM (reshaped ctx) bound' entry._rewritten- (bound'', stood) <- foldM (masked ctx) (rewrote, morphed) entry._symbolized- (bound''', forked) <- foldM (paired ctx (listToMaybe (reverse conditions))) (bound'', stood) entry._paired- answered ctx entry bound''' forked+ known <- recalled caller._memo form+ maybe (made entry) told known where+ -- Fire the entry: charge the firing, reduce every operand, build the+ -- answer and keep it for the next firing of the same formation. A+ -- recursion cut on the way leaves the firing with no answer, and it is+ -- kept instead, as the formation the cut carried, since the next firing+ -- of the same formation would only walk down to it again (#1480).+ made :: Lambda -> IO (Expression, State)+ made entry = do+ charged caller+ caller._saveEval (EvFiring caller._nesting func caller._judgment caller._site)+ let ctx = caller{_nesting = caller._nesting + 1}+ outcome <- try $ do+ (bound, dataized, conditions) <- foldM (down ctx) (substEmpty, state, []) entry._dataized+ (bound', morphed) <- foldM (through ctx) (bound, dataized) entry._morphed+ rewrote <- foldM (reshaped ctx) bound' entry._rewritten+ (bound'', stood) <- foldM (masked ctx) (rewrote, morphed) entry._symbolized+ (bound''', forked) <- foldM (paired ctx (listToMaybe (reverse conditions))) (bound'', stood) entry._paired+ answered ctx entry (reverse conditions) bound''' forked+ case outcome of+ Right (answer, state') -> do+ retained caller._memo form (Answered answer)+ pure (snd answer, state')+ Left failure -> do+ mapM_ (retained caller._memo form . Looped) (cut failure)+ throwIO failure+ -- The formation a recursion was cut at, where that is what the signal+ -- escaping a firing says.+ cut :: ReduceException -> Maybe Expression+ cut (Looping term) = Just term+ cut (LoopingAt term _ _) = Just term+ cut _ = Nothing+ -- Answer the firing with what the first firing of the formation made,+ -- written as that one was written: the firing at its site, the term the+ -- entry wrote and the normal form it came to, and nothing between them.+ -- Where the first firing was cut, the firing is cut again at its own site,+ -- with the formation that cut carried and nothing reduced before it.+ told :: Kept -> IO (Expression, State)+ told (Answered (built, normal)) = do+ caller._saveEval (EvFiring caller._nesting func caller._judgment caller._site)+ caller._saveEval (EvBuilt (caller._nesting + 1) built)+ caller._saveEval (EvAnswer (caller._nesting + 1) normal)+ pure (normal, state)+ told (Looped term) = do+ caller._saveEval (EvFiring caller._nesting func caller._judgment caller._site)+ mapM_ (\mode -> caller._saveEval (EvLooped (caller._nesting + 1) caller._judgment mode term caller._site)) caller._acyclic+ throwIO (Looping term) -- Bring one 'dataize' operand down through 𝔻 and bind the bytes meta that -- names it. An operand 𝔻 could not bring down to data — a site '_partial' -- parked — leaves the firing with nothing to bind, so it gets stuck like a@@ -191,7 +242,7 @@ reshaped :: ReduceContext -> Subst -> (Meta, (Meta, [Y.Rule])) -> IO Subst reshaped ctx bound (meta, (source, rules)) = do term <- buildExpressionThrows (ExMeta source._name) bound- shaped <- rewritten rules (RuleContext ctx._buildTerm) term+ shaped <- rewritten rules (RuleContext ctx._buildTerm Nothing) term ctx._saveEval (EvSymbolize ctx._nesting meta._spelling (ExMeta source._name) shaped) bind meta (MvExpression shaped) bound -- Stand the data of a term another line of the entry has bound into@@ -242,8 +293,8 @@ two <- branch right case (one, two) of (ExTermination, ExTermination) -> both one two- (ExTermination, _) -> raising "left" left two- (_, ExTermination) -> raising "right" right one+ (ExTermination, _) -> terminating "left" left two+ (_, ExTermination) -> terminating "right" right one _ -> both one two where -- The two sides joined symbol by symbol (see 'joined').@@ -258,9 +309,9 @@ -- The side that raises written down, named by the meta holding its ⊥, -- and the other side bound as the join; nothing is minted, since one -- value is left and a symbol would stand for nothing but it.- raising :: T.Text -> Meta -> Expression -> IO (Subst, State)- raising side raised term = do- ctx._saveEval (EvRaiseIf ctx._nesting condition side raised._spelling)+ terminating :: T.Text -> Meta -> Expression -> IO (Subst, State)+ terminating side raised term = do+ ctx._saveEval (EvTerminate ctx._nesting condition side raised._spelling) ctx._saveEval (EvJoin ctx._nesting meta._spelling (left._spelling, right._spelling) term) bound' <- bind meta (MvExpression term) bound pure (bound', state')@@ -278,7 +329,10 @@ -- counts them, which is what keeps two firings from spelling two unknowns -- alike. Each one goes into the protocol as it is handed out, ahead of the -- answer carrying it, so a reader ties an unknown back to the firing that- -- made it without reading the term it stands in (#1280).+ -- made it without reading the term it stands in (#1280). Each record also+ -- carries what the 'dataize' operands of the entry came down to, in the+ -- order the entry declares them, since the symbol stands for what the λ+ -- function makes of them (#1421). -- -- The answer is morphed rather than handed back as the entry wrote it, -- because a firing is one of the things a term can come from and every@@ -295,17 +349,18 @@ -- protocol and no silent change of shape: whatever 𝕄 fires on the way opens -- its block between the two, where every other firing of an operand opens -- its own, and the formation standing on the second line is read as what- -- the three tokens on the first came to (#1298).- answered :: ReduceContext -> Lambda -> Subst -> State -> IO (Expression, State)- answered ctx entry bound state' = do+ -- the three tokens on the first came to (#1298). Both come back, since+ -- they are what the memo keeps of a firing (see 'Memo').+ answered :: ReduceContext -> Lambda -> [Either Int Bytes] -> Subst -> State -> IO (Answer, State)+ answered ctx entry operands bound state' = do let (fresh, spent) = minted entry._answer state'._minted- mapM_ (ctx._saveEval . EvMinted ctx._nesting) [idx | (_, FnSymbol idx) <- fresh]+ mapM_ (\idx -> ctx._saveEval (EvMinted ctx._nesting idx operands)) [idx | (_, FnSymbol idx) <- fresh] symbolic <- foldM mint bound fresh built <- buildExpressionThrows entry._answer symbolic ctx._saveEval (EvBuilt ctx._nesting built) (normal, state'') <- settled built univ state'{_minted = spent} ctx ctx._saveEval (EvAnswer ctx._nesting normal)- pure (normal, state'')+ pure ((built, normal), state'') mint :: Subst -> (Slot, Function) -> IO Subst mint bound (slot, fresh) = case combine (substSlot slot (MvFunction fresh)) bound of Just bound' -> pure bound'@@ -414,11 +469,16 @@ -- model (#1288). The state it had reached goes back rather than the one the -- walk came in with, since the firings before it are done and the symbols -- they minted are spent.+ --+ -- The firing enters the formation it fires, the way 'fire' of 𝔻 does, so+ -- '--acyclic' sees a recursion the walk alone drives: an entry reducing an+ -- operand whose walk fires the same formation again is cut there and parked+ -- like any other loop (#1451). evaluated :: ReduceContext -> State -> Expression -> (T.Text, Expression) -> IO (Maybe Expression, State) evaluated ctx state' form (func, self) | isNothing (matched ctx._symbolic func) = pure (Nothing, state') | otherwise = do- made <- try (symbol func form self univ state' ctx)+ made <- try (enter form ctx >>= symbol func form self univ state') case made of Right (answer, answered) -> do (again, reached) <- fired dispatched answer univ answered ctx@@ -442,7 +502,7 @@ parked _ (LoopingAt _ _ reached) = pure (Nothing, reached) parked reached (Looping _) = pure (Nothing, reached) parked _ (StuckAt func _ _) = throwIO (Stuck func)- parked _ (OutOfStepsAt limit _ _) = throwIO (OutOfSteps limit)+ parked _ (OutOfStepsAt budget _ _) = throwIO (OutOfSteps budget) parked _ failure = throwIO failure -- A term of the '--symbolic' file as 𝕄 leaves it: an entry's answer on its way@@ -460,25 +520,6 @@ (normal, _) <- normalized term ((univ, Nothing) :| []) ctx ((morphed, _), state') <- morph' (normal, (univ, Nothing) :| []) univ state ctx pure (morphed, state')---- Split the λ binding off a formation for the LAMBDA morphing rule: the name of--- the λ function to fire and the formation it fires against, the λ binding--- removed. A formation with no λ binding, or with more than one, has nothing to--- fire; neither has one carrying a symbol, which is a λ name nothing answers.--- The three are one answer here but not to 𝔼, which tells all three apart: no λ--- at all is answered with ⊥, a symbol gets stuck the way an unanswered name--- does, and only the rest is a term it cannot work out (see 'evaluation').-lambda :: [Binding] -> Maybe (T.Text, Expression)-lambda bds = case partition isLambda bds of- ([BiLambda (Function func)], rest) -> Just (func, ExFormation rest)- _ -> Nothing---- Whether a binding names a λ function, whatever that name turns out to be.--- 𝔼 asks this before 'lambda' does its splitting, since a formation carrying no--- λ at all is answered with ⊥ rather than refused (see 'evaluation').-isLambda :: Binding -> Bool-isLambda (BiLambda _) = True-isLambda _ = False -- 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
src/Files.hs view
@@ -10,7 +10,7 @@ import Control.Exception (Exception, onException, throwIO) import Control.Monad (forM, when)-import System.Directory (copyPermissions, doesDirectoryExist, doesFileExist, listDirectory, pathIsSymbolicLink, removeFile, renameFile)+import System.Directory (copyPermissions, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, listDirectory, pathIsSymbolicLink, removeFile, renameFile) import System.FilePath (takeDirectory, takeFileName, (</>)) import System.IO (Handle, hClose, hPutStr, hSetEncoding, openTempFileWithDefaultPermissions, utf8) import Text.Printf (printf)@@ -31,6 +31,7 @@ overwrite :: FilePath -> String -> IO () overwrite file content = do+ createDirectoryIfMissing True (takeDirectory file) (temp, handle) <- openTempFileWithDefaultPermissions (takeDirectory file) (takeFileName file) replace temp handle `onException` (hClose handle >> removeFile temp) where
src/Functions.hs view
@@ -3,7 +3,7 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module Functions (buildTerm, execFunctions) where+module Functions (buildTerm, buildFunctions, execFunctions, nameOf) where import AST import Builder@@ -32,6 +32,9 @@ execFunctions :: [String] execFunctions = ["evaluate", "morph"] +buildFunctions :: [String]+buildFunctions = ["contextualize", "random-tau", "dataize", "concat", "sed", "random-string", "size", "tau", "string", "number", "sum", "join", "named"]+ buildTerm :: BuildTermFunc buildTerm func args subst = do logDebug (printf "Building new term using '%s' function..." func)@@ -76,6 +79,18 @@ pure (TeExpression (contextualize expr' context')) _contextualize _ _ = throwIO (userError "Function contextualize() requires exactly 2 arguments as expression") +-- The name the formation of the only argument goes by in the given world, or+-- the formation itself where it has none (see 'pathOf'). The world is not an+-- argument a rule writes: 'Rule' hands over the one its context knows. Where+-- no world is known — the 'rewrite' command, and 'isNF' asking about a term on+-- its own — the formation is answered as it is, exactly as 'dot' answered+-- before any object of the world had a name.+nameOf :: Maybe Expression -> BuildTermMethod+nameOf universe [Y.ArgExpression expr] subst = do+ form <- buildExpressionThrows expr subst+ pure (TeExpression (maybe form (`pathOf` form) universe))+nameOf _ _ _ = throwIO (userError "Function named() requires exactly 1 argument as expression")+ -- Uniqueness is the engine's job: 'freshTau' draws from the document-wide -- avoid-set seeded at the start of the run, so no collision list is needed. -- The function takes no arguments and rejects any extras so rule mistakes are@@ -92,6 +107,7 @@ expr' <- buildExpressionThrows expr subst case expr' of DataObject _ bytes -> pure (TeBytes bytes)+ ExFormation [BiDelta bytes, BiVoid AtRho] -> pure (TeBytes bytes) _ -> throwIO (userError "Only data objects and bytes are supported by 'dataize' function now") _dataize _ _ = throwIO (userError "Function dataize() requires exactly 1 argument as expression or bytes")
src/LaTeX.hs view
@@ -317,6 +317,7 @@ toLaTeX PA_META_DELTA'{..} = PA_META_DELTA' (toLaTeX meta) toLaTeX PA_META_LAMBDA{..} = toLaTeX (PA_META_LAMBDA' meta) toLaTeX PA_META_LAMBDA'{..} = PA_META_LAMBDA' (toLaTeX meta)+ toLaTeX folded@PA_FOLDED{} = folded instance ToLaTeX META where toLaTeX META{..} =@@ -389,6 +390,7 @@ toLaTeX CO_MATCHES{..} = CO_MATCHES regex (toLaTeX expr) toLaTeX CO_PART_OF{..} = CO_PART_OF (toLaTeX expr) (toLaTeX binding) toLaTeX CO_DISJOINT{..} = CO_DISJOINT (map toLaTeX attrs) (map toLaTeX groups)+ toLaTeX CO_SUBSET{..} = CO_SUBSET (map toLaTeX attrs) belongs (map toLaTeX groups) toLaTeX CO_FORMATION{..} = CO_FORMATION (toLaTeX expr) toLaTeX CO_EMPTY = CO_EMPTY @@ -420,7 +422,7 @@ joinedConditions (Just first) (Just second) = Just (Y.And [first, second]) -- Render a morphing rule as a LaTeX inference rule: each premise becomes a--- judgment above the line and the conclusion is 𝕄(match, e, s_1) ⟿ ⟨n-result, s_k⟩+-- judgment above the line and the conclusion is 𝕄(match, e, s_1) ⟿ ⟨conclusion, s_k⟩ -- below, where s_k is the final state threaded through the premises. explainMorphRule :: Y.MorphRule -> String explainMorphRule rule =@@ -435,7 +437,7 @@ (premises, final) = premisesToLatex (renderExpr rule.ematch) rule.premises -- Render a dataization rule as a LaTeX inference rule, with 𝔻(match, e, s_1) ⟿--- ⟨d-result, s_k⟩ as the conclusion below the line, s_k being the final threaded+-- ⟨conclusion, s_k⟩ as the conclusion below the line, s_k being the final threaded -- state. explainDataizeRule :: Y.DataizeRule -> String explainDataizeRule rule =@@ -481,7 +483,7 @@ -- starts in state s_1; each state-changing premise (𝕄, 𝔻, 𝔼) consumes the -- current state and yields the next (s_2, s_3, …), matching how the engine folds -- the state through the premises ('sidePremise' in 'Dataize.hs'). The 'universe'--- is the rule's own e-match, threaded into 𝕄/𝔻 premises (bound by the conclusion)+-- is the rule's own 'universe' key, threaded into 𝕄/𝔻 premises (bound by the conclusion) -- rather than a free 'e'. Returns the rendered judgments and the final state -- index, which the conclusion returns. premisesToLatex :: String -> [Y.Premise] -> ([String], Int)@@ -498,7 +500,7 @@ -- state-changing operations 𝕄 ('morph'), 𝔻 ('dataize') and 𝔼 ('evaluate') consume -- s_index and yield s_index+1 (so they return the bumped index); the rest are -- stateless and leave the index as is. 𝕄 and 𝔻 carry the rule's own 'universe'--- (its e-match) so the premise stays bound by the conclusion instead of naming a+-- (its 'universe' key) so the premise stays bound by the conclusion instead of naming a -- free 'e'; 𝔼 carries the explicit universe from its own operation. premiseToLatex :: String -> Int -> Y.Premise -> (String, Int) premiseToLatex universe index premise = case premise.operation of
src/Lambdas.hs view
@@ -140,7 +140,8 @@ instance FromJSON Lambda where parseJSON = withObject "Lambda" $ \entry -> do- key <- entry .: "λ"+ key <- entry .:? "λ" >>= maybe (fail "The entry has no 'λ' key") pure+ answer <- entry .:? "𝑛" >>= maybe (fail "The entry has no '𝑛' key") pure lambda <- Lambda key <$> operands key bytesMeta entry "dataize"@@ -148,7 +149,7 @@ <*> rewrites (T.unpack key) entry <*> operands key expressionMeta entry "symbolize" <*> pairs (T.unpack key) entry- <*> entry .: "𝑛"+ <*> pure answer sigmas (T.unpack key) lambda._answer dataless (T.unpack key) lambda._answer earlier (T.unpack key) lambda@@ -235,8 +236,8 @@ symbolless result | null (symbols result) && null [kind | Slot kind _ <- slots result, kind == "S"] = pure () | otherwise = fail (printf "A rule of the 'rewrite' block of λ function '%s' writes a symbol 𝜎 into its result" key)- -- Every meta a result reads is one the pattern, the 'e-match' or a- -- 'where' extension of the very same rule binds.+ -- Every meta a result reads is one the pattern or a 'where'+ -- extension of the very same rule binds. bound :: Y.Rule -> Yaml.Parser () bound parsed = case filter (`notElem` known) (metas parsed.result) of [] -> pure ()@@ -250,7 +251,7 @@ ) where known :: [Text]- known = metas parsed.pattern ++ metas parsed.ematch ++ concatMap (metas . (.meta)) (concat parsed.where_)+ known = metas parsed.pattern ++ concatMap (metas . (.meta)) (concat parsed.where_) -- Every 'rewrite', 'symbolize' and 'join' line reads terms the entry has -- bound already: a 'morph' operand, a line above it in its own block or -- a line of a block above its own, since nothing else of an entry is a
src/Lining.hs view
@@ -83,6 +83,7 @@ toSingleLine CO_MATCHES{..} = CO_MATCHES regex (toSingleLine expr) toSingleLine CO_PART_OF{..} = CO_PART_OF (toSingleLine expr) (toSingleLine binding) toSingleLine CO_DISJOINT{..} = CO_DISJOINT attrs (map toSingleLine groups)+ toSingleLine CO_SUBSET{..} = CO_SUBSET attrs belongs (map toSingleLine groups) toSingleLine CO_FORMATION{..} = CO_FORMATION (toSingleLine expr) toSingleLine CO_EMPTY = CO_EMPTY
src/Logger.hs view
@@ -5,9 +5,11 @@ module Logger ( logDebug+ , logInfo , logError+ , logging , setLogConfig- , LogLevel (DEBUG, ERROR, NONE)+ , LogLevel (DEBUG, INFO, ERROR, NONE) ) where @@ -17,7 +19,7 @@ import GHC.IO (unsafePerformIO) import System.IO -data LogLevel = DEBUG | ERROR | NONE+data LogLevel = DEBUG | INFO | ERROR | NONE deriving (Show, Ord, Eq, Bounded, Enum, Read) data Logger = Logger {level :: LogLevel, lns :: Int}@@ -29,6 +31,14 @@ setLogConfig :: LogLevel -> Int -> IO () setLogConfig lvl cnt = writeIORef logger (Logger lvl cnt) +-- Whether a message of this level reaches the console at all, so a caller+-- whose message costs something to put together skips the work when it would+-- be thrown away.+logging :: LogLevel -> IO Bool+logging lvl = do+ Logger{..} <- readIORef logger+ pure (lvl >= level && lns /= 0)+ logMessage :: LogLevel -> String -> IO () logMessage lvl message = do Logger{..} <- readIORef logger@@ -43,6 +53,7 @@ in hPutStrLn stderr ("[" ++ show lvl ++ "]: " ++ DL.intercalate "\n" msg) ) -logDebug, logError :: String -> IO ()+logDebug, logInfo, logError :: String -> IO () logDebug = logMessage DEBUG+logInfo = logMessage INFO logError = logMessage ERROR
src/Matcher.hs view
@@ -152,7 +152,8 @@ matchExpression' ExRoot ExRoot = [substEmpty] matchExpression' ExTermination ExTermination = [substEmpty] matchExpression' (ExFormation pbs) (ExFormation tbs) = matchBindings pbs tbs-matchExpression' (ExDispatch pexp pattr) (ExDispatch texp tattr) = combineMany (matchAttribute pattr tattr) (matchExpression' pexp texp)+matchExpression' (ExDispatch pexp pattr) (ExDispatch texp tattr) = combineMany (matchAttribute pattr tattr) (matchExpression' (pinned pattr tattr pexp) texp)+matchExpression' (ExApplication pexp parg@(ArTau pattr _)) (ExApplication texp targ@(ArTau tattr _)) = combineMany (matchExpression' (pinned pattr tattr pexp) texp) (matchArgument parg targ) matchExpression' (ExApplication pexp parg) (ExApplication texp targ) = combineMany (matchExpression' pexp texp) (matchArgument parg targ) matchExpression' (ExPhiAgain prefix idx expr) (ExPhiAgain prefix' idx' expr') | prefix == prefix' && idx == idx' = matchExpression' expr expr'@@ -162,25 +163,123 @@ | otherwise = [] matchExpression' _ _ = [] --- Deep match pattern to expression inside binding-matchBindingExpression :: Binding -> Expression -> [Subst]-matchBindingExpression (BiTau _ expr) ptn = matchExpressionDeep ptn expr-matchBindingExpression _ _ = []--matchArgumentExpression :: Argument -> Expression -> [Subst]-matchArgumentExpression (ArTau _ expr) ptn = matchExpressionDeep ptn expr-matchArgumentExpression (ArAlpha _ expr) ptn = matchExpressionDeep ptn expr+-- The pattern with the attribute meta written in its place wherever the+-- meta stands in it, once the target has told which attribute that is. A+-- dispatch or an application names its attribute beside the formation it is+-- made of, as '⟦𝐵1, 𝜏1 ↦ 𝑛1, 𝐵2⟧.𝜏1' does, and the formation is matched+-- first, so without it every binding of the formation would be tried as 𝜏1+-- and a substitution made for it before the attribute threw all but one away.+-- The matches are the ones the pattern has anyway, in the same order (#1453).+pinned :: Attribute -> Attribute -> Expression -> Expression+pinned (AtMeta meta) tattr = goExpr+ where+ goExpr :: Expression -> Expression+ goExpr (ExFormation bds) = ExFormation (map goBinding bds)+ goExpr (ExDispatch expr attr) = ExDispatch (goExpr expr) (goAttribute attr)+ goExpr (ExApplication expr (ArTau attr arg)) = ExApplication (goExpr expr) (ArTau (goAttribute attr) (goExpr arg))+ goExpr (ExApplication expr (ArAlpha alpha arg)) = ExApplication (goExpr expr) (ArAlpha alpha (goExpr arg))+ goExpr expr = expr+ goBinding :: Binding -> Binding+ goBinding (BiTau attr expr) = BiTau (goAttribute attr) (goExpr expr)+ goBinding (BiVoid attr) = BiVoid (goAttribute attr)+ goBinding bd = bd+ goAttribute :: Attribute -> Attribute+ goAttribute (AtMeta meta')+ | meta' == meta = tattr+ goAttribute attr = attr+pinned _ _ = id -- Match expression with deep nested expression(s) matching matchExpressionDeep :: MatchExpressionFunc-matchExpressionDeep ptn tgt =- let matched = matchExpression' ptn tgt- deep = case tgt of- ExFormation bds -> concatMap (`matchBindingExpression` ptn) bds- ExDispatch expr _ -> matchExpressionDeep ptn expr- ExApplication expr arg -> matchExpressionDeep ptn expr ++ matchArgumentExpression arg ptn- _ -> []- in matched ++ deep+matchExpressionDeep = matchExpressionDeep' False +-- The same deep matching, told whether the pattern is a redex: one that+-- matches only at a place no 'inert' term holds. The matcher then never looks+-- inside an inert term, so a copy of an object an earlier normalization left+-- in normal form costs nothing to carry along, however big it is (#1453).+matchExpressionDeep' :: Bool -> MatchExpressionFunc+matchExpressionDeep' redex ptn tgt = go tgt []+ where+ go :: Expression -> [Subst] -> [Subst]+ go expr rest+ | redex && inert expr = rest+ | fitting ptn expr = matchExpression' ptn expr ++ below expr rest+ | otherwise = below expr rest+ below :: Expression -> [Subst] -> [Subst]+ below (ExFormation bds) rest = foldr inside rest bds+ below (ExDispatch expr _) rest = go expr rest+ below (ExApplication expr (ArTau _ arg)) rest = go expr (go arg rest)+ below (ExApplication expr (ArAlpha _ arg)) rest = go expr (go arg rest)+ below _ rest = rest+ inside :: Binding -> [Subst] -> [Subst]+ inside (BiTau _ expr) rest = go expr rest+ inside _ rest = rest+ matchExpression :: MatchExpressionFunc matchExpression = matchExpressionDeep++-- Whether the pattern could match at some place of the target where the deep+-- matcher looks, judged by the shape of each place alone: the constructors+-- down the head of the pattern, the attribute a dispatch or an application+-- names, and the kinds of bindings a formation of the pattern asks for. It+-- never says no where 'matchExpressionDeep' would find a match, and it walks+-- the target once without building a single substitution, so a rule whose+-- pattern fits nowhere in a term is told so without the deep matcher trying+-- it at every place of that term (#1453).+reachable :: Expression -> Expression -> Bool+reachable = reachable' False++-- The same judgement, told whether the pattern is a redex, in which case no+-- place inside an 'inert' term is looked at (see 'matchExpressionDeep'').+reachable' :: Bool -> Expression -> Expression -> Bool+reachable' redex ptn = go+ where+ go :: Expression -> Bool+ go tgt+ | redex && inert tgt = False+ | otherwise =+ fitting ptn tgt || case tgt of+ ExFormation bds -> any inside bds+ ExDispatch expr _ -> go expr+ ExApplication expr (ArTau _ arg) -> go expr || go arg+ ExApplication expr (ArAlpha _ arg) -> go expr || go arg+ _ -> False+ inside :: Binding -> Bool+ inside (BiTau _ expr) = go expr+ inside _ = False++-- Whether the pattern could match the target right at its root, judged by+-- shape alone: the constructors down the head of the pattern, the attribute a+-- dispatch or an application names, and the kinds of bindings a formation of+-- the pattern asks for. It never says no where 'matchExpression'' would find+-- a match (#1453).+fitting :: Expression -> Expression -> Bool+fitting = go+ where+ go :: Expression -> Expression -> Bool+ go (ExMeta _) _ = True+ go (ExAny _) _ = True+ go ExXi ExXi = True+ go ExRoot ExRoot = True+ go ExTermination ExTermination = True+ go (ExFormation pbs) (ExFormation tbs) = all (\pbd -> loose pbd || any (kin pbd) tbs) pbs+ go (ExDispatch pexp pattr) (ExDispatch texp tattr) = same pattr tattr && go pexp texp+ go (ExApplication pexp (ArTau pattr _)) (ExApplication texp (ArTau tattr _)) = same pattr tattr && go pexp texp+ go (ExApplication pexp (ArAlpha _ _)) (ExApplication texp (ArAlpha _ _)) = go pexp texp+ go (ExPhiAgain{}) (ExPhiAgain{}) = True+ go (ExPhiMeet{}) (ExPhiMeet{}) = True+ go _ _ = False+ loose :: Binding -> Bool+ loose (BiMeta _) = True+ loose (BiAny _) = True+ loose _ = False+ kin :: Binding -> Binding -> Bool+ kin (BiTau pattr _) (BiTau tattr _) = same pattr tattr+ kin (BiVoid pattr) (BiVoid tattr) = same pattr tattr+ kin (BiLambda _) (BiLambda _) = True+ kin (BiDelta _) (BiDelta _) = True+ kin _ _ = False+ same :: Attribute -> Attribute -> Bool+ same (AtMeta _) _ = True+ same (AtAny _) _ = True+ same pattr tattr = pattr == tattr
src/Misc.hs view
@@ -19,7 +19,6 @@ import Data.Functor ((<&>)) import Data.List (intercalate) import Data.Maybe (catMaybes)-import qualified Data.Set as Set import Text.Printf (printf) -- Unwrap a pure 'Either String' in IO, throwing the built exception on 'Left'@@ -27,15 +26,6 @@ orThrow _ (Right value) = pure value orThrow asException (Left err) = throwIO (asException err) --- Extract attribute from binding-attributeFromBinding :: Binding -> Maybe Attribute-attributeFromBinding (BiTau attr _) = Just attr-attributeFromBinding (BiVoid attr) = Just attr-attributeFromBinding (BiDelta _) = Just AtDelta-attributeFromBinding (BiLambda _) = Just AtLambda-attributeFromBinding (BiMeta _) = Nothing-attributeFromBinding (BiAny _) = Nothing- -- Extract attributes from bindings attributesFromBindings :: [Binding] -> [Attribute] attributesFromBindings [] = []@@ -51,7 +41,7 @@ -- Check if given binding list consists of unique attributes uniqueBindings :: [Binding] -> Either String [Binding]-uniqueBindings bds = case duplicated bds Set.empty of+uniqueBindings bds = case repeated bds of Just attr -> Left ( printf@@ -60,14 +50,6 @@ (intercalate ", " (map show (attributesFromBindings bds))) ) _ -> Right bds- where- duplicated :: [Binding] -> Set.Set Attribute -> Maybe Attribute- duplicated [] _ = Nothing- duplicated (bd : rest) seen = case attributeFromBinding bd of- Just attr- | attr `Set.member` seen -> Just attr- | otherwise -> duplicated rest (Set.insert attr seen)- Nothing -> duplicated rest seen -- Transform dispatch to list of attributes -- >>> fqnToAttrs (ExDispatch (ExDispatch (ExDispatch ExRoot (AtLabel "org")) (AtLabel "eolang")) (AtLabel "number"))
src/Morph.hs view
@@ -18,25 +18,28 @@ -- a λ function itself, which is an evaluation — are injected as '_reduce', -- '_evaluate' and '_fire' rather than imported (see 'ReductionFunc' and -- 'EvaluationFunc').-module Morph (ReduceContext (..), ReduceException (..), EvaluationFunc, FiringFunc, ReductionFunc, Morphed, Steps (..), deeper, emptyState, excluding, execBuildTerm, insideUniverse, leadsTo, morph, morph', morphing, normalized, parking, producer, sidePremise, universed, unparked, unvisited, verb) where+module Morph (Answer, Kept (..), ReduceContext (..), ReduceException (..), EvaluationFunc, FiringFunc, Memo (..), ReductionFunc, Morphed, Steps (..), Tally (..), boxed, charged, deeper, emptyState, enter, entering, excluding, execBuildTerm, insideUniverse, isLambda, lambda, leadsTo, memoized, morph, morph', morphing, normalized, parking, producer, recalled, retained, sidePremise, tallied, universed, unparked, verb) where import AST-import Builder (buildExpressionThrows, contextualize)+import Builder (buildExpressionThrows, contextualize, pathOf) import Control.Exception (Exception, catch, throwIO, try)-import Control.Monad (foldM)-import Data.List (find)+import Control.Monad (foldM, unless, when)+import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)+import Data.List (find, partition) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE-import Data.Maybe (fromMaybe)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe, isJust)+import qualified Data.Set as Set import qualified Data.Text as T-import Deps (BuildTermFunc, BuildTermMethodS, Judgment (..), SaveEvalFunc, SaveStepFunc, State (..), Term (..), dontSaveStep)+import Deps (Acyclic (..), BuildTermFunc, BuildTermMethodS, Evaluation (..), Judgment (..), SaveEvalFunc, SaveStepFunc, State (..), Term (..), dontSaveStep) import Lambdas (Lambdas) import Locator (locatedExpression, withLocatedExpression) import Matcher (MetaValue (..), Subst (..), combine, matchExpression', substEmpty, substSingle) import Must (Must (..)) import Printer (printExpression) import Random (shuffle)-import Rewriter (RewriteContext (RewriteContext), Rewritten, Seen, rewrite, seenInsert, seenMember)+import Rewriter (RewriteContext (RewriteContext), Rewritten, Seen, rewrite, seenInsert) import Rule (RuleContext (RuleContext), matchExpressionWithRule') import Text.Printf (printf) import Yaml (ExtraArgument (..), normalizationRules)@@ -95,6 +98,77 @@ , _spent :: Int } +-- How many λ functions the whole run may fire ('_ceiling', the '--max-firings'+-- option) and how many it has fired so far ('_count'). Unlike 'Steps' it bounds+-- total work and not one branch: a firing whose answer is wider than the term+-- it replaced makes the next descent more siblings than the last one, each of+-- them shallow, so a recursion that widens the term instead of nesting it fires+-- forever inside the depth '--max-steps' gives it (#1472). The count is one+-- cell every frame of the run shares rather than a field of 'State', since a+-- parked frame hands back the state it started from and so would refund every+-- firing made inside it.+data Tally = Tally+ { _ceiling :: Int+ , _count :: IORef Int+ }++-- What the firings of a run under '--acyclic=plausible' answered, by the+-- formation each was fired against, kept so that a later firing of the same+-- formation takes the answer instead of making it again. 𝔼 is a function of+-- the formation it fires: the entry that answers is found by the λ name the+-- formation carries, every operand is reduced from the bindings of it, inside+-- the one universe of the run, and the answer is built from what they came+-- down to, so two firings of one formation make one answer twice, symbols+-- apart. Every use of a binding copies the term bound to it, so a program+-- reading 'truncated ↦ ρ.abs.floor' in five places fires 'abs' and 'floor'+-- five times over and mints five symbols for one value (#1476). The store is+-- keyed by the formation as 𝔼 was handed it, λ binding and all, ρ included,+-- since ρ is what the operands reach the receiver through and two formations+-- differing in ρ alone are fired on two objects; a digest picks the+-- candidates and (==) confirms one, the way 'Seen' does. What is kept is the+-- answer as the first firing made it, the term the entry wrote and the normal+-- form 𝕄 left, with the symbols that firing minted, so a later firing names+-- the very unknowns the first one did and mints nothing, reduces nothing and+-- is charged nothing. It is written to the protocol all the same, as a firing+-- at its own site with that answer, since the protocol records where 𝔼 was+-- asked and what it said there, and with no operand line under it, since none+-- was reduced. A firing that got stuck keeps nothing, since nothing was+-- answered; a site parked or a recursion cut inside an answer is a part of+-- it, since that is what the run made of the formation. A recursion cut+-- inside a firing, so that the firing itself never answered, is kept too, as+-- the formation the cut carried: the formation is fired as often as the+-- program reads it, and without the cut in the store every one of those+-- firings walked all the way down to the same cut again (#1480). The store is+-- one cell every frame of the run shares, like the count of 'Tally', since+-- what one frame answered is what its siblings are after. It belongs to+-- 'Plausible' and to no switch of its own: a run asking for plausible cuts is+-- a run that wants to finish rather than to be exact, and firing one+-- formation as often as the program reads it is the other way such a run+-- fails to.+--+-- Beside the answers the memo keeps the bindings of the world the '--deep'+-- walk has entered, each as the object of the world declaring it and the+-- attribute it is bound to (see 'visited'). Every dispatch on an object of+-- the world copies it, and the walk entered the bindings of every copy as if+-- they were new, so the tests of 'Φ.number' were reduced once per number the+-- program held (#1480).+data Memo = Memo (IORef (Store Kept)) (IORef (Set.Set (Expression, Attribute)))++-- What one firing answered, kept for the firings of the same formation to+-- come: the term the entry wrote, symbols and all, and the normal form 𝕄 made+-- of it, which are the two lines the protocol writes an answer as.+type Answer = (Expression, Expression)++-- What the memo keeps of one formation: the answer its firing made, or the+-- formation a recursion was cut at while it was being fired.+data Kept+ = Answered Answer+ | Looped Expression++-- What 'Memo' keeps: the answers, by the digest of the formation they answer,+-- each beside the very formation, since two terms may share a digest.+type Store answer = Map.Map Int [(Expression, answer)]+ -- The context every reduction of the calculus is threaded with — 𝕄 here and 𝔻 in -- 'Dataize' — carrying the configuration plus the step budget spent so far. Nothing global is fixed here: the universe (the second argument 'e' of -- 𝕄(n, e, s) and 𝔻(n, e, s)) is a plain expression threaded as an argument to@@ -132,12 +206,19 @@ , _maxDepth :: Int , _maxCycles :: Int , _steps :: Steps+ , -- How many λ functions the whole run may fire and how many it has fired+ -- (see 'Tally'), or nothing where '--max-firings' asks for no such limit.+ _tally :: Maybe Tally+ , -- What the firings made so far answered (see 'Memo'), kept under+ -- 'Plausible' alone (see 'memoized'), or nothing under any other mode,+ -- where every formation is fired as many times as it is met.+ _memo :: Maybe Memo , _nesting :: Int , _depthSensitive :: Bool , _shuffle :: Bool , _partial :: Bool , _deep :: Bool- , _acyclic :: Bool+ , _acyclic :: Maybe Acyclic , -- The judgment whose rule is asking 𝔼 to fire, which is what a stuck site -- is written under: 𝔼 is reached from the 'ml' rule of morphing and from -- the 'fire' rule of dataization, and a reader of the protocol is told@@ -153,15 +234,15 @@ -- out; the site is one and the protocol records it once, so the firings -- after the first write nothing (see 'symbol' in 'Evaluate', #1300). _parked :: [T.Text]- , -- The terms the 𝕄 frames above this one are reducing, which is what- -- '_acyclic' answers "have I been here before" with (see 'unvisited').- _seen :: Seen- , -- The same for 𝔻: the terms the 𝔻 frames above this one are dataizing. The- -- two judgments keep one store each because they ask each other about the- -- very term they were asked about — the 'norm' rule hands 𝕄 what 𝔻 was- -- given — so a single store shared by both would read that handover as a- -- repeat and park every term 𝔻 morphs (#1290).- _dataized :: Seen+ , -- The formations the frames above this one have entered, which is what+ -- '_acyclic' answers "have I been here before" with (see 'entering'). A+ -- frame enters a formation where it fires the λ of one — 𝔻 through 'fire',+ -- 𝕄 through 'ml', the '--deep' walk through 'fired' of 'Evaluate' — or gets+ -- into the φ body of one — 𝔻 through 'box' — and nowhere else, so 𝕄 and 𝔻 handing each other the very term they were+ -- asked about enter nothing twice and one store serves both of them. The+ -- store is keyed by 'hashShape' under 'Proven' and by 'hashSkeleton' under+ -- 'Plausible', so a formation is found again the way the mode compares it.+ _entered :: Seen , _symbolic :: Lambdas , _buildTerm :: BuildTermFunc , _reduce :: ReductionFunc@@ -171,8 +252,17 @@ , _saveEval :: SaveEvalFunc } +-- Which of the two budgets a run spent, with the limit it was given: the depth+-- one branch may descend ('--max-steps', see 'Steps') or the firings the whole+-- run may make ('--max-firings', see 'Tally'). Both are the same signal to+-- '_partial', which parks either as a site that never finishes, and differ only+-- in what the message names.+data Budget+ = Depth Int+ | Firings Int+ data ReduceException- = OutOfSteps Int+ = OutOfSteps Budget | -- A λ function could not fire: the '--symbolic' file carries no entry -- answering that name, or an operand of the entry it does carry never came -- down to data, or the two branches it joins differ by more than a symbol,@@ -192,21 +282,23 @@ -- and state just like 'StuckAt': a term that never reduces is a stuck site -- too, so '_partial' parks it and hands back the residual instead of -- failing hard (#1078)- OutOfStepsAt Int (NonEmpty Rewritten) State- | -- A judgment was asked to reduce a term a frame above it is already- -- reducing, which it can only ever answer by asking again. 𝕄 and 𝔻 both- -- raise it, each over the terms of its own spine (see 'unvisited'), and- -- neither names itself in the message, since a run that meets the signal- -- meets it through whichever of the two came back. Raised under '_acyclic'- -- alone, so the signal itself is the permission to park on it: a run that- -- never asked for the guard never sees it.+ OutOfStepsAt Budget (NonEmpty Rewritten) State+ | -- A frame was about to enter a formation a frame above it has already+ -- entered, up to a renaming of symbols, which it can only ever answer by+ -- entering it again. 𝕄 and 𝔻 both raise it, over the one store of the+ -- formations their branch has entered (see 'entering'), and neither names+ -- itself in the message, since a run that meets the signal meets it+ -- through whichever of the two came back. It carries the formation.+ -- Raised under '_acyclic' alone, so the signal itself is the permission to+ -- park on it: a run that never asked for the guard never sees it. Looping Expression | -- A 'Looping' caught by a frame of the 𝕄 or 𝔻 spine, carrying that frame's -- derivation and state the way 'StuckAt' does. The guard runs as a frame -- opens, before that frame parks anything, so the frame attaching the chain -- is the one the repeat was reached from and the head of the chain is its- -- working expression — the term that came back left exactly where it stood,- -- the way an exhausted budget stops on the last step it could afford.+ -- working expression — the term that would have entered the formation+ -- again left exactly where it stood, the way an exhausted budget stops on+ -- the last step it could afford. LoopingAt Expression (NonEmpty Rewritten) State | -- 𝔻 was handed a term outside its domain: the terminator ⊥, which signals -- an error (see #955), or a term no dataization rule matches, such as a@@ -219,12 +311,14 @@ deriving anyclass (Exception) instance Show ReduceException where- show (OutOfSteps limit) =+ show (OutOfSteps (Depth limit)) = printf "Dataization did not finish before reaching the limit of steps: --max-steps=%d" limit- show (OutOfStepsAt limit _ _) = show (OutOfSteps limit)+ show (OutOfSteps (Firings limit)) =+ printf "Evaluation did not finish before reaching the limit of firings: --max-firings=%d" limit+ show (OutOfStepsAt budget _ _) = show (OutOfSteps budget) show (Stuck func) = printf "No entry of --symbolic answers the λ function '%s'" (T.unpack func) show (StuckAt func _ _) = show (Stuck func)- show (Looping term) = printf "Reduction came back to a term it is already reducing: %s" (printExpression term)+ show (Looping term) = printf "Reduction entered a formation it is already inside: %s" (printExpression term) show (LoopingAt term _ _) = show (Looping term) show (Undataizable ExTermination _) = "dataization reached the terminator ⊥, which signals an error and cannot be dataized" show (Undataizable _ _) = "no dataization rule matched"@@ -238,9 +332,58 @@ -- with or without '--depth-sensitive'. deeper :: ReduceContext -> IO ReduceContext deeper ctx@ReduceContext{_steps = Steps limit spent}- | spent >= limit = throwIO (OutOfSteps limit)+ | spent >= limit = throwIO (OutOfSteps (Depth limit)) | otherwise = pure ctx{_steps = Steps limit (spent + 1)} +-- The tally a run starts from where '--max-firings' gives a ceiling: nothing+-- fired yet.+tallied :: Maybe Int -> IO (Maybe Tally)+tallied = traverse (\cap -> Tally cap <$> newIORef 0)++-- Charge one firing of a λ function to the budget of the whole run, refusing+-- to fire once it is gone (see 'Tally'). 'deeper' bounds how far one branch+-- descends, which stops a recursion that nests but not one that widens.+charged :: ReduceContext -> IO ()+charged ReduceContext{_tally = Nothing} = pure ()+charged ReduceContext{_tally = Just (Tally cap count)} = do+ fired <- readIORef count+ when (fired >= cap) (throwIO (OutOfSteps (Firings cap)))+ writeIORef count (fired + 1)++-- The memo a run keeps, by the mode of '--acyclic' it runs under: an empty+-- one under 'Plausible', the mode the memo belongs to (see 'Memo'), and none+-- under any other, where nothing is ever recalled.+memoized :: Maybe Acyclic -> IO (Maybe Memo)+memoized (Just Plausible) = Just <$> (Memo <$> newIORef Map.empty <*> newIORef Set.empty)+memoized _ = pure Nothing++-- What the memo keeps for the formation, if this run fired it already (see+-- 'Memo'); nothing where the run keeps no memo at all.+recalled :: Maybe Memo -> Expression -> IO (Maybe Kept)+recalled Nothing _ = pure Nothing+recalled (Just (Memo store _)) form = do+ kept <- readIORef store+ pure (Map.lookup (hashExpression form) kept >>= lookup form)++-- Keep what firing the formation came to, for the next firing of it (see+-- 'Memo').+retained :: Maybe Memo -> Expression -> Kept -> IO ()+retained Nothing _ _ = pure ()+retained (Just (Memo store _)) form kept = modifyIORef' store (Map.insertWith (++) (hashExpression form) [(form, kept)])++-- Whether the '--deep' walk has entered the binding the object of the world+-- declares under the attribute, in whichever copy of the object (see 'Memo');+-- never where the run keeps no memo at all.+visited :: Maybe Memo -> Expression -> Attribute -> IO Bool+visited Nothing _ _ = pure False+visited (Just (Memo _ walked)) object attr = Set.member (object, attr) <$> readIORef walked++-- Remember that the '--deep' walk has entered the binding the object of the+-- world declares under the attribute (see 'visited').+visit :: Maybe Memo -> Expression -> Attribute -> IO ()+visit Nothing _ _ = pure ()+visit (Just (Memo _ walked)) object attr = modifyIORef' walked (Set.insert (object, attr))+ -- Run one frame of the 𝕄/𝔻 spine, attaching its derivation and its state to a -- stuck λ function or an exhausted budget escaping it. 'Stuck' is raised deep -- inside a firing, which knows nothing about the chain, so the innermost spine@@ -258,7 +401,7 @@ where rethrow :: ReduceException -> IO a rethrow (Stuck func) = throwIO (StuckAt func seq state)- rethrow (OutOfSteps limit) = throwIO (OutOfStepsAt limit seq state)+ rethrow (OutOfSteps budget) = throwIO (OutOfStepsAt budget seq state) rethrow (Looping term) = throwIO (LoopingAt term seq state) rethrow failure = throwIO failure @@ -272,42 +415,121 @@ where rethrow :: ReduceException -> IO a rethrow (StuckAt func _ _) = throwIO (Stuck func)- rethrow (OutOfStepsAt limit _ _) = throwIO (OutOfSteps limit)+ rethrow (OutOfStepsAt budget _ _) = throwIO (OutOfSteps budget) rethrow (LoopingAt term _ _) = throwIO (Looping term) rethrow failure = throwIO failure --- The terms the frames above this one are reducing, which is what '_acyclic'--- answers "have I been here before" with. The context travels down the--- recursion and never back up, exactly as the step budget does, so what it--- carries is the branch from the run to this frame and not everything the run--- has ever touched: two sibling subterms that happen to be equal are two terms,--- while a term reached from itself is a loop. The store is the one the rewriter--- detects its own loops with, a digest map resolving a collision by an exact--- comparison (see 'Seen').--- Which store is read is the judgment of the frame asking ('_judgment', which--- the caller has already named): 𝕄 and 𝔻 recurse into each other and a term 𝔻--- hands 𝕄 is the term 𝔻 was given, so one store for the two would make every--- 'norm' rule a loop. Each judgment therefore remembers its own branch, and a--- run that comes back to a term through either of them is parked (#1290).-unvisited :: Expression -> ReduceContext -> IO ReduceContext-unvisited term ctx- | not ctx._acyclic = pure ctx- | seenMember digest term (store ctx._judgment) = throwIO (Looping term)- | otherwise = pure (remembered ctx._judgment)+-- The formations the frames above this one have entered, which is what+-- '_acyclic' answers "have I been here before" with: where the frame opening on+-- this term enters a formation (see 'entrance') and a frame above it has+-- already entered the same one, the run is going round and 'Looping' says so;+-- otherwise the formation is remembered for the frames below. The context+-- travels down the recursion and never back up, exactly as the step budget+-- does, so what it carries is the branch from the run to this frame and not+-- everything the run has ever touched: two siblings entering one formation+-- enter it twice, while a formation entered from inside itself is a loop.+--+-- Under 'Proven' the same means 'alike', equal up to a bijective renaming of+-- symbols, and not equal: every round of a recursion over an unknown mints fresh symbols, so+-- the formation it enters on the second round is the first one with 𝜎5 where+-- 𝜎3 stood, and an exact comparison never finds it (#1420). That is sound,+-- since a symbol is an opaque unknown — each dataizes to the same manufactured+-- datum and no entry of '--symbolic' answers one — so a formation entered again+-- with nothing but its symbols renamed replays the round forever; data still+-- tells rounds apart, so a recursion over a literal is not cut. The store is a+-- digest map keyed by 'hashShape', which is blind to symbols, and a digest+-- match is confirmed by 'alike', the way 'Seen' confirms one by (==). The cut+-- is written to the protocol where the formation would have opened, as a+-- 'looped' line carrying the site, the mode and the formation the frame above entered,+-- spelled as that frame's own 'formation' line spelled it, so the two lines+-- read as a pair without renaming symbols by eye (#1434).+--+-- Under 'Plausible' the same means that the formation a frame above entered is+-- 'within' the one about to be entered: an accumulator gains a wrapper every+-- round, so no two rounds are ever 'alike', while each still holds the one+-- before it (#1451). A formation entered from inside a smaller one is never cut,+-- since a smaller term never holds a larger one, which is what keeps a call+-- nested in its own operand, such as a sum of sums, reducing as it did. It is+-- not sound: a recursion whose argument grows on its way to stopping is cut as+-- well. The store is keyed by 'hashSkeleton', which sees the attributes and+-- not the terms bound to them, and a digest match is confirmed by 'within'.+entering :: Expression -> ReduceContext -> IO ReduceContext+entering term ctx = maybe (pure ctx) (`enter` ctx) (entrance ctx._judgment term)++-- The same guard asked about a formation the frame is about to enter, for a+-- frame that knows it enters one without being a rule of 𝕄 or 𝔻: the '--deep'+-- walk, which fires the λ of every formation 𝕄 leaves bare, so a recursion+-- driven by the walk alone goes through no rule 'entrance' knows of (#1451).+enter :: Expression -> ReduceContext -> IO ReduceContext+enter form ctx = maybe (pure ctx) remembered ctx._acyclic where- digest :: Int- digest = hashExpression term- store :: Judgment -> Seen- store Morphing = ctx._seen- store Dataization = ctx._dataized- remembered :: Judgment -> ReduceContext- remembered Morphing = ctx{_seen = seenInsert digest term ctx._seen}- remembered Dataization = ctx{_dataized = seenInsert digest term ctx._dataized}+ remembered :: Acyclic -> IO ReduceContext+ remembered mode = case find (repeated mode form) (Map.findWithDefault [] (digest mode form) ctx._entered) of+ Just before -> do+ ctx._saveEval (EvLooped ctx._nesting ctx._judgment mode before ctx._site)+ throwIO (Looping form)+ Nothing -> pure ctx{_entered = seenInsert (digest mode form) form ctx._entered}+ digest :: Acyclic -> Expression -> Int+ digest Proven = hashShape+ digest Plausible = hashSkeleton+ repeated :: Acyclic -> Expression -> Expression -> Bool+ repeated Proven form before = alike form before+ repeated Plausible form before = within before form +-- The formation a frame of the judgment enters as it opens on the term, if it+-- enters one at all. Only three rules get into a formation, besides the firing+-- of the '--deep' walk, which asks 'enter' itself: 'box' of 𝔻, into+-- the φ body of a formation carrying no λ and no Δ; 'fire' of 𝔻, into the λ+-- function of a formation carrying one naming a function; and 'ml' of 𝕄, into+-- the λ function of the head of a dispatch, which is the formation entered and+-- not the dispatch off it. Every other term the two judgments are handed is+-- one they only pass through on their way to such a formation, and 𝕄 stops at+-- a formation without getting into it.+entrance :: Judgment -> Expression -> Maybe Expression+entrance Dataization term@(ExFormation bds)+ | boxed bds || isJust (lambda bds) = Just term+entrance Morphing (ExDispatch form@(ExFormation bds) _)+ | isJust (lambda bds) = Just form+entrance _ _ = Nothing++-- Whether the 'box' rule of 𝔻 gets into a formation with these bindings: one+-- binding φ to a term, and none binding Δ or a λ (see 'box.yaml').+boxed :: [Binding] -> Bool+boxed bds = any phi bds && not (any isLambda bds) && not (any delta bds)+ where+ phi :: Binding -> Bool+ phi (BiTau AtPhi _) = True+ phi _ = False+ delta :: Binding -> Bool+ delta (BiDelta _) = True+ delta _ = False++-- Split the λ binding off a formation for the LAMBDA morphing rule: the name of+-- the λ function to fire and the formation it fires against, the λ binding+-- removed. A formation with no λ binding, or with more than one, has nothing to+-- fire; neither has one carrying a symbol, which is a λ name nothing answers.+-- The three are one answer here but not to 𝔼, which tells all three apart: no λ+-- at all is answered with ⊥, a symbol gets stuck the way an unanswered name+-- does, and only the rest is a term it cannot work out (see 'evaluation' in+-- 'Evaluate'). It lives here and not beside 𝔼 because the guard of '_acyclic'+-- asks it too (see 'entrance').+lambda :: [Binding] -> Maybe (T.Text, Expression)+lambda bds = case partition isLambda bds of+ ([BiLambda (Function func)], rest) -> Just (func, ExFormation rest)+ _ -> Nothing++-- Whether a binding names a λ function, whatever that name turns out to be.+-- 𝔼 asks this before 'lambda' does its splitting, since a formation carrying no+-- λ at all is answered with ⊥ rather than refused (see 'evaluation' in+-- 'Evaluate').+isLambda :: Binding -> Bool+isLambda (BiLambda _) = True+isLambda _ = False+ -- The Morphing function 𝕄 maps normal forms to formations. It is ternary, -- 𝕄(n, e, s): besides the term 'n' it takes the universe 'e' ('univ') — a plain -- expression — and the mutable state 's', returning the morphed term together--- with the new state. The universe is matched against the rule's 'e-match'+-- with the new state. The universe is matched against the rule's 'universe' -- pattern (usually the '𝑒' meta, which binds 'e' so the 'universe' rule substitutes -- it, but a rule may pin it to a literal such as 'mg' matching Φ). Its rules -- come from 'resources/morphing': the first matching rule's premises are evaluated and@@ -325,7 +547,7 @@ -- evaluated in isolation by 'sidePremise', its own steps discarded. morph' :: Morphed -> Expression -> State -> ReduceContext -> IO (Morphed, State) morph' (expr, seq) univ state caller = do- ctx <- deeper =<< unvisited expr =<< universed univ caller{_judgment = Morphing}+ ctx <- deeper =<< entering expr =<< universed univ caller{_judgment = Morphing} parking seq state $ do rules <- if ctx._shuffle then shuffle Y.morphingRules else pure Y.morphingRules matched <- firstMatch ctx rules@@ -336,16 +558,16 @@ firstMatch :: ReduceContext -> [Y.MorphRule] -> IO (Maybe (Y.MorphRule, Subst)) firstMatch _ [] = pure Nothing firstMatch ctx (rule : rest) = do- substs <- matchExpressionWithRule' (matchExpression' rule.ematch univ) expr (asRule rule) (RuleContext (execBuildTerm univ ctx))+ substs <- matchExpressionWithRule' (matchExpression' rule.ematch univ) expr (asRule rule) (RuleContext (execBuildTerm univ ctx) (Just univ)) case substs of (subst : _) -> pure (Just (rule, subst)) [] -> firstMatch ctx rest -- Match the conclusion term and check the guard; premises are no longer the -- matcher's business, so 'where'/'having' stay empty and the guard lives in -- 'when'. Every morphing guard reads only meta-variables bound by 'match'- -- and 'e-match', so it holds before any premise runs.+ -- and 'universe', so it holds before any premise runs. asRule :: Y.MorphRule -> Y.Rule- asRule rule = Y.Rule rule.name Nothing Nothing rule.match Nothing ExRoot rule.when Nothing Nothing+ asRule rule = Y.Rule rule.name Nothing Nothing rule.match ExRoot rule.when Nothing Nothing -- Evaluate the rule's premises and build its conclusion. A literal -- conclusion is terminal. Otherwise the conclusion meta is produced by a -- trailing 'morph' premise (the spine); if that premise's argument is itself@@ -362,8 +584,7 @@ Just normal@(Y.Premise _ (Y.OpNormalize inner)) -> do (final, state') <- sides ctx (rule.premises `excluding` [concl, normal]) subst built <- buildExpressionThrows inner final- labelled <- leadsTo seq rule.name built ctx- (normal', seq') <- normalized built labelled ctx+ (normal', seq') <- settle ctx rule inner built morph' (normal', seq') univ state' ctx _ -> do (final, state') <- sides ctx (rule.premises `excluding` [concl]) subst@@ -373,6 +594,21 @@ Just _ -> throwIO (userError (printf "morphing rule '%s' must conclude with a 'morph' premise" rule.name)) sides :: ReduceContext -> [Y.Premise] -> Subst -> IO (Subst, State) sides ctx premises subst = foldM (sidePremise univ ctx) (subst, state) premises+ -- Bring the term a 'normalize' premise built to its normal form and splice+ -- the steps into the chain. A premise normalizing the universe itself, the+ -- meta the rule's 'universe' bound, is answered with the world the run has+ -- already named (see '_universe'), since that is the normal form of the+ -- very same program: the 'universe' rule asks for it every time 𝕄 resolves+ -- Φ, and normalizing the whole program again for each of them made every+ -- step cost the size of the world (#1453).+ settle :: ReduceContext -> Y.MorphRule -> Expression -> Expression -> IO Morphed+ settle ctx rule inner built = case ctx._universe of+ Just world | inner == rule.ematch -> do+ seq' <- leadsTo seq rule.name world ctx+ pure (world, seq')+ _ -> do+ labelled <- leadsTo seq rule.name built ctx+ normalized built labelled ctx -- Morph the expression located at '_locator' — 𝕄 asked on its own, the way -- 'dataize' asks 𝔻. The whole input expression is itself the universe Φ (the 'e'@@ -390,36 +626,39 @@ -- (see 'deepened'). The state 𝑠 goes in and comes back out, so a 𝕄 asked -- inside another judgment goes on minting symbols where that judgment left off. morph :: Expression -> State -> ReduceContext -> IO (Expression, [Rewritten], State)-morph universe state ctx@ReduceContext{..} = do+morph universe state caller@ReduceContext{..} = do+ ctx <- universed universe caller expr <- locatedExpression _locator universe result <- try (morph' (expr, (universe, Nothing) :| []) universe state ctx) case result of- Right ((morphed, seq), state') -> walked walking morphed seq state'+ Right ((morphed, seq), state') -> walked (walking ctx) morphed seq state' Left (StuckAt func seq parked) | _partial -> do residue <- locatedExpression _locator (fst (NE.head seq))- walked (marked func) residue seq parked{_stuck = Just func}+ walked (marked ctx func) residue seq parked{_stuck = Just func} Left (OutOfStepsAt _ seq parked) | _partial -> do residue <- locatedExpression _locator (fst (NE.head seq))- walked walking residue seq parked+ walked (walking ctx) residue seq parked -- Unlike the two above, this one takes no '_partial' guard: a 'LoopingAt' -- exists only where '_acyclic' put it, so asking for the guard is already -- asking to be parked on what it finds. Left (LoopingAt _ seq parked) -> do residue <- locatedExpression _locator (fst (NE.head seq))- walked walking residue seq parked+ walked (walking ctx) residue seq parked Left failure -> throwIO (failure :: ReduceException) where -- The context the walk runs with: the one this run was given, named after -- 𝕄, since the walk is 𝕄's own and a λ function it fires is fired by no- -- other judgment, whichever one asked for this run (see '_judgment').- walking :: ReduceContext- walking = ctx{_judgment = Morphing}+ -- other judgment, whichever one asked for this run (see '_judgment'). It+ -- carries the world the spine named, so no firing of the walk normalizes+ -- the whole program again to name it once more (#1453).+ walking :: ReduceContext -> ReduceContext+ walking ctx = ctx{_judgment = Morphing} -- The same, plus the λ function the spine got stuck on. The site is still -- standing in the residue, so the walk asks 𝕄 about it again and 𝔼 gets -- stuck on it again; the protocol has the site already and the second -- firing writes nothing (see '_parked', #1300).- marked :: T.Text -> ReduceContext- marked func = walking{_parked = func : _parked}+ marked :: ReduceContext -> T.Text -> ReduceContext+ marked ctx func = (walking ctx){_parked = func : _parked} -- The answer 𝕄 reached, walked by '_deep' before it is handed back (see -- 'deepened'), and the chain that led to both. The walk joins the chain as -- one step named 'deep', so '--sequence' ends on the term the command@@ -492,8 +731,8 @@ abstract :: Binding -> Bool abstract (BiVoid _) = True abstract _ = False- parts standing _ (ExFormation bds) state' caller = do- (entered, state'') <- bindings standing bds bds state' caller+ parts standing _ form@(ExFormation bds) state' caller = do+ (entered, state'') <- bindings standing (synonym caller._universe form) bds bds state' caller pure (ExFormation entered, state'') parts _ context (ExDispatch target attr) state' caller = do (entered, state'') <- go Nothing (Just attr) context target state' caller@@ -508,17 +747,59 @@ -- the object around it rather than one inside it, and a void, Δ or λ -- binding carries no term to walk at all. A body of a formation the walk -- can name is named by that locator and the attribute it is bound to, which- -- is the very locator '--locator' would aim a run of its own at.- bindings :: Maybe Expression -> [Binding] -> [Binding] -> State -> ReduceContext -> IO ([Binding], State)- bindings _ _ [] state' _ = pure ([], state')- bindings standing whole (BiTau attr body : rest) state' caller+ -- is the very locator '--locator' would aim a run of its own at. A binding+ -- the walk has entered in another copy of the same object of the world is+ -- left as it was written (see 'fresh').+ bindings :: Maybe Expression -> Maybe (Expression, [Attribute]) -> [Binding] -> [Binding] -> State -> ReduceContext -> IO ([Binding], State)+ bindings _ _ _ [] state' _ = pure ([], state')+ bindings standing alias whole (BiTau attr body : rest) state' caller | attr /= AtRho = do- (entered, state'') <- go (fmap (`ExDispatch` attr) standing) Nothing (scope attr whole) body state' caller- (others, state''') <- bindings standing whole rest state'' caller+ new <- fresh alias attr caller+ (entered, state'') <-+ if new+ then go (fmap (`ExDispatch` attr) standing) Nothing (scope attr whole) body state' caller+ else pure (body, state')+ (others, state''') <- bindings standing alias whole rest state'' caller pure (BiTau attr entered : others, state''')- bindings standing whole (bd : rest) state' caller = do- (others, state'') <- bindings standing whole rest state' caller+ bindings standing alias whole (bd : rest) state' caller = do+ (others, state'') <- bindings standing alias whole rest state' caller pure (bd : others, state'')+ -- The object of the world a formation is a copy of, where it is one, with+ -- the attributes whose voids the copy filled. 'pathOf' names the copy the+ -- way 'dot' names it in a ρ, 'Φ.num( φ ↦ ⟦ Δ ⤍ 2A- ⟧ )', and that name with+ -- its applications erased, 'Φ.num', is a synonym of every copy: the+ -- bindings a copy did not fill are the ones the world declares, written+ -- once (#1480). The arguments of the outermost application are the voids+ -- this copy filled, and they belong to it alone. The world itself has no+ -- such synonym, and neither has a formation the world does not declare.+ synonym :: Maybe Expression -> Expression -> Maybe (Expression, [Attribute])+ synonym Nothing _ = Nothing+ synonym (Just world) form = case pathOf world form of+ ExRoot -> Nothing+ ExFormation _ -> Nothing+ name -> Just (erased name, supplied name)+ where+ erased :: Expression -> Expression+ erased (ExApplication target _) = erased target+ erased (ExDispatch target attr) = ExDispatch (erased target) attr+ erased other = other+ supplied :: Expression -> [Attribute]+ supplied (ExApplication target (ArTau attr _)) = attr : supplied target+ supplied _ = []+ -- Whether the walk enters the binding under the attribute: always, unless+ -- the formation is a copy of an object of the world, the attribute is one+ -- the object declares rather than a void the copy filled, and the walk has+ -- entered that binding already, in this copy or another, which the memo of+ -- '--acyclic=plausible' remembers (see 'Memo'). A binding left out stays as+ -- it was written and is never replaced by what an earlier copy came to,+ -- since a body may read the ρ or the φ of the copy it stands in.+ fresh :: Maybe (Expression, [Attribute]) -> Attribute -> ReduceContext -> IO Bool+ fresh (Just (object, filled)) attr caller+ | attr `notElem` filled = do+ seen <- visited caller._memo object attr+ unless seen (visit caller._memo object attr)+ pure (not seen)+ fresh _ _ _ = pure True -- The context a binding's body is entered in: the formation without that -- binding, the very context 'dot' contextualizes a dispatched body in, so -- a body reaching back at itself through ξ collapses instead of looping.
src/Parser.hs view
@@ -297,6 +297,9 @@ [(n, "")] -> return (chr n) _ -> fail ("Invalid hex escape: \\x" ++ digits) +-- The value of a τ binding: the expression after the arrow, or, after inline+-- voids, whatever spells the formation they open, a literal `⟦ … ⟧` or the+-- one-binding sugar of #1385, as `x(y) ↦ 42:a` (see #1482) tauValue :: Parser Expression tauValue = choice@@ -313,9 +316,10 @@ rb >> return voids' ] _ <- arrow- bs <- formationBindings- bds <- validatedBindings (voids ++ bs)- return (ExFormation bds)+ opened <- expression+ case opened of+ ExFormation bds -> ExFormation <$> validatedBindings (voids ++ bds)+ _ -> fail "Inline voids open a formation, so nothing but a formation may follow their arrow" ] where rb :: Parser String
src/Printer.hs view
@@ -8,6 +8,7 @@ ( printExpression , printExpression' , printExpressionHidingRho'+ , printExpressionWith , printAttribute , printAlpha , printBinding
src/Random.hs view
@@ -6,7 +6,7 @@ import Control.Exception (throwIO) import Control.Monad (forM_, replicateM) import Data.Char (intToDigit)-import Data.IORef (IORef, modifyIORef', newIORef, readIORef)+import Data.IORef (IORef, atomicModifyIORef', newIORef) import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Vector as V@@ -45,22 +45,22 @@ maxAttempts :: Int maxAttempts = 100000 -regenerate :: String -> Set String -> IO String-regenerate pat set = go maxAttempts+regenerate :: String -> IO String+regenerate pat = go maxAttempts where go :: Int -> IO String go 0 = throwIO (userError (printf "randomString() cannot produce a unique value for pattern '%s': the value space is exhausted" pat)) go attempts = do next <- generate pat- if next `Set.member` set- then go (attempts - 1)- else do- modifyIORef' strings (Set.insert next)- pure next+ fresh <- atomicModifyIORef' strings $ \set ->+ if next `Set.member` set+ then (set, False)+ else (Set.insert next set, True)+ if fresh then pure next else go (attempts - 1) randomString :: String -> IO String randomString pat- | randomized pat = readIORef strings >>= regenerate pat+ | randomized pat = regenerate pat | otherwise = generate pat where randomized :: String -> Bool
src/Render.hs view
@@ -109,6 +109,7 @@ render (BT_MANY bts) = T.intercalate "-" (map render bts) render (BT_META mt) = render mt render (BT_PIPED bts) = "|" <> render bts <> "|"+ render (BT_CUT bts size) = T.intercalate "-" (map render bts) <> "-...(" <> render size <> "b)" instance Render EXCLAMATION where render EXCL = "!"@@ -168,6 +169,7 @@ render PA_META_LAMBDA'{..} = "L> " <> render meta render PA_META_DELTA{..} = render DELTA <> render SPACE <> render DASHED_ARROW <> render SPACE <> render meta render PA_META_DELTA'{..} = "D> " <> render meta+ render PA_FOLDED{..} = "+" <> render count <> " attrs" instance Render BINDINGS where render = TL.toStrict . TLB.toLazyText . binds@@ -291,18 +293,16 @@ render CO_MATCHES{..} = "matches\\lparen " <> T.pack regex <> ", " <> render expr <> " \\rparen" render CO_PART_OF{..} = "part-of\\lparen " <> render expr <> ", " <> render binding <> " \\rparen" render CO_FORMATION{..} = "\\phinoIsFormation{ " <> render expr <> " }"- render CO_DISJOINT{..} =- "[ "- <> T.intercalate " \\char44{} " (map render attrs)- <> " ] \\cap "- <> renderGroups groups- <> " = \\emptyset"- where- renderGroups :: [BINDING] -> Text- renderGroups [group] = render group- renderGroups gs = "\\lparen " <> T.intercalate " \\cup " (map render gs) <> " \\rparen"+ render CO_DISJOINT{..} = render (ST_ATTRIBUTES attrs) <> " \\cap " <> union groups <> " = \\emptyset"+ render CO_SUBSET{belongs = NOT_IN, ..} = render (ST_ATTRIBUTES attrs) <> " \\not\\subseteq " <> union groups+ render CO_SUBSET{..} = render (ST_ATTRIBUTES attrs) <> " \\subseteq " <> union groups render CO_EMPTY = "" +-- The union of binding groups, parenthesized when there is more than one.+union :: [BINDING] -> Text+union [group] = render group+union groups = "\\lparen " <> T.intercalate " \\cup " (map render groups) <> " \\rparen"+ instance Render EXTRA_ARG where render ARG_ATTR{..} = render attr render ARG_EXPR{..} = render expr@@ -316,6 +316,11 @@ -- trailing arguments. This is a one-off application binding only 'meta', so the -- returned state is dropped (the engine discards it too, see 'execBuildTerm'). render EXTRA{func = "morph", ..} = render meta <> " \\coloneqq \\phinoMorph{ " <> T.intercalate ", " (map render args) <> " }{ e }{ s_1 }"+ -- The name a formation goes by in the universe 'e'. The rule never writes the+ -- universe, since phino knows it where the rule applies (#1460), so it+ -- renders as the metavariable 'e', the way a 'morph' extra renders it, and+ -- the formation the name stands for gets an argument of its own.+ render EXTRA{func = "named", args = [form], ..} = render meta <> " \\coloneqq \\phinoNamed{ e }{ " <> render form <> " }" render EXTRA{..} = render meta <> " \\coloneqq " <> macro func <> "{ " <> T.intercalate ", " (map render args) <> " }" where macro :: String -> Text
src/Replacer.hs view
@@ -45,11 +45,15 @@ let (expr', ptns', repls') = func (expr, ptns, repls) ctx in (ArAlpha alpha expr', ptns', repls') +-- A term equal to a pattern is inert only when the pattern is, and a term+-- inside an inert one is inert too, so a pattern that is not inert is never+-- looked for inside an inert term, which is where the copies of big objects+-- a normalization carries along are (#1453). replaceExpression' :: ReplaceExpressionFunc'-replaceExpression' state@(expr, ptns@(ptn : _ptns), repls@(repl : _repls)) ctx =- if expr == ptn- then replaceExpression' (repl expr, _ptns, _repls) ctx- else case expr of+replaceExpression' state@(expr, ptns@(ptn : _ptns), repls@(repl : _repls)) ctx+ | inert expr && not (inert ptn) = state+ | expr == ptn = replaceExpression' (repl expr, _ptns, _repls) ctx+ | otherwise = case expr of ExDispatch inner attr -> let (expr', ptns', repls') = replaceExpression' (inner, ptns, repls) ctx in (ExDispatch expr' attr, ptns', repls')@@ -64,6 +68,8 @@ replaceExpression' state _ = state replaceBindingsFast :: [Binding] -> [Expression] -> [Expression] -> [Binding]+replaceBindingsFast _ ((ExFormation []) : _ptns) ((ExFormation rbds) : _repls) =+ replaceBindingsFast rbds _ptns _repls replaceBindingsFast bds ((ExFormation pbds) : _ptns) ((ExFormation rbds) : _repls) = let replaced = findAndReplace bds pbds rbds in replaceBindingsFast replaced _ptns _repls
src/Rewriter.hs view
@@ -82,11 +82,11 @@ , _maxDepth :: Int , _maxCycles :: Int , _depthSensitive :: Bool- , -- The world the rewritten term stands in, where one is known. A rule- -- carrying an 'e-match' is matched against it and reads what it binds- -- there, which is how 'dot' tells the formation it dispatched from the- -- whole program and writes 'ρ ↦ Φ' rather than the program itself- -- (#1318). Normalization inside 𝕄 and 𝔻 knows the universe and names it+ , -- The world the rewritten term stands in, where one is known. The rules+ -- never see it: it reaches the 'named' function through 'RuleContext',+ -- which is how 'dot' tells the formation it dispatched from the whole+ -- program and writes 'ρ ↦ Φ' rather than the program itself (#1318,+ -- #1460). Normalization inside 𝕄 and 𝔻 knows the universe and names it -- here; the 'rewrite' command rewrites a term with no world around it and -- names nothing. _universe :: Maybe Expression@@ -203,7 +203,7 @@ else do logDebug (printf "Starting rewriting cycle for rule '%s': %d out of %d" ruleName _count _maxDepth) expression <- locatedExpression _locator current- R.matchExpressionWithRuleIn _universe expression rule (RuleContext _buildTerm) >>= \case+ R.matchExpressionWithRule expression rule (RuleContext _buildTerm _universe) >>= \case [] -> do logDebug (printf "Rule '%s' does not match, rewriting is stopped" ruleName) if _breakpoint == Just ruleName@@ -259,7 +259,7 @@ rewrite' state rules count ctx >>= \case (_, _, True) -> pure ((expr, Nothing) :| [], False) -- breakpoint, return original expression state'@(rewrittens'@((current', _) :| _), _, False) ->- if current' == current+ if length rewrittens' == length rewrittens || current' == current then do logDebug "Rewriting is stopped since it has no effect" if not (inRange _must count)
src/Rule.hs view
@@ -6,13 +6,13 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module Rule (RuleContext (..), isNF, matchExpressionWithRule, matchExpressionWithRule', matchExpressionWithRuleIn, meetCondition) where+module Rule (RuleContext (..), isNF, matchExpressionWithRule, matchExpressionWithRule', meetCondition, redex) where import AST import Builder ( buildAttribute- , buildBinding , buildBindingThrows+ , buildBindingUnchecked , buildExpression , buildExpressionThrows )@@ -22,11 +22,12 @@ import Control.Monad (when) import qualified Data.ByteString.Char8 as B import Data.Foldable (foldlM)-import Data.List (nub)+import Data.List (foldl', intersect, nub) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes) import qualified Data.Text as T-import Deps (BuildTermFunc, Term (..))+import Deps (BuildTermFunc, BuildTermMethod, Term (..))+import Functions (nameOf) import GHC.IO (unsafePerformIO) import Logger (logDebug) import Matcher@@ -36,7 +37,15 @@ import Yaml (normalizationRules) import qualified Yaml as Y -newtype RuleContext = RuleContext {_buildTerm :: BuildTermFunc}+-- What a rule is matched and extended with: the builder of its 'where'+-- functions and the world the matched term stands in, where one is known.+-- A normalization rule is about a term alone, so the world stays out of its+-- YAML and reaches only the functions that need it, which is 'named' writing+-- 'Φ' or 'Φ.number' into a ρ instead of the object (#1318, #1460).+data RuleContext = RuleContext+ { _buildTerm :: BuildTermFunc+ , _universe :: Maybe Expression+ } -- Returns True if given expression matches with any of given normalization rules -- Here we use unsafePerformIO because we're sure that conditions which are used@@ -95,22 +104,13 @@ met <- meetCondition' cond subst ctx pure [subst | null met] -_in :: Attribute -> Binding -> Subst -> RuleContext -> IO [Subst]-_in attr binding subst _ =- case (buildAttribute attr subst, buildBinding binding subst) of- (Right attr, Right bds) -> pure [subst | attrInBindings attr bds]+-- Hold if every given attribute is present in the union of the bindings+-- captured by the given binding metas.+_in :: [Attribute] -> [Binding] -> Subst -> RuleContext -> IO [Subst]+_in attrs bindings subst _ =+ case (traverse (`buildAttribute` subst) attrs, traverse (`buildBindingUnchecked` subst) bindings) of+ (Right attrs', Right bdss) -> pure [subst | all (`presentIn` concat bdss) attrs'] (_, _) -> pure []- where- attrInBindings :: Attribute -> [Binding] -> Bool- attrInBindings attr (bd : bds) = attrInBinding attr bd || attrInBindings attr bds- where- attrInBinding :: Attribute -> Binding -> Bool- attrInBinding attr (BiTau battr _) = attr == battr- attrInBinding attr (BiVoid battr) = attr == battr- attrInBinding AtLambda (BiLambda _) = True- attrInBinding AtDelta (BiDelta _) = True- attrInBinding _ _ = False- attrInBindings _ _ = False -- Convert a 'Number' to an 'Int' under the given substitution, resolving -- index metas, binding lengths and formation domains.@@ -241,26 +241,26 @@ -- bindings captured by the given binding metas. _disjoint :: [Attribute] -> [Binding] -> Subst -> RuleContext -> IO [Subst] _disjoint attrs bindings subst _ =- case (traverse (`buildAttribute` subst) attrs, traverse (`buildBinding` subst) bindings) of- (Right attrs', Right bdss) ->- let bds = concat bdss- in pure [subst | not (any (`presentIn` bds) attrs')]+ case (traverse (`buildAttribute` subst) attrs, traverse (`buildBindingUnchecked` subst) bindings) of+ (Right attrs', Right bdss) -> pure [subst | not (any (`presentIn` concat bdss) attrs')] (_, _) -> pure []++-- Tell whether the attribute is present among the bindings.+presentIn :: Attribute -> [Binding] -> Bool+presentIn attr = any present where- presentIn :: Attribute -> [Binding] -> Bool- presentIn attr = any (presentInBinding attr)- presentInBinding :: Attribute -> Binding -> Bool- presentInBinding attr (BiTau battr _) = attr == battr- presentInBinding attr (BiVoid battr) = attr == battr- presentInBinding AtLambda (BiLambda _) = True- presentInBinding AtDelta (BiDelta _) = True- presentInBinding _ _ = False+ present :: Binding -> Bool+ present (BiTau battr _) = attr == battr+ present (BiVoid battr) = attr == battr+ present (BiLambda _) = attr == AtLambda+ present (BiDelta _) = attr == AtDelta+ present _ = False meetCondition' :: Y.Condition -> Subst -> RuleContext -> IO [Subst] meetCondition' (Y.Or conds) = _or conds meetCondition' (Y.And conds) = _and conds meetCondition' (Y.Not cond) = _not cond-meetCondition' (Y.In attr binding) = _in attr binding+meetCondition' (Y.In attrs bds) = _in attrs bds meetCondition' (Y.Eq left right) = _eq left right meetCondition' (Y.Gt left right) = _gt left right meetCondition' (Y.NF expr) = _nf expr@@ -315,7 +315,7 @@ _ -> Nothing func = Y.function extra args = Y.args extra- term <- _buildTerm func args subst'+ term <- built func args subst' meta <- case term of TeExpression expr -> do logDebug (printf "Function %s() returned expression:\n%s" func (printExpression expr))@@ -339,6 +339,10 @@ ] logDebug "Extra substitutions have been built" pure (catMaybes res)+ where+ built :: String -> BuildTermMethod+ built "named" = nameOf _universe+ built func = _buildTerm func -- Collect the constrained expression meta-variables with the given -- one-character prefix used in a pattern. Each kind ('𝑛'/'!n' normal-form,@@ -369,23 +373,50 @@ goArgument (ArTau _ expr) = go expr goArgument (ArAlpha _ expr) = go expr +-- Match a rewriting rule against an expression and every place inside it.+-- The deep matcher is asked only where the pattern fits somewhere in the term+-- at all (see 'reachable'), since trying it at every place of a term holding+-- copies of big objects is what a rule that fits nowhere used to cost (#1453).+-- A rule that matches only a redex never looks inside an inert term (see+-- 'redex'). matchExpressionWithRule :: Expression -> Y.Rule -> RuleContext -> IO [Subst]-matchExpressionWithRule = matchExpressionWithRuleIn Nothing+matchExpressionWithRule expr rule = matchExpressionBy deep [substEmpty] expr rule+ where+ deep :: MatchExpressionFunc+ deep ptn tgt+ | reachable' (redex rule) ptn tgt = matchExpressionDeep' (redex rule) ptn tgt+ | otherwise = [] --- Match a rewriting rule against an expression standing in the given universe.--- A rule carrying an 'e-match' is matched against that universe too and what it--- binds there joins every match, which is how 'dot' tells the formation it--- dispatched from the whole program (#1318). A rule carrying none is matched--- exactly as 'matchExpressionWithRule' matches it, and so is every rule where--- no universe is known — the 'rewrite' command rewrites a term and no world--- around it, and 'isNF' asks about a term alone.-matchExpressionWithRuleIn :: Maybe Expression -> Expression -> Y.Rule -> RuleContext -> IO [Subst]-matchExpressionWithRuleIn universe expr rule = matchExpressionBy matchExpression seed expr rule+-- Whether every match of the rule its 'when' lets through stands at a place+-- no 'inert' term holds, judged by the pattern and the 'when' alone, so it+-- holds for a rule of phino and for a rule of the user alike. A pattern+-- dispatching on or applying a formation or ⊥ matches only such a place, and+-- so does a formation pattern holding both λ and Δ, counting those its 'when'+-- demands of its binding metas through 'in', which is how 'dl' is one (#1453).+redex :: Y.Rule -> Bool+redex rule = case rule.pattern of+ ExDispatch head' _ -> stuck head'+ ExApplication head' _ -> stuck head'+ ExFormation bds -> all (`elem` (concatMap attribute bds ++ maybe [] (demanded bds) rule.when)) [AtLambda, AtDelta]+ _ -> False where- seed :: [Subst]- seed = case (rule.ematch, universe) of- (Just ptn, Just whole) -> matchExpression' ptn whole- _ -> [substEmpty]+ stuck :: Expression -> Bool+ stuck (ExFormation _) = True+ stuck ExTermination = True+ stuck _ = False+ attribute :: Binding -> [Attribute]+ attribute (BiLambda _) = [AtLambda]+ attribute (BiDelta _) = [AtDelta]+ attribute _ = []+ demanded :: [Binding] -> Y.Condition -> [Attribute]+ demanded bds (Y.In attrs metas)+ | all (\meta -> isMeta meta && meta `elem` bds) metas = attrs+ demanded bds (Y.And conds) = concatMap (demanded bds) conds+ demanded bds (Y.Or (cond : conds)) = foldl' (\attrs cond' -> attrs `intersect` demanded bds cond') (demanded bds cond) conds+ demanded _ _ = []+ isMeta :: Binding -> Bool+ isMeta (BiMeta _) = True+ isMeta _ = False -- Like 'matchExpressionWithRule' but matches the pattern against the whole -- expression only (no deep, sub-expression matching). Used by the dataization
src/Sugar.hs view
@@ -101,17 +101,13 @@ goPair PA_ALPHA{..} = PA_ALPHA alpha arrow (goExpr expr) goPair PA_FORMATION{..} = case filter (not . rho) voids of [] -> PA_TAU attr arrow (goExpr expr)- voids' -> PA_FORMATION attr voids' arrow (unsugared (goExpr expr))+ voids' -> PA_FORMATION attr voids' arrow (goExpr expr) where -- A void ρ the formation declares is listed among its inline voids rho :: ATTRIBUTE -> Bool rho AT_RHO{} = True rho _ = False goPair pair = pair- -- Inline voids open a formation, which the sugar may not stand for- unsugared :: EXPRESSION -> EXPRESSION- unsugared EX_SINGLE{..} = formation- unsugared expr = expr -- Whether the only binding of a formation has the one-binding sugar sugared :: PAIR -> Bool sugared PA_TAU{attr = AT_DELTA{}} = False@@ -258,6 +254,7 @@ instance ToSalty PAIR where toSalty PA_TAU{..} = PA_TAU attr arrow (toSalty expr) toSalty PA_ALPHA{..} = PA_ALPHA alpha arrow (toSalty expr)+ toSalty PA_FORMATION{voids, attr, arrow, expr = EX_SINGLE{formation}} = toSalty (PA_FORMATION attr voids arrow formation) toSalty PA_FORMATION{voids, attr, arrow, expr = EX_FORMATION{..}} = PA_TAU attr arrow (toSalty (EX_FORMATION lsb eol tab (joinToBinding voids binding) eol' tab' rsb)) where@@ -295,6 +292,7 @@ toSalty CO_MATCHES{..} = CO_MATCHES regex (toSalty expr) toSalty CO_PART_OF{..} = CO_PART_OF (toSalty expr) (toSalty binding) toSalty CO_DISJOINT{..} = CO_DISJOINT attrs (map toSalty groups)+ toSalty CO_SUBSET{..} = CO_SUBSET attrs belongs (map toSalty groups) toSalty CO_FORMATION{..} = CO_FORMATION (toSalty expr) toSalty CO_EMPTY = CO_EMPTY
src/XMIR.hs view
@@ -156,7 +156,9 @@ if null base' then [("as", as)] else [("as", as), ("base", base')]- pure (base, children ++ [object attrs children'])+ if null base && not (null children)+ then pure ("", [object [] (children ++ [object attrs children'])])+ else pure (base, children ++ [object attrs children']) where (as, texpr) = case arg of ArTau attr value -> (printAttribute attr, value)@@ -607,6 +609,7 @@ then pure ExRoot else throwIO (InvalidXMIRFormat "Application of 'Φ' is illegal in XMIR" cur) "⊥" -> xmirToApplication ExTermination (cur C.$/ C.element (toName "o")) fqn+ '⊥' : '.' : rest -> xmirToExpression' ExTermination "⊥" rest cur fqn 'Φ' : '.' : rest -> xmirToExpression' ExRoot "Φ" rest cur fqn 'ξ' : '.' : rest -> xmirToExpression' ExXi "ξ" rest cur fqn _ -> throwIO (InvalidXMIRFormat "The @base attribute must be either ['∅'|'Φ'] or start with ['Φ.'|'ξ.'|'.']" cur)
src/Yaml.hs view
@@ -12,7 +12,7 @@ module Yaml where import AST-import Control.Applicative (asum)+import Control.Applicative (asum, (<|>)) import Data.Aeson import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KeyMap@@ -138,7 +138,7 @@ "in" -> do vals <- v .: "in" case vals of- [attr_, binding_] -> In <$> parseJSON attr_ <*> parseJSON binding_+ [attrs_, bds_] -> In <$> several attrs_ <*> several bds_ _ -> fail "'in' expects exactly two arguments" "matches" -> do vals <- v .: "matches"@@ -152,6 +152,9 @@ _ -> fail "'part-of' expects exactly two arguments" _ -> fail "Unknown condition type" _ -> fail "Exactly one condition type is expected"+ where+ several :: FromJSON a => Value -> Parser [a]+ several val = parseJSON val <|> (pure <$> parseJSON val) instance FromJSON ExtraArgument where parseJSON v =@@ -180,10 +183,10 @@ defaultOptions { fieldLabelModifier = \case "where_" -> "where"- "ematch" -> "e-match" other -> other } value+ universeless rule.name value referenceless rule.name "result" rule.result referenceless rule.name "when" rule.when referenceless rule.name "where" rule.where_@@ -207,7 +210,7 @@ data Condition = And [Condition] | Or [Condition]- | In Attribute Binding+ | In [Attribute] [Binding] | Not Condition | Eq Comparable Comparable | Gt Comparable Comparable@@ -238,12 +241,6 @@ , label :: Maybe String , description :: Maybe String , pattern :: Expression- , -- The universe-argument matcher, the one 'MorphRule' spells as 'ematch'.- -- A rewriting rule is about a term and knows nothing of the world around- -- it, so almost every rule leaves this out; a rule that does carry one is- -- matched against the universe too and reads what it binds, which is how- -- 'dot' tells the formation it dispatched from the whole program (#1318).- ematch :: Maybe Expression , result :: Expression , when :: Maybe Condition , where_ :: Maybe [Extra]@@ -255,7 +252,7 @@ slots (And conds) = slots conds slots (Or conds) = slots conds slots (Not cond) = slots cond- slots (In attr bd) = slots attr ++ slots bd+ slots (In attrs bds) = slots attrs ++ slots bds slots (Eq left right) = slots left ++ slots right slots (Gt left right) = slots left ++ slots right slots (NF expr) = slots expr@@ -300,7 +297,7 @@ metas (And conds) = metas conds metas (Or conds) = metas conds metas (Not cond) = metas cond- metas (In attr bd) = metas attr ++ metas bd+ metas (In attrs bds) = metas attrs ++ metas bds metas (Eq left right) = metas left ++ metas right metas (Gt left right) = metas left ++ metas right metas (NF expr) = metas expr@@ -312,7 +309,7 @@ bare names (And conds) = And (bare names conds) bare names (Or conds) = Or (bare names conds) bare names (Not cond) = Not (bare names cond)- bare names (In attr bd) = In (bare names attr) (bare names bd)+ bare names (In attrs bds) = In (bare names attrs) (bare names bds) bare names (Eq left right) = Eq (bare names left) (bare names right) bare names (Gt left right) = Gt (bare names left) (bare names right) bare names (NF expr) = NF (bare names expr)@@ -375,11 +372,10 @@ -- inference within it and nowhere else, so a kind the rule names just once -- carries no index anywhere in the rule. instance Metas Rule where- metas rule = metas rule.pattern ++ metas rule.ematch ++ metas rule.result ++ metas rule.when ++ metas rule.having ++ metas rule.where_+ metas rule = metas rule.pattern ++ metas rule.result ++ metas rule.when ++ metas rule.having ++ metas rule.where_ bare names rule = rule { pattern = bare names rule.pattern- , ematch = bare names rule.ematch , result = bare names rule.result , when = bare names rule.when , having = bare names rule.having@@ -423,6 +419,15 @@ -- part of a rule to read it back by. Writing one outside the pattern is -- therefore a mistake in the rule, not a term to be resolved later, and the -- rule is rejected as it loads.+-- A rewriting rule is about a term and knows nothing of the world around it,+-- so it has no 'e-match' to match that world with: only a morphing and a+-- dataization rule carry one. A rule written with it anyway is refused where+-- it is read, since ignoring the key would rewrite with a meta nobody binds.+universeless :: String -> Value -> Parser ()+universeless rule (Object fields)+ | KeyMap.member "e-match" fields = fail (printf "The rule '%s' carries an 'e-match', which only a morphing or a dataization rule may" rule)+universeless _ _ = pure ()+ referenceless :: (MonadFail m, Slots a) => String -> String -> a -> m () referenceless rule field term = case anonymous term of Nothing -> pure ()@@ -576,11 +581,11 @@ MorphRule ruleName <$> parseLabel ruleName o <*> o .: "match"- <*> o .: "e-match"- <*> o .: "n-result"+ <*> o .: "universe"+ <*> o .: "conclusion" <*> o .:? "when" <*> o .:? "premises" .!= []- referenceless ruleName "n-result" rule.nresult+ referenceless ruleName "conclusion" rule.nresult referenceless ruleName "when" rule.when referenceless ruleName "premises" rule.premises pure rule@@ -596,11 +601,11 @@ DataizeRule ruleName <$> parseLabel ruleName o <*> o .: "match"- <*> o .: "e-match"- <*> o .: "d-result"+ <*> o .: "universe"+ <*> o .: "conclusion" <*> o .:? "when" <*> o .:? "premises" .!= []- referenceless ruleName "d-result" rule.dresult+ referenceless ruleName "conclusion" rule.dresult referenceless ruleName "when" rule.when referenceless ruleName "premises" rule.premises pure rule
test/ASTSpec.hs view
@@ -13,6 +13,7 @@ import AST import Control.Monad (forM_) import Data.List (nub, sort)+import Data.Text qualified as T import Test.Hspec (Spec, describe, it, shouldBe, shouldNotBe, shouldSatisfy) spec :: Spec@@ -275,6 +276,56 @@ hashExpression ExRoot `shouldNotBe` hashExpression ExXi hashExpression (ExDispatch ExRoot (AtLabel "x")) `shouldNotBe` hashExpression (ExDispatch ExRoot (AtLabel "y")) + describe "alike" $ do+ let application :: [Int] -> Expression+ application idxs = ExApplication (ExDispatch ExRoot (AtLabel "f")) (ArTau (AtLabel "x") (ExFormation (map (BiLambda . FnSymbol) idxs)))+ it "does not tell apart two terms that differ by a bijective renaming of symbols" $+ alike (application [1, 2]) (application [7, 3]) `shouldBe` True+ it "does not take two terms that differ by a datum for the same" $+ alike (ExFormation [BiDelta (BtOne "01"), BiLambda (FnSymbol 4)]) (ExFormation [BiDelta (BtOne "02"), BiLambda (FnSymbol 9)]) `shouldBe` False+ it "does not map one symbol to two others" $+ alike (application [1, 1]) (application [1, 2]) `shouldBe` False+ it "does not map two symbols to one other" $+ alike (application [5, 6]) (application [8, 8]) `shouldBe` False+ it "does not take two terms that differ by a λ name for the same" $+ alike (ExFormation [BiLambda (Function "L_one")]) (ExFormation [BiLambda (Function "L_two")]) `shouldBe` False+ it "does not take two terms that differ by an attribute for the same" $+ alike (ExDispatch (application [3]) (AtLabel "a")) (ExDispatch (application [3]) (AtLabel "b")) `shouldBe` False++ describe "within" $ do+ let pair :: Expression -> Expression+ pair tail' = ExApplication (ExDispatch ExRoot (AtLabel "pair")) (ArTau (AtLabel "tail") tail')+ call :: Int -> Expression -> Expression+ call idx acc = ExFormation [BiTau (AtLabel "n") (ExFormation [BiLambda (FnSymbol idx)]), BiTau (AtLabel "acc") acc, BiLambda (Function "L_fact")]+ it "finds a round inside the next one that wraps its accumulator once more" $+ within (call 3 (ExFormation [BiDelta (BtOne "2A")])) (call 8 (pair (ExFormation [BiDelta (BtOne "2A")]))) `shouldBe` True+ it "does not find a call inside a smaller one nested in it" $+ within (call 4 (pair (pair ExRoot))) (call 4 (pair ExRoot)) `shouldBe` False+ it "does not find a formation inside one of other attributes" $+ within (call 5 ExXi) (ExFormation [BiTau (AtLabel "m") (ExFormation [BiLambda (FnSymbol 5)]), BiTau (AtLabel "acc") ExXi, BiLambda (Function "L_fact")]) `shouldBe` False+ it "does not find a formation inside one naming another λ function" $+ within (ExFormation [BiTau (AtLabel "x") ExXi, BiLambda (Function "L_zero")]) (ExFormation [BiTau (AtLabel "x") ExXi, BiLambda (Function "L_dec")]) `shouldBe` False+ it "does not find a round inside one that differs by a datum" $+ within (call 1 (ExFormation [BiDelta (BtOne "07")])) (call 1 (pair (ExFormation [BiDelta (BtOne "09")]))) `shouldBe` False+ it "does not find a formation inside one that only holds it under an attribute" $+ within (call 2 ExRoot) (ExFormation [BiTau (AtLabel "x") (call 2 ExRoot), BiLambda (Function "L_g")]) `shouldBe` False+ it "does not find a formation under the ρ of the next one" $+ within (call 6 ExRoot) (call 6 (ExFormation [BiTau AtRho (call 6 ExRoot)])) `shouldBe` False++ describe "hashSkeleton" $ do+ it "does not tell apart two formations that bind other terms to the same attributes" $+ hashSkeleton (ExFormation [BiTau (AtLabel "acc") ExRoot, BiLambda (Function "L_f")])+ `shouldBe` hashSkeleton (ExFormation [BiTau (AtLabel "acc") (ExDispatch ExXi (AtLabel "q")), BiLambda (Function "L_f")])+ it "does not hash two formations naming different λ functions alike" $+ hashSkeleton (ExFormation [BiLambda (Function "L_f")]) `shouldNotBe` hashSkeleton (ExFormation [BiLambda (Function "L_g")])++ describe "hashShape" $ do+ it "does not tell apart two terms that differ by symbols alone" $+ hashShape (ExFormation [BiTau (AtLabel "n") (ExFormation [BiLambda (FnSymbol 3)])])+ `shouldBe` hashShape (ExFormation [BiTau (AtLabel "n") (ExFormation [BiLambda (FnSymbol 5)])])+ it "does not hash two terms differing by a datum alike" $+ hashShape (ExFormation [BiDelta (BtOne "0A")]) `shouldNotBe` hashShape (ExFormation [BiDelta (BtOne "0B")])+ describe "BaseObject pattern" $ do it "constructs a Q-dispatch expression" $ BaseObject "bytes" `shouldBe` ExDispatch ExRoot (AtLabel "bytes")@@ -400,3 +451,53 @@ _ -> Nothing in matched `shouldBe` Nothing )++ describe "attributeFromBinding" $+ forM_+ [ ("BiTau yields its attribute", BiTau AtRho ExRoot, Just AtRho)+ , ("BiVoid yields its attribute", BiVoid AtPhi, Just AtPhi)+ , ("BiDelta yields AtDelta", BiDelta BtEmpty, Just AtDelta)+ , ("BiLambda yields AtLambda", BiLambda (Function "F"), Just AtLambda)+ , ("BiMeta yields Nothing", BiMeta "B", Nothing)+ ]+ (\(desc, binding, expected) -> it desc (attributeFromBinding binding `shouldBe` expected))++ describe "inert" $ do+ it "takes a formation of dispatches off ξ and Φ for inert" $+ inert (ExFormation [BiTau (AtLabel "kv") (ExDispatch ExXi (AtLabel "ob")), BiTau (AtLabel "zu") (ExApplication (ExDispatch ExRoot (AtLabel "ny")) (ArTau (AtLabel "q") ExXi)), BiLambda (Function "L_wy")])+ `shouldBe` True+ it "does not take a dispatch on a formation for inert" $+ inert (ExDispatch (ExFormation [BiTau (AtLabel "hm") ExRoot]) (AtLabel "hm")) `shouldBe` False+ it "does not take an application of ⊥ for inert" $+ inert (ExApplication ExTermination (ArAlpha (Alpha 2) ExXi)) `shouldBe` False+ it "does not take a formation holding both λ and Δ for inert" $+ inert (ExFormation [BiDelta (BtOne "3F"), BiVoid AtRho, BiLambda (Function "L_ep")]) `shouldBe` False+ it "does not take a formation holding a redex deep inside for inert" $+ inert (ExFormation [BiTau (AtLabel "ix") (ExFormation [BiTau (AtLabel "gu") (ExDispatch ExTermination (AtLabel "sa"))])]) `shouldBe` False+ it "does not take a formation holding a binding meta for inert" $+ inert (ExFormation [BiVoid (AtLabel "ro"), BiMeta "B4"]) `shouldBe` False++ describe "distinct" $ do+ it "takes a formation of different attributes for distinct" $+ distinct (ExFormation [BiVoid (AtLabel "ka"), BiTau (AtLabel "ak") ExXi, BiLambda (Function "L_ok")]) `shouldBe` True+ it "does not take a formation carrying one attribute twice for distinct" $+ distinct (ExFormation [BiVoid (AtLabel "ka"), BiTau AtPhi ExXi, BiTau (AtLabel "ka") ExRoot]) `shouldBe` False++ describe "repeated" $ do+ it "finds the attribute the bindings carry for the second time" $+ repeated [BiVoid (AtLabel "wz"), BiDelta (BtOne "0C"), BiTau (AtLabel "zw") ExXi, BiDelta BtEmpty] `shouldBe` Just AtDelta+ it "does not find a repeat among hundreds of distinct labels" $+ repeated [BiVoid (AtLabel (T.pack ('q' : show idx))) | idx <- [3 :: Int, 10 .. 2900]] `shouldBe` Nothing++ describe "Expression equality" $ do+ it "does not tell apart two formations built apart of the same parts" $+ ExFormation [BiTau (AtLabel "lu") (ExDispatch ExXi (AtLabel "op")), BiVoid AtRho]+ `shouldBe` ExFormation [BiTau (AtLabel "lu") (ExDispatch ExXi (AtLabel "op")), BiVoid AtRho]+ it "tells apart two formations that differ deep inside" $+ ExFormation [BiTau (AtLabel "lu") (ExDispatch ExXi (AtLabel "op"))]+ `shouldNotBe` ExFormation [BiTau (AtLabel "lu") (ExDispatch ExXi (AtLabel "po"))]++ describe "Expression Show instance" $+ it "does not show what a node carries besides its parts" $+ show (ExApplication (ExDispatch ExXi (AtLabel "yb")) (ArAlpha (Alpha 0) (ExFormation [BiVoid AtRho])))+ `shouldBe` "ExApplication (ExDispatch ExXi yb) (ArAlpha α0 (ExFormation [BiVoid ρ]))"
+ test/AbridgeSpec.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++{- | Tests for the Abridge module, which shortens how a long formation and a+long byte string are spelled in a protocol written under '--abridged'.+-}+module AbridgeSpec where++import AST+import Abridge (abridged)+import Data.Text qualified as T+import Encoding (Encoding (..))+import Lining (LineFormat (..))+import Margin (defaultMargin)+import Printer (printExpressionWith)+import Sugar (SugarType (..))+import Test.Hspec (Spec, describe, it, shouldBe)++spec :: Spec+spec =+ describe "abridged" $ do+ it "leaves a formation no longer than sixty characters as it is" $+ printExpressionWith+ (const abridged)+ (ExFormation [BiTau (AtLabel "kübel") (ExDispatch ExXi (AtLabel "wand")), BiVoid (AtLabel "zaun")])+ (SWEET, UNICODE, SINGLELINE, defaultMargin)+ `shouldBe` "⟦ kübel ↦ wand, zaun ↦ ∅ ⟧"+ it "keeps the data and the λ of a long formation and folds the rest into a count" $+ printExpressionWith+ (const abridged)+ ( ExFormation+ ( BiDelta (BtMany ["00", "77", "66"])+ : BiLambda (Function "L_xxx")+ : map (\idx -> BiVoid (AtLabel (T.pack ("atributo-" <> show idx)))) [1 .. 34 :: Int]+ )+ )+ (SWEET, UNICODE, SINGLELINE, defaultMargin)+ `shouldBe` "⟦ Δ ⤍ 00-77-66, λ ⤍ L_xxx, +34 attrs ⟧"+ it "keeps the φ of a long formation and folds the formation it holds" $+ printExpressionWith+ (const abridged)+ ( ExFormation+ [ BiTau (AtLabel "hund") ExRoot+ , BiTau AtPhi (ExFormation (map (\idx -> BiTau (AtLabel (T.pack ("pfote-" <> show idx))) ExRoot) [1 .. 9 :: Int]))+ , BiTau (AtLabel "katze") ExXi+ ]+ )+ (SWEET, UNICODE, SINGLELINE, defaultMargin)+ `shouldBe` "⟦ φ ↦ ⟦ +9 attrs ⟧, +2 attrs ⟧"+ it "cuts a long byte string to its first bytes and its length" $+ printExpressionWith+ (const abridged)+ (ExFormation [BiDelta (BtMany (replicate 45 "A7"))])+ (SWEET, UNICODE, SINGLELINE, defaultMargin)+ `shouldBe` "A7-A7-A7-A7-...(45b):Δ"+ it "cuts a long byte string inside a formation too short to fold" $+ printExpressionWith+ (const abridged)+ (ExFormation [BiTau (AtLabel "k") (ExFormation [BiDelta (BtMany ["01", "02", "03", "04", "05", "06", "07", "08", "09", "0A"])])])+ (SWEET, UNICODE, SINGLELINE, defaultMargin)+ `shouldBe` "01-02-03-04-...(10b):Δ:k"+ it "keeps a byte string of eight bytes whole" $+ printExpressionWith+ (const abridged)+ (ExFormation (BiDelta (BtMany ["40", "60", "E0", "00", "00", "00", "00", "01"]) : map (\idx -> BiVoid (AtLabel (T.pack ("ränder-" <> show idx)))) [1 .. 5 :: Int]))+ (SWEET, UNICODE, SINGLELINE, defaultMargin)+ `shouldBe` "⟦ Δ ⤍ 40-60-E0-00-00-00-00-01, +5 attrs ⟧"+ it "spells a folded formation the same way in ASCII" $+ printExpressionWith+ (const abridged)+ (ExFormation (BiLambda (Function "F") : map (\idx -> BiVoid (AtLabel (T.pack ("sehr-langes-" <> show idx)))) [1 .. 5 :: Int]))+ (SWEET, ASCII, SINGLELINE, defaultMargin)+ `shouldBe` "[[ L> F, +5 attrs ]]"
test/BuilderSpec.hs view
@@ -253,3 +253,10 @@ (ExApplication ExRoot (ArTau AtRho (ExFormation [BiVoid AtRho]))) substEmpty `shouldBe` Right ExRoot++ describe "pathOf" $+ it "names the world itself as Φ" $+ pathOf+ (ExFormation [BiTau (AtLabel "qwv") (ExFormation [BiVoid AtRho]), BiLambda (Function "Kzr")])+ (ExFormation [BiTau (AtLabel "qwv") (ExFormation [BiVoid AtRho]), BiLambda (Function "Kzr")])+ `shouldBe` ExRoot
test/BytesSpec.hs view
@@ -7,7 +7,8 @@ import AST import Bytes- ( NonFinite (..)+ ( BytesException (..)+ , NonFinite (..) , btsAnd , btsConcat , btsEqual@@ -99,7 +100,7 @@ describe "btsToNum with a byte array that is not 8 bytes long" $ it "errors out" $- evaluate (btsToNum (BtMany ["40", "45"])) `shouldThrow` anyErrorCall+ evaluate (btsToNum (BtMany ["40", "45"])) `shouldThrow` (== InvalidNumberLength 2) describe "strToBts" $ forM_
test/CLIHelpersSpec.hs view
@@ -28,7 +28,7 @@ {-# ANN testPrintContext ("HLint: ignore Eta reduce" :: String) #-} testPrintContext :: IOFormat -> PrintContext testPrintContext format =- PrintCtx SWEET False MULTILINE 2 defaultXmirContext False False False False False 1 1 ExRoot Nothing Nothing Nothing format+ PrintCtx SWEET False False MULTILINE 2 defaultXmirContext False False False False False 1 1 ExRoot Nothing Nothing Nothing format spec :: Spec spec = do
test/CLISpec.hs view
@@ -223,16 +223,26 @@ , ["rewrite", "--flat", "--sweet", "--hide-rho"] , ["42:a"] )+ ,+ ( "keeps the one-binding sugar after inline voids"+ , "[[ x(y) -> [[ a -> 42, ^ -> ? ]] ]]"+ , ["rewrite", "--flat", "--sweet", "--hide-rho"]+ , ["⟦ x(y) ↦ 42:a ⟧"]+ ) ] (\(desc, input, args, expected) -> it desc (withStdin input (testCLISucceeded args expected))) + it "prints the one-binding sugar after inline voids with --sweet" $+ withStdin "[[ x(y) -> [[ a -> 42 ]] ]]" $+ testCLISucceeded ["rewrite", "--sweet"] ["⟦ x(y) ↦ 42:a ⟧"]+ it "prints debug info with --log-level=DEBUG" $ withStdin "[[]]" $ testCLISucceeded ["rewrite", "--log-level=DEBUG"] ["[DEBUG]:"] describe "--log-level accepts every named level" $ forM_- ["ERROR", "ERR", "error", "NONE", "none"]+ ["INFO", "info", "ERROR", "ERR", "error", "NONE", "none"] ( \flagValue -> it ("--log-level=" ++ flagValue) $ withStdin "[[]]" $@@ -1138,12 +1148,21 @@ ["dataize", "--symbolic=" ++ endless, "--max-steps=40", "--partial", "--flat", "--hide-rho"] ["⟦ λ ⤍ L_loop ⟧"] + -- The firing budget counts every firing of the run, so a recursion that+ -- stays well inside '--max-steps' is still stopped by it (#1472)+ it "fails on --max-firings before --max-steps is spent" $+ loopingLambdas $ \endless ->+ withStdin "⟦ @ ↦ ⟦ λ ⤍ L_loop ⟧ ⟧" $+ testCLIFailed+ ["dataize", "--symbolic=" ++ endless, "--max-steps=400", "--max-firings=5"]+ ["[ERROR]: Evaluation did not finish before reaching the limit of firings: --max-firings=5"]+ -- '--acyclic' used to be the 'morph' command's alone, so a program coming -- back to a term through 𝔻 rather than 𝕄 — a body dispatching the very -- object it stands in, which 𝕄 stops at a formation of every round and -- only 𝔻 walks round — spent the whole budget and failed on the limit -- (#1290)- describe "--acyclic" $ do+ describe "--acyclic=proven" $ do let circling = "⟦ cyc ↦ ⟦ x ↦ ∅, φ ↦ Φ.cyc( ξ.x ) ⟧, t ↦ Φ.cyc( ⟦⟧ ) ⟧" it "spends the whole budget and fails on the limit without the flag" $ withStdin circling $@@ -1156,23 +1175,84 @@ it "names the term it came back to with the flag" $ withStdin circling $ testCLIFailed- ["dataize", "--locator=Q.t", "--acyclic", "--max-steps=4000"]- ["[ERROR]: Reduction came back to a term it is already reducing:"]+ ["dataize", "--locator=Q.t", "--acyclic=proven", "--max-steps=4000"]+ ["[ERROR]: Reduction entered a formation it is already inside:"] -- 𝔻 insists on bytes and a parked term carries none, so what a cut run -- prints is the residual program, exactly as it prints one for a λ- -- function that cannot fire+ -- function that cannot fire. The frame the repeat was reached from is+ -- the one handed the call whose formation came back, so the call stands+ -- in the residue as it was written (#1420) it "prints the residue and exits successfully with --partial" $ withStdin circling $ testCLISucceeded- ["dataize", "--locator=Q.t", "--acyclic", "--partial", "--max-steps=4000", "--flat", "--hide-rho"]- ["⟦ cyc ↦ ⟦ x ↦ ∅, φ ↦ Φ.cyc( α0 ↦ ξ.x ) ⟧, t ↦ ⟦ x ↦ ⟦⟧, φ ↦ Φ.cyc( α0 ↦ ξ.x ) ⟧ ⟧"]+ ["dataize", "--locator=Q.t", "--acyclic=proven", "--partial", "--max-steps=4000", "--flat", "--hide-rho"]+ ["⟦ cyc ↦ ⟦ x ↦ ∅, φ ↦ Φ.cyc( α0 ↦ ξ.x ) ⟧, t ↦ Φ.cyc( α0 ↦ ⟦⟧ ) ⟧"] - -- The guard reads nothing but the terms the frames above it are- -- dataizing, so a run that never comes back to one answers as it always did+ -- A cut is written where the formation it refused would have opened,+ -- carrying the term of the one that was entered, so the two lines read+ -- as a pair and nobody has to infer the cut from the residue (#1434)+ it "writes the cut to the protocol where the formation would have opened" $+ withTempFile "protocolXXXXXX.txt" $ \(path, stream) -> do+ hClose stream+ withStdin circling $+ testCLISucceeded+ ["dataize", "--locator=Q.t", "--acyclic=proven", "--partial", "--protocol=" ++ path, "--sweet", "--hide-rho", "--flat", "--quiet"]+ []+ records <- readUtf8 path+ lines records+ `shouldBe` [ "𝔻(Φ.t)"+ , " formation(⟦ x ↦ ⟦⟧, φ ↦ Φ.cyc( x ) ⟧) # 𝔻(Φ.t)"+ , " looped(⟦ x ↦ ⟦⟧, φ ↦ Φ.cyc( x ) ⟧) # 𝔻(Φ.t), proven"+ ]++ -- The markup of a cut is one self-closing element, since nothing runs+ -- under it, with the attributes a '<formation>' carries (#1434)+ it "writes the cut to the XML protocol as a self-closing element" $+ withTempFile "protocolXXXXXX.xml" $ \(path, stream) -> do+ hClose stream+ withStdin circling $+ testCLISucceeded+ ["dataize", "--locator=Q.t", "--acyclic=proven", "--partial", "--protocol=" ++ path, "--sweet", "--hide-rho", "--flat", "--quiet"]+ []+ records <- readUtf8 path+ lines records+ `shouldBe` [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"+ , "<dataize at=\"Φ.t\">"+ , " <formation at=\"Φ.t\" term=\"⟦ x ↦ ⟦⟧, φ ↦ Φ.cyc( x ) ⟧\">"+ , " <looped by=\"dataize\" match=\"proven\" at=\"Φ.t\" term=\"⟦ x ↦ ⟦⟧, φ ↦ Φ.cyc( x ) ⟧\"/>"+ , " </formation>"+ , "</dataize>"+ ]++ -- A formation entered again as it was is within itself, so the embedding+ -- cuts every loop the renaming does, and the cut says which one made it+ -- (#1451)+ it "writes a plausible cut to the protocol as plausible" $+ withTempFile "protocolXXXXXX.txt" $ \(path, stream) -> do+ hClose stream+ withStdin circling $+ testCLISucceeded+ ["dataize", "--locator=Q.t", "--acyclic=plausible", "--partial", "--protocol=" ++ path, "--sweet", "--hide-rho", "--flat", "--quiet"]+ []+ records <- readUtf8 path+ lines records `shouldContain` [" looped(⟦ x ↦ ⟦⟧, φ ↦ Φ.cyc( x ) ⟧) # 𝔻(Φ.t), plausible"]++ -- The mode is what the guard compares by, and the command has no+ -- business guessing one for a user who asked for the guard (#1451)+ it "refuses the flag without a mode" $+ withStdin "⟦ t ↦ ⟦ Δ ⤍ 01-02 ⟧ ⟧" $+ testCLIFailed ["dataize", "--locator=Q.t", "--acyclic"] ["The option `--acyclic` expects an argument"]++ it "refuses a mode it does not know" $+ withStdin "⟦ t ↦ ⟦ Δ ⤍ 01-02 ⟧ ⟧" $+ testCLIFailed ["dataize", "--locator=Q.t", "--acyclic=sure"] ["The value 'sure' can't be used for '--acyclic' option"]++ -- The guard reads nothing but the formations the frames above it have+ -- entered, so a run that never enters one twice answers as it always did it "answers a terminating program the same way with the flag" $ withStdin "⟦ t ↦ ⟦ Δ ⤍ 01-02 ⟧ ⟧" $- testCLISucceeded ["dataize", "--locator=Q.t", "--acyclic"] ["01-02"]+ testCLISucceeded ["dataize", "--locator=Q.t", "--acyclic=proven"] ["01-02"] it "dataizes with --sequence" $ withStdin "[[ @ -> [[ x -> [[ D> 01-, y -> ? ]](y -> [[ ]]) ]].x ]]" $@@ -1230,6 +1310,34 @@ withStdin "[[ D> 01- ]]" $ testCLISucceeded ["dataize", "--quiet"] [] + -- A formation spelled flat in the protocol can run for tens of thousands+ -- of characters, so '--abridged' folds a long one down to what says what+ -- it holds and fires, and cuts a long byte string to its head (#1465)+ describe "--abridged" $ do+ let wide = "⟦ t ↦ ⟦ φ ↦ ⟦ Δ ⤍ 01-02 ⟧, anfang ↦ ξ.schluss, mitte ↦ ξ.anfang, schluss ↦ ξ.mitte, rand ↦ ξ.schluss ⟧ ⟧"+ it "folds a long formation in the text protocol" $+ withTempFile "protocolXXXXXX.txt" $ \(path, stream) -> do+ hClose stream+ withStdin wide $+ testCLISucceeded ["dataize", "--locator=Q.t", "--protocol=" ++ path, "--abridged", "--sweet", "--hide-rho", "--quiet"] []+ records <- readUtf8 path+ lines records `shouldContain` [" formation(⟦ φ ↦ 01-02:Δ, +4 attrs ⟧) # 𝔻(Φ.t)"]+ it "folds a long formation in the XML protocol" $+ withTempFile "protocolXXXXXX.xml" $ \(path, stream) -> do+ hClose stream+ withStdin wide $+ testCLISucceeded ["dataize", "--locator=Q.t", "--protocol=" ++ path, "--abridged", "--sweet", "--hide-rho", "--quiet"] []+ records <- readUtf8 path+ lines records `shouldContain` [" <formation at=\"Φ.t\" term=\"⟦ φ ↦ 01-02:Δ, +4 attrs ⟧\">"]+ it "leaves the printed result whole" $+ withTempFile "protocolXXXXXX.txt" $ \(path, stream) -> do+ hClose stream+ withStdin wide $+ testCLISucceeded ["morph", "--locator=Q.t", "--protocol=" ++ path, "--abridged", "--sweet", "--hide-rho", "--flat"] ["anfang ↦ schluss, mitte ↦ anfang"]+ it "refuses the flag without a protocol" $+ withStdin wide $+ testCLIFailed ["dataize", "--locator=Q.t", "--abridged"] ["The option --abridged requires --protocol"]+ -- Every firing of the run reaches the protocol as a tree: the run itself, -- one line per firing, one per operand it brought down or reduced and one -- per answer it gave. Nothing but the symbols ties them together, so the@@ -1259,11 +1367,17 @@ records <- readUtf8 path lines records `shouldBe` [ "𝔻(Φ)"- , " 𝔼(L_number_plus) # 𝔻(Φ)"- , " 𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ξ.ρ)"- , " 𝛿2.1 := 40-18-00-00-00-00-00-00 # 𝔻(ξ.x)"- , " 𝑛.1.1 := Φ.number( φ ↦ 𝜎1:λ ) # 𝑛"- , " 𝑛.1.2 := ⟦ φ ↦ 𝜎1:λ, plus(x) ↦ ⟦ λ ⤍ L_number_plus ⟧ ⟧ # 𝕄(𝑛.1.1)"+ , " formation(⟦ bytes(φ) ↦ ⟦⟧, number(φ) ↦ ⟦ plus(x) ↦ L_number_plus:λ ⟧, φ ↦ 5.plus( 6 ) ⟧) # 𝔻(Φ)"+ , " 𝔼(L_number_plus) # 𝔻(Φ)"+ , " formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-14-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ ⟧) # 𝔻(Φ.a🌵0)"+ , " formation(40-14-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵0)"+ , " 𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ξ.ρ)"+ , " formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-18-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ ⟧) # 𝔻(Φ.a🌵1)"+ , " formation(40-18-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵1)"+ , " 𝛿2.1 := 40-18-00-00-00-00-00-00 # 𝔻(ξ.x)"+ , " 𝑛.1.1 := Φ.number( φ ↦ 𝜎1:λ ) # 𝑛"+ , " 𝑛.1.2 := ⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ ⟧ # 𝕄(𝑛.1.1)"+ , " formation(⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ ⟧) # 𝔻(Φ)" ] -- The second firing of one entry numbers its own metas 𝛿1.2 and 𝛿2.2,@@ -1277,16 +1391,25 @@ records <- readUtf8 path lines records `shouldBe` [ "𝔻(Φ)"- , " 𝔼(L_number_plus) # 𝕄(Φ)"- , " 𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ξ.ρ)"- , " 𝛿2.1 := 40-18-00-00-00-00-00-00 # 𝔻(ξ.x)"- , " 𝑛.1.1 := Φ.number( φ ↦ 𝜎1:λ ) # 𝑛"- , " 𝑛.1.2 := ⟦ φ ↦ 𝜎1:λ, plus(x) ↦ ⟦ λ ⤍ L_number_plus ⟧ ⟧ # 𝕄(𝑛.1.1)"- , " 𝔼(L_number_plus) # 𝔻(Φ)"- , " 𝛿1.2 := 𝔻(𝜎1:λ) # 𝔻(ξ.ρ)"- , " 𝛿2.2 := 40-1C-00-00-00-00-00-00 # 𝔻(ξ.x)"- , " 𝑛.2.1 := Φ.number( φ ↦ 𝜎2:λ ) # 𝑛"- , " 𝑛.2.2 := ⟦ φ ↦ 𝜎2:λ, plus(x) ↦ ⟦ λ ⤍ L_number_plus ⟧ ⟧ # 𝕄(𝑛.2.1)"+ , " formation(⟦ bytes(φ) ↦ ⟦⟧, number(φ) ↦ ⟦ plus(x) ↦ L_number_plus:λ ⟧, φ ↦ 5.plus( 6 ).plus( 7 ) ⟧) # 𝔻(Φ)"+ , " 𝔼(L_number_plus) # 𝕄(Φ)"+ , " formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-14-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ ⟧) # 𝔻(Φ.a🌵0)"+ , " formation(40-14-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵0)"+ , " 𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ξ.ρ)"+ , " formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-18-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ ⟧) # 𝔻(Φ.a🌵1)"+ , " formation(40-18-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵1)"+ , " 𝛿2.1 := 40-18-00-00-00-00-00-00 # 𝔻(ξ.x)"+ , " 𝑛.1.1 := Φ.number( φ ↦ 𝜎1:λ ) # 𝑛"+ , " 𝑛.1.2 := ⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ ⟧ # 𝕄(𝑛.1.1)"+ , " 𝔼(L_number_plus) # 𝔻(Φ)"+ , " formation(⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ ⟧) # 𝔻(Φ.a🌵2)"+ , " 𝛿1.2 := 𝔻(𝜎1:λ) # 𝔻(ξ.ρ)"+ , " formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-1C-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ ⟧) # 𝔻(Φ.a🌵3)"+ , " formation(40-1C-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵3)"+ , " 𝛿2.2 := 40-1C-00-00-00-00-00-00 # 𝔻(ξ.x)"+ , " 𝑛.2.1 := Φ.number( φ ↦ 𝜎2:λ ) # 𝑛"+ , " 𝑛.2.2 := ⟦ φ ↦ 𝜎2:λ, plus(x) ↦ L_number_plus:λ ⟧ # 𝕄(𝑛.2.1)"+ , " formation(⟦ φ ↦ 𝜎2:λ, plus(x) ↦ L_number_plus:λ ⟧) # 𝔻(Φ)" ] -- A meta is a variable bound exactly once, so its name has to be unique@@ -1302,16 +1425,25 @@ records <- readUtf8 path lines records `shouldBe` [ "𝔻(Φ)"- , " 𝔼(L_number_plus) # 𝕄(Φ)"- , " 𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ξ.ρ)"- , " 𝛿2.1 := 40-18-00-00-00-00-00-00 # 𝔻(ξ.x)"- , " 𝑛.1.1 := Φ.number( φ ↦ 𝜎1:λ ) # 𝑛"- , " 𝑛.1.2 := ⟦ φ ↦ 𝜎1:λ, plus(x) ↦ ⟦ λ ⤍ L_number_plus ⟧, times(x) ↦ ⟦ λ ⤍ L_number_times ⟧ ⟧ # 𝕄(𝑛.1.1)"- , " 𝔼(L_number_times) # 𝔻(Φ)"- , " 𝛿1.2 := 𝔻(𝜎1:λ) # 𝔻(ξ.ρ)"- , " 𝛿2.2 := 40-1C-00-00-00-00-00-00 # 𝔻(ξ.x)"- , " 𝑛.2.1 := Φ.number( φ ↦ 𝜎2:λ ) # 𝑛"- , " 𝑛.2.2 := ⟦ φ ↦ 𝜎2:λ, plus(x) ↦ ⟦ λ ⤍ L_number_plus ⟧, times(x) ↦ ⟦ λ ⤍ L_number_times ⟧ ⟧ # 𝕄(𝑛.2.1)"+ , " formation(⟦ bytes(φ) ↦ ⟦⟧, number(φ) ↦ ⟦ plus(x) ↦ L_number_plus:λ, times(x) ↦ L_number_times:λ ⟧, φ ↦ 5.plus( 6 ).times( 7 ) ⟧) # 𝔻(Φ)"+ , " 𝔼(L_number_plus) # 𝕄(Φ)"+ , " formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-14-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ, times(x) ↦ L_number_times:λ ⟧) # 𝔻(Φ.a🌵0)"+ , " formation(40-14-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵0)"+ , " 𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ξ.ρ)"+ , " formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-18-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ, times(x) ↦ L_number_times:λ ⟧) # 𝔻(Φ.a🌵1)"+ , " formation(40-18-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵1)"+ , " 𝛿2.1 := 40-18-00-00-00-00-00-00 # 𝔻(ξ.x)"+ , " 𝑛.1.1 := Φ.number( φ ↦ 𝜎1:λ ) # 𝑛"+ , " 𝑛.1.2 := ⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ, times(x) ↦ L_number_times:λ ⟧ # 𝕄(𝑛.1.1)"+ , " 𝔼(L_number_times) # 𝔻(Φ)"+ , " formation(⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ, times(x) ↦ L_number_times:λ ⟧) # 𝔻(Φ.a🌵2)"+ , " 𝛿1.2 := 𝔻(𝜎1:λ) # 𝔻(ξ.ρ)"+ , " formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-1C-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ, times(x) ↦ L_number_times:λ ⟧) # 𝔻(Φ.a🌵3)"+ , " formation(40-1C-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵3)"+ , " 𝛿2.2 := 40-1C-00-00-00-00-00-00 # 𝔻(ξ.x)"+ , " 𝑛.2.1 := Φ.number( φ ↦ 𝜎2:λ ) # 𝑛"+ , " 𝑛.2.2 := ⟦ φ ↦ 𝜎2:λ, plus(x) ↦ L_number_plus:λ, times(x) ↦ L_number_times:λ ⟧ # 𝕄(𝑛.2.1)"+ , " formation(⟦ φ ↦ 𝜎2:λ, plus(x) ↦ L_number_plus:λ, times(x) ↦ L_number_times:λ ⟧) # 𝔻(Φ)" ] -- An operand is brought down by a whole run of 𝔻, so a λ function it@@ -1324,16 +1456,25 @@ records <- readUtf8 path lines records `shouldBe` [ "𝔻(Φ)"- , " 𝔼(L_number_plus) # 𝔻(Φ)"- , " 𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ξ.ρ)"- , " 𝔼(L_number_plus) # 𝔻(Φ.a🌵1)"- , " 𝛿1.2 := 40-18-00-00-00-00-00-00 # 𝔻(ξ.ρ)"- , " 𝛿2.2 := 40-1C-00-00-00-00-00-00 # 𝔻(ξ.x)"- , " 𝑛.2.1 := Φ.number( φ ↦ 𝜎1:λ ) # 𝑛"- , " 𝑛.2.2 := ⟦ φ ↦ 𝜎1:λ, plus(x) ↦ ⟦ λ ⤍ L_number_plus ⟧ ⟧ # 𝕄(𝑛.2.1)"- , " 𝛿2.1 := 𝔻(𝜎1:λ) # 𝔻(ξ.x)"- , " 𝑛.1.1 := Φ.number( φ ↦ 𝜎2:λ ) # 𝑛"- , " 𝑛.1.2 := ⟦ φ ↦ 𝜎2:λ, plus(x) ↦ ⟦ λ ⤍ L_number_plus ⟧ ⟧ # 𝕄(𝑛.1.1)"+ , " formation(⟦ bytes(φ) ↦ ⟦⟧, number(φ) ↦ ⟦ plus(x) ↦ L_number_plus:λ ⟧, φ ↦ 5.plus( 6.plus( 7 ) ) ⟧) # 𝔻(Φ)"+ , " 𝔼(L_number_plus) # 𝔻(Φ)"+ , " formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-14-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ ⟧) # 𝔻(Φ.a🌵0)"+ , " formation(40-14-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵0)"+ , " 𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ξ.ρ)"+ , " 𝔼(L_number_plus) # 𝔻(Φ.a🌵1)"+ , " formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-18-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ ⟧) # 𝔻(Φ.a🌵2)"+ , " formation(40-18-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵2)"+ , " 𝛿1.2 := 40-18-00-00-00-00-00-00 # 𝔻(ξ.ρ)"+ , " formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-1C-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ ⟧) # 𝔻(Φ.a🌵3)"+ , " formation(40-1C-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵3)"+ , " 𝛿2.2 := 40-1C-00-00-00-00-00-00 # 𝔻(ξ.x)"+ , " 𝑛.2.1 := Φ.number( φ ↦ 𝜎1:λ ) # 𝑛"+ , " 𝑛.2.2 := ⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ ⟧ # 𝕄(𝑛.2.1)"+ , " formation(⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ ⟧) # 𝔻(Φ.a🌵1)"+ , " 𝛿2.1 := 𝔻(𝜎1:λ) # 𝔻(ξ.x)"+ , " 𝑛.1.1 := Φ.number( φ ↦ 𝜎2:λ ) # 𝑛"+ , " 𝑛.1.2 := ⟦ φ ↦ 𝜎2:λ, plus(x) ↦ L_number_plus:λ ⟧ # 𝕄(𝑛.1.1)"+ , " formation(⟦ φ ↦ 𝜎2:λ, plus(x) ↦ L_number_plus:λ ⟧) # 𝔻(Φ)" ] -- A 'symbolize' line stands the data of a term an earlier line bound@@ -1369,12 +1510,17 @@ records <- readUtf8 path lines records `shouldBe` [ "𝔻(Φ)"- , " 𝔼(L_number_plus) # 𝕄(Φ)"- , " 𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ξ.ρ)"- , " 𝛿2.1 := 40-18-00-00-00-00-00-00 # 𝔻(ξ.x)"- , " 𝑛.1.1 := Φ.number( φ ↦ 𝜎1:λ ) # 𝑛"- , " 𝑛.1.2 := ⟦ φ ↦ 𝜎1:λ, plus(x) ↦ ⟦ λ ⤍ L_number_plus ⟧, nope ↦ L_number_nope:λ ⟧ # 𝕄(𝑛.1.1)"- , " ?(L_number_nope) # 𝔻(L_number_nope:λ)"+ , " formation(⟦ bytes(φ) ↦ ⟦⟧, number(φ) ↦ ⟦ plus(x) ↦ L_number_plus:λ, nope ↦ L_number_nope:λ ⟧, φ ↦ 5.plus( 6 ).nope ⟧) # 𝔻(Φ)"+ , " 𝔼(L_number_plus) # 𝕄(Φ)"+ , " formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-14-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ, nope ↦ L_number_nope:λ ⟧) # 𝔻(Φ.a🌵0)"+ , " formation(40-14-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵0)"+ , " 𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ξ.ρ)"+ , " formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-18-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ, nope ↦ L_number_nope:λ ⟧) # 𝔻(Φ.a🌵1)"+ , " formation(40-18-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵1)"+ , " 𝛿2.1 := 40-18-00-00-00-00-00-00 # 𝔻(ξ.x)"+ , " 𝑛.1.1 := Φ.number( φ ↦ 𝜎1:λ ) # 𝑛"+ , " 𝑛.1.2 := ⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ, nope ↦ L_number_nope:λ ⟧ # 𝕄(𝑛.1.1)"+ , " ?(L_number_nope) # 𝔻(L_number_nope:λ)" ] it "truncates the lines left over from the previous run" $@@ -1392,7 +1538,7 @@ withStdin sum' $ testCLISucceeded ["dataize", symbolic, "--protocol=" ++ path, "--output=xmir", "--quiet", "--sweet", "--hide-rho"] [] records <- readUtf8 path- records `shouldEndWith` " 𝑛.1.2 := ⟦ φ ↦ 𝜎1:λ, plus(x) ↦ ⟦ λ ⤍ L_number_plus ⟧ ⟧ # 𝕄(𝑛.1.1)\n"+ records `shouldEndWith` " formation(⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ ⟧) # 𝔻(Φ)\n" -- The same facts as markup, so a program reading the protocol back never -- has to parse 𝜑 to learn them: the name of an element says what its@@ -1409,17 +1555,43 @@ records <- readUtf8 path lines records `shouldBe` [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"- , "<dataize locator=\"Φ\">"- , " <evaluate λ=\"L_number_plus\" id=\"1\" judgment=\"dataize\" locator=\"Φ\">"- , " <bind meta=\"𝛿1.1\">40-14-00-00-00-00-00-00</bind>"- , " <bind meta=\"𝛿2.1\">40-18-00-00-00-00-00-00</bind>"- , " <minted>𝜎1</minted>"- , " <built meta=\"𝑛.1.1\">Φ.number( φ ↦ 𝜎1:λ )</built>"- , " <answer meta=\"𝑛.1.2\">⟦ φ ↦ 𝜎1:λ, plus(x) ↦ ⟦ λ ⤍ L_number_plus ⟧ ⟧</answer>"- , " </evaluate>"+ , "<dataize at=\"Φ\">"+ , " <formation at=\"Φ\" term=\"⟦ bytes(φ) ↦ ⟦⟧, number(φ) ↦ ⟦ plus(x) ↦ L_number_plus:λ ⟧, φ ↦ 5.plus( 6 ) ⟧\">"+ , " <evaluate λ=\"L_number_plus\" by=\"dataize\" at=\"Φ\">"+ , " <formation at=\"Φ.a🌵0\" term=\"⟦ φ ↦ Φ.bytes( φ ↦ 40-14-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ ⟧\">"+ , " <formation at=\"Φ.a🌵0\" term=\"40-14-00-00-00-00-00-00:Δ:φ\">"+ , " </formation>"+ , " </formation>"+ , " <bind meta=\"𝛿1.1\">40-14-00-00-00-00-00-00</bind>"+ , " <formation at=\"Φ.a🌵1\" term=\"⟦ φ ↦ Φ.bytes( φ ↦ 40-18-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ ⟧\">"+ , " <formation at=\"Φ.a🌵1\" term=\"40-18-00-00-00-00-00-00:Δ:φ\">"+ , " </formation>"+ , " </formation>"+ , " <bind meta=\"𝛿2.1\">40-18-00-00-00-00-00-00</bind>"+ , " <minted symbol=\"𝜎1\">40-14-00-00-00-00-00-00 40-18-00-00-00-00-00-00</minted>"+ , " <built meta=\"𝑛.1.1\">Φ.number( φ ↦ 𝜎1:λ )</built>"+ , " <answer meta=\"𝑛.1.2\">⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ ⟧</answer>"+ , " </evaluate>"+ , " <formation at=\"Φ\" term=\"⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ ⟧\">"+ , " </formation>"+ , " </formation>" , "</dataize>" ] + -- A formation 𝔻 gets into through 'box' is an element of its own, and+ -- whatever its φ body fires stands inside it, so a reader sees which+ -- object a firing was made on the way into (#1420)+ it "nests what a φ body fires inside the formation element it was boxed from" $+ withTempFile "protocolXXXXXX.xml" $ \(path, stream) -> do+ hClose stream+ withStdin sum' $+ testCLISucceeded ["dataize", symbolic, "--protocol=" ++ path, "--quiet", "--sweet", "--hide-rho"] []+ records <- readUtf8 path+ lines records+ `shouldContain` [ " <formation at=\"Φ\" term=\"⟦ bytes(φ) ↦ ⟦⟧, number(φ) ↦ ⟦ plus(x) ↦ L_number_plus:λ ⟧, φ ↦ 5.plus( 6 ) ⟧\">"+ , " <evaluate λ=\"L_number_plus\" by=\"dataize\" at=\"Φ\">"+ ]+ -- A run firing nothing still writes a document a parser can read, -- since the root is closed on the way out and not by the last firing it "closes the document even when nothing fires" $@@ -1430,7 +1602,7 @@ records <- readUtf8 path lines records `shouldBe` [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"- , "<dataize locator=\"Φ\">"+ , "<dataize at=\"Φ\">" , "</dataize>" ] @@ -1447,21 +1619,39 @@ records <- readUtf8 path lines records `shouldBe` [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"- , "<dataize locator=\"Φ\">"- , " <evaluate λ=\"L_number_plus\" id=\"1\" judgment=\"morph\" locator=\"Φ\">"- , " <bind meta=\"𝛿1.1\">40-14-00-00-00-00-00-00</bind>"- , " <bind meta=\"𝛿2.1\">40-18-00-00-00-00-00-00</bind>"- , " <minted>𝜎1</minted>"- , " <built meta=\"𝑛.1.1\">Φ.number( φ ↦ 𝜎1:λ )</built>"- , " <answer meta=\"𝑛.1.2\">⟦ φ ↦ 𝜎1:λ, plus(x) ↦ ⟦ λ ⤍ L_number_plus ⟧ ⟧</answer>"- , " </evaluate>"- , " <evaluate λ=\"L_number_plus\" id=\"2\" judgment=\"dataize\" locator=\"Φ\">"- , " <dataize meta=\"𝛿1.2\">𝜎1:λ</dataize>"- , " <bind meta=\"𝛿2.2\">40-1C-00-00-00-00-00-00</bind>"- , " <minted>𝜎2</minted>"- , " <built meta=\"𝑛.2.1\">Φ.number( φ ↦ 𝜎2:λ )</built>"- , " <answer meta=\"𝑛.2.2\">⟦ φ ↦ 𝜎2:λ, plus(x) ↦ ⟦ λ ⤍ L_number_plus ⟧ ⟧</answer>"- , " </evaluate>"+ , "<dataize at=\"Φ\">"+ , " <formation at=\"Φ\" term=\"⟦ bytes(φ) ↦ ⟦⟧, number(φ) ↦ ⟦ plus(x) ↦ L_number_plus:λ ⟧, φ ↦ 5.plus( 6 ).plus( 7 ) ⟧\">"+ , " <evaluate λ=\"L_number_plus\" by=\"morph\" at=\"Φ\">"+ , " <formation at=\"Φ.a🌵0\" term=\"⟦ φ ↦ Φ.bytes( φ ↦ 40-14-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ ⟧\">"+ , " <formation at=\"Φ.a🌵0\" term=\"40-14-00-00-00-00-00-00:Δ:φ\">"+ , " </formation>"+ , " </formation>"+ , " <bind meta=\"𝛿1.1\">40-14-00-00-00-00-00-00</bind>"+ , " <formation at=\"Φ.a🌵1\" term=\"⟦ φ ↦ Φ.bytes( φ ↦ 40-18-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ ⟧\">"+ , " <formation at=\"Φ.a🌵1\" term=\"40-18-00-00-00-00-00-00:Δ:φ\">"+ , " </formation>"+ , " </formation>"+ , " <bind meta=\"𝛿2.1\">40-18-00-00-00-00-00-00</bind>"+ , " <minted symbol=\"𝜎1\">40-14-00-00-00-00-00-00 40-18-00-00-00-00-00-00</minted>"+ , " <built meta=\"𝑛.1.1\">Φ.number( φ ↦ 𝜎1:λ )</built>"+ , " <answer meta=\"𝑛.1.2\">⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ ⟧</answer>"+ , " </evaluate>"+ , " <evaluate λ=\"L_number_plus\" by=\"dataize\" at=\"Φ\">"+ , " <formation at=\"Φ.a🌵2\" term=\"⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ ⟧\">"+ , " </formation>"+ , " <dataize meta=\"𝛿1.2\">𝜎1:λ</dataize>"+ , " <formation at=\"Φ.a🌵3\" term=\"⟦ φ ↦ Φ.bytes( φ ↦ 40-1C-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ ⟧\">"+ , " <formation at=\"Φ.a🌵3\" term=\"40-1C-00-00-00-00-00-00:Δ:φ\">"+ , " </formation>"+ , " </formation>"+ , " <bind meta=\"𝛿2.2\">40-1C-00-00-00-00-00-00</bind>"+ , " <minted symbol=\"𝜎2\">𝜎1 40-1C-00-00-00-00-00-00</minted>"+ , " <built meta=\"𝑛.2.1\">Φ.number( φ ↦ 𝜎2:λ )</built>"+ , " <answer meta=\"𝑛.2.2\">⟦ φ ↦ 𝜎2:λ, plus(x) ↦ L_number_plus:λ ⟧</answer>"+ , " </evaluate>"+ , " <formation at=\"Φ\" term=\"⟦ φ ↦ 𝜎2:λ, plus(x) ↦ L_number_plus:λ ⟧\">"+ , " </formation>"+ , " </formation>" , "</dataize>" ] @@ -1479,8 +1669,8 @@ records <- readUtf8 path lines records `shouldBe` [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"- , "<morph locator=\"Φ.y\">"- , " <evaluate λ=\"L_stand\" id=\"1\" judgment=\"morph\" locator=\"Φ.y\">"+ , "<morph at=\"Φ.y\">"+ , " <evaluate λ=\"L_stand\" by=\"morph\" at=\"Φ.y\">" , " <bind meta=\"𝑛1.1\">01-:Δ</bind>" , " <known symbol=\"𝜎1\">01-</known>" , " <bind meta=\"𝑛2.1\">𝜎1:λ</bind>"@@ -1507,8 +1697,8 @@ records <- readUtf8 path lines records `shouldBe` [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"- , "<morph locator=\"Φ.y\">"- , " <evaluate λ=\"L_fork\" id=\"1\" judgment=\"morph\" locator=\"Φ.y\">"+ , "<morph at=\"Φ.y\">"+ , " <evaluate λ=\"L_fork\" by=\"morph\" at=\"Φ.y\">" , " <bind meta=\"𝑛1.1\">𝜎1:λ:φ</bind>" , " <bind meta=\"𝑛2.1\">𝜎2:λ:φ</bind>" , " <joined symbol=\"𝜎3\">𝜎1 𝜎2</joined>"@@ -1532,12 +1722,12 @@ records <- readUtf8 path lines records `shouldBe` [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"- , "<morph locator=\"Φ.y\">"- , " <evaluate λ=\"L_fork\" id=\"1\" judgment=\"morph\" locator=\"Φ.y\">"+ , "<morph at=\"Φ.y\">"+ , " <evaluate λ=\"L_fork\" by=\"morph\" at=\"Φ.y\">" , " <dataize meta=\"𝛿1.1\">𝜎1:λ</dataize>" , " <bind meta=\"𝑛1.1\">𝜎2:λ:φ</bind>" , " <bind meta=\"𝑛2.1\">⊥</bind>"- , " <raise-if symbol=\"𝜎1\" branch=\"right\"/>"+ , " <terminate symbol=\"𝜎1\" branch=\"right\"/>" , " <bind meta=\"𝑛3.1\">𝜎2:λ:φ</bind>" , " <built meta=\"𝑛.1.1\">𝜎2:λ:φ</built>" , " <answer meta=\"𝑛.1.2\">𝜎2:λ:φ</answer>"@@ -1559,11 +1749,11 @@ records <- readUtf8 path lines records `shouldBe` [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"- , "<morph locator=\"Φ.y\">"- , " <evaluate λ=\"L_pair\" id=\"1\" judgment=\"morph\" locator=\"Φ.y\">"+ , "<morph at=\"Φ.y\">"+ , " <evaluate λ=\"L_pair\" by=\"morph\" at=\"Φ.y\">" , " <bind meta=\"𝑛1.1\">01-:Δ</bind>"- , " <minted>𝜎1</minted>"- , " <minted>𝜎2</minted>"+ , " <minted symbol=\"𝜎1\"/>"+ , " <minted symbol=\"𝜎2\"/>" , " <built meta=\"𝑛.1.1\">⟦ left ↦ 𝜎1:λ, right ↦ 𝜎2:λ ⟧</built>" , " <answer meta=\"𝑛.1.2\">⟦ left ↦ 𝜎1:λ, right ↦ 𝜎2:λ ⟧</answer>" , " </evaluate>"@@ -1582,8 +1772,8 @@ records <- readUtf8 path lines records `shouldBe` [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"- , "<morph locator=\"Φ.y\">"- , " <evaluate λ=\"L_keep\" id=\"1\" judgment=\"morph\" locator=\"Φ.y\">"+ , "<morph at=\"Φ.y\">"+ , " <evaluate λ=\"L_keep\" by=\"morph\" at=\"Φ.y\">" , " <bind meta=\"𝑛1.1\">01-:Δ</bind>" , " <built meta=\"𝑛.1.1\">01-:Δ:z</built>" , " <answer meta=\"𝑛.1.2\">01-:Δ:z</answer>"@@ -1602,21 +1792,39 @@ records <- readUtf8 path lines records `shouldBe` [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"- , "<dataize locator=\"Φ\">"- , " <evaluate λ=\"L_number_plus\" id=\"1\" judgment=\"dataize\" locator=\"Φ\">"- , " <bind meta=\"𝛿1.1\">40-14-00-00-00-00-00-00</bind>"- , " <evaluate λ=\"L_number_plus\" id=\"2\" judgment=\"dataize\" locator=\"Φ.a🌵1\">"- , " <bind meta=\"𝛿1.2\">40-18-00-00-00-00-00-00</bind>"- , " <bind meta=\"𝛿2.2\">40-1C-00-00-00-00-00-00</bind>"- , " <minted>𝜎1</minted>"- , " <built meta=\"𝑛.2.1\">Φ.number( φ ↦ 𝜎1:λ )</built>"- , " <answer meta=\"𝑛.2.2\">⟦ φ ↦ 𝜎1:λ, plus(x) ↦ ⟦ λ ⤍ L_number_plus ⟧ ⟧</answer>"+ , "<dataize at=\"Φ\">"+ , " <formation at=\"Φ\" term=\"⟦ bytes(φ) ↦ ⟦⟧, number(φ) ↦ ⟦ plus(x) ↦ L_number_plus:λ ⟧, φ ↦ 5.plus( 6.plus( 7 ) ) ⟧\">"+ , " <evaluate λ=\"L_number_plus\" by=\"dataize\" at=\"Φ\">"+ , " <formation at=\"Φ.a🌵0\" term=\"⟦ φ ↦ Φ.bytes( φ ↦ 40-14-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ ⟧\">"+ , " <formation at=\"Φ.a🌵0\" term=\"40-14-00-00-00-00-00-00:Δ:φ\">"+ , " </formation>"+ , " </formation>"+ , " <bind meta=\"𝛿1.1\">40-14-00-00-00-00-00-00</bind>"+ , " <evaluate λ=\"L_number_plus\" by=\"dataize\" at=\"Φ.a🌵1\">"+ , " <formation at=\"Φ.a🌵2\" term=\"⟦ φ ↦ Φ.bytes( φ ↦ 40-18-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ ⟧\">"+ , " <formation at=\"Φ.a🌵2\" term=\"40-18-00-00-00-00-00-00:Δ:φ\">"+ , " </formation>"+ , " </formation>"+ , " <bind meta=\"𝛿1.2\">40-18-00-00-00-00-00-00</bind>"+ , " <formation at=\"Φ.a🌵3\" term=\"⟦ φ ↦ Φ.bytes( φ ↦ 40-1C-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ ⟧\">"+ , " <formation at=\"Φ.a🌵3\" term=\"40-1C-00-00-00-00-00-00:Δ:φ\">"+ , " </formation>"+ , " </formation>"+ , " <bind meta=\"𝛿2.2\">40-1C-00-00-00-00-00-00</bind>"+ , " <minted symbol=\"𝜎1\">40-18-00-00-00-00-00-00 40-1C-00-00-00-00-00-00</minted>"+ , " <built meta=\"𝑛.2.1\">Φ.number( φ ↦ 𝜎1:λ )</built>"+ , " <answer meta=\"𝑛.2.2\">⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ ⟧</answer>"+ , " </evaluate>"+ , " <formation at=\"Φ.a🌵1\" term=\"⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ ⟧\">"+ , " </formation>"+ , " <dataize meta=\"𝛿2.1\">𝜎1:λ</dataize>"+ , " <minted symbol=\"𝜎2\">40-14-00-00-00-00-00-00 𝜎1</minted>"+ , " <built meta=\"𝑛.1.1\">Φ.number( φ ↦ 𝜎2:λ )</built>"+ , " <answer meta=\"𝑛.1.2\">⟦ φ ↦ 𝜎2:λ, plus(x) ↦ L_number_plus:λ ⟧</answer>" , " </evaluate>"- , " <dataize meta=\"𝛿2.1\">𝜎1:λ</dataize>"- , " <minted>𝜎2</minted>"- , " <built meta=\"𝑛.1.1\">Φ.number( φ ↦ 𝜎2:λ )</built>"- , " <answer meta=\"𝑛.1.2\">⟦ φ ↦ 𝜎2:λ, plus(x) ↦ ⟦ λ ⤍ L_number_plus ⟧ ⟧</answer>"- , " </evaluate>"+ , " <formation at=\"Φ\" term=\"⟦ φ ↦ 𝜎2:λ, plus(x) ↦ L_number_plus:λ ⟧\">"+ , " </formation>"+ , " </formation>" , "</dataize>" ] @@ -1632,15 +1840,25 @@ records <- readUtf8 path lines records `shouldBe` [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"- , "<dataize locator=\"Φ\">"- , " <evaluate λ=\"L_number_times\" id=\"1\" judgment=\"morph\" locator=\"Φ\">"- , " <bind meta=\"𝛿1.1\">40-00-00-00-00-00-00-00</bind>"- , " <bind meta=\"𝛿2.1\">40-08-00-00-00-00-00-00</bind>"- , " <minted>𝜎1</minted>"- , " <built meta=\"𝑛.1.1\">Φ.number( φ ↦ 𝜎1:λ )</built>"- , " <answer meta=\"𝑛.1.2\">⟦ φ ↦ 𝜎1:λ, times(x) ↦ ⟦ λ ⤍ L_number_times ⟧, nope ↦ L_number_nope:λ ⟧</answer>"- , " </evaluate>"- , " <stuck λ=\"L_number_nope\" judgment=\"dataize\">L_number_nope:λ</stuck>"+ , "<dataize at=\"Φ\">"+ , " <formation at=\"Φ\" term=\"⟦ bytes(φ) ↦ ⟦⟧, number(φ) ↦ ⟦ times(x) ↦ L_number_times:λ, nope ↦ L_number_nope:λ ⟧, φ ↦ 2.times( 3 ).nope ⟧\">"+ , " <evaluate λ=\"L_number_times\" by=\"morph\" at=\"Φ\">"+ , " <formation at=\"Φ.a🌵0\" term=\"⟦ φ ↦ Φ.bytes( φ ↦ 40-00-00-00-00-00-00-00:Δ ), times(x) ↦ L_number_times:λ, nope ↦ L_number_nope:λ ⟧\">"+ , " <formation at=\"Φ.a🌵0\" term=\"40-00-00-00-00-00-00-00:Δ:φ\">"+ , " </formation>"+ , " </formation>"+ , " <bind meta=\"𝛿1.1\">40-00-00-00-00-00-00-00</bind>"+ , " <formation at=\"Φ.a🌵1\" term=\"⟦ φ ↦ Φ.bytes( φ ↦ 40-08-00-00-00-00-00-00:Δ ), times(x) ↦ L_number_times:λ, nope ↦ L_number_nope:λ ⟧\">"+ , " <formation at=\"Φ.a🌵1\" term=\"40-08-00-00-00-00-00-00:Δ:φ\">"+ , " </formation>"+ , " </formation>"+ , " <bind meta=\"𝛿2.1\">40-08-00-00-00-00-00-00</bind>"+ , " <minted symbol=\"𝜎1\">40-00-00-00-00-00-00-00 40-08-00-00-00-00-00-00</minted>"+ , " <built meta=\"𝑛.1.1\">Φ.number( φ ↦ 𝜎1:λ )</built>"+ , " <answer meta=\"𝑛.1.2\">⟦ φ ↦ 𝜎1:λ, times(x) ↦ L_number_times:λ, nope ↦ L_number_nope:λ ⟧</answer>"+ , " </evaluate>"+ , " <stuck λ=\"L_number_nope\" by=\"dataize\">L_number_nope:λ</stuck>"+ , " </formation>" , "</dataize>" ] @@ -1656,8 +1874,8 @@ records <- readUtf8 path lines records `shouldBe` [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"- , "<morph locator=\"Φ.x\">"- , " <stuck λ=\"L_number_nope\" judgment=\"morph\">⟦ λ ⤍ L_number_nope ⟧</stuck>"+ , "<morph at=\"Φ.x\">"+ , " <stuck λ=\"L_number_nope\" by=\"morph\">⟦ λ ⤍ L_number_nope ⟧</stuck>" , "</morph>" ] @@ -1673,15 +1891,25 @@ records <- readUtf8 path lines records `shouldBe` [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"- , "<dataize locator=\"Φ\">"- , " <evaluate λ=\"L_number_times\" id=\"1\" judgment=\"morph\" locator=\"Φ\">"- , " <bind meta=\"𝛿1.1\">40-00-00-00-00-00-00-00</bind>"- , " <bind meta=\"𝛿2.1\">40-08-00-00-00-00-00-00</bind>"- , " <minted>𝜎1</minted>"- , " <built meta=\"𝑛.1.1\">Φ.number( φ ↦ ⟦ λ ⤍ 𝜎1 ⟧ )</built>"- , " <answer meta=\"𝑛.1.2\">⟦ φ ↦ ⟦ λ ⤍ 𝜎1 ⟧, times ↦ ⟦ ρ ↦ ∅, x ↦ ∅, λ ⤍ L_number_times ⟧, nope ↦ ⟦ ρ ↦ ∅, λ ⤍ L_number_nope ⟧ ⟧</answer>"- , " </evaluate>"- , " <stuck λ=\"L_number_nope\" judgment=\"dataize\">⟦ ρ ↦ ⟦ φ ↦ ⟦ λ ⤍ 𝜎1 ⟧, times ↦ ⟦ ρ ↦ ∅, x ↦ ∅, λ ⤍ L_number_times ⟧, nope ↦ ⟦ ρ ↦ ∅, λ ⤍ L_number_nope ⟧ ⟧, λ ⤍ L_number_nope ⟧</stuck>"+ , "<dataize at=\"Φ\">"+ , " <formation at=\"Φ\" term=\"⟦ bytes ↦ ⟦ φ ↦ ∅ ⟧, number ↦ ⟦ φ ↦ ∅, times ↦ ⟦ ρ ↦ ∅, x ↦ ∅, λ ⤍ L_number_times ⟧, nope ↦ ⟦ ρ ↦ ∅, λ ⤍ L_number_nope ⟧ ⟧, φ ↦ Φ.number( φ ↦ Φ.bytes( φ ↦ ⟦ Δ ⤍ 40-00-00-00-00-00-00-00 ⟧ ) ).times( α0 ↦ Φ.number( φ ↦ Φ.bytes( φ ↦ ⟦ Δ ⤍ 40-08-00-00-00-00-00-00 ⟧ ) ) ).nope ⟧\">"+ , " <evaluate λ=\"L_number_times\" by=\"morph\" at=\"Φ\">"+ , " <formation at=\"Φ.a🌵0\" term=\"⟦ φ ↦ Φ.bytes( φ ↦ ⟦ Δ ⤍ 40-00-00-00-00-00-00-00 ⟧ ), times ↦ ⟦ ρ ↦ ∅, x ↦ ∅, λ ⤍ L_number_times ⟧, nope ↦ ⟦ ρ ↦ ∅, λ ⤍ L_number_nope ⟧ ⟧\">"+ , " <formation at=\"Φ.a🌵0\" term=\"⟦ φ ↦ ⟦ Δ ⤍ 40-00-00-00-00-00-00-00 ⟧ ⟧\">"+ , " </formation>"+ , " </formation>"+ , " <bind meta=\"𝛿1.1\">40-00-00-00-00-00-00-00</bind>"+ , " <formation at=\"Φ.a🌵1\" term=\"⟦ φ ↦ Φ.bytes( φ ↦ ⟦ Δ ⤍ 40-08-00-00-00-00-00-00 ⟧ ), times ↦ ⟦ ρ ↦ ∅, x ↦ ∅, λ ⤍ L_number_times ⟧, nope ↦ ⟦ ρ ↦ ∅, λ ⤍ L_number_nope ⟧ ⟧\">"+ , " <formation at=\"Φ.a🌵1\" term=\"⟦ φ ↦ ⟦ Δ ⤍ 40-08-00-00-00-00-00-00 ⟧ ⟧\">"+ , " </formation>"+ , " </formation>"+ , " <bind meta=\"𝛿2.1\">40-08-00-00-00-00-00-00</bind>"+ , " <minted symbol=\"𝜎1\">40-00-00-00-00-00-00-00 40-08-00-00-00-00-00-00</minted>"+ , " <built meta=\"𝑛.1.1\">Φ.number( φ ↦ ⟦ λ ⤍ 𝜎1 ⟧ )</built>"+ , " <answer meta=\"𝑛.1.2\">⟦ φ ↦ ⟦ λ ⤍ 𝜎1 ⟧, times ↦ ⟦ ρ ↦ ∅, x ↦ ∅, λ ⤍ L_number_times ⟧, nope ↦ ⟦ ρ ↦ ∅, λ ⤍ L_number_nope ⟧ ⟧</answer>"+ , " </evaluate>"+ , " <stuck λ=\"L_number_nope\" by=\"dataize\">⟦ ρ ↦ Φ.number( φ ↦ ⟦ λ ⤍ 𝜎1 ⟧ ), λ ⤍ L_number_nope ⟧</stuck>"+ , " </formation>" , "</dataize>" ] @@ -1700,14 +1928,14 @@ records <- readUtf8 path lines records `shouldBe` [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"- , "<morph locator=\"Φ.x\">"- , " <evaluate λ=\"L_pick\" id=\"1\" judgment=\"morph\" locator=\"Φ.x\">"+ , "<morph at=\"Φ.x\">"+ , " <evaluate λ=\"L_pick\" by=\"morph\" at=\"Φ.x\">" , " <bind meta=\"𝑛1.1\">⊥</bind>"- , " <minted>𝜎1</minted>"+ , " <minted symbol=\"𝜎1\"/>" , " <built meta=\"𝑛.1.1\">⟦ λ ⤍ 𝜎1 ⟧</built>" , " <answer meta=\"𝑛.1.2\">⟦ λ ⤍ 𝜎1 ⟧</answer>" , " </evaluate>"- , " <stuck λ=\"𝜎1\" judgment=\"morph\">⟦ λ ⤍ 𝜎1 ⟧</stuck>"+ , " <stuck λ=\"𝜎1\" by=\"morph\">⟦ λ ⤍ 𝜎1 ⟧</stuck>" , "</morph>" ] @@ -1756,12 +1984,17 @@ records <- readUtf8 path lines records `shouldBe` [ "𝔻(Φ)"- , " 𝔼(L_number_times) # 𝕄(Φ)"- , " 𝛿1.1 := 40-00-00-00-00-00-00-00 # 𝔻(ξ.ρ)"- , " 𝛿2.1 := 40-08-00-00-00-00-00-00 # 𝔻(ξ.x)"- , " 𝑛.1.1 := Φ.number( φ ↦ 𝜎1:λ ) # 𝑛"- , " 𝑛.1.2 := ⟦ φ ↦ 𝜎1:λ, times(x) ↦ ⟦ λ ⤍ L_number_times ⟧, nope ↦ L_number_nope:λ ⟧ # 𝕄(𝑛.1.1)"- , " ?(L_number_nope) # 𝔻(L_number_nope:λ)"+ , " formation(⟦ bytes(φ) ↦ ⟦⟧, number(φ) ↦ ⟦ times(x) ↦ L_number_times:λ, nope ↦ L_number_nope:λ ⟧, φ ↦ 2.times( 3 ).nope ⟧) # 𝔻(Φ)"+ , " 𝔼(L_number_times) # 𝕄(Φ)"+ , " formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-00-00-00-00-00-00-00:Δ ), times(x) ↦ L_number_times:λ, nope ↦ L_number_nope:λ ⟧) # 𝔻(Φ.a🌵0)"+ , " formation(40-00-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵0)"+ , " 𝛿1.1 := 40-00-00-00-00-00-00-00 # 𝔻(ξ.ρ)"+ , " formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-08-00-00-00-00-00-00:Δ ), times(x) ↦ L_number_times:λ, nope ↦ L_number_nope:λ ⟧) # 𝔻(Φ.a🌵1)"+ , " formation(40-08-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵1)"+ , " 𝛿2.1 := 40-08-00-00-00-00-00-00 # 𝔻(ξ.x)"+ , " 𝑛.1.1 := Φ.number( φ ↦ 𝜎1:λ ) # 𝑛"+ , " 𝑛.1.2 := ⟦ φ ↦ 𝜎1:λ, times(x) ↦ L_number_times:λ, nope ↦ L_number_nope:λ ⟧ # 𝕄(𝑛.1.1)"+ , " ?(L_number_nope) # 𝔻(L_number_nope:λ)" ] it "still prints bytes when nothing gets stuck" $@@ -1774,7 +2007,7 @@ withStdin dispatched $ testCLISucceeded ["dataize", symbolic, "--partial", "--output=xmir"]- ["<o name=\"λ\">L_number_nope</o>", "<o name=\"ρ\">", "<listing>⟦"]+ ["<o name=\"λ\">L_number_nope</o>", "<o base=\"Φ.foo\" name=\"ρ\"/>", "<listing>⟦"] it "honors --hide-rho and --omit-listing when printing the residual to XMIR" $ withStdin dispatched $@@ -1810,6 +2043,10 @@ withStdin sum' $ testCLISucceeded ["dataize", symbolic] ["40-45-00-00-00-00-00-00"] + it "reports the progress of the run with --log-level=INFO" $+ withStdin sum' $+ testCLISucceeded ["dataize", symbolic, "--log-level=INFO", "--quiet"] ["[INFO]: Entered "]+ it "gets stuck on every λ function when it is not given" $ withStdin sum' $ testCLIFailed ["dataize"] ["No entry of --symbolic answers the λ function 'L_number_plus'"]@@ -1986,10 +2223,14 @@ lines records `shouldBe` [ "𝕄(Φ.φ)" , " 𝔼(L_number_plus) # 𝕄(Φ.φ)"+ , " formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-14-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ ⟧) # 𝔻(Φ.a🌵0)"+ , " formation(40-14-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵0)" , " 𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ξ.ρ)"+ , " formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-18-00-00-00-00-00-00:Δ ), plus(x) ↦ L_number_plus:λ ⟧) # 𝔻(Φ.a🌵1)"+ , " formation(40-18-00-00-00-00-00-00:Δ:φ) # 𝔻(Φ.a🌵1)" , " 𝛿2.1 := 40-18-00-00-00-00-00-00 # 𝔻(ξ.x)" , " 𝑛.1.1 := Φ.number( φ ↦ 𝜎1:λ ) # 𝑛"- , " 𝑛.1.2 := ⟦ φ ↦ 𝜎1:λ, plus(x) ↦ ⟦ λ ⤍ L_number_plus ⟧ ⟧ # 𝕄(𝑛.1.1)"+ , " 𝑛.1.2 := ⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_number_plus:λ ⟧ # 𝕄(𝑛.1.1)" ] it "saves morphing steps to dir with --steps-dir" $@@ -2022,6 +2263,54 @@ ["morph", "--locator=Q.@", "--max-steps=3"] ["[ERROR]: Dataization did not finish before reaching the limit of steps: --max-steps=3"] + -- '--max-steps' bounds one branch and not the whole run, so an entry+ -- morphing two operands that each fire it again doubles its work at every+ -- level and never reaches the limit it is given; '--max-firings' counts+ -- every firing of the run and so ends it (#1472)+ describe "--max-firings" $ do+ let splitting = withLambdasOf (T.pack "- λ: L_split\n morph:\n 𝑛1: Φ.s.foo\n 𝑛2: Φ.s.foo\n 𝑛: ⟦ l ↦ 𝑛1, r ↦ 𝑛2 ⟧\n")+ split = "⟦ s ↦ ⟦ λ ⤍ L_split ⟧, x ↦ Φ.s.foo ⟧"+ it "fails with non-positive --max-firings" $+ withStdin split $+ testCLIFailed ["morph", "--max-firings=0"] ["--max-firings must be positive"]++ it "fails once the --max-firings budget is spent on a widening recursion" $+ splitting $ \table ->+ withStdin split $+ testCLIFailed+ ["morph", "--symbolic=" ++ table, "--locator=Q.x", "--max-firings=64"]+ ["[ERROR]: Evaluation did not finish before reaching the limit of firings: --max-firings=64"]++ -- The answer holds no 'foo', so what the dispatch reaches once every+ -- operand is parked is the terminator+ it "ends the widening recursion with --partial" $+ splitting $ \table ->+ withStdin split $+ testCLISucceeded+ ["morph", "--symbolic=" ++ table, "--locator=Q.x", "--max-firings=64", "--partial", "--flat", "--hide-rho", "--sweet"]+ ["⊥"]++ it "parks the spent --max-firings budget with --deep and --partial" $+ splitting $ \table ->+ withStdin split $+ testCLISucceeded+ ["morph", "--symbolic=" ++ table, "--deep", "--max-firings=64", "--partial", "--flat", "--hide-rho", "--sweet"]+ ["x ↦ Φ.s.foo"]++ -- A parked frame hands back the state it started from, so a count kept+ -- in that state would refund every firing made inside it; the tally is+ -- shared by the whole run and never goes back+ it "fires no more λ functions than --max-firings allows" $+ splitting $ \table ->+ withTempFile "protocolXXXXXX.txt" $ \(path, stream) -> do+ hClose stream+ withStdin split $+ testCLISucceeded+ ["morph", "--symbolic=" ++ table, "--deep", "--max-firings=64", "--partial", "--protocol=" ++ path, "--quiet"]+ []+ records <- readUtf8 path+ length (filter (isInfixOf "𝔼(L_split)") (lines records)) `shouldBe` 64+ -- '--partial' parks a spent 𝕄 budget the same way it parks a stuck λ: -- the answer is the term the walk had reached, dispatch intact (#1078) it "parks the spent budget as a residual with --partial" $@@ -2067,7 +2356,7 @@ withStdin program $ testCLISucceeded ["morph", symbolic, "--deep", "--inside=Q.demo.foo", "--sweet", "--hide-rho", "--flat"]- ["⟦ n ↦ 3, φ ↦ Φ.bar( ⟦ φ ↦ 𝜎2:λ, times(x) ↦ ⟦ λ ⤍ L_number_times ⟧ ⟧ ) ⟧"]+ ["⟦ n ↦ 3, φ ↦ Φ.bar( ⟦ φ ↦ 𝜎2:λ, times(x) ↦ L_number_times:λ ⟧ ) ⟧"] -- The same term the run above stops at as a bare λ-formation: 'mf' leaves -- it to 𝔻, and the walk fires it instead of demanding bytes@@ -2075,7 +2364,7 @@ withStdin chained $ testCLISucceeded ["morph", symbolic, "--deep", "--locator=Q.@", "--sweet", "--hide-rho", "--flat"]- ["⟦ φ ↦ 𝜎2:λ, plus(x) ↦ ⟦ λ ⤍ L_number_plus ⟧ ⟧"]+ ["⟦ φ ↦ 𝜎2:λ, plus(x) ↦ L_number_plus:λ ⟧"] -- The default locator walks the whole program: the method table of the -- object model keeps every one of its λ-formations, since not one of them@@ -2084,8 +2373,8 @@ withStdin program $ testCLISucceeded ["morph", symbolic, "--deep", "--sweet", "--hide-rho", "--flat"]- [ "number(φ) ↦ ⟦ times(x) ↦ ⟦ λ ⤍ L_number_times ⟧ ⟧"- , "demo ↦ ⟦ n ↦ 3, φ ↦ Φ.bar( ⟦ φ ↦ 𝜎2:λ, times(x) ↦ ⟦ λ ⤍ L_number_times ⟧ ⟧ ) ⟧:foo"+ [ "number(φ) ↦ ⟦ times(x) ↦ L_number_times:λ ⟧"+ , "demo ↦ ⟦ n ↦ 3, φ ↦ Φ.bar( ⟦ φ ↦ 𝜎2:λ, times(x) ↦ L_number_times:λ ⟧ ) ⟧:foo" ] it "keeps a binding whose spine got stuck with --partial" $@@ -2098,12 +2387,62 @@ withStdin "[[ x -> [[ L> Sym_arg_0 ]].foo ]]" $ testCLIFailed ["morph", "--deep"] ["No entry of --symbolic answers the λ function 'Sym_arg_0'"] + -- Two bindings spelling one term are two firings of one formation, inner+ -- sum and outer sum alike, so the walk fires four λ functions for two+ -- values and charges four to '--max-firings'. Under '--acyclic=plausible'+ -- the first firing of a formation is kept and the second takes its answer,+ -- reducing and minting nothing, so the walk over the second binding is+ -- charged nothing and lands it on the symbol the first came to; the+ -- protocol still writes that firing at its own site, with the answer of+ -- the first named after the line that made it, and no operand line under+ -- it (#1476)+ describe "--acyclic=plausible" $ do+ let twins = "[[ bytes ↦ ⟦ φ ↦ ∅ ⟧, number(φ) -> [[ plus(^, x) -> [[ L> L_number_plus ]] ]], a -> 7.plus( 5.plus( 6 ) ), b -> 7.plus( 5.plus( 6 ) ) ]]"+ recorded :: String -> IO [String]+ recorded mode =+ withTempFile "protocolXXXXXX.txt" $ \(path, stream) -> do+ hClose stream+ withStdin twins $+ testCLISucceeded+ ["morph", symbolic, "--deep", "--acyclic=" ++ mode, "--protocol=" ++ path, "--quiet"]+ []+ lines <$> readUtf8 path+ it "charges a formation once per binding spelling it under proven" $+ withStdin twins $+ testCLIFailed+ ["morph", symbolic, "--deep", "--acyclic=proven", "--max-firings=3"]+ ["[ERROR]: Evaluation did not finish before reaching the limit of firings: --max-firings=3"]++ it "charges a formation once for the run under plausible" $+ withStdin twins $+ testCLISucceeded+ ["morph", symbolic, "--deep", "--acyclic=plausible", "--max-firings=2", "--flat", "--hide-rho", "--sweet"]+ ["b ↦ ⟦ φ ↦ 𝜎2:λ, plus(x) ↦ L_number_plus:λ ⟧"]++ it "reduces the operands of a formation once per binding spelling it under proven" $+ recorded "proven" >>= (`shouldSatisfy` ((== 4) . length . filter (isInfixOf "𝛿1.")))++ it "reduces the operands of a formation once for the run under plausible" $+ recorded "plausible" >>= (`shouldSatisfy` ((== 2) . length . filter (isInfixOf "𝛿1.")))++ it "writes a recalled firing at its own site under plausible" $+ recorded "plausible" >>= (`shouldSatisfy` ((== 4) . length . filter (isInfixOf "𝔼(L_number_plus)")))++ it "answers a recalled firing with the line of the first under plausible" $+ recorded "plausible" >>= (`shouldContain` [" 𝑛.4.2 := 𝑛.2.2 # 𝕄(𝑛.4.1)"])++ it "dataizes to the same datum under plausible" $+ withStdin chained $+ testCLISucceeded+ ["dataize", symbolic, "--acyclic=plausible", "--locator=Q.@"]+ ["40-45-00-00-00-00-00-00"]+ -- The step budget used to be the only thing ending the 𝕄/𝔻 recursion, so an -- entry answering with a firing of itself spent the whole of it and then -- failed on the limit; '--acyclic' stops the moment morphing comes back to a -- term a frame above it is already reducing and parks that site the way -- '--partial' parks a λ function that cannot fire- describe "--acyclic" $ do+ describe "--acyclic=proven" $ do let looping = "⟦ x ↦ ⟦ λ ⤍ L_loop ⟧.foo ⟧" it "spends the whole budget and fails on the limit without the flag" $ loopingLambdas $ \endless ->@@ -2118,15 +2457,15 @@ loopingLambdas $ \endless -> withStdin looping $ testCLISucceeded- ["morph", "--symbolic=" ++ endless, "--locator=Q.x", "--acyclic", "--max-steps=4000", "--flat", "--hide-rho"]+ ["morph", "--symbolic=" ++ endless, "--locator=Q.x", "--acyclic=proven", "--max-steps=4000", "--flat", "--hide-rho"] ["⟦ λ ⤍ L_loop ⟧.foo"] - -- The guard reads nothing but the terms the frames above it are reducing,- -- so a run that never comes back to one answers exactly as it did before+ -- The guard reads nothing but the formations the frames above it have+ -- entered, so a run that never enters one twice answers exactly as it did before it "answers a terminating program the same way with the flag" $ withStdin chained $ testCLISucceeded- ["morph", symbolic, "--acyclic", "--locator=Q.@", "--sweet", "--hide-rho", "--flat"]+ ["morph", symbolic, "--acyclic=proven", "--locator=Q.@", "--sweet", "--hide-rho", "--flat"] ["⟦ x ↦ 7, λ ⤍ L_number_plus ⟧"] -- The deep walk parks the one binding that loops and walks on, the way it@@ -2136,7 +2475,7 @@ loopingLambdas $ \endless -> withStdin "⟦ x ↦ ⟦ λ ⤍ L_loop, ρ ↦ ∅ ⟧.foo, y ↦ ⟦ z ↦ ⟦⟧ ⟧ ⟧" $ testCLISucceeded- ["morph", "--symbolic=" ++ endless, "--deep", "--acyclic", "--max-steps=4000", "--flat", "--hide-rho"]+ ["morph", "--symbolic=" ++ endless, "--deep", "--acyclic=proven", "--max-steps=4000", "--flat", "--hide-rho"] ["⟦ x ↦ ⟦ λ ⤍ L_loop ⟧.foo, y ↦ ⟦ z ↦ ⟦⟧ ⟧ ⟧"] describe "fails" $ do@@ -2247,18 +2586,13 @@ , "\\phinoNormalizationRule{dl}" , " { [[ B_1, L> f, B_2 ]] }" , " { T }"- , " { D \\in B_1 \\;\\text{or}\\; D \\in B_2 }"+ , " { [ D ] \\subseteq \\lparen B_1 \\cup B_2 \\rparen }" , " { }" , "\\phinoNormalizationRule{dot}" , " { [[ B_1, \\tau -> n, B_2 ]] . \\tau }"- , " { e_2 ( \\phiTerminal{\\rho} -> [[ B_1, \\tau -> n, B_2 ]] ) }"- , " { [[ B_1, \\tau -> n, B_2 ]] \\not= e_1 \\;\\text{and}\\; \\lparen [ L ] \\cap \\lparen B_1 \\cup B_2 \\rparen = \\emptyset \\;\\text{or}\\; [ D ] \\cap \\lparen B_1 \\cup B_2 \\rparen = \\emptyset \\rparen }"- , " { \\phinoContextualize{ n }{ [[ B_1, B_2 ]] }{ e_2 } }"- , "\\phinoNormalizationRule{dotg}"- , " { [[ B_1, \\tau -> n, B_2 ]] . \\tau }"- , " { e_2 ( \\phiTerminal{\\rho} -> Q ) }"- , " { [[ B_1, \\tau -> n, B_2 ]] = e_1 \\;\\text{and}\\; \\lparen [ L ] \\cap \\lparen B_1 \\cup B_2 \\rparen = \\emptyset \\;\\text{or}\\; [ D ] \\cap \\lparen B_1 \\cup B_2 \\rparen = \\emptyset \\rparen }"- , " { \\phinoContextualize{ n }{ [[ B_1, B_2 ]] }{ e_2 } }"+ , " { e_1 ( \\phiTerminal{\\rho} -> e_2 ) }"+ , " { [ D \\char44{} L ] \\not\\subseteq \\lparen B_1 \\cup B_2 \\rparen }"+ , " { \\phinoContextualize{ n }{ [[ B_1, B_2 ]] }{ e_1 } and e_2 \\coloneqq \\phinoNamed{ e }{ [[ B_1, \\tau -> n, B_2 ]] } }" , "\\phinoNormalizationRule{miss}" , " { [[ B ]] ( \\tau -> e ) }" , " { T }"@@ -2292,7 +2626,7 @@ , "\\phinoNormalizationRule{stop}" , " { [[ B ]] . \\tau }" , " { T }"- , " { \\tau \\notin B \\;\\text{and}\\; @ \\notin B \\;\\text{and}\\; L \\notin B }"+ , " { [ \\tau \\char44{} @ \\char44{} L ] \\cap B = \\emptyset }" , " { }" ] ]@@ -2359,7 +2693,7 @@ , "\\begin{phinoMorphingInference}" , " \\phinoName{mphi}" , " \\phinoLabel{\\varphi}"- , " \\phinoCondition{ @ \\in B \\;\\text{and}\\; \\tau \\notin B \\;\\text{and}\\; L \\notin B }"+ , " \\phinoCondition{ @ \\in B \\;\\text{and}\\; [ \\tau \\char44{} L ] \\cap B = \\emptyset }" , " \\phinoPremise{ \\phinoNormalize{ [[ B ]] . @ . \\tau }{ n_1 } }" , " \\phinoPremise{ \\phinoMorph{ n_1 }{ e }{ s_1 }{ n_2 }{ s_2 } }" , " \\phinoConclusion{ \\phinoMorph{ [[ B ]] . \\tau }{ e }{ s_1 }{ n_2 }{ s_2 } }"@@ -2549,7 +2883,7 @@ withTempFileContent "phino-atom.xmir" xmir $ \file -> do testCLISucceeded ["merge", "--input=xmir", "--sweet", "--flat", file]- ["λ ⤍ L_number_plus"]+ ["L_number_plus:λ"] testCLISucceeded ["merge", "--input=xmir", "--output=xmir", file] ["<o atom=\"Φ.number\" name=\"λ\">L_number_plus</o>"]
test/CSTSpec.hs view
@@ -312,10 +312,10 @@ let voidYBinding :: BINDING voidYBinding = BI_PAIR (PA_VOID (AT_LABEL "y") ARROW EMPTY) (BDS_EMPTY (TAB 0)) (TAB 0) forM_- [ ("In", Y.In (AtLabel "x") (BiVoid (AtLabel "y")), CO_BELONGS (AT_LABEL "x") IN (ST_BINDING voidYBinding))+ [ ("In", Y.In [AtLabel "x"] [BiVoid (AtLabel "y")], CO_BELONGS (AT_LABEL "x") IN (ST_BINDING voidYBinding)) , ( "Not (In ...) flips the belonging"- , Y.Not (Y.In (AtLabel "x") (BiVoid (AtLabel "y")))+ , Y.Not (Y.In [AtLabel "x"] [BiVoid (AtLabel "y")]) , CO_BELONGS (AT_LABEL "x") NOT_IN (ST_BINDING voidYBinding) ) ,@@ -341,6 +341,16 @@ , ("Absolute", Y.Absolute ExXi, CO_ABSOLUTE (EX_XI XI) IN) , ("Not (Absolute ...) flips membership", Y.Not (Y.Absolute ExXi), CO_ABSOLUTE (EX_XI XI) NOT_IN) , ("Disjoint", Y.Disjoint [AtLabel "a"] [BiVoid (AtLabel "y")], CO_DISJOINT [AT_LABEL "a"] [voidYBinding])+ ,+ ( "In over many attributes becomes a subset"+ , Y.In [AtLabel "a", AtLabel "x"] [BiVoid (AtLabel "y")]+ , CO_SUBSET [AT_LABEL "a", AT_LABEL "x"] IN [voidYBinding]+ )+ ,+ ( "Not (In ...) over many binding metas flips the subset"+ , Y.Not (Y.In [AtLabel "x"] [BiVoid (AtLabel "y"), BiVoid (AtLabel "y")])+ , CO_SUBSET [AT_LABEL "x"] NOT_IN [voidYBinding, voidYBinding]+ ) , ("And on an empty list collapses to CO_EMPTY", Y.And [], CO_EMPTY) , ("And on a non-empty list wraps every condition", Y.And [Y.NF ExXi], CO_LOGIC [CO_NF (EX_XI XI)] AND) , ("Or on an empty list collapses to CO_EMPTY", Y.Or [], CO_EMPTY)
test/ConditionSpec.hs view
@@ -33,8 +33,8 @@ describe "parses correctly" $ forM_- [ ("in(!t1, !B1)", Y.In (AtMeta "t1") (BiMeta "B1"))- , ("not(in(!t1,!B1))", Y.Not (Y.In (AtMeta "t1") (BiMeta "B1")))+ [ ("in(!t1, !B1)", Y.In [AtMeta "t1"] [BiMeta "B1"])+ , ("not(in(!t1,!B1))", Y.Not (Y.In [AtMeta "t1"] [BiMeta "B1"])) , ("eq(1,-2)", Y.Eq (Y.CmpNum (Y.Literal 1)) (Y.CmpNum (Y.Literal (-2)))) , ("eq(!i1,length(!B1))", Y.Eq (Y.CmpNum (Y.MetaIndex "i1")) (Y.CmpNum (Y.Length (BiMeta "B1")))) , ("eq(!i2,domain(!B1))", Y.Eq (Y.CmpNum (Y.MetaIndex "i2")) (Y.CmpNum (Y.Domain (BiMeta "B1"))))
test/DataizeSpec.hs view
@@ -112,11 +112,11 @@ -- (#955). The dataization clauses are therefore disjoint and their order in -- 'resources/dataization' cannot change behavior. describe "dataization 'norm' is disjoint from the specific clauses" $ do- let rctx = RuleContext (execBuildTerm ExRoot (defaultReduceContext ExRoot))+ let rctx = RuleContext (execBuildTerm ExRoot (defaultReduceContext ExRoot)) Nothing dataizeRule :: String -> Yaml.DataizeRule dataizeRule nm = fromMaybe (error ("no dataization rule named " ++ nm)) (find (\r -> r.name == nm) Yaml.dataizationRules) asRule :: Yaml.DataizeRule -> Yaml.Rule- asRule r = Yaml.Rule r.name Nothing Nothing r.match Nothing ExRoot r.when Nothing Nothing+ asRule r = Yaml.Rule r.name Nothing Nothing r.match ExRoot r.when Nothing Nothing it "does not fire on a formation" $ do substs <- matchExpressionWithRule' [substEmpty] (ExFormation [BiDelta (BtOne "00")]) (asRule (dataizeRule "norm")) rctx substs `shouldBe` []@@ -210,7 +210,7 @@ it "fails on the step limit instead of morphing forever" $ looping $ \endless -> do expr <- parseExpressionThrows "⟦ @ ↦ ⟦ λ ⤍ L_loop ⟧ ⟧"- dataize expr emptyState (ReduceContext ExRoot ExRoot Nothing 25 25 (Steps 40 0) 1 False True False False False Dataization [] Map.empty Map.empty endless buildTerm reduction evaluation fired dontSaveStep dontSaveEval)+ dataize expr emptyState (ReduceContext ExRoot ExRoot Nothing 25 25 (Steps 40 0) Nothing Nothing 1 False True False False Nothing Dataization [] Map.empty endless buildTerm reduction evaluation fired dontSaveStep dontSaveEval) `shouldThrow` (\e -> "--max-steps=40" `isInfixOf` show (e :: SomeException)) -- A budget spent on a cycle is a stuck site just as a λ function that@@ -219,7 +219,7 @@ it "parks the step limit as a residual with --partial" $ looping $ \endless -> do expr <- parseExpressionThrows "⟦ @ ↦ ⟦ λ ⤍ L_loop ⟧ ⟧"- (outcome, _, _) <- dataize expr emptyState (ReduceContext ExRoot ExRoot Nothing 25 25 (Steps 40 0) 1 False True True False False Dataization [] Map.empty Map.empty endless buildTerm reduction evaluation fired dontSaveStep dontSaveEval)+ (outcome, _, _) <- dataize expr emptyState (ReduceContext ExRoot ExRoot Nothing 25 25 (Steps 40 0) Nothing Nothing 1 False True True False Nothing Dataization [] Map.empty endless buildTerm reduction evaluation fired dontSaveStep dontSaveEval) case outcome of Residual _ -> pure () Dataized bts -> expectationFailure ("expected a residual, dataized to " ++ show bts)@@ -248,24 +248,30 @@ Residual (ExFormation bds) -> do let rho = [value | BiTau AtRho value <- bds] length rho `shouldBe` 1- -- the times application is gone: ρ is the number it answered, its 'as-bytes' bound- [() | ExFormation inner <- rho, BiTau (AtLabel "as-bytes") _ <- inner] `shouldBe` [()]+ -- the times application is gone: ρ is the number it answered, named+ -- by the path it is reached by instead of copied out (#1446)+ [() | ExApplication (ExDispatch ExRoot (AtLabel "number")) (ArTau AtPhi _) <- rho] `shouldBe` [()] other -> expectationFailure ("expected a residual formation, got " ++ show other) it "writes the firing that answered into the protocol and stops at the stuck one" $ do (_, protocol) <- partially known "2.times(3).nope" protocol `shouldBe` unlines- [ " 𝔼(L_number_times) # 𝕄(Φ)"- , " 𝛿1.1 := 40-00-00-00-00-00-00-00 # 𝔻(ξ.ρ)"- , " 𝛿2.1 := 40-08-00-00-00-00-00-00 # 𝔻(ξ.x)"- , " 𝑛.1.1 := Φ.number( φ ↦ 𝜎1:λ ) # 𝑛"- , " 𝑛.1.2 := ⟦ φ ↦ 𝜎1:λ, as-bytes ↦ φ, plus(ρ, x) ↦ ⟦ λ ⤍ L_number_plus ⟧, times(ρ, x) ↦ ⟦ λ ⤍ L_number_times ⟧, div(ρ, x) ↦ ⟦ λ ⤍ L_number_div ⟧, gt(ρ, x) ↦ ⟦ λ ⤍ L_number_gt ⟧, eq(ρ, x) ↦ ⟦ φ ↦ ρ.as-bytes.eq( x.as-bytes ) ⟧, nope(ρ) ↦ ⟦ λ ⤍ L_number_nope ⟧ ⟧ # 𝕄(𝑛.1.1)"- , " ?(L_number_nope) # 𝔻(⟦ ρ ↦ ⟦ φ ↦ 𝜎1:λ, as-bytes ↦ φ, plus(ρ, x) ↦ ⟦ λ ⤍ L_number_plus ⟧, times(ρ, x) ↦ ⟦ λ ⤍ L_number_times ⟧, div(ρ, x) ↦ ⟦ λ ⤍ L_number_div ⟧, gt(ρ, x) ↦ ⟦ λ ⤍ L_number_gt ⟧, eq(ρ, x) ↦ ⟦ φ ↦ ρ.as-bytes.eq( x.as-bytes ) ⟧, nope(ρ) ↦ ⟦ λ ⤍ L_number_nope ⟧ ⟧, λ ⤍ L_number_nope ⟧)"+ [ " formation(⟦ bytes(φ) ↦ ⟦ not(ρ) ↦ L_bytes_not:λ, eq(ρ, b) ↦ L_bytes_eq:λ ⟧, bool(φ) ↦ ⟦ if(ρ, then, else) ↦ L_fork:λ ⟧, number(φ) ↦ ⟦ as-bytes ↦ φ, plus(ρ, x) ↦ L_number_plus:λ, times(ρ, x) ↦ L_number_times:λ, div(ρ, x) ↦ L_number_div:λ, gt(ρ, x) ↦ L_number_gt:λ, eq(ρ, x) ↦ ρ.as-bytes.eq( x.as-bytes ):φ, nope(ρ) ↦ L_number_nope:λ ⟧, φ ↦ 2.times( 3 ).nope ⟧) # 𝔻(Φ)"+ , " 𝔼(L_number_times) # 𝕄(Φ)"+ , " formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-00-00-00-00-00-00-00:Δ ), as-bytes ↦ φ, plus(ρ, x) ↦ L_number_plus:λ, times(ρ, x) ↦ L_number_times:λ, div(ρ, x) ↦ L_number_div:λ, gt(ρ, x) ↦ L_number_gt:λ, eq(ρ, x) ↦ ρ.as-bytes.eq( x.as-bytes ):φ, nope(ρ) ↦ L_number_nope:λ ⟧) # 𝔻(Φ.a🌵17)"+ , " formation(⟦ φ ↦ 40-00-00-00-00-00-00-00:Δ, not(ρ) ↦ L_bytes_not:λ, eq(ρ, b) ↦ L_bytes_eq:λ ⟧) # 𝔻(Φ.a🌵17)"+ , " 𝛿1.1 := 40-00-00-00-00-00-00-00 # 𝔻(ξ.ρ)"+ , " formation(⟦ φ ↦ Φ.bytes( φ ↦ 40-08-00-00-00-00-00-00:Δ ), as-bytes ↦ φ, plus(ρ, x) ↦ L_number_plus:λ, times(ρ, x) ↦ L_number_times:λ, div(ρ, x) ↦ L_number_div:λ, gt(ρ, x) ↦ L_number_gt:λ, eq(ρ, x) ↦ ρ.as-bytes.eq( x.as-bytes ):φ, nope(ρ) ↦ L_number_nope:λ ⟧) # 𝔻(Φ.a🌵18)"+ , " formation(⟦ φ ↦ 40-08-00-00-00-00-00-00:Δ, not(ρ) ↦ L_bytes_not:λ, eq(ρ, b) ↦ L_bytes_eq:λ ⟧) # 𝔻(Φ.a🌵18)"+ , " 𝛿2.1 := 40-08-00-00-00-00-00-00 # 𝔻(ξ.x)"+ , " 𝑛.1.1 := Φ.number( φ ↦ 𝜎1:λ ) # 𝑛"+ , " 𝑛.1.2 := ⟦ φ ↦ 𝜎1:λ, as-bytes ↦ φ, plus(ρ, x) ↦ L_number_plus:λ, times(ρ, x) ↦ L_number_times:λ, div(ρ, x) ↦ L_number_div:λ, gt(ρ, x) ↦ L_number_gt:λ, eq(ρ, x) ↦ ρ.as-bytes.eq( x.as-bytes ):φ, nope(ρ) ↦ L_number_nope:λ ⟧ # 𝕄(𝑛.1.1)"+ , " ?(L_number_nope) # 𝔻(⟦ ρ ↦ Φ.number( φ ↦ 𝜎1:λ ), λ ⤍ L_number_nope ⟧)" ] it "leaves an unanswered λ function dataized directly as the whole residue" $ do ((outcome, chain), protocol) <- partially known "[[ L> Sym_arg_0 ]]" outcome `shouldBe` Residual placeholder- protocol `shouldBe` " ?(Sym_arg_0) # 𝔻(Sym_arg_0:λ)\n"+ protocol `shouldBe` " formation(⟦ bytes(φ) ↦ ⟦ not(ρ) ↦ L_bytes_not:λ, eq(ρ, b) ↦ L_bytes_eq:λ ⟧, bool(φ) ↦ ⟦ if(ρ, then, else) ↦ L_fork:λ ⟧, number(φ) ↦ ⟦ as-bytes ↦ φ, plus(ρ, x) ↦ L_number_plus:λ, times(ρ, x) ↦ L_number_times:λ, div(ρ, x) ↦ L_number_div:λ, gt(ρ, x) ↦ L_number_gt:λ, eq(ρ, x) ↦ ρ.as-bytes.eq( x.as-bytes ):φ, nope(ρ) ↦ L_number_nope:λ ⟧, φ ↦ Sym_arg_0:λ ⟧) # 𝔻(Φ)\n ?(Sym_arg_0) # 𝔻(Sym_arg_0:λ)\n" map fst chain `shouldEndWith` [placeholder] it "still reaches the manufactured datum when nothing is stuck" $ do ((outcome, _), _) <- partially known "2.times(3)"@@ -285,12 +291,12 @@ forM_ [ ( "--max-cycles"- , ReduceContext ExRoot ExRoot Nothing 25 0 (Steps 250 0) 1 True True False False False Dataization [] Map.empty Map.empty emptyLambdas buildTerm reduction evaluation fired dontSaveStep dontSaveEval+ , ReduceContext ExRoot ExRoot Nothing 25 0 (Steps 250 0) Nothing Nothing 1 True True False False Nothing Dataization [] Map.empty emptyLambdas buildTerm reduction evaluation fired dontSaveStep dontSaveEval , "--max-cycles=0" ) , ( "--max-depth"- , ReduceContext ExRoot ExRoot Nothing 0 25 (Steps 250 0) 1 True True False False False Dataization [] Map.empty Map.empty emptyLambdas buildTerm reduction evaluation fired dontSaveStep dontSaveEval+ , ReduceContext ExRoot ExRoot Nothing 0 25 (Steps 250 0) Nothing Nothing 1 True True False False Nothing Dataization [] Map.empty emptyLambdas buildTerm reduction evaluation fired dontSaveStep dontSaveEval , "--max-depth=0" ) ]@@ -300,8 +306,8 @@ dataize expr emptyState ctx `shouldThrow` (\e -> message `isInfixOf` show (e :: SomeException)) ) forM_- [ ("--max-cycles", ReduceContext ExRoot ExRoot Nothing 25 0 (Steps 250 0) 1 False True False False False Dataization [] Map.empty Map.empty emptyLambdas buildTerm reduction evaluation fired dontSaveStep dontSaveEval)- , ("--max-depth", ReduceContext ExRoot ExRoot Nothing 0 25 (Steps 250 0) 1 False True False False False Dataization [] Map.empty Map.empty emptyLambdas buildTerm reduction evaluation fired dontSaveStep dontSaveEval)+ [ ("--max-cycles", ReduceContext ExRoot ExRoot Nothing 25 0 (Steps 250 0) Nothing Nothing 1 False True False False Nothing Dataization [] Map.empty emptyLambdas buildTerm reduction evaluation fired dontSaveStep dontSaveEval)+ , ("--max-depth", ReduceContext ExRoot ExRoot Nothing 0 25 (Steps 250 0) Nothing Nothing 1 False True False False Nothing Dataization [] Map.empty emptyLambdas buildTerm reduction evaluation fired dontSaveStep dontSaveEval) ] ( \(flag, ctx) -> it ("does not throw without --depth-sensitive even once " ++ flag ++ " is exhausted") $ do@@ -369,4 +375,4 @@ ] it "dataizes a located reference through the expected rules" $ do labels <- labelsOf "Q.foo.bar" "[[ foo -> [[ bar -> [[ @ -> Q.x ]] ]], x -> [[ D> 42- ]] ]]"- labels `shouldBe` ["contextualize", "md", "dotg", "skip", "mf", "delta"]+ labels `shouldBe` ["contextualize", "md", "dot", "skip", "mf", "delta"]
test/DepsSpec.hs view
@@ -1,14 +1,18 @@+{-# LANGUAGE OverloadedStrings #-}+ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT module DepsSpec where -import AST (Expression (ExRoot))+import AST (Expression (ExRoot, ExXi)) import Control.Exception (bracket)-import Control.Monad (when)+import Control.Monad (replicateM_, when)+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.List (isInfixOf) import Data.Time.Clock.POSIX (getPOSIXTime)-import Deps (dontSaveStep, saveStep)-import Logger (LogLevel (DEBUG, ERROR), setLogConfig)+import Deps (Evaluation (EvFiring, EvFormation, EvRun), Judgment (Morphing), dontSaveEval, dontSaveStep, emptyProgress, progressed, saveStep)+import Logger (LogLevel (DEBUG, ERROR, INFO), setLogConfig) import System.Directory ( doesDirectoryExist , doesFileExist@@ -17,8 +21,8 @@ ) import System.FilePath ((</>)) import System.IO (stderr)-import System.IO.Silently (hSilence)-import Test.Hspec (Spec, describe, it, shouldBe)+import System.IO.Silently (hCapture_, hSilence)+import Test.Hspec (Spec, after_, describe, it, shouldBe, shouldSatisfy) withScratchDir :: (FilePath -> IO a) -> IO a withScratchDir =@@ -57,3 +61,41 @@ saveStep (Just dir) "txt" (pure . show) 42 ExRoot exists <- doesFileExist (dir </> "00042.txt") exists `shouldBe` True++ describe "progressed" $ after_ (setLogConfig ERROR 25) $ do+ it "passes every record on to the recording function it wraps" $ do+ cursor <- newIORef (emptyProgress 0)+ seen <- newIORef (0 :: Int)+ hSilence [stderr] (mapM_ (progressed cursor 3600 (const (pure "Φ.q")) (const (modifyIORef' seen (+ 1)))) [EvRun Morphing "Φ", EvFiring 1 "L_x" Morphing ExXi, EvFormation 2 ExRoot ExXi])+ count <- readIORef seen+ count `shouldBe` 3++ it "counts the firings when the interval has passed" $ do+ setLogConfig INFO 25+ cursor <- newIORef (emptyProgress 0)+ captured <- hCapture_ [stderr] (replicateM_ 7 (progressed cursor 0 (const (pure "Φ.q")) dontSaveEval (EvFiring 1 "L_y" Morphing ExXi)))+ last (lines captured) `shouldSatisfy` isInfixOf "fired 7 λ functions"++ it "counts the formations entered when the interval has passed" $ do+ setLogConfig INFO 25+ cursor <- newIORef (emptyProgress 0)+ captured <- hCapture_ [stderr] (replicateM_ 4 (progressed cursor 0 (const (pure "Φ.q")) dontSaveEval (EvFormation 3 ExRoot ExXi)))+ last (lines captured) `shouldSatisfy` isInfixOf "Entered 4 formations"++ it "names the site of the latest record" $ do+ setLogConfig INFO 25+ cursor <- newIORef (emptyProgress 0)+ captured <- hCapture_ [stderr] (progressed cursor 0 (const (pure "Φ.org.ёж")) dontSaveEval (EvFiring 2 "L_z" Morphing ExXi))+ captured `shouldSatisfy` isInfixOf "now at Φ.org.ёж"++ it "stays silent on a record that comes before the interval has passed" $ do+ setLogConfig INFO 25+ cursor <- newIORef (emptyProgress 0)+ captured <- hCapture_ [stderr] (replicateM_ 5 (progressed cursor 3600 (const (pure "Φ.q")) dontSaveEval (EvFiring 1 "L_w" Morphing ExXi)))+ length (lines captured) `shouldBe` 1++ it "says nothing about a record that carries no site" $ do+ setLogConfig INFO 25+ cursor <- newIORef (emptyProgress 0)+ captured <- hCapture_ [stderr] (progressed cursor 0 (const (pure "Φ.q")) dontSaveEval (EvRun Morphing "Φ.k"))+ captured `shouldBe` ""
test/EvaluateSpec.hs view
@@ -13,11 +13,11 @@ import Control.Exception (SomeException) import Control.Monad import Data.Aeson (FromJSON (parseJSON), camelTo2, defaultOptions, fieldLabelModifier, genericParseJSON)-import Data.List (isInfixOf)+import Data.List (find, isInfixOf) import Data.Maybe (fromMaybe) import Data.Text qualified as T import Data.Yaml qualified as Decode-import Deps (Evaluation (EvRun), Judgment (Morphing), Term (TeExpression))+import Deps (Acyclic, Evaluation (EvRun), Judgment (Morphing), Term (TeExpression), certainty) import Encoding (Encoding (UNICODE)) import Files (allPathsIn) import Fixtures (defaultReduceContext, fixtureLambdas, recorded, recorded', withLambdas, withLambdasOf)@@ -26,7 +26,7 @@ import Lining (LineFormat (SINGLELINE)) import Margin (defaultMargin) import Matcher (substEmpty)-import Morph (ReduceContext (..), Steps (..), execBuildTerm, morph)+import Morph (ReduceContext (..), Steps (..), execBuildTerm, memoized, morph) import Parser (parseExpressionThrows) import Printer (printExpression, printExpression', printExpressionHidingRho') import Sugar (SugarType (SWEET))@@ -45,14 +45,16 @@ -- two of them verbatim. Every term of both is spelled without its ρ bindings, -- the way '--hide-rho' spells one, unless the pack says 'hide-rho: false': the -- ρ chain is the universe an entry was fired inside and not the answer it gave,--- so spelling it buries the symbol a pack is there to show (#1313).+-- so spelling it buries the symbol a pack is there to show (#1313). A pack+-- saying 'acyclic: plausible' runs with the memo that mode keeps, so the+-- protocol it spells is the one of a run firing every formation once. data SymbolPack = SymbolPack { symbolic :: String , location :: Maybe String , input :: String , deep :: Maybe Bool , partial :: Maybe Bool- , acyclic :: Maybe Bool+ , acyclic :: Maybe String , steps :: Maybe Int , protocol :: String , result :: Maybe String@@ -81,11 +83,14 @@ withLambdasOf (T.pack symbolic) $ \file -> do known <- readLambdas file (_, written) <- recorded' hidden $ \record -> do+ let mode = named <$> acyclic+ cells <- memoized mode let ctx = (defaultReduceContext loc) { _deep = deep == Just True , _partial = partial == Just True- , _acyclic = acyclic == Just True+ , _acyclic = mode+ , _memo = cells , _steps = Steps (fromMaybe 250 steps) 0 , _symbolic = known , _saveEval = record@@ -101,6 +106,10 @@ spelled hidden morphed `shouldBe` spelled False expected written `shouldBe` protocol where+ -- The mode of '--acyclic' a pack names, which has to be one the option+ -- knows, or the pack is broken and says so rather than running unguarded.+ named :: String -> Acyclic+ named mode = fromMaybe (error ("The pack names an unknown mode of acyclic: " ++ mode)) (find ((== mode) . certainty) [minBound .. maxBound]) -- How a pack spells a program: 𝜑 on one line, in the sugar the protocol -- writes its own terms with. The answer goes through it with the ρ bindings -- hidden where the pack hides them and the 'result' of the pack goes
test/Fixtures.hs view
@@ -49,7 +49,7 @@ -- none of them: a case that needs one to answer brings the fixture file in -- through 'withLambdas'. defaultReduceContext :: Expression -> ReduceContext-defaultReduceContext loc = ReduceContext loc loc Nothing 25 25 (Steps 250 0) 1 False True False False False Morphing [] Map.empty Map.empty emptyLambdas buildTerm reduction evaluation fired dontSaveStep dontSaveEval+defaultReduceContext loc = ReduceContext loc loc Nothing 25 25 (Steps 250 0) Nothing Nothing 1 False True False False Nothing Morphing [] Map.empty emptyLambdas buildTerm reduction evaluation fired dontSaveStep dontSaveEval -- The same context with the given λ functions registered withLambdas :: Lambdas -> ReduceContext -> ReduceContext@@ -141,6 +141,7 @@ PrintCtx SWEET hidden+ False MULTILINE 2 defaultXmirContext
test/LaTeXSpec.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} @@ -11,8 +13,12 @@ import AST (Attribute (AtLabel, AtMeta, AtPhi, AtRho), Binding (BiDelta, BiLambda, BiMeta, BiTau, BiVoid), Bytes (BtMeta, BtOne), Expression (ExDispatch, ExFormation, ExMeta, ExPhiAgain, ExPhiMeet, ExRoot), Function (FnMeta, FnSymbol)) import Control.Monad (forM_)+import Data.Aeson (FromJSON) import Data.List (intercalate) import Data.Text qualified as T+import Data.Yaml qualified as Yaml+import Files (allPathsIn)+import GHC.Generics (Generic) import LaTeX ( LatexContext (..) , conditionToLatex@@ -28,11 +34,32 @@ ) import Lining (LineFormat (MULTILINE)) import Parser (parseExpressionThrows)-import Test.Hspec (Spec, describe, expectationFailure, it, shouldBe, shouldContain)+import System.FilePath (makeRelative)+import Test.Hspec (Spec, describe, expectationFailure, it, runIO, shouldBe, shouldContain) import Yaml qualified as Y +data LatexPack = LatexPack+ { expression :: String+ , result :: String+ }+ deriving (Generic, Show, FromJSON)++latexPack :: FilePath -> IO LatexPack+latexPack = Yaml.decodeFileThrow+ spec :: Spec spec = do+ describe "LaTeX printing packs" $ do+ let resources = "test-resources/latex-packs"+ packs <- runIO (allPathsIn resources)+ forM_+ packs+ ( \pth -> it (makeRelative resources pth) $ do+ pack <- latexPack pth+ parsed <- parseExpressionThrows (expression pack)+ expressionToLaTeX parsed defaultLatexContext `shouldBe` result pack+ )+ describe "meet expression in expression" $ forM_ [ ("Q.x.y", "Q.x.y", "[[ x -> Q.x.y ]]", ["Q.x.y"])@@ -245,7 +272,6 @@ { name = "myrule" , label = Just "disp" , description = Nothing- , ematch = Nothing , pattern = ExMeta "n" , result = ExMeta "n" , when = Just (Y.NF (ExMeta "n"))@@ -278,7 +304,6 @@ { name = "lambdas" , label = Nothing , description = Nothing- , ematch = Nothing , pattern = ExFormation [BiMeta "B1", BiLambda (FnMeta "f"), BiMeta "B2"] , result = ExFormation [BiLambda (FnSymbol 1)] , when = Nothing@@ -299,7 +324,6 @@ { name = "myrule2" , label = Nothing , description = Nothing- , ematch = Nothing , pattern = ExMeta "n" , result = ExMeta "n" , when = Nothing@@ -320,7 +344,6 @@ { name = "myrule3" , label = Nothing , description = Nothing- , ematch = Nothing , pattern = ExMeta "n" , result = ExMeta "n" , when = Nothing@@ -442,7 +465,6 @@ { name = "norm1" , label = Nothing , description = Nothing- , ematch = Nothing , pattern = ExDispatch (ExMeta "n1") (AtMeta "t1") , result = ExMeta "n1" , when = Just (Y.IsFormation (ExMeta "n1"))
test/LambdasSpec.hs view
@@ -160,7 +160,8 @@ -- discover that one of its λ functions cannot be read at all forM_ [ ("a file which is no list of entries" :: String, "λ: L_pair\n" :: T.Text, "cannot be read" :: String)- , ("an entry with no answer at all", "- λ: L_pair\n", "cannot be read")+ , ("an entry with no λ key", "- 𝑛: ⟦ λ ⤍ 𝜎 ⟧\n", "no 'λ' key")+ , ("an entry with no answer at all", "- λ: L_pair\n", "no '𝑛' key") , ("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") ,
test/LoggerSpec.hs view
@@ -4,7 +4,7 @@ module LoggerSpec where import Control.Monad (forM_)-import Logger (LogLevel (..), logDebug, logError, setLogConfig)+import Logger (LogLevel (..), logDebug, logError, logInfo, setLogConfig) import System.IO (stderr) import System.IO.Silently (hCapture_) import Test.Hspec (Spec, after_, describe, it, shouldBe)@@ -47,10 +47,23 @@ captured `shouldBe` expected ) + describe "logInfo" $+ forM_+ [ ("prints when the level allows info messages", INFO, 25, "[INFO]: fired 7\n")+ , ("prints at the debug level too, since info is more severe", DEBUG, 25, "[INFO]: fired 7\n")+ , ("is suppressed when the configured level is above info", ERROR, 25, "")+ ]+ ( \(desc, level, lineLimit, expected) -> it desc $ do+ setLogConfig level lineLimit+ captured <- hCapture_ [stderr] (logInfo "fired 7")+ captured `shouldBe` expected+ )+ describe "logError" $ forM_ [ ("prints when the level allows error messages", ERROR, 25, "[ERROR]: oops\n") , ("prints at the debug level too, since error is more severe", DEBUG, 25, "[ERROR]: oops\n")+ , ("prints at the info level too, since error is more severe", INFO, 25, "[ERROR]: oops\n") , ("is suppressed when the configured level is NONE", NONE, 25, "") , ("is suppressed when the line limit is zero", ERROR, 0, "") ]
test/MatcherSpec.hs view
@@ -506,6 +506,62 @@ ] (\(desc, ptn, tgt, expected) -> it desc (matchExpression ptn tgt `shouldBe` expected)) + describe "reachable" $ do+ it "reaches a redex standing deep inside a formation" $+ reachable+ (ExDispatch (ExFormation [BiMeta "B1"]) (AtMeta "t1"))+ (ExFormation [BiTau (AtLabel "kw") (ExFormation [BiTau (AtLabel "zu") (ExDispatch (ExFormation []) (AtLabel "qo"))])])+ `shouldBe` True+ it "does not reach a dispatch whose head is no formation" $+ reachable+ (ExDispatch (ExFormation [BiMeta "B1"]) (AtMeta "t1"))+ (ExFormation [BiTau (AtLabel "kw") (ExDispatch (ExDispatch ExRoot (AtLabel "zu")) (AtLabel "qo"))])+ `shouldBe` False+ it "does not reach a formation lacking the λ the pattern asks for" $+ reachable+ (ExFormation [BiMeta "B1", BiLambda (FnMeta "f"), BiMeta "B2"])+ (ExFormation [BiTau (AtLabel "kw") (ExFormation [BiDelta (BtOne "9E")])])+ `shouldBe` False+ it "does not reach an application handing an attribute other than the one the pattern names" $+ reachable+ (ExApplication (ExFormation [BiMeta "B1"]) (ArTau AtRho (ExMeta "e1")))+ (ExApplication (ExFormation []) (ArTau (AtLabel "vy") ExRoot))+ `shouldBe` False+ it "reaches a redex in the argument of an application" $+ reachable+ (ExDispatch ExTermination (AtMeta "t"))+ (ExApplication (ExDispatch ExRoot (AtLabel "hp")) (ArTau (AtLabel "yd") (ExDispatch ExTermination (AtLabel "ob"))))+ `shouldBe` True+ it "does not reach into a term the deep matcher never enters" $+ reachable+ (ExDispatch ExTermination (AtMeta "t"))+ (ExPhiMeet Nothing 3 (ExDispatch ExTermination (AtLabel "ob")))+ `shouldBe` False+ it "reaches any term with a bare meta" $+ reachable (ExMeta "e1") ExXi `shouldBe` True++ describe "fitting" $ do+ it "fits a dispatch of a formation holding the attribute the pattern names" $+ fitting+ (ExDispatch (ExFormation [BiMeta "B1", BiTau (AtMeta "t1") (ExMeta "e1"), BiMeta "B2"]) (AtMeta "t1"))+ (ExDispatch (ExFormation [BiVoid (AtLabel "wu"), BiTau (AtLabel "kx") ExRoot]) (AtLabel "kx"))+ `shouldBe` True+ it "does not fit a redex standing below the root" $+ fitting+ (ExDispatch (ExFormation [BiMeta "B1"]) (AtMeta "t1"))+ (ExFormation [BiTau (AtLabel "kw") (ExDispatch (ExFormation []) (AtLabel "qo"))])+ `shouldBe` False+ it "does not fit a dispatch of another attribute" $+ fitting+ (ExDispatch (ExMeta "e1") AtRho)+ (ExDispatch ExXi (AtLabel "zo"))+ `shouldBe` False+ it "does not fit a formation lacking the Δ the pattern asks for" $+ fitting+ (ExFormation [BiDelta (BtMeta "d1"), BiMeta "B1"])+ (ExFormation [BiLambda (Function "Lq"), BiVoid AtRho])+ `shouldBe` False+ describe "combine" $ forM_ [ ("combines two empty substitutions", substEmpty, substEmpty, Just substEmpty)@@ -542,6 +598,36 @@ it "dont cut the target anew at every index a meta binding may end at" $ do matched <- timeout 5000000 (evaluate (length (matchExpression dot (ExDispatch (crowd 3000) (AtLabel "d1"))))) matched `shouldBe` Just 1++ describe "matchExpressionDeep'" $ do+ it "does not look inside an inert term for a redex" $+ matchExpressionDeep' True (ExMeta "e1") (ExFormation [BiTau (AtLabel "oq") (ExDispatch ExXi (AtLabel "ze"))]) `shouldBe` []+ it "looks inside an inert term for what is no redex" $+ length (matchExpressionDeep' False (ExMeta "e1") (ExFormation [BiTau (AtLabel "oq") (ExDispatch ExXi (AtLabel "ze"))])) `shouldBe` 3+ it "finds a redex standing beside an inert term" $+ matchExpressionDeep' True (ExDispatch ExTermination (AtMeta "t1")) (ExFormation [BiTau (AtLabel "ux") (ExFormation [BiVoid AtRho]), BiTau (AtLabel "xu") (ExDispatch ExTermination (AtLabel "vo"))])+ `shouldBe` substs [[("t1", MvAttribute (AtLabel "vo"))]]++ describe "reachable'" $+ it "does not reach into an inert term for a redex" $+ reachable' True (ExMeta "e1") (ExDispatch (ExDispatch ExRoot (AtLabel "gh")) (AtLabel "hg")) `shouldBe` False++ describe "pinned" $+ it "writes the attribute in place of its meta wherever the meta stands" $+ pinned (AtMeta "t1") (AtLabel "wk") (ExFormation [BiMeta "B1", BiTau (AtMeta "t1") (ExDispatch ExXi (AtMeta "t1")), BiVoid (AtMeta "t2")])+ `shouldBe` ExFormation [BiMeta "B1", BiTau (AtLabel "wk") (ExDispatch ExXi (AtLabel "wk")), BiVoid (AtMeta "t2")]++ describe "matchExpression' of a dispatch naming a meta attribute" $+ it "binds the attribute the dispatch names and nothing else" $+ matchExpression' dot (ExDispatch (ExFormation [BiTau (AtLabel "pa") ExRoot, BiTau (AtLabel "ap") ExXi, BiVoid AtRho]) (AtLabel "ap"))+ `shouldBe` substs+ [+ [ ("B1", MvBindings [BiTau (AtLabel "pa") ExRoot])+ , ("t1", MvAttribute (AtLabel "ap"))+ , ("n1", MvExpression ExXi)+ , ("B2", MvBindings [BiVoid AtRho])+ ]+ ] where -- The pattern of the 'dot' normalization rule, the one every dispatch of a -- program is matched against: a meta binding on either side of the binding
test/MiscSpec.hs view
@@ -10,8 +10,7 @@ import Control.Monad (forM_) import Data.Either (isLeft, isRight) import Misc- ( attributeFromBinding- , attributesFromBindings+ ( attributesFromBindings , attributesFromBindings' , fqnToAttrs , orThrow@@ -36,16 +35,6 @@ case result of Left err -> show err `shouldContain` "boom" Right _ -> fail "expected orThrow to throw"-- describe "attributeFromBinding" $- forM_- [ ("BiTau yields its attribute", BiTau AtRho ExRoot, Just AtRho)- , ("BiVoid yields its attribute", BiVoid AtPhi, Just AtPhi)- , ("BiDelta yields AtDelta", BiDelta BtEmpty, Just AtDelta)- , ("BiLambda yields AtLambda", BiLambda (Function "F"), Just AtLambda)- , ("BiMeta yields Nothing", BiMeta "B", Nothing)- ]- (\(desc, binding, expected) -> it desc (attributeFromBinding binding `shouldBe` expected)) describe "attributesFromBindings" $ forM_
test/MorphSpec.hs view
@@ -14,6 +14,7 @@ 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)@@ -105,6 +106,17 @@ map snd chain `shouldBe` [Just "mf", Nothing] map fst chain `shouldBe` [expr, expr] + -- The 'universe' rule resolves Φ to the world in normal form, and the run+ -- has named that world before its first step, so no part of the program is+ -- normalized again for it: the steps reducing the body of 'w' used to be+ -- taken, and saved, on every resolution of Φ (#1453)+ it "resolves Φ to the world it has already normalized" $ do+ expr <- parseExpressionThrows "[[ w -> [[ k -> [[ ]] ]].k, y -> Q.w ]]"+ loc <- parseExpressionThrows "Q.y"+ saved <- newIORef (0 :: Int)+ _ <- morph expr emptyState (defaultReduceContext loc){_saveStep = const (modifyIORef' saved (+ 1))}+ readIORef saved `shouldReturn` 2+ -- 𝕄 stops at the first formation 'mf' hands back and leaves its bindings as -- they were written, since firing a bare λ is 𝔻's business, so a program -- whose parts nothing demands is never reduced (#1124). The deep walk@@ -264,11 +276,11 @@ -- two clauses are mutually exclusive and their order in 'resources/morphing' -- cannot change behavior. describe "morphing 'md' is disjoint from 'ml'" $ do- let rctx = RuleContext (execBuildTerm ExRoot (defaultReduceContext ExRoot))+ let rctx = RuleContext (execBuildTerm ExRoot (defaultReduceContext ExRoot)) Nothing morphRule :: String -> Yaml.MorphRule morphRule nm = fromMaybe (error ("no morphing rule named " ++ nm)) (find (\r -> r.name == nm) Yaml.morphingRules) asRule :: Yaml.MorphRule -> Yaml.Rule- asRule r = Yaml.Rule r.name Nothing Nothing r.match Nothing ExRoot r.when Nothing Nothing+ asRule r = Yaml.Rule r.name Nothing Nothing r.match ExRoot r.when Nothing Nothing lambdaFormation = ExFormation [BiLambda (Function "L_dummy"), BiVoid AtRho] it "does not fire on a λ-bearing formation dispatch" $ do substs <- matchExpressionWithRule' [substEmpty] (ExDispatch lambdaFormation (AtLabel "x")) (asRule (morphRule "md")) rctx
test/ParserSpec.hs view
@@ -706,6 +706,11 @@ , ("[[ x -> ?:a ]]", "⟦ x ↦ ⟦ a ↦ ∅ ⟧ ⟧") , ("Q.x(y -> ?:a)", "Q.x(y ↦ ⟦ a ↦ ∅ ⟧)") , ("Q.x(α0 ↦ Plus:λ)", "Q.x(α0 ↦ ⟦ λ ⤍ Plus ⟧)")+ , ("⟦ x(y) ↦ 42:a ⟧", "⟦ x ↦ ⟦ y ↦ ∅, a ↦ 42 ⟧ ⟧")+ , ("⟦ x(y) ↦ 42:a:b ⟧", "⟦ x ↦ ⟦ y ↦ ∅, b ↦ ⟦ a ↦ 42 ⟧ ⟧ ⟧")+ , ("⟦ x(y, z) ↦ ∅:a ⟧", "⟦ x ↦ ⟦ y ↦ ∅, z ↦ ∅, a ↦ ∅ ⟧ ⟧")+ , ("[[ x(y) -> Plus:L ]]", "⟦ x ↦ ⟦ y ↦ ∅, λ ⤍ Plus ⟧ ⟧")+ , ("Q.x(y(z) ↦ FF-:Δ)", "Q.x(y ↦ ⟦ z ↦ ∅, Δ ⤍ FF- ⟧)") ] ( \(sweet, plain) -> it sweet $ do@@ -719,4 +724,12 @@ ( map (\ipt -> (ipt, Nothing :: Maybe Expression)) ["FF-AA:φ", "Plus:x", "∅:Δ", "ξ.a:", ":φ", "ξ.a:Δ", "ξ.a:λ"]+ )++ describe "rejects what inline voids open unless it is a formation" $+ test+ parseExpression+ ( map+ (\ipt -> (ipt, Nothing :: Maybe Expression))+ ["⟦ x(y) ↦ 42 ⟧", "⟦ x(y) ↦ 42:a.b ⟧", "⟦ x(y) ↦ 42:a(z) ⟧", "⟦ x(y) ↦ ξ.a ⟧", "Q.x(y(z) ↦ FF-:Δ.b)"] )
test/PrinterSpec.hs view
@@ -422,7 +422,7 @@ , ("⟦ φ ↦ ξ.a ⟧", SWEET, ASCII, "a:@") , ("⟦ x ↦ ⟦ y ↦ ξ.z ⟧ ⟧", SWEET, UNICODE, "z:y:x") , ("⟦ x ↦ ⟦ φ ↦ ξ.a ⟧.b ⟧", SWEET, UNICODE, "a:φ.b:x")- , ("⟦ x(a) ↦ ⟦ φ ↦ a ⟧ ⟧", SWEET, UNICODE, "⟦ x(a) ↦ ⟦ φ ↦ a ⟧ ⟧")+ , ("⟦ x(a) ↦ ⟦ φ ↦ a ⟧ ⟧", SWEET, UNICODE, "⟦ x(a) ↦ a:φ ⟧") , ("⟦ x ↦ ξ.a, y ↦ ∅ ⟧", SWEET, UNICODE, "⟦ x ↦ a, y ↦ ∅ ⟧") , ("⟦ x ↦ ξ.a ⟧", SALTY, UNICODE, "⟦ x ↦ ξ.a ⟧") , ("⟦ Δ ⤍ FF-AA ⟧", SALTY, ASCII, "[[ D> FF-AA ]]")
test/RenderSpec.hs view
@@ -329,6 +329,12 @@ , CO_DISJOINT [AT_LABEL "a", AT_LABEL "b"] [bindingXi "x", bindingXi "y"] , "[ a \\char44{} b ] \\cap \\lparen x ↦ ξ \\cup y ↦ ξ \\rparen = \\emptyset" )+ ,+ ( "CO_SUBSET"+ , CO_SUBSET [AT_LABEL "a", AT_LABEL "b"] IN [bindingXi "x", bindingXi "y"]+ , "[ a \\char44{} b ] \\subseteq \\lparen x ↦ ξ \\cup y ↦ ξ \\rparen"+ )+ , ("CO_SUBSET negated", CO_SUBSET [AT_LABEL "a"] NOT_IN [bindingXi "x"], "[ a ] \\not\\subseteq x ↦ ξ") , ("CO_EMPTY", CO_EMPTY, "") ] (\(desc, node, expected) -> it desc (render node `shouldBe` expected))
test/ReplacerSpec.hs view
@@ -332,3 +332,22 @@ , ExFormation [BiTau (AtLabel "z") ExRoot] ) ]++ describe "replace expression inside an inert term" $+ test+ replaceExpression+ [+ ( "Q -> [[ vt -> ξ.ek ]] => ([ξ.ek], [Φ]) => Q -> [[ vt -> Φ ]] (an inert pattern is still looked for inside an inert term)"+ , ExFormation [BiTau (AtLabel "vt") (ExDispatch ExXi (AtLabel "ek"))]+ , [ExDispatch ExXi (AtLabel "ek")]+ , [ExRoot]+ , ExFormation [BiTau (AtLabel "vt") ExRoot]+ )+ ,+ ( "Q -> [[ vt -> ξ.ek, te -> ⊥.ke ]] => ([⊥.ke], [Φ]) => Q -> [[ vt -> ξ.ek, te -> Φ ]] (a redex beside an inert term is replaced)"+ , ExFormation [BiTau (AtLabel "vt") (ExDispatch ExXi (AtLabel "ek")), BiTau (AtLabel "te") (ExDispatch ExTermination (AtLabel "ke"))]+ , [ExDispatch ExTermination (AtLabel "ke")]+ , [ExRoot]+ , ExFormation [BiTau (AtLabel "vt") (ExDispatch ExXi (AtLabel "ek")), BiTau (AtLabel "te") ExRoot]+ )+ ]
test/RuleSpec.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com@@ -7,7 +8,8 @@ module RuleSpec where -import AST (Argument (..), Attribute (..), Binding (..), Bytes (..), Expression (..), Function (..))+import AST (Argument (..), Attribute (..), Binding (..), Bytes (..), Expression (..), Function (..), inert)+import Builder (buildExpressionThrows) import Control.Monad import Data.Aeson import Data.Yaml qualified as Y@@ -15,10 +17,11 @@ import Functions (buildTerm) import GHC.Generics import Matcher+import Parser (parseExpressionThrows) import Printer (printSubsts)-import Rule (RuleContext (RuleContext), isNF, matchExpressionWithRule, meetCondition)+import Rule (RuleContext (RuleContext), isNF, matchExpressionWithRule, meetCondition, redex) import System.FilePath-import Test.Hspec (Spec, describe, expectationFailure, it, runIO, shouldBe, shouldSatisfy)+import Test.Hspec (Spec, describe, expectationFailure, it, runIO, shouldBe, shouldReturn, shouldSatisfy) import Yaml qualified data ConditionPack = ConditionPack@@ -41,7 +44,7 @@ let expr = expression pack let matched = matchExpression (pattern pack) expr unless (matched /= []) (expectationFailure "List of matched substitutions is empty which is not expected")- met <- meetCondition (condition pack) matched (RuleContext buildTerm)+ met <- meetCondition (condition pack) matched (RuleContext buildTerm Nothing) case failure pack of Just True -> unless@@ -59,7 +62,7 @@ ) ) describe "isNF determines normal form" $ do- let ctx = RuleContext buildTerm+ let ctx = RuleContext buildTerm Nothing forM_ [ ("returns true for ExXi", ExXi, True) , ("returns true for ExRoot", ExRoot, True)@@ -80,7 +83,7 @@ describe "matchExpressionWithRule via a 'where' extension or a φ-marker meta" $ do let ctx :: RuleContext- ctx = RuleContext buildTerm+ ctx = RuleContext buildTerm Nothing joinRule :: Yaml.Rule joinRule =@@ -89,7 +92,6 @@ Nothing Nothing (ExFormation [BiMeta "B"])- Nothing (ExMeta "B") Nothing (Just [Yaml.Extra (Yaml.ArgBinding (BiMeta "J")) "join" [Yaml.ArgBinding (BiMeta "B")]])@@ -102,7 +104,6 @@ Nothing Nothing (ExMeta "e")- Nothing (ExMeta "e") Nothing ( Just@@ -119,7 +120,6 @@ Nothing Nothing (ExFormation [BiTau (AtLabel "x") (ExPhiMeet Nothing 0 (ExMeta "n1")), BiVoid AtRho])- Nothing (ExMeta "n1") Nothing Nothing@@ -132,7 +132,6 @@ Nothing Nothing (ExFormation [BiTau (AtLabel "x") (ExPhiAgain Nothing 0 (ExMeta "n2")), BiVoid AtRho])- Nothing (ExMeta "n2") Nothing Nothing@@ -165,3 +164,54 @@ then matched `shouldSatisfy` (not . null) else matched `shouldBe` [] )++ describe "matchExpressionWithRule names a formation in the universe of its context" $ do+ let namingRule :: Yaml.Rule+ namingRule =+ Yaml.Rule+ "named-test"+ Nothing+ Nothing+ (ExFormation [BiMeta "B", BiVoid AtRho])+ (ExMeta "e2")+ Nothing+ (Just [Yaml.Extra (Yaml.ArgExpression (ExMeta "e2")) "named" [Yaml.ArgExpression (ExFormation [BiMeta "B", BiVoid AtRho])]])+ Nothing+ world :: Expression+ world = ExFormation [BiTau (AtLabel "qwj") (ExFormation [BiDelta (BtOne "7C")]), BiVoid AtRho]+ it "writes Φ for the whole program the context stands in" $ do+ (mapM (buildExpressionThrows (ExMeta "e2")) =<< matchExpressionWithRule world namingRule (RuleContext buildTerm (Just world)))+ `shouldReturn` [ExRoot]+ it "writes the formation itself where the context knows no universe" $ do+ (mapM (buildExpressionThrows (ExMeta "e2")) =<< matchExpressionWithRule world namingRule (RuleContext buildTerm Nothing))+ `shouldReturn` [world]++ describe "redex" $ do+ it "takes every normalization rule for a redex" $+ all redex Yaml.normalizationRules `shouldBe` True+ it "does not take a rule of a formation holding a λ alone for a redex" $+ redex (Yaml.Rule "lone" Nothing Nothing (ExFormation [BiMeta "B1", BiLambda (FnMeta "f1")]) ExTermination Nothing Nothing Nothing) `shouldBe` False+ it "does not take a rule demanding a Δ under 'not' for a redex" $+ redex (Yaml.Rule "negated" Nothing Nothing (ExFormation [BiMeta "B1", BiLambda (FnMeta "f1")]) ExTermination (Just (Yaml.Not (Yaml.In [AtDelta] [BiMeta "B1"]))) Nothing Nothing) `shouldBe` False+ it "does not take a rule dispatching on a meta for a redex" $+ redex (Yaml.Rule "loose" Nothing Nothing (ExDispatch (ExMeta "e1") (AtMeta "t1")) ExTermination Nothing Nothing Nothing) `shouldBe` False++ describe "normalization rules over inert terms" $ do+ let samples :: [String]+ samples =+ [ "⟦ kx ↦ ξ.ow( jy ↦ Φ.ya ), λ ⤍ L_ok, b ↦ ∅ ⟧"+ , "⟦ φ ↦ Φ.number( φ ↦ Φ.bytes( φ ↦ ⟦ λ ⤍ 𝜎3 ⟧ ) ), ρ ↦ ∅, qe ↦ ⟦ Δ ⤍ 1F- ⟧ ⟧"+ , "Φ.hz( ⟦ ab ↦ ⟦ kw ↦ ξ.ρ, λ ⤍ L_z ⟧ ⟧ ).uv( α0 ↦ ⊥ )"+ , "⟦ x ↦ ∅, dd ↦ ⟦ λ ⤍ L_dd, ρ ↦ ∅ ⟧, m1 ↦ ⟦ b ↦ ∅, φ ↦ ξ.ρ.dd( b ↦ ξ.b ), ρ ↦ ∅ ⟧ ⟧"+ ]+ context :: RuleContext+ context = RuleContext buildTerm Nothing+ matches :: Expression -> Yaml.Rule -> IO [Subst]+ matches term rule = maybe pure (\cond substs -> meetCondition cond substs context) rule.when (matchExpressionDeep rule.pattern term)+ it "takes every sample for inert" $ do+ terms <- mapM parseExpressionThrows samples+ all inert terms `shouldBe` True+ it "does not find a normalization rule matching anywhere in an inert term" $ do+ terms <- mapM parseExpressionThrows samples+ found <- concat <$> sequence [matches term rule | term <- terms, rule <- Yaml.normalizationRules]+ found `shouldBe` []
test/SugarSpec.hs view
@@ -316,6 +316,29 @@ ) ) ,+ ( "PA_FORMATION carrying the one-binding sugar joins its void params ahead of that binding"+ , PA_FORMATION+ (AT_LABEL "f")+ [AT_LABEL "p"]+ ARROW+ ( EX_SINGLE+ (PA_TAU (AT_LABEL "a") ARROW xiExpr)+ (EX_FORMATION LSB EOL (TAB 2) (BI_PAIR (PA_TAU (AT_LABEL "a") ARROW xiExpr) (BDS_EMPTY (TAB 2)) (TAB 2)) EOL (TAB 1) RSB)+ )+ , PA_TAU+ (AT_LABEL "f")+ ARROW+ ( EX_FORMATION+ LSB+ EOL+ (TAB 2)+ (BI_PAIR (PA_VOID (AT_LABEL "p") ARROW EMPTY) (BDS_PAIR EOL (TAB 2) (PA_TAU (AT_LABEL "a") ARROW xiExpr) (BDS_EMPTY (TAB 2))) (TAB 2))+ EOL+ (TAB 1)+ RSB+ )+ )+ , ( "PA_FORMATION with a non-empty object body joins several void params ahead of the existing bindings" , PA_FORMATION (AT_LABEL "f")@@ -620,6 +643,31 @@ ] (\(desc, input, expected) -> it desc (withoutRho SWEET input `shouldBe` expected)) + it "keeps the one-binding sugar a formation after inline voids is left with" $+ render+ ( withoutRho+ SWEET+ ( EX_FORMATION+ LSB+ EOL+ (TAB 1)+ ( BI_PAIR+ ( PA_FORMATION+ (AT_LABEL "x")+ [AT_LABEL "y"]+ ARROW+ (EX_FORMATION LSB EOL (TAB 2) (BI_PAIR (PA_TAU (AT_LABEL "a") ARROW xiExpr) (BDS_PAIR EOL (TAB 2) (PA_TAU (AT_RHO RHO) ARROW xiExpr) (BDS_EMPTY (TAB 2))) (TAB 2)) EOL (TAB 1) RSB)+ )+ (BDS_EMPTY (TAB 1))+ (TAB 1)+ )+ EOL+ (TAB 0)+ RSB+ )+ )+ `shouldBe` "⟦\n x(y) ↦ ξ:a\n⟧"+ describe "full pipeline round trips, SWEET vs SALTY" $ do let config :: SugarType -> (SugarType, Encoding, LineFormat, Int) config sugar = (sugar, UNICODE, SINGLELINE, defaultMargin)@@ -645,7 +693,7 @@ "a nested object-with-params formation sugars/salts between obj(p, q) -> [[..]] and its expanded void bindings" $ do let nestedForm = ExFormation [BiTau (AtLabel "obj") (ExFormation [BiVoid (AtLabel "p"), BiVoid (AtLabel "q"), BiTau (AtLabel "z") ExXi])]- printExpression' nestedForm (config SWEET) `shouldBe` "⟦ obj(p, q) ↦ ⟦ z ↦ ξ ⟧ ⟧"+ printExpression' nestedForm (config SWEET) `shouldBe` "⟦ obj(p, q) ↦ ξ:z ⟧" printExpression' nestedForm (config SALTY) `shouldBe` "⟦ obj ↦ ⟦ p ↦ ∅, q ↦ ∅, z ↦ ξ ⟧ ⟧" it "a phi-meet/phi-again chain renders identically under both sugar types"
test/YamlSpec.hs view
@@ -56,8 +56,8 @@ ) describe "rejects malformed rule content" $ do- let primYaml = "name: prim\nlabel: prim\nmatch: ⟦𝐵⟧\ne-match: 𝑒\nn-result: ⟦𝐵⟧"- endYaml = "name: end\nlabel: end\nmatch: ⊥\ne-match: 𝑒\nd-result: '--'"+ let primYaml = "name: prim\nlabel: prim\nmatch: ⟦𝐵⟧\nuniverse: 𝑒\nconclusion: ⟦𝐵⟧"+ endYaml = "name: end\nlabel: end\nmatch: ⊥\nuniverse: 𝑒\nconclusion: '--'" cxiYaml = "name: cxi\nlabel: cxi\nmatch: ξ\nc-match: 𝑘\nc-result: 𝑘" forM_ [ ("a label that equals the name in a morphing rule", primYaml, failsAsRedundant (decodeYaml' primYaml :: Either Yaml.ParseException MorphRule))@@ -74,6 +74,9 @@ it ("rejects " ++ desc) (unless valid (expectationFailure ("expected rejection for: " ++ yaml))) ) + it "rejects an 'e-match' in a rewriting rule" $+ (decodeYaml' "name: kvz\npattern: '⟦ 𝜏1 ↦ 𝑒1 ⟧'\ne-match: '𝑒2'\nresult: '𝑒2'" :: Either Yaml.ParseException Rule)+ `shouldSatisfy` failsWith "The rule 'kvz' carries an 'e-match'" describe "rejects an anonymous meta outside a pattern" $ do -- An anonymous meta is bound by the pattern it stands in and forgotten as -- soon as that pattern matches, so no other part of a rule has a name to@@ -121,40 +124,40 @@ (decodeYaml' (rewriting "result: '⟦ ⟧'\nwhen:\n nf: '𝑒'") :: Either Yaml.ParseException Rule) ) ,- ( "in 'n-result' of a morphing rule"+ ( "in 'conclusion' of a morphing rule" , failsWith- "anonymous meta '!n' cannot be referenced in 'n-result' of rule 'foo'"- (decodeYaml' (inferring "e-match: 𝑒2\nn-result: '𝑛'") :: Either Yaml.ParseException MorphRule)+ "anonymous meta '!n' cannot be referenced in 'conclusion' of rule 'foo'"+ (decodeYaml' (inferring "universe: 𝑒2\nconclusion: '𝑛'") :: Either Yaml.ParseException MorphRule) ) , ( "in a premise of a morphing rule" , failsWith "anonymous meta '!e' cannot be referenced in 'premises' of rule 'foo'"- (decodeYaml' (inferring "e-match: 𝑒2\nn-result: 𝑛1\npremises:\n - n-result: 𝑛1\n normalize: '𝑒'") :: Either Yaml.ParseException MorphRule)+ (decodeYaml' (inferring "universe: 𝑒2\nconclusion: 𝑛1\npremises:\n - n-result: 𝑛1\n normalize: '𝑒'") :: Either Yaml.ParseException MorphRule) ) , ( "in 'when' of a morphing rule" , failsWith "anonymous meta '!e' cannot be referenced in 'when' of rule 'foo'"- (decodeYaml' (inferring "e-match: 𝑒2\nn-result: 𝑛1\nwhen:\n formation: '𝑒'") :: Either Yaml.ParseException MorphRule)+ (decodeYaml' (inferring "universe: 𝑒2\nconclusion: 𝑛1\nwhen:\n formation: '𝑒'") :: Either Yaml.ParseException MorphRule) ) ,- ( "in 'd-result' of a dataization rule"+ ( "in 'conclusion' of a dataization rule" , failsWith- "anonymous meta '!d' cannot be referenced in 'd-result' of rule 'foo'"- (decodeYaml' (inferring "e-match: 𝑒2\nd-result: '𝛿'") :: Either Yaml.ParseException DataizeRule)+ "anonymous meta '!d' cannot be referenced in 'conclusion' of rule 'foo'"+ (decodeYaml' (inferring "universe: 𝑒2\nconclusion: '𝛿'") :: Either Yaml.ParseException DataizeRule) ) , ( "in 'when' of a dataization rule" , failsWith "anonymous meta '!e' cannot be referenced in 'when' of rule 'foo'"- (decodeYaml' (inferring "e-match: 𝑒2\nd-result: 𝛿1\nwhen:\n formation: '𝑒'") :: Either Yaml.ParseException DataizeRule)+ (decodeYaml' (inferring "universe: 𝑒2\nconclusion: 𝛿1\nwhen:\n formation: '𝑒'") :: Either Yaml.ParseException DataizeRule) ) , ( "in a premise of a dataization rule" , failsWith "anonymous meta '!e' cannot be referenced in 'premises' of rule 'foo'"- (decodeYaml' (inferring "e-match: 𝑒2\nd-result: 𝛿1\npremises:\n - d-result: 𝛿1\n dataize: '𝑒'") :: Either Yaml.ParseException DataizeRule)+ (decodeYaml' (inferring "universe: 𝑒2\nconclusion: 𝛿1\npremises:\n - d-result: 𝛿1\n dataize: '𝑒'") :: Either Yaml.ParseException DataizeRule) ) , ( "in a premise of a contextualization rule"