diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -34,7 +34,7 @@ ```bash cabal update -cabal install --overwrite-policy=always phino-0.0.143 +cabal install --overwrite-policy=always phino-0.0.144 phino --version ``` diff --git a/benchmark/Main.hs b/benchmark/Main.hs --- a/benchmark/Main.hs +++ b/benchmark/Main.hs @@ -15,7 +15,7 @@ import Dataize (reduction) import Deps (Acyclic (Plausible, Proven), Judgment (Morphing), dontSaveEval, dontSaveStep) import Encoding (Encoding (UNICODE)) -import Engine (Engine (_normal), building, stepOf, yaml) +import Engine (Engine (_matching, _normal), building, stepOf, yaml) import Evaluate (evaluation, fired) import Lambdas (Lambdas, readLambdas) import Lining (LineFormat (MULTILINE, SINGLELINE)) @@ -41,17 +41,6 @@ targetBatchMs :: Double targetBatchMs = 20.0 --- The wall-clock, in microseconds, one case may spend on its warmups and its --- measured batches together. Every case that only parses, prints or rewrites --- runs in microseconds and batches up to the window above, so ten batches of --- it cost a fraction of a second and the budget never binds. A symbolic --- morphing takes whole seconds per run, and inside a world the size of --- 'native.phi' tens of them, so three warmups plus ten batches of one would --- outlast the jobs the workflows run the suite in — 'regression-check' runs --- the whole binary ten times over, once per round per side. The warmups and --- the iterations are therefore cut to what the budget affords, never below one --- measured batch, so an expensive case still reports the same lines as every --- other one. budget :: Double budget = 30.0 * 1e6 @@ -65,53 +54,42 @@ Nothing (building linked) (_normal linked) + (_matching linked) MtDisabled Nothing dontSaveStep --- The step budget, the rewriting bounds and the flags the symbolic cases morph --- with, which are the defaults of the 'morph' command plus the three switches --- 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, 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 :: Acyclic -> Maybe Memo -> Lambdas -> Expression -> ReduceContext symbolicCtx acyclic memo lambdas locator = ReduceContext - locator -- _locator - locator -- _site - Nothing -- _universe - 25 -- _maxDepth - 25 -- _maxCycles - (Steps 1000 0) -- _steps - Nothing -- _tally - Nothing -- _deadline - memo -- _memo - 1 -- _nesting - False -- _depthSensitive - False -- _shuffle - True -- _partial - True -- _deep - 1 -- _jobs - (Just acyclic) -- _acyclic - Morphing -- _judgment - [] -- _parked - Map.empty -- _entered - lambdas -- _symbolic - (building linked) -- _buildTerm - reduction -- _reduce - evaluation -- _evaluate - fired -- _fire - dontSaveStep -- _saveStep - dontSaveEval -- _saveEval - linked -- _engine + locator + locator + Nothing + 25 + 25 + (Steps 1000 0) + Nothing + Nothing + memo + 1 + False + False + True + True + 1 + (Just acyclic) + Morphing + [] + Map.empty + lambdas + (building linked) + reduction + evaluation + fired + dontSaveStep + dontSaveEval + linked --- The engine the rules run on: the one 'phino compile' wrote, where the build --- links it in, and the one interpreting the rules of YAML otherwise, so the --- same suite times either (#1617). linked :: Engine linked = fromMaybe yaml compiled @@ -184,44 +162,20 @@ 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 - -- slowdown of one of them is a line of its own rather than a share of a - -- single total. entries :: [String] entries = ["e1", "e2", "e3", "e4", "e5"] - -- The one entry timed inside 'native.phi' as well, whose two numbers say - -- between them what the world around an entry costs — the very comparison - -- nothing in the suite used to make, and the one 'number.neg' was seen to - -- lose two orders of magnitude on (#1291). It is the smallest entry of the - -- demo world, a single λ function fired against one unknown, because the - -- cost measured here is the world's and not the term's: the bigger entries - -- pay the same price per firing and merely pay it more often, which inside - -- a megabyte of 'native.phi' is more than a benchmark can wait for. probe :: String probe = "e5" - -- One case of the symbolic suite: the entry of the demo world 𝕄 is aimed - -- at, inside the world it is aimed in. 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 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 @@ -233,12 +187,6 @@ 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 :: Acyclic -> Expression -> Lambdas -> Expression -> IO Int symbolic acyclic universe lambdas locator = do seedTaus universe diff --git a/compiled/generated/Compiled.hs b/compiled/generated/Compiled.hs --- a/compiled/generated/Compiled.hs +++ b/compiled/generated/Compiled.hs @@ -15,12 +15,14 @@ import qualified Data.Map.Strict as Map import qualified Rewriter as R import qualified Rule as Ru +import qualified Data.Set as Set compiled :: Maybe En.Engine compiled = Just En.Engine { En._normalization = normalization + , En._matching = \universe -> Set.fromList . matching universe , En._rules = steps , En._normal = nf , En._contextualize = \term context -> either E.throwIO pure (contextualize term context) @@ -53,25 +55,30 @@ -- Whether the term is a normal form: no built-in rule of normalization -- matches anywhere inside it. nf :: Expression -> Bool -nf = - Ru.normalWith - ( \term -> - M.anywhere True (not . null . rewriteAlpha Nothing) term - || M.anywhere True (not . null . rewriteAmiss Nothing) term - || M.anywhere True (not . null . rewriteCopy Nothing) term - || M.anywhere True (not . null . rewriteDc Nothing) term - || M.anywhere True (not . null . rewriteDca Nothing) term - || M.anywhere True (not . null . rewriteDd Nothing) term - || M.anywhere True (not . null . rewriteDl Nothing) term - || M.anywhere True (not . null . rewriteDot Nothing) term - || M.anywhere True (not . null . rewriteMiss Nothing) term - || M.anywhere True (not . null . rewriteNull Nothing) term - || M.anywhere True (not . null . rewriteOver Nothing) term - || M.anywhere True (not . null . rewriteOvera Nothing) term - || M.anywhere True (not . null . rewriteSkip Nothing) term - || M.anywhere True (not . null . rewriteStay Nothing) term - || M.anywhere True (not . null . rewriteStop Nothing) term - ) +nf = Ru.normalWith (not . null . matching Nothing) + +-- The numbers of the built-in rules of normalization matching somewhere in +-- the term, in the order one walk over it meets them, told the world the +-- term stands in. +matching :: Maybe Expression -> Expression -> [Int] +matching = + M.hits + [ (0, True, rewriteAlpha) + , (1, True, rewriteAmiss) + , (2, True, rewriteCopy) + , (3, True, rewriteDc) + , (4, True, rewriteDca) + , (5, True, rewriteDd) + , (6, True, rewriteDl) + , (7, True, rewriteDot) + , (8, True, rewriteMiss) + , (9, True, rewriteNull) + , (10, True, rewriteOver) + , (11, True, rewriteOvera) + , (12, True, rewriteSkip) + , (13, True, rewriteStay) + , (14, True, rewriteStop) + ] -- The Contextualization function 𝒞, the conclusion of the one rule matching -- the term and the context. diff --git a/compiled/stub/Compiled.hs b/compiled/stub/Compiled.hs --- a/compiled/stub/Compiled.hs +++ b/compiled/stub/Compiled.hs @@ -1,13 +1,9 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- The engine 'phino compile' writes, where it has written one: this module --- stands in its place until it does, and a build without the flag 'compiled' --- links it in, so phino interprets its rules of YAML (#1617). module Compiled (compiled) where import Engine (Engine) --- No engine was compiled. compiled :: Maybe Engine compiled = Nothing diff --git a/phino.cabal b/phino.cabal --- a/phino.cabal +++ b/phino.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: phino -version: 0.0.144 +version: 0.0.145 license: MIT synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions description: Please see the README on GitHub at diff --git a/src/AST.hs b/src/AST.hs --- a/src/AST.hs +++ b/src/AST.hs @@ -8,7 +8,6 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- This module represents AST tree for parsed phi-calculus expression module AST ( Slot (..) , Expression (ExFormation, ExXi, ExRoot, ExTermination, ExApplication, ExDispatch, ExMeta, ExAny, ExPhiMeet, ExPhiAgain, ExBytes) @@ -51,22 +50,9 @@ import GHC.Exts (isTrue#, reallyUnsafePtrEquality#) import GHC.Generics (Generic) --- An anonymous meta-variable, written bare — 𝜏, 𝐵, 𝑒, 𝑛, 𝑘, 𝛿, 𝑓, 𝜎 or 𝑖 --- with no index after it. It matches whatever term stands in its place and no rule --- can name it afterwards, so it is known only by the kind it was written as --- ('t', 'B', 'e', 'n', 'k', 'd', 'F', 'S', 'i') and by the offset it was written --- at, which tells it apart from every other anonymous meta of the same term. 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 = Formed Facts [Binding] | ExXi @@ -78,19 +64,8 @@ | ExAny Slot | ExPhiMeet (Maybe String) Int Expression | ExPhiAgain (Maybe String) Int Expression - | {- | Bare data 𝛿 — the raw bytes extracted by the 'delta' dataization rule. - It is not a phi-calculus term but a rendering-only chain node, so a - '--sequence' derivation can terminate at the data itself rather than at - the data object it was pulled out of (see #980). It never flows into the - matcher, builder or the dataization relation. - -} - ExBytes Bytes + | ExBytes Bytes --- 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 #-} @@ -110,29 +85,18 @@ 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 @@ -152,8 +116,6 @@ 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' @@ -179,8 +141,6 @@ 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) @@ -237,17 +197,8 @@ = Function Text | FnMeta Text | FnAny Slot - | {- | A symbol 𝜎1 — a λ function nothing answers, which is what makes the - value the term it stands in carries unknown. It is a name and not a - meta-variable: no substitution ever binds it and the matcher never reads - it, while 'FnMeta' 𝑓1 stands for any λ name at all, a symbol included. - -} - FnSymbol Int - | {- | A symbol written bare, 𝜎, which is an answer asking for a fresh one. - The slot it was written at tells two of them apart inside one answer, so - each is minted its own name (see 'minted' in 'Lambdas'). - -} - FnFresh Slot + | FnSymbol Int + | FnFresh Slot deriving (Eq, Generic, Show, Ord) instance Show Attribute where @@ -264,30 +215,13 @@ show (AlMeta meta) = 'α' : '!' : T.unpack meta show (AlAny (Slot kind _)) = 'α' : '!' : T.unpack kind --- 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. 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 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 @@ -303,17 +237,12 @@ 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 - -- FNV-1a style mixing step (Int multiplication wraps silently). step :: Int -> Int -> Int step h x = (h `xor` x) * fnvPrime hashText :: Int -> Text -> Int @@ -379,16 +308,6 @@ 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 @@ -427,31 +346,10 @@ (Just right', Just _) | right' == right -> Just (forward, backward) _ -> Nothing --- What one call of 'within' has found out so far: whether a term is embedded --- in another, for every pair of terms the call has asked about, kept by the --- digests of the two and confirmed by (==), since two terms may share a digest. type Searched = Map.Map (Int, Int) [(Expression, Expression, Bool)] --- A question 'within' asks, answered from what the call has found out so far --- and handing that back with what the answer added to it. type Search = Searched -> (Bool, Searched) --- 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, and below the top a symbol also --- stands for a term that holds no symbol itself, since a round holding an --- unknown where the previous one held a datum is more general than it (#1491). --- A ρ binding is never looked below, since it holds the object a term was --- taken from and not a term it grew into. A call answers every pair of terms it --- asks about once and keeps the answer, since a search that fails walks the --- whole of the second term and the same pair is asked about again from every --- place above it, so without the answers kept the cost grows with the number --- of ways one term can be laid along the other (#1623). within :: Expression -> Expression -> Bool within before after = fst (coupled before after Map.empty) where @@ -518,11 +416,6 @@ 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 --- the firing that minted 𝜎4 answered with, whatever it has been rewritten --- into since. symbols :: Expression -> [Int] symbols = goExpr where @@ -541,12 +434,6 @@ goArgument (ArTau _ expr) = goExpr expr goArgument (ArAlpha _ expr) = goExpr expr --- The same term with every symbol above the floor raised by the offset, and --- every other one left as it was. A run under '--jobs' morphs each binding of --- a formation from the same state, so each of them numbers what it mints from --- the same floor; raising what a binding minted by what the bindings before it --- minted numbers the symbols the way one walk over all of them would have, --- whichever worker finished first (#1534). lifted :: Int -> Int -> Expression -> Expression lifted floor' offset = goExpr where @@ -565,11 +452,6 @@ goArgument (ArTau attr expr) = ArTau attr (goExpr expr) goArgument (ArAlpha alpha expr) = ArAlpha alpha (goExpr expr) --- The symbol a term stands for, if its value is one at all. A term carries its --- value where the φ chain ends, so that is the only place a symbol names this --- term: one sitting under ρ, or inside an operand, belongs to the term it was --- minted for and says nothing about this one. This is how a firing is read as --- the answer of an earlier firing. denoted :: Expression -> Maybe Int denoted = goExpr where @@ -585,12 +467,10 @@ 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 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 @@ -606,39 +486,18 @@ 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 @@ -654,7 +513,6 @@ 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 @@ -663,7 +521,6 @@ 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 @@ -709,12 +566,6 @@ where BaseObject label = ExDispatch ExRoot (AtLabel label) --- Minimal matcher function (required for view pattern) --- --- Both bindings of a literal are named φ, the only void that the real --- 'number', 'string' and 'bytes' declare ([@] > number, see #1155). The --- legacy 'as-bytes', 'data' and positional α0 forms are still recognized --- so XMIR produced by older jeo versions keeps sugaring back. matchDataObject :: Expression -> Maybe (T.Text, Bytes) matchDataObject (ExApplication outer arg) | Just inner <- asBytesArg arg = case (matchOuter outer, matchInner inner) of @@ -766,11 +617,6 @@ DataObject label bts = ExApplication (BaseObject label) (ArTau AtPhi (dataBytes bts)) --- The bytes object Φ.bytes(φ ↦ ⟦ Δ ⤍ … ⟧) — what a 'bytes' atom --- yields and what a 'DataObject' carries under its φ argument. --- The payload is bound to 'φ', the void that the real 'bytes' object --- declares ([@] > bytes), so that every dispatch on the literal can bind --- (see #1142) dataBytes :: Bytes -> Expression dataBytes bts = ExApplication diff --git a/src/Abridge.hs b/src/Abridge.hs --- a/src/Abridge.hs +++ b/src/Abridge.hs @@ -3,19 +3,6 @@ -- 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 --- the width the option names keeps its salient bindings — φ, Δ and λ, the --- ones saying what the object decorates, holds and fires — and folds the rest --- into a count, '+34'; a shorter one says little enough to keep them all. A --- byte string past eight bytes keeps its first two and its last two, with the --- count of the bytes cut out between them, '00-00-..(45b)..-FF-EE', 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 @@ -39,14 +26,10 @@ 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 @@ -72,7 +55,6 @@ 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 @@ -88,10 +70,8 @@ goBytes (BT_MANY bts) | length bts > 8 = BT_CUT (take 2 bts) (length bts - 4) (drop (length bts - 2) bts) goBytes bts = bts - -- Whether a formation spelled flat fits in the width. short :: EXPRESSION -> Bool short expr = T.length (render (toSingleLine expr)) <= width - -- 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 diff --git a/src/Builder.hs b/src/Builder.hs --- a/src/Builder.hs +++ b/src/Builder.hs @@ -4,9 +4,6 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- The goal of the module is to build phi expression based on --- pattern expression and set of substitutions by replacing --- meta variables with appropriate meta values module Builder ( buildExpressionsThrows , buildExpression @@ -48,8 +45,6 @@ metaMsg :: Text -> String metaMsg = printf "meta '%s' is either does not exist or refers to an inappropriate term" . T.unpack --- An anonymous meta is bound only within the very pattern that matched it, so --- a lookup that misses means the term being built is not that pattern slotMsg :: Slot -> String slotMsg (Slot kind _) = printf "anonymous meta '!%s' cannot be referenced" (T.unpack kind) @@ -88,16 +83,9 @@ _ -> Left (slotMsg slot) buildBytes bts _ = Right bts --- Build binding --- The function returns [Binding] because the BiMeta is always attached --- 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 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 @@ -121,8 +109,6 @@ 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. buildBindingUnchecked (BiLambda (FnFresh slot)) (Subst mp) = case Map.lookup (Anon slot) mp of Just (MvFunction func) -> Right [BiLambda func] _ -> Left (slotMsg slot) @@ -138,7 +124,6 @@ expression <- buildExpression expr subst Right (ArAlpha alpha' expression) --- Build bindings that may contain meta binding (BiMeta) buildBindings :: [Binding] -> Subst -> Built [Binding] buildBindings [] _ = Right [] buildBindings (bd : rest) subst = do @@ -146,26 +131,6 @@ bds <- buildBindings rest subst Right (first ++ bds) --- 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 @@ -173,14 +138,10 @@ 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 @@ -195,8 +156,6 @@ 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 [] @@ -212,7 +171,6 @@ 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 @@ -223,31 +181,18 @@ closed _ = False pathOf _ form = form --- The name the formation goes by in the world, where a world is known, or the --- formation itself (see 'pathOf'), which is what the 'named' function of a --- rule writes. nameIn :: Maybe Expression -> Expression -> Expression nameIn universe form = maybe form (`pathOf` form) universe --- The formation of the bindings, which a rule 'phino compile' turned into --- Haskell builds the way the builder builds a formation of a template: it --- refuses one carrying an attribute twice (see 'unique'). formed :: [Binding] -> Expression formed bds = either (throw . CouldNotBuildExpression (ExFormation bds)) id (unique (ExFormation bds)) --- 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 expr@(ExFormation bds) | distinct expr = Right expr | otherwise = uniqueBindings bds >> Right expr unique expr = Right expr --- Build meta expression with given substitution buildExpression :: Expression -> Subst -> Built Expression buildExpression (ExDispatch ex at) subst = do dispatched <- buildExpression ex subst @@ -281,6 +226,5 @@ buildExpressionThrows :: Expression -> Subst -> IO Expression buildExpressionThrows expr subst = orThrow (CouldNotBuildExpression expr) (buildExpression expr subst) --- Build a several expression from one expression and several substitutions buildExpressionsThrows :: Expression -> [Subst] -> IO [Expression] buildExpressionsThrows expr = traverse (buildExpressionThrows expr) diff --git a/src/Bytes.hs b/src/Bytes.hs --- a/src/Bytes.hs +++ b/src/Bytes.hs @@ -3,10 +3,6 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- This module is a codec between 'Bytes' and the values they encode: --- IEEE-754 doubles, UTF-8 strings and raw hex. It also owns the byte-array --- operations that EO's 'bytes' atoms are built on, since only this module knows --- how a 'Bytes' maps onto the octets underneath it. module Bytes ( numToBts , strToBts @@ -50,20 +46,11 @@ 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") --- [1] --- >>> btsToWord8 (BtMany []) --- [] --- >>> btsToWord8 (BtMany ["40", "14", "00", "00", "00", "00", "00", "00"]) --- [64,20,0,0,0,0,0,0] btsToWord8 :: Bytes -> [Word8] btsToWord8 BtEmpty = [] btsToWord8 (BtOne bt) = [hexByte bt] @@ -84,8 +71,6 @@ [(hex, "")] -> fromIntegral (hex :: Integer) _ -> error $ "Invalid hex byte; " ++ bt --- >>> word8ToBytes [64, 20, 0] --- BtMany ["40","14","00"] word8ToBytes :: [Word8] -> Bytes word8ToBytes [] = BtEmpty word8ToBytes [w8] = BtOne (toHex w8) @@ -99,23 +84,6 @@ | n < 10 = chr (fromIntegral n + ord '0') | otherwise = chr (fromIntegral n + ord 'A' - 10) --- Convert Bytes back to Double --- >>> btsToNum (BtMany ["40", "14", "00", "00", "00", "00", "00", "00"]) --- Left 5 --- >>> btsToNum (BtMany ["BF", "D0", "00", "00", "00", "00", "00", "00"]) --- Right (-0.25) --- >>> btsToNum (BtMany ["40", "45", "00", "00", "00", "00", "00", "00"]) --- Left 42 --- >>> btsToNum (BtMany ["40", "45"]) --- Expected 8 bytes for conversion, got 2 --- >>> btsToNum (BtMany ["7F", "F8", "00", "00", "00", "00", "00", "00"]) --- Right NaN --- >>> btsToNum (BtMany ["7F", "F0", "00", "00", "00", "00", "00", "00"]) --- Right Infinity --- >>> btsToNum (BtMany ["FF", "F0", "00", "00", "00", "00", "00", "00"]) --- Right (-Infinity) --- >>> btsToNum (BtMany ["80", "00", "00", "00", "00", "00", "00", "00"]) --- Right (-0.0) btsToNum :: Bytes -> Either Int Double btsToNum hx = let bytes = btsToWord8 hx @@ -142,95 +110,38 @@ .|. fromIntegral h toWord64BE _ = error "Expected 8 bytes for Double" --- >>> numToBts 0.0 --- BtMany ["00","00","00","00","00","00","00","00"] --- >>> numToBts 42 --- BtMany ["40","45","00","00","00","00","00","00"] --- >>> numToBts (-0.25) --- BtMany ["BF","D0","00","00","00","00","00","00"] --- >>> numToBts 5 --- BtMany ["40","14","00","00","00","00","00","00"] numToBts :: Double -> Bytes numToBts num = word8ToBytes (unpack (toLazyByteString (word64BE (doubleToWord num)))) --- The three IEEE-754 doubles that are not finite numbers. None of them has a --- numeric literal to be written with, so the printer spells each one as a --- dispatch off the root — 'Φ.nan', 'Φ.pinf', 'Φ.ninf' — and the parser reads --- those names back into the very bytes they stand for (see #1065) data NonFinite = NfNan | NfPinf | NfNinf deriving (Eq, Show) --- All the non-finite doubles, in the order they are documented in nonFinites :: [NonFinite] nonFinites = [NfNan, NfPinf, NfNinf] --- The attribute name the value is dispatched on --- >>> nonFiniteName NfPinf --- "pinf" nonFiniteName :: NonFinite -> T.Text nonFiniteName NfNan = "nan" nonFiniteName NfPinf = "pinf" nonFiniteName NfNinf = "ninf" --- The canonical byte form of a non-finite double. The patterns are spelled out --- instead of being derived from '0 / 0' and '1 / 0' because the sign bit and --- the payload of a computed NaN are platform-dependent, while the printer and --- the parser have to agree on one exact pattern --- >>> nonFiniteBts NfNan --- BtMany ["7F","F8","00","00","00","00","00","00"] nonFiniteBts :: NonFinite -> Bytes nonFiniteBts NfNan = BtMany ["7F", "F8", "00", "00", "00", "00", "00", "00"] nonFiniteBts NfPinf = BtMany ["7F", "F0", "00", "00", "00", "00", "00", "00"] nonFiniteBts NfNinf = BtMany ["FF", "F0", "00", "00", "00", "00", "00", "00"] --- Which non-finite double the given bytes encode, if they encode one at all. --- Only the three canonical patterns qualify: a NaN carrying a payload, or the --- negative quiet NaN, has no name of its own and keeps its byte form, so that --- printing never drops a bit --- >>> btsToNonFinite (BtMany ["FF", "F0", "00", "00", "00", "00", "00", "00"]) --- Just NfNinf --- >>> btsToNonFinite (BtMany ["40", "45", "00", "00", "00", "00", "00", "00"]) --- Nothing --- >>> btsToNonFinite (BtMany ["7F", "F8", "00", "00", "00", "00", "00", "01"]) --- Nothing btsToNonFinite :: Bytes -> Maybe NonFinite btsToNonFinite (BtMeta _) = Nothing btsToNonFinite (BtAny _) = Nothing btsToNonFinite bts = find (btsEqual bts . nonFiniteBts) nonFinites --- The non-finite double the given name stands for, if it names one at all --- >>> nonFiniteOf "ninf" --- Just NfNinf --- >>> nonFiniteOf "number" --- Nothing nonFiniteOf :: T.Text -> Maybe NonFinite nonFiniteOf name = find ((== name) . nonFiniteName) nonFinites --- >>> strToBts "hello" --- BtMany ["68","65","6C","6C","6F"] --- >>> strToBts "world" --- BtMany ["77","6F","72","6C","64"] --- >>> strToBts "" --- BtEmpty --- >>> strToBts "h" --- BtOne "68" --- >>> strToBts "h\"" --- BtMany ["68","22"] --- >>> strToBts "\x01\x01" --- BtMany ["01","01"] --- >>> strToBts "Hey" --- BtMany ["48","65","79"] strToBts :: String -> Bytes strToBts "" = BtEmpty strToBts [ch] = word8ToBytes (unpack (U.fromString [ch])) strToBts str = word8ToBytes (unpack (U.fromString str)) --- >>> bytesToBts "--" --- BtEmpty --- >>> bytesToBts "77-6F" --- BtMany ["77","6F"] --- >>> bytesToBts "01-" --- BtOne "01" bytesToBts :: String -> Bytes bytesToBts "--" = BtEmpty bytesToBts str @@ -238,21 +149,6 @@ | 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"]) --- "hello" --- >>> btsToStr (BtOne "68") --- "h" --- >>> btsToStr (BtOne "35") --- "5" --- >>> btsToStr (BtMany ["77", "6F", "72", "6C", "64"]) --- "world" --- >>> btsToStr BtEmpty --- "" --- >>> btsToStr (BtMany ["68", "22"]) --- "h\\\"" --- >>> btsToStr (BtMany ["01", "02"]) --- "\\x01\\x02" btsToStr :: Bytes -> String btsToStr BtEmpty = "" btsToStr bytes = escapeStr (btsToUnescapedStr bytes) @@ -277,22 +173,6 @@ low = 0xDC00 + rest `mod` 0x400 in printf "\\u%04x\\u%04x" high low --- The inverse of the escaping that 'btsToStr' applies, so that a sweet string --- literal can be turned back into the very bytes it was printed from. A --- backslash that starts no escape 'btsToStr' can produce is kept as it stands, --- together with the character behind it --- >>> unescapeStr "hello" --- "hello" --- >>> unescapeStr "h\\\"" --- "h\"" --- >>> unescapeStr "e\\ne" --- "e\ne" --- >>> unescapeStr "\\\\" --- "\\" --- >>> unescapeStr "\\t" --- "\t" --- >>> unescapeStr "\\x01" --- "\SOH" unescapeStr :: String -> String unescapeStr = go where @@ -327,45 +207,18 @@ escapes :: [(Char, Char)] escapes = [('"', '"'), ('\\', '\\'), ('n', '\n'), ('t', '\t'), ('r', '\r'), ('b', '\b'), ('f', '\f')] --- >>> btsToUnescapedStr (BtMany ["01", "02"]) --- "\SOH\STX" --- >>> btsToUnescapedStr (BtMany ["77", "6F", "72", "6C", "64"]) --- "world" --- >>> btsToUnescapedStr (BtMany ["68", "22"]) --- "h\"" --- >>> btsToUnescapedStr (BtOne "35") --- "5" btsToUnescapedStr :: Bytes -> String btsToUnescapedStr bytes = T.unpack (T.decodeUtf8 (B.pack (btsToWord8 bytes))) --- Whether the byte array is valid UTF-8. The string-side counterpart of the --- eight-byte check on numbers: a short or malformed datum is legal, and the --- printer keeps it in its byte form instead of aborting with an uncaught --- 'decodeUtf8' exception (see #1138). --- >>> btsIsUtf8 (BtMany ["77", "6F", "72", "6C", "64"]) --- True --- >>> btsIsUtf8 (BtMany ["F0", "90", "80", "41"]) --- False --- >>> btsIsUtf8 (BtOne "FE") --- False btsIsUtf8 :: Bytes -> Bool btsIsUtf8 bytes = case T.decodeUtf8' (B.pack (btsToWord8 bytes)) of Left _ -> False Right _ -> True --- Bitwise conjunction of two byte arrays, byte by byte. EO's 'BytesRaw.and' --- refuses operands of different lengths, so there is nothing to yield for them --- >>> btsAnd (BtMany ["02", "EF"]) (BtMany ["12", "33"]) --- Just (BtMany ["02","23"]) --- >>> btsAnd (BtOne "20") (BtMany ["CA", "FE"]) --- Nothing btsAnd :: Bytes -> Bytes -> Maybe Bytes btsAnd = zipBytes (.&.) --- Bitwise disjunction of two byte arrays, under the same length rule as 'btsAnd' --- >>> btsOr (BtMany ["02", "EF"]) (BtMany ["12", "33"]) --- Just (BtMany ["12","FF"]) btsOr :: Bytes -> Bytes -> Maybe Bytes btsOr = zipBytes (.|.) @@ -379,37 +232,18 @@ rights :: [Word8] rights = btsToWord8 right --- Bitwise negation of every byte --- >>> btsNot (BtMany ["CA", "FE", "BE", "BE"]) --- BtMany ["35","01","41","41"] btsNot :: Bytes -> Bytes btsNot = word8ToBytes . map complement . btsToWord8 --- >>> btsConcat (BtMany ["05", "5E"]) BtEmpty --- BtMany ["05","5E"] --- >>> btsConcat BtEmpty BtEmpty --- BtEmpty btsConcat :: Bytes -> Bytes -> Bytes btsConcat left right = word8ToBytes (btsToWord8 left ++ btsToWord8 right) --- EO's 'bytes.eq' compares the two arrays octet by octet, so two spellings of --- the same single byte are equal even though their constructors differ --- >>> btsEqual (BtOne "01") (BtMany ["01"]) --- True btsEqual :: Bytes -> Bytes -> Bool btsEqual left right = btsToWord8 left == btsToWord8 right --- >>> btsSize (BtMany ["F1", "20", "5F"]) --- 3 btsSize :: Bytes -> Int btsSize = length . btsToWord8 --- Take 'len' bytes starting at 'start'. A window reaching past the end of the --- array has no answer, which is the case EO's 'cant-slice' fallback exists for --- >>> btsSlice 1 3 (BtMany ["20", "1F", "EE", "B5", "90"]) --- Just (BtMany ["1F","EE","B5"]) --- >>> btsSlice 3 10 (BtMany ["20", "1F", "EE", "B5", "90"]) --- Nothing btsSlice :: Int -> Int -> Bytes -> Maybe Bytes btsSlice start len bts | start < 0 || len < 0 || start + len > length octets = Nothing @@ -418,13 +252,6 @@ octets :: [Word8] octets = btsToWord8 bts --- Shift a byte array right by 'bits' bit positions, or left when 'bits' is --- negative, the way EO's 'BytesRaw.shift' does it. The array keeps its length: --- bits pushed past either end are dropped and the vacated positions read zero --- >>> btsShift 1 (BtMany ["C0", "43", "00"]) --- BtMany ["60","21","80"] --- >>> btsShift (-2147483648) (BtMany ["BF", "F0"]) --- BtMany ["00","00"] btsShift :: Int -> Bytes -> Bytes btsShift bits bts | magnitude >= toInteger size * 8 = word8ToBytes (replicate size 0) diff --git a/src/CLI.hs b/src/CLI.hs --- a/src/CLI.hs +++ b/src/CLI.hs @@ -30,12 +30,9 @@ let (msg, code) = renderFailure failure "phino" case code of ExitSuccess -> do - putStrLn msg -- --version/--help output as-is + putStrLn msg exitWith code _ -> do - -- Keep the full optparse message (including the Usage/synopsis - -- block that follows a parse error), but without the GHC - -- HasCallStack backtrace; prefix just the first line with [ERROR]:. hPutStrLn stderr (prefixFirstLine "[ERROR]: " msg) exitWith code CompletionInvoked _ -> handleParseResult parsed @@ -55,8 +52,8 @@ prefixFirstLine prefix msg = prefix ++ msg handler :: SomeException -> IO () handler e = case fromException e of - Just ExitSuccess -> pure () -- prevent printing error on --version etc. - Just (ExitFailure _) -> exitFailure -- already logged by the Failure branch above + Just ExitSuccess -> pure () + Just (ExitFailure _) -> exitFailure _ -> do logError (show e) exitFailure diff --git a/src/CLI/Helpers.hs b/src/CLI/Helpers.hs --- a/src/CLI/Helpers.hs +++ b/src/CLI/Helpers.hs @@ -23,7 +23,7 @@ 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, emptyProgress, emptyProtocol, endEvalXml, progressed, saveEval, saveEvalXml, saveStep) +import Deps (Evaluation (EvRun), Judgment, SaveEvalFunc, SaveStepFunc, State (..), dontSaveEval, emptyNesting, emptyProgress, emptyProtocol, endEval, endEvalXml, progressed, saveEval, saveEvalXml, saveStep) import Encoding import Engine (Engine, fresh, yaml) import Files (ensuredFile, overwrite) @@ -54,7 +54,6 @@ justMeetLength :: Maybe Int -> Int justMeetLength = fromMaybe defaultMeetLength --- Prepare saveStepFunc saveStepFunc :: Maybe FilePath -> PrintContext -> IO SaveStepFunc saveStepFunc stepsDir ctx@PrintCtx{..} = do counter <- newIORef (0 :: Int) @@ -69,25 +68,9 @@ saveStep stepsDir ioToExt render step expr pure save --- Run the action with a function writing the protocol of the run, holding the --- file open for the whole of it. Opening it for writing truncates it, so that --- it always holds the firings of exactly one run: a caller reading it back --- never picks up lines left over from the previous run, even when this run --- fires nothing at all. The handle is closed on the way out, failure included, --- so the last lines reach the disk even when the run gives up. What the --- protocol has counted so far rides in an 'IORef' next to the handle, since it --- is the cursor of the file and not a property of the reduction (see --- 'Protocol'). Every term is flattened into a single line, whatever '--flat' --- says about the main output, since the file is a tree of one-line records. The --- 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 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 @@ -104,41 +87,26 @@ 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 where - -- Which of the two formats the file holds is decided by the name it was - -- given and by nothing else: '.xml' asks for the markup one, every other - -- name for the indented text the option has always written (#1245). There - -- is no flag for it, since a caller naming a file '.xml' and getting text - -- back has been told nothing useful. markup :: Bool markup = map toLower (takeExtension file) == ".xml" - -- The markup format closes on the way out what the run left open, so the - -- document is well-formed however the run ended. The closing runs before - -- the handle does, and the handle closes whether or not it succeeded. markedUp :: IO a markedUp = do cursor <- newIORef emptyNesting - bracket opened (\protocol -> endEvalXml protocol cursor `finally` hClose protocol) $ \protocol -> + began <- getMonotonicTime + bracket opened (\protocol -> endEvalXml protocol cursor began `finally` hClose protocol) $ \protocol -> action (saveEvalXml protocol cursor (flattened ctx)) plain :: IO a plain = do cursor <- newIORef emptyProtocol - bracket opened hClose $ \protocol -> + began <- getMonotonicTime + bracket opened (\protocol -> endEval protocol cursor began `finally` hClose protocol) $ \protocol -> action (saveEval protocol cursor (flattened ctx) (salted ctx)) - -- 'withFile' would do the same, except that it annotates whatever the action - -- throws with the name of the file, and a dataization failure has to reach - -- the user as it is opened :: IO Handle opened = do protocol <- openFile file WriteMode hSetEncoding protocol utf8 pure protocol --- The λ functions this run may fire. phino implements none of them, so without --- '--symbolic' there are none at all and every λ function a program names gets --- stuck — which is exactly what '--partial' parks on. The file is read here, --- before anything is parsed or reduced, so a key that is no regular expression --- or an answer the calculus cannot read fails the run up front rather than --- half-way through a derivation. lambdasOf :: Maybe FilePath -> IO Lambdas lambdasOf Nothing = do logDebug "The option '--symbolic' is not specified, no λ function can be fired" @@ -147,27 +115,13 @@ logDebug (printf "The option '--symbolic' is specified, reading the λ functions from '%s'" file) ensuredFile file >>= readLambdas --- The state a run starts from: nothing manufactured yet and every symbol the --- program already carries counted as minted, so a fresh 𝜎 is never spelled like --- one the input was written with (see 'taken'). started :: Expression -> State started expr = emptyState{_minted = taken expr} --- Open the protocol with the run itself — the judgment it runs and the term it --- is aimed at — which is the line every firing of it stands under. heading :: SaveEvalFunc -> PrintContext -> Judgment -> Expression -> IO () heading record ctx judgment locator = record . EvRun judgment . T.pack =<< flattened ctx locator --- How every term of the protocol is rendered: as 𝜑 on a single line, in the --- 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@PrintCtx{..} expr = pure (P.printExpressionWith shaped expr (_sugar, UNICODE, SINGLELINE, _margin)) @@ -175,19 +129,9 @@ shaped :: SugarType -> EXPRESSION -> EXPRESSION shaped sugar = maybe id abridged _abridged . 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 --- wrote, and the sweet syntax writes 'ξ.x' as a bare 'x', which reads as a name --- and not as the term it is — so the comment that names an operand spells it --- salty and the value beside it stays as the run spells it (#1265). salted :: PrintContext -> Expression -> IO String salted ctx = flattened ctx{_sugar = SALTY} --- Aim the run at the '--inside' expression instead of at '--locator': the --- expression is bound to a synthetic attribute prepended to the input --- expression, which the run takes as the universe, and the locator becomes that --- attribute (see 'insideUniverse'). Without the option nothing moves and the --- context is handed back as it came. aimed :: Maybe String -> Expression -> ReduceContext -> IO (Expression, ReduceContext) aimed Nothing expr ctx = pure (expr, ctx) aimed (Just src) expr@(ExFormation _) ctx = do @@ -198,7 +142,6 @@ invalidCLIArguments (printf "The option --inside requires the input expression to be a formation, but given: %s" (P.printExpression expr)) --- Read input from file or stdin readInput :: Maybe FilePath -> IO String readInput inputFile' = case inputFile' of Just pth -> do @@ -208,23 +151,17 @@ logDebug "Reading from stdin" getContents' `catch` (\(e :: SomeException) -> throwIO (CouldNotReadFromStdin (show e))) --- Parse expression from String input depending on input IO format parseInput :: String -> IOFormat -> IO Expression parseInput phi PHI = parseExpressionThrows phi parseInput xmir XMIR = parseXMIRThrows xmir >>= xmirToPhi parseInput _ LATEX = invalidCLIArguments "LaTeX cannot be used as input format" --- Parse expression like 'parseInput' does, together with the result types --- the atoms of an XMIR input carry, which the XMIR writer restores (#1389) parseInputWithAtoms :: String -> IOFormat -> IO (Expression, Atoms) parseInputWithAtoms xmir XMIR = do doc <- parseXMIRThrows xmir (,) <$> xmirToPhi doc <*> xmirAtoms doc parseInputWithAtoms input format = (,M.empty) <$> parseInput input format --- The LaTeX sequence path canonizes inside 'rewrittensToLatex', after the meet --- compression (see 'canonizedRewrittens' there); the remaining formats have no --- meet pass, so canonization happens here right before rendering. printRewrittens :: PrintContext -> Rewrittens' -> IO String printRewrittens ctx@PrintCtx{..} rewrittens@(chain, _) | _outputFormat == LATEX && _sequence = rewrittensToLatex rewrittens (printCtxToLatexCtx ctx) @@ -232,11 +169,6 @@ where canonized :: [Rewritten] -> [Rewritten] canonized = if _canonize then canonize else id - -- Prefix every step with an empty line and its header (see 'stepHeaders') - -- when '--headers' is on. Headers, like the other intermediate-output - -- flags, are meaningful only together with '--sequence'. Node counts come - -- from the original 'chain', not the canonized one, since canonization - -- only renames functions and never changes the AST size. withHeaders :: [String] -> String withHeaders rendered | _headers && _sequence = intercalate "\n" (zipWith prefixed (stepHeaders chain) rendered) @@ -245,14 +177,9 @@ prefixed :: String -> String -> String prefixed = printf "\n%s\n%s" --- Render the one answer a run of 𝕄 or 𝔻 hands back the way 'printRewrittens' --- renders a step: canonized under '--canonize', then narrowed to '--focus' --- (#1441). printAnswer :: PrintContext -> Expression -> IO String printAnswer ctx@PrintCtx{..} expr = printFocused ctx (if _canonize then canonizeExpr expr else expr) --- Render one expression in the output format, narrowed to the '--focus' --- sub-expression when one is given. printFocused :: PrintContext -> Expression -> IO String printFocused ctx@PrintCtx{..} expr | _focus == ExRoot = printInFormat ctx expr @@ -264,19 +191,15 @@ XMIR -> throwIO CouldNotPrintExpressionInXMIR LATEX -> pure (expressionToLaTeX ex (printCtxToLatexCtx ctx)) --- Convert an expression to its corresponding String format printInFormat :: PrintContext -> Expression -> IO String printInFormat ctx@PrintCtx{..} expr = case _outputFormat of PHI -> pure (printPhi ctx expr) XMIR -> expressionToXMIR expr _xmirCtx <&> printXMIR LATEX -> pure (expressionToLaTeX expr (printCtxToLatexCtx ctx)) --- Render an expression as PHI, dropping every ρ binding when '--hide-rho' is set. printPhi :: PrintContext -> Expression -> String 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 @@ -286,8 +209,6 @@ printCtxToLatexCtx PrintCtx{..} = LatexContext _sugar _line _margin _nonumber _compress _canonize _meetPopularity _meetLength _focus _expression _label _meetPrefix _headers --- Get rules for rewriting depending on provided flags. Both flags may be given --- together, in which case the user rules follow the built-in ones getRules :: Bool -> Bool -> [FilePath] -> IO [Y.Rule] getRules normalize shuffle rules = do ordered <- (++) <$> builtin <*> custom @@ -313,9 +234,6 @@ yamls <- mapM ensuredFile (nub rules) mapM (Y.yamlRule >=> validateRewriteRule) yamls --- Pass a user-supplied rewriting rule through unchanged, or fail fast if it --- references a build-term function which needs the dataization context: those --- work only for dataization and morphing, never for plain rewriting. validateRewriteRule :: Y.Rule -> IO Y.Rule validateRewriteRule rule = let used = maybe [] (map Y.function) rule.where_ @@ -327,7 +245,6 @@ 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 () printOut target content = case target of Nothing -> do @@ -338,10 +255,6 @@ overwrite file content logDebug (printf "The command result was saved in '%s'" file) --- The engine the rules run on: the one 'phino compile' wrote, where the build --- links one in, and the one interpreting the rules of YAML otherwise. An --- engine compiled from rules phino no longer carries is refused, since it --- would run rules nobody wrote (#1617). engine :: IO Engine engine = case compiled of Nothing -> pure yaml diff --git a/src/CLI/Parsers.hs b/src/CLI/Parsers.hs --- a/src/CLI/Parsers.hs +++ b/src/CLI/Parsers.hs @@ -223,26 +223,15 @@ optPartial :: Parser Bool optPartial = switch (long "partial" <> help "Partial evaluation: compute what the known inputs decide and, instead of failing on a λ function that cannot fire (no entry of the --symbolic file answers it), leave it in place and print the residual 𝜑-program") --- 𝕄 stops at the first formation it reaches and hands its bindings back as --- they were written, so what a program holds but nothing demands is never --- reduced. This walks into them (see 'deepened'). optDeep :: Parser Bool optDeep = switch (long "deep" <> help "Don't stop at the first formation: enter its bindings too, recursively, firing every λ function the --symbolic file answers and standing its answer in the place of what it computed, while everything else stays as it was written") --- The bindings of the formation '--deep' starts at share nothing but the world --- they read, so they are walked side by side on as many workers as this says --- (see 'spread' in 'Morph', #1534). optJobs :: Parser Int optJobs = option (auto >>= validateIntOption (> 0) "--jobs must be positive") (long "jobs" <> metavar "JOBS" <> help "Number of workers the --deep walk morphs the bindings of the formation it starts at on, side by side, each with a memo, a tally and fresh names of its own" <> value 1 <> showDefault) --- 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 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 @@ -251,9 +240,6 @@ 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 --- stuck. optSymbolic :: Parser (Maybe FilePath) optSymbolic = optional @@ -268,12 +254,6 @@ ) ) --- The external face of the trick phino plays internally to reduce a --- sub-expression against a universe: prepend a synthetic binding holding it to --- that universe and aim the locator at the binding. It is the same trick a λ --- function's operands are reduced with (see 'insideUniverse' in 'Morph'), made --- available to whoever asks phino to reduce a term that is not part of the --- program. optInside :: Parser (Maybe String) optInside = optional diff --git a/src/CLI/Runners.hs b/src/CLI/Runners.hs --- a/src/CLI/Runners.hs +++ b/src/CLI/Runners.hs @@ -74,7 +74,8 @@ exclude = (`F.exclude` excluded) include = (`F.include` included) save <- saveStepFunc _stepsDir printCtx - (rewrittens, exceeded) <- rewrite expr (map (stepOf linked) rules) (RewriteContext loc _maxDepth _maxCycles _depthSensitive Nothing (building linked) linked._normal _must _breakpoint save) + let steps = map (stepOf linked) rules + (rewrittens, exceeded) <- rewrite expr steps (RewriteContext loc _maxDepth _maxCycles _depthSensitive Nothing (building linked) linked._normal (every steps) _must _breakpoint save) rewrittens' <- exclude <$> include (if _sequence then NE.toList rewrittens else [NE.last rewrittens]) logDebug (printf "Printing rewritten 𝜑-expression as %s" (show _outputFormat)) exprs <- printRewrittens printCtx (rewrittens', exceeded) @@ -176,10 +177,6 @@ _protocol printCtx ( \record -> do - -- 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 formation it enters again is a loop of its own (#1290). let ctx = ReduceContext loc loc Nothing _maxDepth _maxCycles (Steps _maxSteps 0) tally deadline memo 1 _depthSensitive _shuffle _partial False 1 _acyclic Dataization [] Map.empty lambdas (building linked) reduction evaluation fired save record linked (universe, aiming) <- aimed _inside expr ctx heading record printCtx Dataization aiming._locator @@ -188,10 +185,6 @@ when _sequence (include chain >>= \shown -> printRewrittens printCtx (exclude shown, False) >>= putStrLn) unless _quiet (printOutcome printCtx (\residue -> (`F.exclude'` excluded) <$> F.include' residue included) outcome >>= putStrLn) where - -- The bytes the run reached or, when '--partial' let it end on a λ function - -- that could not fire, the residual program, rendered like a rewriting - -- result: narrowed by '--show' and '--hide', canonized, in the output - -- format, narrowed to '--focus'. printOutcome :: PrintContext -> (Expression -> IO Expression) -> Outcome -> IO String printOutcome _ _ (Dataized bytes) = pure (P.printBytes bytes) printOutcome ctx narrowed (Residual residue) = do @@ -233,18 +226,9 @@ _label _meetPrefix _outputFormat - -- The listing of a dataization result is the 𝜑 text of the printed - -- expression, the way 'rewrite' does it; the omit flags and '--hide-rho' - -- reach the XMIR writer through this context (#1076) listing :: Expression -> String listing e = escapeXMLText (P.printExpression' e (_sugarType, UNICODE, _flat, _margin)) --- Run 𝕄 on its own, the way 'runDataize' runs 𝔻. The whole option surface of --- 'dataize' applies unchanged, since the two commands differ only in the --- judgment they run; what differs here is the answer printed: 𝕄 is total and --- always hands back a 𝜑-expression — a formation, or the terminator ⊥ where no --- formation is reachable — so there are no bytes to print and no failure to --- report where 𝔻 would give up. runMorph :: OptsMorph -> IO () runMorph OptsMorph{..} = do validateOpts @@ -318,9 +302,6 @@ _label _meetPrefix _outputFormat - -- The listing of a dataization result is the 𝜑 text of the printed - -- expression, the way 'rewrite' does it; the omit flags and '--hide-rho' - -- reach the XMIR writer through this context (#1076) listing :: Expression -> String listing e = escapeXMLText (P.printExpression' e (_sugarType, UNICODE, _flat, _margin)) diff --git a/src/CLI/Types.hs b/src/CLI/Types.hs --- a/src/CLI/Types.hs +++ b/src/CLI/Types.hs @@ -130,10 +130,6 @@ , _inputFile :: Maybe FilePath } --- The option surface of 'morph' is that of 'dataize': the two commands read the --- same input, aim the same '_locator' at the same subterm and print through the --- same formatting flags, differing only in the judgment they run — 𝕄, which --- stops at the first formation it reaches, against 𝔻, which insists on bytes. data OptsMorph = OptsMorph { _logLevel :: LogLevel , _logLines :: Int diff --git a/src/CLI/Validators.hs b/src/CLI/Validators.hs --- a/src/CLI/Validators.hs +++ b/src/CLI/Validators.hs @@ -17,7 +17,6 @@ invalidCLIArguments :: String -> IO a invalidCLIArguments msg = throwIO (InvalidCLIArguments msg) --- Validate given expressions as valid dispatches validatedDispatches :: String -> [String] -> IO [Expression] validatedDispatches opt = traverse (parseExpressionThrows >=> asDispatch) where @@ -35,9 +34,6 @@ (printExpression' expr logPrintConfig) ) --- Reject a --show locator that is also hidden via --hide: 'exclude' runs over --- the result of 'include', so an overlap would silently wipe the very subtree --- --show was meant to keep. validateNoOverlap :: String -> [Expression] -> String -> [Expression] -> IO () validateNoOverlap showOpt shown hideOpt hidden = for_ shown $ \shown' -> @@ -51,7 +47,6 @@ hideOpt ) --- Validate LaTeX options validateLatexOptions :: IOFormat -> [(Bool, String)] -> [(Maybe String, String)] -> [(Maybe Int, String)] -> IO () validateLatexOptions LATEX _ _ _ = pure () validateLatexOptions _ bools strings ints = do @@ -63,21 +58,15 @@ forM_ strings callback forM_ ints callback --- Validate 'must' option validateMust' :: Must -> IO () validateMust' must = for_ (validateMust must) invalidCLIArguments --- Validate options for output to XMIR validateXmirOptions :: IOFormat -> [(Bool, String)] -> String -> IO () validateXmirOptions XMIR _ focus = when (focus /= "Q") (invalidCLIArguments "Only --focus=Q is allowed to be used with --output=xmir") validateXmirOptions _ bools _ = let (bools', opts) = unzip bools in validateBoolOpts (zip bools' (map (printf "The --%s can be used only with --output=xmir") opts)) --- Check that an expression is printable as XMIR: its top level must be a --- single binding, optionally next to a void ρ (the shape 'expressionToXMIR' --- accepts). Called right after parsing, so a bad shape fails before any --- rewriting or dataization work instead of at print time (issue #1082). validateXmirTopLevel :: IOFormat -> Expression -> IO () validateXmirTopLevel XMIR (ExFormation [_]) = pure () validateXmirTopLevel XMIR (ExFormation [_, BiVoid AtRho]) = pure () diff --git a/src/CST.hs b/src/CST.hs --- a/src/CST.hs +++ b/src/CST.hs @@ -7,7 +7,6 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- This module represents concrete syntax tree for phi-calculus expression module CST where import AST @@ -75,33 +74,33 @@ | BT_ONE String | BT_MANY [String] | BT_META META - | BT_PIPED BYTES -- bytes wrapped in vertical pipes, as the eolang LaTeX package expects - | BT_CUT [String] Int [String] -- the first bytes of a long string, the count of the bytes cut out of it and its last bytes, as '--abridged' spells it (#1465) + | BT_PIPED BYTES + | BT_CUT [String] Int [String] deriving (Eq, Show) data META_HEAD - = E -- 𝑒 - | E' -- e - | N -- 𝑛 - | N' -- n - | K -- 𝑘 - | K' -- k - | A -- t (ASCII attribute meta) - | TAU -- 𝜏 - | TAU' -- \tau - | I -- 𝑖 - | I' -- i - | B -- 𝐵 - | B' -- B - | D -- 𝛿 - | D' -- \delta - | D'' -- d - | F -- 𝑓 - | F' -- F - | F'' -- f - | S -- 𝜎 - | S' -- S - | S'' -- \sigma + = E + | E' + | N + | N' + | K + | K' + | A + | TAU + | TAU' + | I + | I' + | B + | B' + | D + | D' + | D'' + | F + | F' + | F'' + | S + | S' + | S'' deriving (Eq, Show) data EXCLAMATION = EXCL | NO_EXCL @@ -130,14 +129,14 @@ | PA_FORMATION {attr :: ATTRIBUTE, voids :: [ATTRIBUTE], arrow :: ARROW, expr :: EXPRESSION} | PA_VOID {attr :: ATTRIBUTE, arrow :: ARROW, void :: VOID} | PA_LAMBDA {func :: T.Text} - | PA_LAMBDA' {func :: T.Text} -- ASCII version of PA_LAMBDA + | PA_LAMBDA' {func :: T.Text} | PA_META_LAMBDA {meta :: META} - | PA_META_LAMBDA' {meta :: META} -- ASCII version of PA_META_LAMBDA' + | PA_META_LAMBDA' {meta :: META} | PA_DELTA {bytes :: BYTES} - | PA_DELTA' {bytes :: BYTES} -- ASCII version of PA_DELTA + | PA_DELTA' {bytes :: BYTES} | 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' (#1465) + | PA_META_DELTA' {meta :: META} + | PA_FOLDED {count :: Int} deriving (Eq, Show) newtype APP_BINDING = APP_BINDING {pair :: PAIR} @@ -155,8 +154,6 @@ | BDS_META {eol :: EOL, tab :: TAB, meta :: META, bindings :: BINDINGS} deriving (Eq, Show) --- Arguments for application with default α attributes --- which are not necessary to be printed data APP_ARG = APP_ARG {expr :: EXPRESSION, args :: APP_ARGS} deriving (Eq, Show) @@ -165,29 +162,28 @@ | AAS_EMPTY deriving (Eq, Show) --- The argument carried by an application, in one of three sugar shapes data APP_ARGUMENT - = AA_TAU APP_BINDING -- e(a1 -> e1) - | AA_TAUS BINDING -- e(a1 -> e1)(a2 -> e2)(...) - | AA_EXPRS APP_ARG -- e(e1, e2, ...) + = AA_TAU APP_BINDING + | AA_TAUS BINDING + | AA_EXPRS APP_ARG deriving (Eq, Show) data EXPRESSION = EX_GLOBAL {global :: GLOBAL} | EX_XI {xi :: XI} - | EX_ATTR {attr :: ATTRIBUTE} -- sugar for $.x -> just x + | EX_ATTR {attr :: ATTRIBUTE} | EX_TERMINATION {termination :: TERMINATION} | EX_FORMATION {lsb :: LSB, eol :: EOL, tab :: TAB, binding :: BINDING, eol' :: EOL, tab' :: TAB, rsb :: RSB} | EX_DISPATCH {expr :: EXPRESSION, space :: SPACE, attr :: ATTRIBUTE} - | EX_APPLICATION {expr :: EXPRESSION, space :: SPACE, eol :: EOL, tab :: TAB, argument :: APP_ARGUMENT, eol' :: EOL, tab' :: TAB, indent :: Int} -- e(...) + | EX_APPLICATION {expr :: EXPRESSION, space :: SPACE, eol :: EOL, tab :: TAB, argument :: APP_ARGUMENT, eol' :: EOL, tab' :: TAB, indent :: Int} | EX_STRING {str :: String, tab :: TAB, rhos :: [Argument]} | EX_NUMBER {num :: Either Int Double, tab :: TAB, rhos :: [Argument]} - | EX_NONFINITE {global :: GLOBAL, nonfinite :: NonFinite, tab :: TAB, rhos :: [Argument]} -- Φ.nan, Φ.pinf and Φ.ninf (see #1065) + | EX_NONFINITE {global :: GLOBAL, nonfinite :: NonFinite, tab :: TAB, rhos :: [Argument]} | EX_META {meta :: META} | EX_PHI_MEET {prefix :: Maybe String, idx :: Int, expr :: EXPRESSION} | EX_PHI_AGAIN {prefix :: Maybe String, idx :: Int, expr :: EXPRESSION} - | EX_BYTES {bytes :: BYTES} -- bare data 𝛿, a rendering-only terminal chain node (see #980) - | EX_SINGLE {pair :: PAIR, space :: SPACE, formation :: EXPRESSION} -- one-binding formation as 'FF-:Δ' or 'ξ.a:φ', with its full form (see #1385) + | EX_BYTES {bytes :: BYTES} + | EX_SINGLE {pair :: PAIR, space :: SPACE, formation :: EXPRESSION} deriving (Eq, Show) data ATTRIBUTE @@ -263,21 +259,9 @@ expressionToCST :: Expression -> EXPRESSION expressionToCST = toCST' --- Like 'expressionToCST', but lays the expression out from a given base tab --- instead of column 0. Used when an expression sits on an already-indented --- line (e.g. a continuation step of the LaTeX --sequence output, after its --- arrow), so its wrapped member lines nest one level below that line and its --- closing bracket aligns with the opening one. expressionToCSTFrom :: Int -> Expression -> EXPRESSION expressionToCSTFrom tabs expr = toCST expr (tabs, EOL) --- A number can be rendered in sweet form when it is either finite, and so has --- a numeric literal, or one of the three canonical non-finite doubles, which --- get the root dispatches `Φ.nan`, `Φ.pinf` and `Φ.ninf` instead (the bare --- `show` tokens `NaN`, `Infinity` and `-Infinity` would collide with --- object/function names, hence the dispatch — see #1065). Any other non-finite --- pattern, such as a NaN carrying a payload, is kept in its byte form so that --- no bit of it is lost. sweetNumber :: Bytes -> Bool sweetNumber bts | btsSize bts /= 8 = False @@ -285,14 +269,9 @@ Right dbl | isNaN dbl || isInfinite dbl -> isJust (btsToNonFinite bts) _ -> True --- A string can be rendered as a literal only when its bytes decode as UTF-8. --- An arbitrary byte array is a legal datum and nothing promises it decodes, so --- a malformed one is kept in its byte form, exactly as a payload NaN is kept --- today (see #1138). sweetString :: Bytes -> Bool sweetString = btsIsUtf8 --- Whether a data object may be collapsed into its sweet literal form. sweetCollapsible :: Expression -> Bool sweetCollapsible (DataNumber bts) = sweetNumber bts sweetCollapsible (DataString bts) = sweetString bts @@ -322,24 +301,15 @@ metaTail :: T.Text -> T.Text metaTail = T.drop 1 --- An anonymous meta renders as the bare sigil it was written with: it carries --- no suffix, and needs none, since nothing on the page refers back to it. anyMeta :: META_HEAD -> META anyMeta hd' = META NO_EXCL hd' T.empty --- The first character of an expression meta name encodes its kind: --- 'n'-prefixed names are normal-form-constrained '𝑛' metas, 'k'-prefixed --- names are absolute-constrained '𝑘' metas, everything else is an ordinary --- '𝑒' meta. exMetaHead :: T.Text -> META_HEAD exMetaHead mt | T.isPrefixOf "n" mt = N | T.isPrefixOf "k" mt = K | otherwise = E --- This class is used to convert AST to CST --- CST is created with sugar and unicode --- All further transformations must consider that class ToCST a b where toCST :: a -> (Int, EOL) -> b @@ -353,10 +323,6 @@ toCST (ExPhiMeet prefix idx expr) ctx = EX_PHI_MEET prefix idx (toCST expr ctx) toCST (ExPhiAgain prefix idx expr) ctx = EX_PHI_AGAIN prefix idx (toCST expr ctx) toCST (ExFormation []) _ = EX_FORMATION LSB NO_EOL NO_TAB (BI_EMPTY NO_TAB) NO_EOL NO_TAB RSB - -- A formation of a single binding is sugared into its asset, a colon and - -- the attribute, as `FF-:Δ`, `Plus:λ`, `∅:a` or `ξ.a:φ` (see #1385). The - -- full formation is kept next to it, for the notations that have no such - -- sugar: the salty one and the one '--hide-rho' strips. toCST (ExFormation bds) ctx@(tabs, eol) = maybe full (\sole -> EX_SINGLE sole NO_SPACE full) (single bds) where @@ -372,11 +338,6 @@ EOL (TAB tabs) RSB - -- The asset of the only binding, laid out where the formation stands, - -- unless it has no sugar: a meta binding, a τ binding whose attribute - -- the parser takes for a Δ or a λ, one that carries a formation with - -- inline voids, which reads better as 'x(a) ↦ ⟦ … ⟧', or the void ρ a - -- formation declares as its receiver, which reads better as '⟦ ρ ↦ ∅ ⟧' single :: [Binding] -> Maybe PAIR single [BiTau AtDelta _] = Nothing single [BiTau AtLambda _] = Nothing @@ -391,24 +352,10 @@ inlined PA_FORMATION{voids = _ : _} = True inlined _ = False toCST (DataString bts) (tabs, _) | sweetString bts = EX_STRING (btsToStr bts) (TAB tabs) [] - -- The three canonical non-finite doubles have no sweet numeric literal, so - -- they become the root dispatches `Φ.nan`, `Φ.pinf` and `Φ.ninf`. Any other - -- non-finite pattern is left in its byte form `Φ.number(Φ.bytes(⟦ Δ ⤍ … ⟧))` - -- by falling through to the generic application clause below. toCST (DataNumber bts) (tabs, _) | Just nonfinite <- btsToNonFinite bts = EX_NONFINITE Φ nonfinite (TAB tabs) [] toCST (DataNumber bts) (tabs, _) | sweetNumber bts = EX_NUMBER (btsToNum bts) (TAB tabs) [] toCST (ExDispatch ExXi attr) ctx = EX_ATTR (toCST attr ctx) toCST (ExDispatch expr attr) ctx = EX_DISPATCH (toCST expr ctx) NO_SPACE (toCST attr ctx) - -- Since we convert AST to CST in sweet notation, here we're trying to get rid of unnecessary rho bindings - -- in primitives (more details here: https://github.com/objectionary/phino/issues/451) - -- If we find something similar to: - -- `Q.number(~0 -> Q.bytes(...), ^ -> ..., ^ -> ...)` - -- We remove unnecessary rho bindings and save them to EX_STRING or EX_NUMBER so they can be successfully - -- converted to salty notation without losing information. - -- In the end we just get CST with data primitive which is printed correctly. - -- If given application is not such primitive - we just convert it to one of the applications: - -- 1. either with pure expression with arguments, which means there are incremented only alpha bindings - -- 2. or with just bindings toCST app@(ExApplication _ _) ctx@(tabs, eol) = let (ex, ts, exs) = complexApplication app ex' = toCST ex ctx :: EXPRESSION @@ -465,12 +412,6 @@ Nothing -> EX_NUMBER (btsToNum bts) (TAB tabs) rhos applicationToPrimitive (DataString bts) tabs rhos = EX_STRING (btsToStr bts) (TAB tabs) rhos applicationToPrimitive _ _ _ = error "applicationToPrimitive expects DataNumber or DataString" - -- Here we unroll nested application sequence into flat structure - -- The returned tuple consists of: - -- 1. deepest start expression - -- 2. list of tau bindings which are applied to start expression - -- 3. list of expressions which are applied to start expression with default - -- alpha attributes (~0 -> e1, ~1 -> e2, ...) complexApplication :: Expression -> (Expression, [Argument], [Expression]) complexApplication expr = let (expr', taus', exprs') = complexApplication' expr @@ -491,12 +432,6 @@ complexApplication' (ExApplication expr (ArAlpha (Alpha 0) expr')) = (expr, [ArAlpha (Alpha 0) expr'], [expr']) complexApplication' (ExApplication expr tau) = (expr, [tau], []) complexApplication' expr = (expr, [], []) - -- This head' works the same as head from Prelude but doesn't throw an error - -- It's used to bypass the x-partial error in ghc 9.8.* - -- This approach is just simpler that switching to NonEmpty for complexApplication or withoutRhosInPrimitives functions - -- but not a brightest design - -- There never be an empty list because application always has binding, which means complex application - -- always has non empty list of bindings head' :: [a] -> a head' [] = error "Should never be called" head' (x : _) = x @@ -536,8 +471,6 @@ ARROW (toCST (ExFormation (others ++ rest)) ctx) where - -- 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 positionless BiVoid{} = True positionless BiLambda{} = True diff --git a/src/Canonizer.hs b/src/Canonizer.hs --- a/src/Canonizer.hs +++ b/src/Canonizer.hs @@ -1,9 +1,6 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- Canonization is the process of replacing function names attached to --- lambda bindings with numbered identifiers prefixed with 'Fn' --- like 'Fn1', 'Fn2', etc. module Canonizer (canonize, canonizeExpr) where import AST @@ -12,6 +9,10 @@ canonizeBindings :: [Binding] -> Int -> ([Binding], Int) canonizeBindings [] idx = ([], idx) +canonizeBindings ((BiLambda (Function name)) : rest) idx + | name == T.pack "Package" = + let (bds', idx') = canonizeBindings rest idx + in (BiLambda (Function name) : bds', idx') canonizeBindings ((BiLambda (Function _)) : rest) idx = let (bds', idx') = canonizeBindings rest (idx + 1) in (BiLambda (Function (T.pack ("Fn" <> show idx))) : bds', idx') @@ -50,8 +51,6 @@ let (expr', idx') = canonizeExpression expr idx in (ArAlpha alpha expr', idx') --- Canonize a single expression, restarting the 'Fn' counter from 1 so the --- numbering is local to that expression. canonizeExpr :: Expression -> Expression canonizeExpr expr = fst (canonizeExpression expr 1) diff --git a/src/Condition.hs b/src/Condition.hs --- a/src/Condition.hs +++ b/src/Condition.hs @@ -24,15 +24,12 @@ type Parser = Parsec Void String --- White space consumer whiteSpace :: Parser () whiteSpace = L.space hspace1 empty empty --- Lexeme that ignores white spaces after lexeme :: Parser a -> Parser a lexeme = L.lexeme whiteSpace --- Strict symbol (or sequence of symbols) with ignored white spaces after symbol :: String -> Parser String symbol = L.symbol whiteSpace diff --git a/src/Contextualize.hs b/src/Contextualize.hs --- a/src/Contextualize.hs +++ b/src/Contextualize.hs @@ -4,14 +4,6 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- The Contextualization function 𝒞 of the calculus, carried out by the rules --- of 'resources/contextualization' and by nothing else, the way the other --- judgments are carried out by theirs: 𝒞(n, c) is the conclusion of the one --- rule whose 'match' matches the term and whose 'c-match' matches the context, --- every premise of it a 𝒞 of a smaller term. A change to a rule is a change to --- what runs, and 'explain --contextualize' prints the rules that fire (#1618). --- The letters '𝑛' and '𝑘' of the rules are only names here, since the match is --- the plain one, which demands neither a normal form nor an absolute term. module Contextualize (concluded, contextualize, ContextualizeException (..)) where import AST @@ -26,28 +18,17 @@ import Text.Printf (printf) import qualified Yaml as Y --- 𝒞 has no single conclusion for a term: no rule matches it, more than one --- does, or the one that does cannot be carried out on it. It carries the term --- and the reason, which is a clause of the sentence it is shown in. data ContextualizeException = Uncontextualizable Expression String deriving (Exception) instance Show ContextualizeException where show (Uncontextualizable term reason) = printf "Contextualization has no single conclusion, since %s: %s" reason (printExpression term) --- The conclusion of the one rule that matched the term, among the names of the --- rules that matched it beside what each of them concludes, or the failure of --- a term no rule or more than one rule matches. Only the conclusion of the one --- rule is ever worked out, so the other judgments of 'contextualize' and of --- the function 'phino compile' writes for 𝒞 are never asked for (#1617). concluded :: Expression -> [(String, Either ContextualizeException Expression)] -> Either ContextualizeException Expression concluded _ [(_, answer)] = answer concluded term [] = Left (Uncontextualizable term "no contextualization rule matches the term") concluded term several = Left (Uncontextualizable term (printf "the contextualization rules %s all match the term" (intercalate ", " (map fst several)))) --- The term with every ξ outside the formations nested in it standing for the --- context, or the failure of the term that has no single conclusion, which may --- be a part of the term rather than the term itself. contextualize :: Expression -> Expression -> IO Expression contextualize expr context = either throwIO pure (contextualized expr context) where @@ -58,8 +39,6 @@ [ (rule.name, foldM (premised term rule) subst rule.premises >>= built term rule rule.cresult) | (rule, subst) <- matching term around ] - -- Every rule matching the term and the context, once for every way it - -- matches them, so a rule matching in two ways is as ambiguous as two rules. matching :: Expression -> Expression -> [(Y.ContextualizeRule, Subst)] matching term around = [ (rule, subst) diff --git a/src/Dataize.hs b/src/Dataize.hs --- a/src/Dataize.hs +++ b/src/Dataize.hs @@ -7,10 +7,6 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- The Dataization function 𝔻 and what a program asking phino to reduce one of --- its own terms gets back. Everything 𝔻 shares with the Morphing function 𝕄 — --- the context, the budget, the signals, the premise plumbing — lives in --- 'Morph', which this module imports. module Dataize (dataize, dataize', reduction, Outcome (..)) where import AST @@ -29,32 +25,13 @@ type Dataized = (Bytes, [Rewritten]) --- What 𝔻 is handed: a term plus the derivation that reached it, the same pair --- 𝕄 works on (see 'Morphed'). type Dataizable = Morphed --- What a run of 𝔻 ends with: the bytes it reached or, under '_partial', the --- residual program: what the known inputs decided is computed, the stuck λ --- function and everything depending on it survive in place. data Outcome = Dataized Bytes | Residual Expression deriving stock (Eq, Show) --- Dataize the expression located at '_locator'. The whole input expression is --- itself the universe Q (the 'e' argument) threaded through 𝔻 and 𝕄, so it is --- passed both as the located target and as the universe. A λ function that --- 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 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 @@ -66,40 +43,6 @@ Left (LoopingAt _ seq parked) | _partial -> pure (Residual (fst (NE.head seq)), reverse (NE.toList seq), parked) Left failure -> throwIO (failure :: ReduceException) --- The Dataization function 𝔻 retrieves bytes from an expression. It is partial --- and ternary, 𝔻(n, e, s): besides the term 'n' it takes the universe 'e' ('univ'), --- which it forwards to 𝕄, and the mutable state 's', returning the bytes together --- with the new state. Its rules come from 'resources/dataization', run by the --- engine (see '_dataization' of 'Engine'): 'delta' yields the --- asset bytes and 'none' (a formation with no Δ/λ/φ) has nothing to dataize, so --- it dataizes ⊥. The terminator ⊥ signals an error and lies outside 𝔻's domain, --- so it matches no clause (there is no 'end' rule mapping it to empty bytes) and --- dataization stops there; a data-less formation therefore fails through the --- same path (see #955). The dead end is signalled as 'Undataizable', whose --- message names the terminator where that is what was reached rather than --- reporting the generic "no dataization rule matched", and which an operand of --- a firing parks on under '_partial' (see 'reduction', #1401). --- 'box' contextualizes the φ-body and keeps dataizing (its step is labelled by --- its 'contextualize' side-computation), and 'norm' reduces through morphing, --- splicing the morphing steps into the chain. The clauses are disjoint (see --- #902, #905), so their declaration order must not be load-bearing; when --- '_shuffle' is on (the '--shuffle' flag) the rules are shuffled before --- 'inferred' walks them to exercise that invariant — mirroring normalization's --- "apply until they stop matching". A genuinely order-independent step stays --- deterministic; a hidden overlap surfaces as a nondeterministic failure rather --- than staying silently green. --- 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 (see --- 'dataizationSpine' of 'Inference'). --- 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 guarded <- deeper =<< entering expr =<< universed univ caller{_judgment = Dataization} @@ -109,9 +52,6 @@ Nothing -> do reached <- inferred expr univ state ctx ctx._engine._dataization case reached of - -- Data the program itself carries stands for nothing but itself, so - -- whichever symbol the last datum was manufactured for is forgotten - -- here: only a run ending on a symbol leaves one behind. Just (In.Answered step bts, state') -> do seq' <- leadsTo seq step (ExBytes bts) ctx pure ((bts, NE.toList seq'), state'{_manufactured = Nothing}) @@ -120,55 +60,20 @@ dataize' dataizable world state'' ctx 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 - -- would get stuck; 𝔻 therefore takes it before the rules are ever walked, - -- which also keeps 'fire' from matching what it cannot fire. unknown :: Expression -> Maybe Int unknown (ExFormation bds) = listToMaybe [idx | BiLambda (FnSymbol idx) <- bds] unknown _ = Nothing - -- A symbol dataizes to a datum manufactured for it: dataizing an unknown - -- never gets stuck, and the very same 42 answers every symbol, since the - -- run is symbolic and no arithmetic of it is ever read. Which symbol the - -- datum stands for is told to the state rather than to the term, so the - -- protocol writes '𝔻(𝜎1)' where the term carries nothing but the 42. manufactured :: Int -> ReduceContext -> IO (Dataized, State) manufactured idx ctx = do seq' <- leadsTo seq (Dataization, "symbol") (ExBytes datum) ctx pure ((datum, NE.toList seq'), state{_manufactured = Just idx}) --- What a 'dataize' operand of a λ function is brought down with (see --- 'ReductionFunc' in 'Morph'): the operand is bound to a synthetic attribute of --- the universe and dataized there, exactly the way the '--inside' option does --- it, so what comes back is the data the operand carries. Where a λ function on --- the way could not fire and '_partial' parked it, the operand never came down --- to data at all and nothing comes back, which leaves the firing that asked for --- it stuck. An operand reaches a firing unreduced, since reducing it may take --- the very λ function being fired, so it is reduced here, on demand, and not --- before. The context is the one the fire descended with, so the step budget of --- the run bounds the nesting, and the state 𝑠 goes in and comes back out, so --- the symbols this reduction mints are counted in the same sequence as the ones --- around it. --- --- An operand reaching a term outside the domain of 𝔻 — the terminator ⊥, or a --- term no dataization rule matches, such as a formation whose φ is a void --- nothing filled — never comes down to data either, and under '_partial' it --- leaves the firing stuck the same way rather than ending the run: an unfilled --- void or an error object is as much a property of the program as a λ function --- nobody answers (#1401). The protocol records the dead end as a stuck site --- named '⊥', written with the term 𝔻 could not dataize, and the name travels --- back in the state as the one the firing got stuck on (see '_stuck'). A run --- of 𝔻 that is not an operand still fails on it, '_partial' or not (#955). reduction :: ReductionFunc reduction univ ctx expr state = do (universe, aiming) <- insideUniverse expr univ ctx @@ -186,10 +91,5 @@ reached (Dataized bytes) = Just bytes reached (Residual _) = Nothing --- The datum every symbol dataizes to: 42 as a double, the same for all of them. --- A symbolic run computes nothing, so what the datum is carries no meaning at --- all; what matters is that 𝔻 of an unknown answers rather than gets stuck, so --- a λ function whose operands are unknowns still fires and still answers with --- an unknown of its own. datum :: Bytes datum = BtMany ["40", "45", "00", "00", "00", "00", "00", "00"] diff --git a/src/Deps.hs b/src/Deps.hs --- a/src/Deps.hs +++ b/src/Deps.hs @@ -4,15 +4,10 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- The main goal of this module is breaking cyclic dependency: --- Dataize -> Functions -> Rewriter -> Dataize --- Here we provide custom type BuildTermFunc and add it to --- RewriteContext and ReduceContext. Now Dataize and Rewrite depends --- only on Term module. This allows us to use Rewriter and Dataize in --- Functions module because Rewriter does not depend on Functions anymore. module Deps where import AST +import Control.Monad (unless, when) import Data.IORef (IORef, readIORef, writeIORef) import Data.List (intercalate) import qualified Data.Map.Strict as Map @@ -28,7 +23,7 @@ import System.IO (Handle, hPutStrLn) import Text.Printf (printf) import XMIR (escapeXML, escapeXMLText) -import Yaml +import Yaml (ExtraArgument) data Term = TeExpression Expression @@ -38,26 +33,12 @@ type BuildTermMethod = [ExtraArgument] -> Subst -> IO Term --- The state 𝑠 threaded through the Morphing 𝕄(n, e, s), Dataization 𝔻(n, e, s) --- and Evaluation 𝔼(b, s) functions. Unlike the universe 𝑒, which is immutable --- and threaded unchanged, the state is mutable: 𝔼 takes a state 𝑠1 and returns --- a new one 𝑠2, and 𝕄/𝔻 propagate that change to their callers. It carries how --- many symbols the run has minted, so the next 𝜎 an answer asks for is one no --- term already holds, which symbol the last datum was manufactured for, --- since every symbol dataizes to the very same 42 and only the state can tell --- the protocol which unknown that 42 stood for, and which λ function the last --- reduction of it was parked on, since a run '--partial' parks answers a --- residue and the name of what parked it would otherwise be lost with the --- signal the residue was made of (#1288). data State = State { _minted :: Int , _manufactured :: Maybe Int , _stuck :: Maybe T.Text } --- Like 'BuildTermMethod', but it also takes the incoming state and returns the --- new state alongside the term. Lives here next to 'BuildTermMethod' so the two --- stay together. type BuildTermMethodS = [ExtraArgument] -> Subst -> IO (Term, State) type BuildTermFunc = String -> BuildTermMethod @@ -76,30 +57,14 @@ dontSaveStep :: SaveStepFunc dontSaveStep = saveStep Nothing "" (\_ -> pure "") 0 --- A judgment of the calculus. A run of the protocol records one of two, 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, '', 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. A step of a '--sequence' chain is taken by any of the five, --- which is what picks the arrow LaTeX writes the step with (#1536). data Judgment - = -- The Normalization function 𝒩, which the 'rewrite' command runs. - Normalization - | -- The Morphing function 𝕄, which the 'morph' command runs. - Morphing - | -- The Dataization function 𝔻, which the 'dataize' command runs. - Dataization - | -- The Evaluation function 𝔼, which fires a λ function. - Evaluation - | -- The Contextualization function 𝒞, which 'box' of 𝔻 runs over a φ body. - Contextualization + = Normalization + | Morphing + | Dataization + | Evaluation + | Contextualization deriving (Eq, Show) --- The letter the calculus writes a judgment with, which is how the text format --- opens a run of it. letter :: Judgment -> String letter Normalization = "𝒩" letter Morphing = "𝕄" @@ -107,11 +72,6 @@ letter Evaluation = "𝔼" letter Contextualization = "𝒞" --- The element the markup opens a run of a judgment with, and closes it under, --- named after the judgment the way '' is named after 𝔼. A root --- '' carries the locator the run was aimed at where one inside a --- firing carries the meta it bound, which is the very difference the text --- format draws between '𝔻(Φ)' at the top and '𝛿1.2 := 𝔻(…)' in a block. opened :: Judgment -> String opened Normalization = "normalize" opened Morphing = "morph" @@ -119,213 +79,38 @@ opened Evaluation = "evaluate" opened Contextualization = "contextualize" --- 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 --- under it stands one block per firing, '𝔼(L_number_plus) # 𝔻(Φ.φ)', naming --- the entry that answered, the judgment that asked for the firing and the site --- of the program it was fired at (#1302, #1306). Inside a block stand the --- operands the entry bound — each with the judgment that reduced it and the --- term it was reduced from — whatever a 'symbolize' line of it knows about a --- symbol it minted, the terms a 'join' line of it made one of and what it --- knows about the symbol they were joined into, and the term it answered with, --- one to a line, and any firing an operand took while it was being reduced, --- one level deeper again. The answer takes two of those lines rather than one: --- 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 --- 'unanswered(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 - | -- One firing of the entry under that key, at the depth its nesting gives - -- it, together with the site it was fired at: the locator of the part of - -- the program the firing belongs to, which is the aim of the run refined by - -- the '--deep' walk as it enters a binding (see '_site' in 'Morph'). The - -- key says which entry answered and one entry answers the same way wherever - -- it is fired, so the site is the one thing telling two firings of it apart - -- by something other than the order they came in, and it is written as the - -- comment of the line the way a stuck site carries the formation it was - -- asked about (#1302). The judgment stands beside it for the reason a stuck - -- site carries one: 𝔼 is fired from the 'ml' rule of morphing and from the - -- 'fire' rule of dataization, and the comment says what was running over - -- 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 - -- it. Nothing fired, so the line stands alone and no block opens under it. - -- It is written whether or not '--partial' goes on to park the run, since - -- the protocol records what 𝔼 was asked for and a question it could not - -- answer belongs there as much as one it could — and the object it was - -- asked about is half of that question, so the record carries it the way - -- every other one carries the term it is about, as the comment of the line - -- in the text format and as the text of the element in the markup. The - -- judgment stands beside it because 𝔼 is fired from two places — the 'ml' - -- rule of morphing and the 'fire' rule of dataization — and which of them - -- asked is what says where in the reduction the site stands (#1300). - EvStuck Int T.Text Judgment Expression - | -- A firing the memo of '--acyclic=plausible' answered with the stall an - -- earlier firing of the same formation kept, at the depth of the lines - -- under the firing, together with the λ function that stall names. It - -- stands under the firing line the way a 'looped' line stands under a - -- told cut, so a told stall no longer reads as a fresh firing whose - -- first operand wrote nothing (#1524). - EvStall Int T.Text - | -- The last line of a firing that ended stuck, at the depth of the lines - -- under the firing, together with the λ function it got stuck on, which - -- is seldom the one no entry answers: that one is an 'EvStuck', written - -- where it was asked for, and this one closes every firing the signal - -- passed on its way out (#1524). - EvStuckOn Int T.Text - | -- The step budget running out, at the depth of the frame that asked for - -- one more step, together with the limit, the judgment of that frame and - -- the locator of the site it stood at. It is written whether or not - -- '--partial' goes on to park the term, since a firing the budget starved - -- otherwise reads the same as one that went well (#1524). The site and not - -- the term, since the walk of 𝕄 stands at the whole formation it morphs, - -- which on a real world spells a universe on every line (#1531). - EvStarved Int Int Judgment Expression - | -- The deadline of '--max-seconds' passing, at the depth the frame it - -- refused would have stood at, together with the seconds the run was - -- given, the judgment of that frame and the locator of the site it stood - -- at. The run ends on it with or without '--partial', so it is the last - -- line of the protocol and a run out of time reads as one and not as a - -- crash (#1607, #1619). - EvTimeout Int Int Judgment Expression - | -- A 'dataize' operand of the firing: the meta it bound, the term the entry - -- wrote under that meta, and the data it came down to, or the symbol that - -- data was manufactured for. - EvData Int T.Text Expression (Either Int Bytes) - | -- A 'morph' operand of the firing: the meta it bound, the term the entry - -- wrote under that meta, and the normal form 𝕄 reached. - EvTerm Int T.Text Expression Expression - | -- A 'symbolize' line of the firing: the meta it bound, the meta of the - -- entry it was told to stand the data of, and the term that standing made - -- — the very term that meta is bound to, with the data of it standing for - -- unknowns. It is a binding like 'EvTerm' and differs in what the line is - -- commented with, since nothing of the calculus runs here: the line names - -- a meta the entry bound above it, the way a 'join' line names the two it - -- joined, where an operand line names the judgment that reduced it - -- (#1306). A 'rewrite' line is written the same way and for the same - -- reason: it applies the rules of the entry to a meta bound above it and - -- reduces nothing either (#1409). - EvSymbolize Int T.Text Expression Expression - | -- What is known about a symbol a 'symbolize' line minted: dataizing the - -- formation the symbol names answers these bytes. It is a fact about the - -- symbol and no binding of it, since a 𝜎 is the name of a λ function and - -- neither a datum nor a term, so it stands on a line of its own rather - -- than beside a meta the firing bound (#1269). - EvKnown Int Int Bytes - | -- A 'join' line of the firing: the meta it bound, the two metas whose terms - -- it joined, in the order the entry wrote them, and the term they joined - -- into. It is a binding like 'EvTerm' and differs only in what the line is - -- commented with, a 'join' line naming two metas of the entry where every - -- other block names a term of the calculus (#1246). - EvJoin Int T.Text (T.Text, T.Text) Expression - | -- What is known about a symbol the join of two branches of a fork minted: - -- dataizing the formation it names answers what dataizing one of the two - -- formations the branches carried answers, and which of the two it is is - -- the very thing nobody has worked out. The two stand in the order the - -- entry listed the branches under '𝑛', so a reader who knows the entry - -- knows which of them belongs to which branch. It is a fact about the - -- symbol and no binding of it, exactly as 'EvKnown' is (#1246). - EvJoined Int Int (Int, Int) - | -- A 'join' line one of whose two terms is ⊥, which is how a program - -- spells "raise unless the condition holds": what the condition of the - -- fork came down to — the first operand the entry dataized, a symbol or - -- data, where it dataized any — the side that raises, 'left' or 'right' in - -- 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). - 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). 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 - -- answer of a firing is morphed (#1268) and a morphing nobody sees is a - -- term appearing out of nothing: whatever that morphing fires opens its - -- own block between this record and 'EvAnswer', so a reader sees the term - -- the entry wrote, the firings reducing it took, and the normal form it - -- came to, in that order (#1298). The line of it is commented with '𝑛', - -- the key the entry writes its answer under, the way an operand line - -- carries the term it was reduced from: the name on the left is minted by - -- the protocol and says nothing about where the term was read from. - EvBuilt Int Expression - | -- What the firing answered with, which is the term of 'EvBuilt' as 𝕄 - -- leaves it. It is the answer every consumer reads, since it is the term - -- the walk stands back into the program. The line of it is commented with - -- '𝕄(𝑛.4.1)', naming the line it was morphed from, since the two may stand - -- whole blocks apart and a value alone never says what it came from — the - -- very reason an operand line carries the term it was reduced from. - EvAnswer Int Expression + = EvRun Judgment T.Text + | EvFiring Int T.Text Judgment Expression + | EvFormation Int Expression Expression + | EvLooped Int Judgment Acyclic Expression Expression + | EvStuck Int T.Text Judgment Expression + | EvStall Int T.Text + | EvStuckOn Int T.Text + | EvStarved Int Int Judgment Expression + | EvTimeout Int Int Judgment Expression + | EvData Int T.Text Expression (Either Int Bytes) + | EvTerm Int T.Text Expression Expression + | EvSymbolize Int T.Text Expression Expression + | EvKnown Int Int Bytes + | EvJoin Int T.Text (T.Text, T.Text) Expression + | EvJoined Int Int (Int, Int) + | EvTerminate Int (Maybe (Either Int Bytes)) T.Text T.Text + | EvMinted Int Int [Either Int Bytes] + | EvBuilt Int Expression + | EvAnswer Int Expression type SaveEvalFunc = Evaluation -> IO () --- The same record with every symbol it names above the floor raised by the --- offset, the terms it carries included (see 'lifted'). A binding the --- '--deep' walk morphs on a worker of its own under '--jobs' numbers its --- symbols from the floor every worker starts at, and its records are --- renumbered like this as they are written, once the bindings before it are, --- so the protocol names a symbol the way the answer does (#1534). renumbered :: Int -> Int -> Evaluation -> Evaluation renumbered floor' offset = record where @@ -356,117 +141,48 @@ datum :: Either Int Bytes -> Either Int Bytes datum = either (Left . symbol) Right --- 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 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 --- keeps the format honest: the symbolized copy of a term carries the same --- first symbol as the term it was made of and differs deeper down, so naming --- the copy after the original claimed nothing was replaced on the very line --- that replaced something (#1292). type Named = Map.Map Int [(Expression, T.Text)] --- The name an earlier line gave this very term, if one did. The digest lookup --- is fast; the (==) check runs only on a digest match, so two terms that differ --- anywhere are two terms and neither is ever written as the other. namedLookup :: Expression -> Named -> Maybe T.Text namedLookup term names = lookup term (Map.findWithDefault [] (hashExpression term) names) --- Remember the name a line gives a term, under the digest of that term, --- keeping the names of any term that collides with it. A term written out --- twice takes the name of the later line, which is the line a reader counting --- back from the next one reaches first. namedInsert :: Expression -> T.Text -> Named -> Named namedInsert term naming = Map.alter renamed (hashExpression term) where renamed :: Maybe [(Expression, T.Text)] -> Maybe [(Expression, T.Text)] renamed entries = Just ((term, naming) : filter ((/= term) . fst) (fromMaybe [] entries)) --- What the protocol has counted so far: how many firings the whole run has --- opened, which is what numbers them and so tells a line of one firing from --- the same line of any other; the name last given to each term, which is how --- a term already written out is named instead of written again; and which --- firing is open at each depth, since the operands of a firing belong to the --- firing it was when it started and not to the one another firing has made of --- it since. The firings are numbered across the run rather than per λ --- function, so no two of them give an operand meta the same name and a name --- the protocol points back to points at one line only (#1261). The answers are --- numbered by that same counter and no counter of their own, since a firing --- answers once and so the two lines of its answer are told from every other --- pair by the firing they stand in (#1298). The order the firings come in --- carries nothing — it is the order 𝕄 walks the term — so the symbols are what --- the dependencies are read from: a term carrying 𝜎4 is the term the line that --- minted 𝜎4 stood for. data Protocol = Protocol { _fired :: Int , _named :: Named , _open :: Map.Map Int Int + , _begun :: Bool } --- The protocol before a single firing has been written. emptyProtocol :: Protocol -emptyProtocol = Protocol 0 Map.empty Map.empty +emptyProtocol = Protocol 0 Map.empty Map.empty False --- 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 --- 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 --- nothing; markup does, and the depth a record carries is the only thing --- saying which firings it stands outside of. data Nesting = Nesting { _fires :: Int , _openedAt :: Map.Map Int Int , _closing :: [(Int, String)] } --- The XML protocol before a single element has been opened. emptyNesting :: Nesting emptyNesting = Nesting 0 Map.empty [] --- Append the line of one record to the protocol, indented by the depth of what --- it reports and numbered by what the protocol has seen before it. The handle --- stays open for the whole run, since a run may fire thousands of λ functions --- and reopening the file for each of them buys nothing; the counting rides in --- an 'IORef' next to it, since it is the cursor of the file and not a property --- of the reduction. Expressions are rendered by the caller, which flattens --- them, so a line never spills over more than one. There are two renderers and --- not one because the operand a line is commented with is spelled salty while --- the value it took is spelled the way the run prints its own answer: the --- sweet syntax drops the ξ of 'ξ.x' and leaves a bare 'x', which is the very --- thing the comment is there to say (see 'commented'). saveEval :: Handle -> IORef Protocol -> (Expression -> IO String) -> (Expression -> IO String) -> SaveEvalFunc saveEval handle cursor render salted report = do line <- atomicModify cursor (written report) mapM_ saved line where - -- Put one line of the protocol on the disk and say in the log what went - -- there, the indentation of it dropped, since the log is a list of what - -- happened and no tree. saved :: String -> IO () saved line = do hPutStrLn handle line logDebug (printf "Saved one line of the protocol: %s" (dropWhile (== ' ') line)) - -- The line a report is written as, where it is written as one, together - -- with what the protocol has counted once it is written. A term is looked - -- up by the first symbol it carries and, where that symbol has a name - -- already, written as that name; otherwise it is written out and the - -- symbol takes the name of this line. - -- - -- A symbol the answer of a firing minted is the one record this format - -- keeps no line for: the answer stands spelled out on the line of it, - -- symbols and all, so a reader ties a later 𝔻(⟦ λ ⤍ 𝜎4 ⟧) back to the - -- firing that minted 𝜎4 by reading the very term it answered with. Only - -- the markup, where a term is text and not a thing to be read, spells the - -- fact out (#1280). written :: Evaluation -> Protocol -> IO (Protocol, Maybe String) written (EvRun judgment locator) protocol = - pure (protocol, Just (printf "%s(%s)" (letter judgment) (T.unpack locator))) + pure (protocol{_begun = True}, Just (printf "%s(%s)" (letter judgment) (T.unpack locator))) written (EvFiring depth key judgment site) protocol = do locator <- render site pure @@ -548,106 +264,54 @@ naming = printf "%s.2" stem (protocol', value) <- valued protocol naming term pure (protocol', Just (indented depth (printf "%s := %s # 𝕄(%s.1)" naming value stem))) - -- The value of a term, next to the name this line gives it: the name an - -- earlier line gave this very term, where one did, and the term itself - -- otherwise. Either way the term takes the name of this line, so the next - -- line holding it points back here and not further. Only a term whose - -- value is a symbol is named at all, since that is a term a firing - -- answered with and every other one is worth no less written out than - -- pointed at; the term is matched verbatim, so a term that differs from - -- the one a name stands for is written out however deep the difference - -- sits (#1292). valued :: Protocol -> String -> Expression -> IO (Protocol, String) valued protocol naming term = case denoted term of Nothing -> (,) protocol <$> render term Just _ -> do value <- maybe (render term) (pure . T.unpack) (namedLookup term protocol._named) pure (protocol{_named = namedInsert term (T.pack naming) protocol._named}, value) - -- The value of a term on a line that claims no name for it: the name an - -- earlier line gave this very term, where one did, and the term itself - -- otherwise. The built answer of a firing stands on such a line, since the - -- line under it holds the term 𝕄 made of that one and the two are not the - -- same term: were the first of the pair to claim the name, the second - -- would be written as the first and the morphing would be as invisible as - -- it was before it had a line at all (#1298). borrowed :: Protocol -> Expression -> IO String borrowed protocol term = case namedLookup term protocol._named of Nothing -> render term Just naming -> pure (T.unpack naming) - -- The line of an operand with the judgment that reduced it and the term it - -- was reduced from appended to it as a comment, since the value alone says - -- what the meta was bound to and neither what it was bound from nor what - -- was done to it — and which of the two judgments ran is the whole - -- difference between a line ending in data and one ending in a term - -- (#1306). It is the very term the entry wrote under - -- the meta, spelled the way the calculus reads it — '$.x' is read as 'ξ.x' - -- — which is why it goes through 'salted' and not through the 'render' the - -- value goes through: the sweet syntax writes that same term as a bare 'x', - -- and a bare 'x' reads as a name rather than as the term it is. It is - -- flattened like everything else, so the whole line stays one line of 𝜑. commented :: String -> Judgment -> Expression -> IO String commented line judgment operand = printf "%s # %s(%s)" line (letter judgment) <$> salted operand - -- The same for a line no judgment made: a 'symbolize' one, which stands - -- the data of a term into unknowns and reduces nothing, so the comment - -- names the meta of the entry it was told to stand rather than a judgment - -- applied to a term of the calculus (see 'EvSymbolize'). commented' :: String -> Expression -> IO String commented' line source = printf "%s # %s" line <$> salted source - -- The name of an operand meta on this firing of its λ function: the meta - -- the entry spells it with and which firing of the run this is, since - -- every entry numbers its own metas from 𝛿1 and 𝑛1 and only the firing - -- tells two 𝛿1 apart. The number counts the firings of the whole run and - -- not those of one λ function, so the second firing of one entry and the - -- second of another never write the same name (#1261), and it is the very - -- number the XML format gives the firing in its 'id'. The answer of the - -- firing is named the same way, with a step of its own appended: a firing - -- answers once, so '𝑛.4.1' and '𝑛.4.2' are the built term and the normal - -- form of the one answer firing 4 gave (#1298). The firing a line - -- belongs to is the one opened one level above it. labelled :: Protocol -> Int -> T.Text -> String labelled protocol depth spelling = printf "%s.%d" (T.unpack spelling) (fromMaybe 0 (Map.lookup (depth - 1) protocol._open)) --- The same protocol as XML, which is what '--protocol' writes when the file it --- names ends in '.xml' (see 'withEvalFunc'). It carries the very facts the text --- format carries and carries them as markup rather than as a 𝜑-term a reader --- would have to parse back: the name of an element says what its record is and --- the value the record carries stands as the text of the element, so the edge --- from the firing that minted an unknown to the record that consumed it is read --- off the markup instead of off the spelling of a term (#1245, #1257). That --- edge is what 'minted' carries: a firing hands out one symbol per bare 𝜎 of --- its answer and each of them stands in a record of its own, the way what is --- known about a symbol does, since no one symbol of a term stands for the whole --- of it and picking one would say nothing (#1280). The term itself stays as the --- text of the element, for a reader and not for a program. --- --- The two lines an answer stands on are two elements, and they are told apart --- by their names for the same reason every other pair of records is: 'built' --- holds the term the entry wrote and 'answer' the normal form 𝕄 made of it, so --- a consumer reading 'answer' reads what it always read and one asking what the --- entry itself wrote has an element to ask (#1298). --- --- Nothing is buffered: an element is written the moment its record arrives, --- and the ones it closes are written just before it, so a run firing thousands --- of λ functions costs no more memory than one firing a single λ function and --- the last element to reach the disk is the last one the run got to. What is --- still open when the run ends is closed by 'endEvalXml'. +endEval :: Handle -> IORef Protocol -> Double -> IO () +endEval handle cursor began = do + protocol <- readIORef cursor + when protocol._begun $ do + now <- getMonotonicTime + let taken = milliseconds began now + hPutStrLn handle (printf "msec(%d)" taken) + hPutStrLn handle (printf "firings(%d)" protocol._fired) + hPutStrLn handle (printf "fps(%d)" (perSecond protocol._fired taken)) + +milliseconds :: Double -> Double -> Int +milliseconds began now = round ((now - began) * 1000) + +perSecond :: Int -> Int -> Int +perSecond firings taken = round (fromIntegral firings * 1000 / fromIntegral (max 1 taken) :: Double) + saveEvalXml :: Handle -> IORef Nesting -> (Expression -> IO String) -> SaveEvalFunc saveEvalXml handle cursor render report = do written <- atomicModify cursor (elements report) mapM_ (hPutStrLn handle) written logDebug (printf "Saved %d line(s) of the XML protocol" (length written)) where - -- The elements a report is written as, together with what the protocol has - -- counted once they are written. A report closes every firing it stands - -- outside of before it opens or writes anything of its own. elements :: Evaluation -> Nesting -> IO (Nesting, [String]) elements (EvRun judgment locator) nesting = pure - ( nesting{_closing = (0, opened judgment) : nesting._closing} + ( nesting{_closing = (0, opened judgment) : (-1, "protocol") : nesting._closing} , [ "" - , printf "<%s at=\"%s\">" (opened judgment) (quoted locator) + , "" + , indentedXml 0 (printf "<%s at=\"%s\">" (opened judgment) (quoted locator)) ] ) elements (EvFiring depth key judgment site) nesting = do @@ -658,7 +322,7 @@ , _openedAt = Map.insert depth fires nesting._openedAt , _closing = (depth, "evaluate") : kept } - , closers ++ [indented depth (printf "" (quoted key) (opened judgment) (escapeXML locator))] + , closers ++ [indentedXml depth (printf "" (quoted key) (opened judgment) (escapeXML locator))] ) where (kept, closers) = closed depth nesting._closing @@ -668,43 +332,35 @@ form <- render self locator <- render site let (kept, closers) = closed depth nesting._closing - pure (nesting{_closing = (depth, "formation") : kept}, closers ++ [indented depth (printf "" (escapeXML locator) (escapeXML form))]) + pure (nesting{_closing = (depth, "formation") : kept}, closers ++ [indentedXml depth (printf "" (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 "" (opened judgment) (certainty mode) (escapeXML locator) (escapeXML form))]) + pure (nesting{_closing = kept}, closers ++ [indentedXml depth (printf "" (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 "%s" (quoted key) (opened judgment) (escapeXMLText form))]) + pure (nesting{_closing = kept}, closers ++ [indentedXml depth (printf "%s" (quoted key) (opened judgment) (escapeXMLText form))]) elements (EvStall depth key) nesting = do let (kept, closers) = closed depth nesting._closing - pure (nesting{_closing = kept}, closers ++ [indented depth (printf "" (quoted key))]) + pure (nesting{_closing = kept}, closers ++ [indentedXml depth (printf "" (quoted key))]) elements (EvStuckOn depth key) nesting = do let (kept, closers) = closed depth nesting._closing - pure (nesting{_closing = kept}, closers ++ [indented depth (printf "" (quoted key))]) + pure (nesting{_closing = kept}, closers ++ [indentedXml depth (printf "" (quoted key))]) elements (EvStarved depth limit judgment site) nesting = do locator <- render site let (kept, closers) = closed depth nesting._closing - pure (nesting{_closing = kept}, closers ++ [indented depth (printf "" limit (opened judgment) (escapeXML locator))]) + pure (nesting{_closing = kept}, closers ++ [indentedXml depth (printf "" limit (opened judgment) (escapeXML locator))]) elements (EvTimeout depth limit judgment site) nesting = do locator <- render site let (kept, closers) = closed depth nesting._closing - pure (nesting{_closing = kept}, closers ++ [indented depth (printf "" limit (opened judgment) (escapeXML locator))]) + pure (nesting{_closing = kept}, closers ++ [indentedXml depth (printf "" limit (opened judgment) (escapeXML locator))]) elements (EvData depth spelling _ value) nesting = do record <- stood value - pure (nesting{_closing = kept}, closers ++ [indented depth record]) + pure (nesting{_closing = kept}, closers ++ [indentedXml depth record]) where (kept, closers) = closed depth nesting._closing - -- An operand of a 'dataize' line either came down to data, which is - -- the data, or to the datum manufactured for an unknown, which is the - -- formation that unknown names and never the 42 standing for it. These - -- are two different facts, so the name of the element tells them apart - -- the way 𝔻(…) does in the text format, rather than leaving a reader - -- to test which of two attributes an element carries (#1257). What 𝔻 - -- was applied to is a term either way, and the element named after the - -- judgment holds it as the text format holds it (#1278). stood :: Either Int Bytes -> IO String stood (Left symbol) = do form <- render (standing symbol) @@ -713,18 +369,13 @@ elements (EvTerm depth spelling _ term) nesting = do body <- render term let (kept, closers) = closed depth nesting._closing - pure (nesting{_closing = kept}, closers ++ [indented depth (printf "%s" (escapeXML (labelled nesting depth spelling)) (escapeXMLText body))]) - -- A 'symbolize' line binds a meta to a term like every other line of a - -- firing, and the markup holds what it was bound to and not what it was - -- made from: the term an operand was reduced from is what the text format - -- comments a line with and the markup has never carried, so the two lines - -- the text now tells apart by that comment are one element here (#1306). + pure (nesting{_closing = kept}, closers ++ [indentedXml depth (printf "%s" (escapeXML (labelled nesting depth spelling)) (escapeXMLText body))]) elements (EvSymbolize depth spelling _ term) nesting = do body <- render term let (kept, closers) = closed depth nesting._closing - pure (nesting{_closing = kept}, closers ++ [indented depth (printf "%s" (escapeXML (labelled nesting depth spelling)) (escapeXMLText body))]) + pure (nesting{_closing = kept}, closers ++ [indentedXml depth (printf "%s" (escapeXML (labelled nesting depth spelling)) (escapeXMLText body))]) elements (EvKnown depth symbol bytes) nesting = - pure (nesting{_closing = kept}, closers ++ [indented depth known]) + pure (nesting{_closing = kept}, closers ++ [indentedXml depth known]) where (kept, closers) = closed depth nesting._closing known :: String @@ -732,31 +383,26 @@ elements (EvJoin depth spelling _ term) nesting = do body <- render term let (kept, closers) = closed depth nesting._closing - pure (nesting{_closing = kept}, closers ++ [indented depth (printf "%s" (escapeXML (labelled nesting depth spelling)) (escapeXMLText body))]) + pure (nesting{_closing = kept}, closers ++ [indentedXml depth (printf "%s" (escapeXML (labelled nesting depth spelling)) (escapeXMLText body))]) elements (EvJoined depth fresh (one, two)) nesting = - pure (nesting{_closing = kept}, closers ++ [indented depth joint]) + pure (nesting{_closing = kept}, closers ++ [indentedXml depth joint]) where (kept, closers) = closed depth nesting._closing joint :: String joint = printf "%s %s" (sigma fresh) (sigma one) (sigma two) elements (EvTerminate depth condition side _) nesting = - pure (nesting{_closing = kept}, closers ++ [indented depth terminal]) + pure (nesting{_closing = kept}, closers ++ [indentedXml 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. terminal :: String terminal = case condition of Just (Left symbol) -> printf "" (sigma symbol) (quoted side) Just (Right bytes) -> printf "%s" (quoted side) (escapeXMLText (printBytes bytes)) Nothing -> printf "" (quoted side) elements (EvMinted depth symbol operands) nesting = - pure (nesting{_closing = kept}, closers ++ [indented depth mint]) + pure (nesting{_closing = kept}, closers ++ [indentedXml 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 "" (sigma symbol) @@ -769,87 +415,57 @@ let (kept, closers) = closed depth nesting._closing naming :: String naming = printf "%s.1" (labelled nesting depth answer) - pure (nesting{_closing = kept}, closers ++ [indented depth (printf "%s" (escapeXML naming) (escapeXMLText body))]) + pure (nesting{_closing = kept}, closers ++ [indentedXml depth (printf "%s" (escapeXML naming) (escapeXMLText body))]) elements (EvAnswer depth term) nesting = do body <- render term let (kept, closers) = closed depth nesting._closing naming :: String naming = printf "%s.2" (labelled nesting depth answer) - pure (nesting{_closing = kept}, closers ++ [indented depth (printf "%s" (escapeXML naming) (escapeXMLText body))]) - -- The name of an operand meta on this firing, spelled the way the text - -- protocol's own 'labelled' spells it: the meta the entry names it with - -- in the YAML, followed by which firing of the whole run this is, the - -- very number the element's own 'id' carries, since every entry numbers - -- its own metas from 𝛿1 and 𝑛1 and only the firing tells two 𝛿1 apart - -- (#1261). An answer is named the same way, with the step of the pair - -- appended (#1298). The firing a record belongs to is the one opened one - -- level above it. + pure (nesting{_closing = kept}, closers ++ [indentedXml depth (printf "%s" (escapeXML naming) (escapeXMLText body))]) labelled :: Nesting -> Int -> T.Text -> String labelled nesting depth spelling = printf "%s.%d" (T.unpack spelling) (fromMaybe 0 (Map.lookup (depth - 1) nesting._openedAt)) - -- The name of a symbol, spelled the way every term carrying it is spelled, - -- so a reader joining a record to a term compares two strings that look - -- alike instead of a number against a name. sigma :: Int -> String sigma = printFunction . FnSymbol quoted :: T.Text -> String quoted = escapeXML . T.unpack --- Close every element the run left open, innermost first, which is what makes --- the document well-formed however the run ended. It is written on the way out --- of 'withEvalFunc', failure included, so a run giving up half-way through a --- derivation still leaves a file a parser can read. A run failing before it --- opened the protocol leaves an empty file, exactly as it leaves one under the --- text format. -endEvalXml :: Handle -> IORef Nesting -> IO () -endEvalXml handle cursor = do +endEvalXml :: Handle -> IORef Nesting -> Double -> IO () +endEvalXml handle cursor began = do nesting <- readIORef cursor mapM_ (hPutStrLn handle) (snd (closed 0 nesting._closing)) + unless (null nesting._closing) $ do + now <- getMonotonicTime + let taken = milliseconds began now + hPutStrLn handle (indentedXml 0 (printf "%d" taken)) + hPutStrLn handle (indentedXml 0 (printf "%d" nesting._fires)) + hPutStrLn handle (indentedXml 0 (printf "%d" (perSecond nesting._fires taken))) + hPutStrLn handle "" writeIORef cursor nesting{_closing = []} --- The elements a record standing at this depth closes, innermost first, --- together with what stays open once they are written. A record belongs to the --- firing opened above it, so one standing at the depth of an open element, or --- shallower than it, is the first record after that element and ends it. closed :: Int -> [(Int, String)] -> ([(Int, String)], [String]) -closed depth open = (kept, [indented level (printf "" element) | (level, element) <- shut]) +closed depth open = (kept, [indentedXml level (printf "" element) | (level, element) <- shut]) where (shut, kept) = span ((>= depth) . fst) open --- Stand a line at the depth of what it reports, which is what makes both --- protocols a tree rather than a list: two spaces per level. indented :: Int -> String -> String indented depth line = replicate (2 * depth) ' ' ++ line --- Read, change and write the cursor back in one go, which a firing nested in --- the reduction of an operand of another needs: the outer firing is still --- half-written when the inner one starts counting. +indentedXml :: Int -> String -> String +indentedXml depth = indented (depth + 1) + atomicModify :: IORef a -> (a -> IO (a, b)) -> IO b atomicModify ref action = readIORef ref >>= action >>= \(value, made) -> writeIORef ref value >> pure made --- The formation a symbol names, which is what 𝔻 brought an operand down to and --- what a 'symbolize' line knows the data of: a 𝜎 is the name of a λ function --- and no term of its own, so 𝔻 is applied to the formation carrying it and --- never to the name alone (#1269). Both formats stand it where they report --- what 𝔻 was applied to, since they carry the same facts and disagreeing about --- this one would make a reader of the markup believe 𝔻 took a name (#1278). standing :: Int -> Expression standing symbol = ExFormation [BiLambda (FnSymbol symbol)] --- How the calculus spells the meta a λ function writes its answer to, which is --- the name the protocol writes the two lines of a firing's answer under. answer :: T.Text answer = "𝑛" 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 @@ -857,16 +473,9 @@ , _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 diff --git a/src/Emit.hs b/src/Emit.hs --- a/src/Emit.hs +++ b/src/Emit.hs @@ -5,22 +5,6 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- The Haskell module 'phino compile' writes out of the rules of YAML: every --- rewriting rule a function of the term it may match as a whole, answering --- what it rewrites the term to, the normal form a test of whether any --- built-in one matches anywhere, 𝒞 one function with an equation per rule --- of 'resources/contextualization' (#1617), and every rule of 𝕄 and of 𝔻 a --- function of the term and the universe it may match, answering the premises --- it runs and the conclusion it comes to (#1628). A pattern becomes the --- generators of a list comprehension, a meta the variable a generator binds, --- a meta met twice a guard of equality, the 'when' of a rule a guard, a --- function of its 'where' a binding, a premise a function of the answer it is --- handed, and its result the constructors that build it. No substitution is --- made and no template is filled, which is what a rule of YAML costs at every --- step. What the module does is what the matcher, the builder and the --- replacer do for the same rule, in the same order, so the steps a chain is --- made of do not depend on which of the two ran; a rule the module could not --- run that way is refused, with the reason. module Emit (emitted) where import AST @@ -39,12 +23,8 @@ import Text.Printf (printf) import qualified Yaml as Y --- What the emitter knows while it walks one rule: the variable every meta --- matched so far is held in, and the number the next fresh variable takes. data Scope = Scope (Map.Map Meta String) Int --- A walk over one rule, which either writes a piece of Haskell or refuses the --- rule, saying why. newtype Emitting a = Emitting (Scope -> Either String (a, Scope)) instance Functor Emitting where @@ -63,14 +43,11 @@ let Emitting walk' = next value walk' scope' --- One qualifier of a list comprehension: a generator binding a pattern to --- every element of a list, a guard, or a binding of a variable. data Qual = Gen Pat String | Guard String | Let String String --- A pattern a generator matches an element with. data Pat = PVar String | PCon String [Pat] @@ -78,10 +55,6 @@ | PCons Pat Pat | PNil --- The module of the given rules: the built-in rules of normalization, the --- rules of '--rule', the rules of contextualization, of morphing and of --- dataization, and the texts of the built-in rules the engine is compiled --- from; or the reason one of the rules cannot be compiled. emitted :: [Y.Rule] -> [Y.Rule] -> [Y.ContextualizeRule] -> [Y.MorphRule] -> [Y.DataizeRule] -> [String] -> Either String String emitted builtin custom contextual morphs dataizes sources = do let rules = zip (named (map (.name) (builtin ++ custom))) (builtin ++ custom) @@ -96,6 +69,7 @@ , " Just" , " En.Engine" , " { En._normalization = normalization" + , " , En._matching = \\universe -> Set.fromList . matching universe" , " , En._rules = steps" , " , En._normal = nf" , " , En._contextualize = \\term context -> either E.throwIO pure (contextualize term context)" @@ -128,12 +102,16 @@ , "-- Whether the term is a normal form: no built-in rule of normalization" , "-- matches anywhere inside it." , "nf :: Expression -> Bool" - , "nf =" - , " Ru.normalWith" - , " ( \\term ->" - , " " ++ intercalate "\n || " [printf "M.anywhere %s (not . null . rewrite%s Nothing) term" (show (redex rule)) name | (name, rule) <- take (length builtin) rules] - , " )" + , "nf = Ru.normalWith (not . null . matching Nothing)" , "" + , "-- The numbers of the built-in rules of normalization matching somewhere in" + , "-- the term, in the order one walk over it meets them, told the world the" + , "-- term stands in." + , "matching :: Maybe Expression -> Expression -> [Int]" + , "matching =" + , " M.hits" + , " " ++ listed' 4 [printf "(%d, %s, rewrite%s)" idx (show (redex rule)) name | (idx, (name, rule)) <- zip [0 :: Int ..] (take (length builtin) rules)] + , "" , "-- The Contextualization function 𝒞, the conclusion of the one rule matching" , "-- the term and the context." , "contextualize :: Expression -> Expression -> Either C.ContextualizeException Expression" @@ -178,6 +156,7 @@ , ("Map.", "import qualified Data.Map.Strict as Map") , ("R.", "import qualified Rewriter as R") , ("Ru.", "import qualified Rule as Ru") + , ("Set.", "import qualified Data.Set as Set") , ("T.", "import qualified Data.Text as T") ] , qualifier `elem` qualifiers body @@ -193,8 +172,6 @@ isUpperStart (first : _) = first `elem` ['A' .. 'Z'] isUpperStart [] = False --- The names the functions of the rules go by, one per rule, told apart where --- two rules carry the same name. named :: [String] -> [String] named names = zipWith unique [0 :: Int ..] (map camel names) where @@ -212,10 +189,6 @@ upper (first : rest) = toUpper first : rest upper [] = [] --- The functions of one rewriting rule: its step and what it rewrites a term --- matching it as a whole to. A normal form is asked of its '𝑛' and '𝑘' metas --- the way the matcher asks it (see 'Ru.normalHeld'), so a term that is itself --- a meta is no normal form under either engine. rewriting :: (String, Y.Rule) -> Either String String rewriting (name, rule) = do refused @@ -270,10 +243,6 @@ bind (Named meta) var pure [Let var value] --- The function of one contextualization rule: the conclusion it comes to for --- a term and a context matching it, once for every way they match it, beside --- its name. The letters '𝑛' and '𝑘' of these rules are only names, so no --- normal form is asked of anything (see 'Contextualize'). contextualizing :: String -> Y.ContextualizeRule -> Either String String contextualizing name rule = do (quals, result) <- walked $ do @@ -311,23 +280,12 @@ (intercalate "; " [printf "%s <- %s" var call | (var, call) <- premises]) (parens result) --- The function of one rule of 𝕄: what it comes to for a term and a universe --- matching it, once for every way they match it (see 'inferring'). morphing :: String -> Y.MorphRule -> Either String String morphing name rule = inferring "morphing" ("morphing" ++ name, "Expression") (Y.Rule rule.name Nothing Nothing rule.match ExRoot rule.when Nothing Nothing) rule.ematch (built True) (In.morphingSpine rule) --- The function of one rule of 𝔻, the way 'morphing' writes one of 𝕄. dataizing :: String -> Y.DataizeRule -> Either String String dataizing name rule = inferring "dataization" ("dataization" ++ name, "Bytes") (Y.Rule rule.name Nothing Nothing rule.match ExRoot rule.when Nothing Nothing) rule.ematch builtBytes (In.dataizationSpine rule) --- The function of one rule of 𝕄 or 𝔻, of the given kind, name and type of --- answer: the premises it runs beside its spine, each a function of the answer --- it is handed, and the conclusion it comes to, once for every way the term --- and the universe match it, checked the way the matcher checks them — the --- pattern of the universe against the universe first, then the pattern of the --- rule against the term, its 'when', and its '𝑛' and '𝑘' metas (see --- 'matchExpressionWithRule''). What the premises and the conclusion are is --- read off the rule by 'Inference', the very way the engine of YAML reads it. inferring :: forall value. String -> (String, String) -> Y.Rule -> Expression -> (value -> Emitting (Maybe String)) -> Either String ([Y.Premise], In.Conclusion value) -> Either String String inferring kind (name, answer) rule ematch builder spine = do (sides, conclusion) <- either (Left . refusal) Right spine @@ -378,9 +336,6 @@ stepped :: (Judgment, String) -> String stepped (judgment, verb) = printf "(D.%s, %s)" (show judgment) (show verb) --- The comprehension of the qualifiers and the result, every variable a --- generator binds and nothing after it reads written as a wildcard and every --- binding nothing reads dropped, so the module compiles without a warning. comprehension :: [Qual] -> String -> String comprehension quals result = case fst (foldr written ([], Set.fromList (tokens result)) quals) of [] -> " [" ++ result ++ "]" @@ -407,15 +362,9 @@ atomic used pat@(PCon _ (_ : _)) = "(" ++ pattern' used pat ++ ")" atomic used pat = pattern' used pat --- The words of a piece of Haskell, which is how the emitter tells whether a --- variable is read after it was bound. tokens :: String -> [String] tokens = words . map (\char -> if isAlphaNum char || char == '_' || char == '\'' then char else ' ') --- The generators and guards matching the pattern against the term the --- variable holds, in the order the matcher matches it (see 'matchExpression''): --- the attribute of a dispatch before its head, the head of an application --- before its argument, and the bindings of a formation left to right. matching :: Expression -> String -> Emitting [Qual] matching (ExMeta meta) var = meta' (Named meta) var matching (ExAny slot) var = meta' (Anon slot) var @@ -450,10 +399,6 @@ pure (Gen (PCon "ExApplication" [PVar head', PCon "ArAlpha" [PVar alpha', PVar arg']]) (single var) : expression ++ index ++ argument) matching expr _ = refuse (printf "its pattern holds the term '%s', which only a rule of YAML can match" (show expr)) --- The generators and guards matching the bindings of a pattern against the --- list the variable holds, a meta binding trying every leading run of it, --- the shortest first, and taking the whole rest where it is the last one (see --- 'matchBindingsMeta'). bindings :: [Binding] -> String -> Emitting [Qual] bindings [] var = pure [Gen PNil (single var)] bindings [BiMeta meta] var = meta' (Named meta) var @@ -475,8 +420,6 @@ others <- bindings rest after pure (Gen (PCons (PVar first) (PVar after)) (single var) : binding' ++ others) --- The generators and guards matching one binding of a pattern against the --- binding the variable holds (see 'matchBinding'). binding :: Binding -> String -> Emitting [Qual] binding (BiVoid attr) var = do attr' <- fresh @@ -510,16 +453,11 @@ pure [Gen (PCon "BiLambda" [PVar func']) (single var), Guard (printf "%s == %s" func' literal)] binding bd _ = refuse (printf "its pattern holds the binding '%s' where a single binding stands" (show bd)) --- The guards matching an attribute of a pattern against the attribute the --- variable holds (see 'matchAttribute'). attribute :: Attribute -> String -> Emitting [Qual] attribute (AtMeta meta) var = meta' (Named meta) var attribute (AtAny _) _ = pure [] attribute attr var = (\literal -> [Guard (printf "%s == %s" var literal)]) <$> attributed attr --- The generators and guards matching an index of a pattern against the one --- the variable holds, which a meta matches only where it is a number (see --- 'matchAlpha'). indexed :: Alpha -> String -> Emitting [Qual] indexed (AlMeta meta) var = do index <- fresh @@ -528,16 +466,12 @@ indexed (AlAny _) var = pure [Gen (PCon "Alpha" [PVar "_"]) (single var)] indexed (Alpha idx) var = pure [Guard (printf "%s == Alpha %d" var idx)] --- A meta matched against what the variable holds: bound to it the first time, --- and asked to equal what it was bound to every time after. meta' :: Meta -> String -> Emitting [Qual] meta' key var = known key >>= \case Just bound -> pure [Guard (printf "%s == %s" bound var)] Nothing -> bind key var >> pure [] --- The metas of the pattern a normal form or an absolute term is asked of, --- '𝑛' or '𝑘' by the prefix, in the order they are met (see 'metasWithPrefix'). prefixed :: String -> Expression -> [Meta] prefixed prefix = nub . go where @@ -552,9 +486,6 @@ go (ExDispatch expr _) = go expr go _ = [] --- The Haskell of a condition, which holds exactly where the condition of the --- rule does (see 'meetCondition'''): a condition naming a meta the pattern --- does not bind never holds. condition :: Y.Condition -> Emitting String condition (Y.And conds) = parens . intercalate " && " <$> mapM condition conds condition (Y.Or conds) = parens . intercalate " || " <$> mapM condition conds @@ -580,9 +511,6 @@ condition (Y.Matches _ _) = refuse "its condition 'matches' needs a run of dataization" condition (Y.PartOf _ _) = refuse "its condition 'part-of' is not compiled yet" --- A condition asking whether the attributes are present among the bindings --- the metas hold, all of them or none of them, which never holds where an --- attribute or a binding cannot be worked out. present :: Bool -> [Attribute] -> [Binding] -> Emitting String present every attrs bds = do attrs' <- mapM attr' attrs @@ -601,20 +529,15 @@ bindingsOf (BiAny _) = pure Nothing bindingsOf bd = fmap listed . sequence <$> mapM (builtBinding False) [bd] --- A condition asking a question of the term a meta holds. asked :: String -> Expression -> Emitting String asked question (ExMeta meta) = maybe "False" ((question ++ " ") ++) <$> known (Named meta) asked question (ExAny slot) = maybe "False" ((question ++ " ") ++) <$> known (Anon slot) asked _ _ = refuse "its condition asks about a term that is no meta" --- The comparison of the two sides, which never holds where either of them --- cannot be worked out. compared :: String -> Maybe String -> Maybe String -> String compared operator (Just left) (Just right) = printf "%s %s %s" (parens left) operator (parens right) compared _ _ _ = "False" --- The Haskell of a number of a condition, where it can be worked out (see --- 'numToInt'). number :: Y.Number -> Emitting (Maybe String) number (Y.MetaIndex meta) = known (Named meta) number (Y.Length (BiMeta meta)) = fmap ("length " ++) <$> known (Named meta) @@ -622,11 +545,6 @@ number (Y.Literal num) = pure (Just (show num)) number _ = pure Nothing --- The Haskell building the term of a template out of the metas bound, the way --- 'buildExpression' builds it, or nothing where a meta of it is not bound. A --- formation is checked to carry no attribute twice where the flag says so, --- which is what a result and a function of 'where' are built with, and a --- condition is not. built :: Bool -> Expression -> Emitting (Maybe String) built _ (ExMeta meta) = known (Named meta) built _ ExXi = pure (Just "ExXi") @@ -668,7 +586,6 @@ pure (printf "ExApplication %s (ArAlpha %s %s)" <$> fmap parens expr' <*> fmap parens alpha' <*> fmap parens arg') built _ expr = refuse (printf "it builds the term '%s', which only a rule of YAML can build" (show expr)) --- The Haskell building one binding of a template (see 'built'). builtBinding :: Bool -> Binding -> Emitting (Maybe String) builtBinding checked (BiTau attr expr) = do attr' <- builtAttribute attr @@ -684,25 +601,21 @@ builtBinding _ (BiLambda func) = Just . ("BiLambda " ++) . parens <$> function func builtBinding _ bd = refuse (printf "it builds the binding '%s'" (show bd)) --- The Haskell of the data of a template (see 'buildBytes'). builtBytes :: Bytes -> Emitting (Maybe String) builtBytes (BtMeta meta) = known (Named meta) builtBytes (BtAny slot) = known (Anon slot) builtBytes bts = pure (Just (parens (show bts))) --- The Haskell of an attribute of a template (see 'buildAttribute'). builtAttribute :: Attribute -> Emitting (Maybe String) builtAttribute (AtMeta meta) = known (Named meta) builtAttribute (AtAny _) = pure Nothing builtAttribute attr = Just <$> attributed attr --- The Haskell of an index of a template (see 'buildAlpha'). builtAlpha :: Alpha -> Emitting (Maybe String) builtAlpha (AlMeta meta) = fmap ("Alpha " ++) <$> known (Named meta) builtAlpha (AlAny _) = pure Nothing builtAlpha (Alpha idx) = pure (Just (printf "Alpha %d" idx)) --- The Haskell of an attribute no meta stands for. attributed :: Attribute -> Emitting String attributed (AtLabel label) = pure (printf "AtLabel (%s)" (texted label)) attributed AtPhi = pure "AtPhi" @@ -711,19 +624,14 @@ attributed AtDelta = pure "AtDelta" attributed attr = refuse (printf "it holds the attribute '%s' where a literal one stands" (show attr)) --- The Haskell of a λ function no meta stands for. function :: Function -> Emitting String function (Function name) = pure (printf "Function (%s)" (texted name)) function (FnSymbol idx) = pure (printf "FnSymbol %d" idx) function func = refuse (printf "it holds the λ function '%s' where a literal one stands" (show func)) --- The Haskell of a text. texted :: T.Text -> String texted text = "T.pack " ++ show (T.unpack text) --- Whether the pattern applies Φ to a ρ anywhere, which the builder turns into --- Φ alone, so the place the matcher matched is not the term the replacer --- looks for (see 'buildExpression'). rooted :: Expression -> Bool rooted (ExApplication ExRoot (ArTau AtRho _)) = True rooted (ExApplication expr (ArTau _ arg)) = rooted expr || rooted arg @@ -732,24 +640,18 @@ rooted (ExFormation bds) = or [rooted expr | BiTau _ expr <- bds] rooted _ = False --- The variable a meta is held in where the pattern bound it. known :: Meta -> Emitting (Maybe String) known key = Emitting (\scope@(Scope bound _) -> Right (Map.lookup key bound, scope)) --- The variable a meta is held in, where the pattern bound it, or a refusal. held :: Meta -> Emitting String held key = known key >>= maybe (refuse "it asks a normal form of a meta its pattern does not bind") pure --- Remember the variable a meta is held in. bind :: Meta -> String -> Emitting () bind key var = Emitting (\(Scope bound next) -> Right ((), Scope (Map.insert key var bound) next)) --- A variable no meta and no other variable of the rule is held in. fresh :: Emitting String fresh = Emitting (\(Scope bound next) -> Right ("x" ++ show next, Scope bound (next + 1))) --- The variable a premise binds its meta in, which neither the pattern nor a --- premise before it may have bound. introduced :: T.Text -> Emitting String introduced result = known (Named result) >>= \case @@ -759,32 +661,25 @@ bind (Named result) var pure var --- A refusal of the rule, saying why. refuse :: String -> Emitting a refuse reason = Emitting (const (Left reason)) --- The variable a meta a rule binds by itself is held in, named after the --- meta where its name is a plain one. variable :: Meta -> String variable (Named meta) = case T.unpack meta of first : rest | all isDigit rest -> toLower first : rest name -> "m_" ++ map (\char -> if isAlphaNum char then char else '_') name variable (Anon (Slot kind offset)) = printf "a_%s%d" (T.unpack kind) offset --- A list of one element. single :: String -> String single var = "[" ++ var ++ "]" --- The Haskell of a list of the elements. listed :: [String] -> String listed items = "[" ++ intercalate ", " items ++ "]" --- The same, one element per line, indented by the given number of spaces. listed' :: Int -> [String] -> String listed' _ [] = "[]" listed' indent items = "[ " ++ intercalate ("\n" ++ replicate indent ' ' ++ ", ") items ++ "\n" ++ replicate indent ' ' ++ "]" --- The piece of Haskell in parentheses, unless it is one word. parens :: String -> String parens text | all (\char -> isAlphaNum char || char == '_' || char == '\'') text = text diff --git a/src/Engine.hs b/src/Engine.hs --- a/src/Engine.hs +++ b/src/Engine.hs @@ -3,14 +3,6 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- What runs the built-in rules of the calculus: the rewriting steps of --- normalization, the answer to whether a term is a normal form, the --- Contextualization function 𝒞 and the rules of 𝕄 and 𝔻. The engine of 'yaml' --- interprets the rules as they are written, the way phino always has; 'phino --- compile' writes the Haskell of another one into the module 'Compiled', which --- a build with the flag 'compiled' links in (#1617, #1628). Nothing in the library reaches for either --- of them: the command line picks one and hands it down through the contexts, --- the way it hands down '_buildTerm'. module Engine (Engine (..), building, current, fresh, stepOf, yaml) where import AST @@ -18,21 +10,17 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) +import Data.Set (Set) import Deps (BuildTermFunc) import Functions (buildTerm, contextualizing) import Inference (Inference, dataizationOf, morphingOf) -import Rewriter (interpreted) +import Rewriter (every, interpreted) import Rule (Step, normal) import qualified Yaml as Y --- One engine of the built-in rules: the steps normalization takes, in the --- order of the rules; the steps of any other rewriting rule it knows how to --- take, by the text of the rule (see 'stepOf'); whether a term is a normal --- form; 𝒞; the rules of 𝕄 and of 𝔻, in the order of their files (see --- 'Inference'); and the texts of the built-in rules it was made from, which --- tell whether it still runs the rules phino carries (see 'fresh'). data Engine = Engine { _normalization :: [Step] + , _matching :: Maybe Expression -> Expression -> Set Int , _rules :: Map String Step , _normal :: Expression -> Bool , _contextualize :: Expression -> Expression -> IO Expression @@ -41,18 +29,15 @@ , _sources :: [String] } --- The engine interpreting the rules of YAML. yaml :: Engine -yaml = Engine (map interpreted Y.normalizationRules) Map.empty normal contextualize (map morphingOf Y.morphingRules) (map dataizationOf Y.dataizationRules) current +yaml = Engine steps (every steps) Map.empty normal contextualize (map morphingOf Y.morphingRules) (map dataizationOf Y.dataizationRules) current + where + steps :: [Step] + steps = map interpreted Y.normalizationRules --- The step the engine takes for the rewriting rule: the one it was compiled --- to, where the engine was compiled from this very rule, and the interpreted --- one otherwise, so a rule of '--rule' changed after 'phino compile' still --- runs as it is written. stepOf :: Engine -> Y.Rule -> Step stepOf engine rule = fromMaybe (interpreted rule) (Map.lookup (show rule) engine._rules) --- The texts of the built-in rules phino carries, of all four judgments. current :: [String] current = map show Y.normalizationRules @@ -60,13 +45,9 @@ ++ map show Y.morphingRules ++ map show Y.dataizationRules --- Whether the engine runs the built-in rules phino carries, and not the ones --- it carried when the engine was compiled. fresh :: Engine -> Bool fresh engine = engine._sources == current --- The term builder the functions of a rule run with, whose 'contextualize' is --- the 𝒞 of the engine. building :: Engine -> BuildTermFunc building engine "contextualize" = contextualizing engine._contextualize building _ func = buildTerm func diff --git a/src/Evaluate.hs b/src/Evaluate.hs --- a/src/Evaluate.hs +++ b/src/Evaluate.hs @@ -5,15 +5,6 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- The Evaluation function 𝔼 and everything a λ function of the '--symbolic' --- file needs to fire: finding the λ of a formation, bringing the operands of --- its entry down, standing the data of a term it reduced into unknowns, --- minting the symbols its answer carries and writing the firing into the --- protocol. 𝕄 and 𝔻 live in 'Morph' and 'Dataize', and what --- all three share — the context, the budget, the signals — lives in 'Morph', --- 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) where import AST @@ -34,29 +25,6 @@ import Text.Printf (printf) import qualified Yaml as Y --- The Evaluation function 𝔼(b, e, s): it fires the λ function of a formation --- 'b' against the global universe 'e', under the incoming state 𝑠, normalizes --- its raw result 𝒩(e₁) = n, and returns that normal form together with the new --- state. Normalizing here makes 𝔼's codomain 𝓝 (as its type demands), so --- callers ('fire', 'ml') need no follow-up 'normalize' premise. The universe is --- passed explicitly as the second argument (rather than threaded behind the --- scenes), matching how the morphing 𝕄 and dataization 𝔻 functions carry it. --- Every firing writes itself into the protocol the '--protocol' option keeps --- (see 'symbol'). Firings are written in the order they start, so the λ --- function of a head reduced by 'ml' stands above the one dispatched on its --- result; that order carries nothing, since what depends on what is read off --- the symbols. --- --- A formation carrying no λ binding has nothing to fire, and that is a question --- the calculus answers rather than a malformed one: 𝔼 hands back ⊥, the way 𝕄 --- does for a term nobody reduces further. Neither is a λ naming a symbol: a --- symbol is a value nobody worked out, so no entry of the '--symbolic' file --- answers it and 𝔼 gets stuck on it exactly as it does on a λ name nothing --- answers — the site is written to the protocol and '_partial' parks it, rather --- than the run ending on a term the program was entitled to hold (#1287). Only --- a λ 𝔼 cannot make sense of fails — several of them, or one standing for a --- meta or a slot — since a rule naming such a binding meant something phino --- cannot work out (see 'lambda'). evaluation :: ReduceContext -> State -> Expression -> Expression -> IO (Expression, State) evaluation ctx state form univ = case form of ExFormation bds @@ -71,21 +39,10 @@ Nothing -> throwIO (userError "Function evaluate() expects a formation with a single λ binding naming a function") _ -> throwIO (userError "Function evaluate() expects a formation") where - -- The symbol the one λ binding of a formation names, where that is what it - -- names. It is the one λ 'lambda' refuses that 𝔼 still has an answer for, - -- so it is told apart here and nowhere else: a formation carrying several - -- λ bindings, or one standing for a meta or a slot, is still a term phino - -- cannot work out. unknown :: [Binding] -> Maybe Int unknown bindings = case partition isLambda bindings of ([BiLambda (FnSymbol idx)], _) -> Just idx _ -> Nothing - -- Get stuck on a symbol the way 'symbol' gets stuck on a λ name no entry - -- answers, and for the same reason: nothing answers either, so there is no - -- firing to make. The site is written to the protocol under the name the - -- symbol is spelled with everywhere else, so a reader joining the record to - -- the term it came from compares two strings that look alike, and it is - -- written once however many times the walk comes back to it (see '_parked'). stuck :: Int -> Expression -> IO (Expression, State) stuck idx form = do unless (name `elem` ctx._parked) (ctx._saveEval (EvStuck ctx._nesting name ctx._judgment form)) @@ -94,44 +51,6 @@ name :: T.Text name = T.pack (printFunction (FnSymbol idx)) --- phino implements no λ function of its own. Which ones exist is a property of --- the object model being reduced, not of the calculus, so they come from the --- '--symbolic' file, where each is an entry phino answers the firing with --- itself (see 'Lambdas'). The entry is looked up by the λ name and there is at --- most one, since the keys are unique; a name no entry answers has no λ --- function to fire at all, and 𝔼 gets stuck on it — the one behaviour left --- here. The formation 'self' is the one 𝔼 fired against, its λ binding already --- removed, so the entry may name the attributes of it; 'form' is that same --- formation as 𝔼 was handed it, λ binding and all, which is what the protocol --- says a firing nothing answered was about, since a formation with its λ split --- off is no longer the term anybody asked about; the universe 'univ' is what --- every operand of it is reduced inside. What comes back is the term the entry --- answers with, morphed (see 'answered'). --- --- The firing writes itself into the protocol as it goes: the entry that --- answered first, then each operand as it is reduced, then the answer. Whatever --- fires inside an operand writes itself between those lines, one level deeper, --- which is what makes the protocol a tree of firings rather than a list of --- them. A name no entry answers writes itself too, before 𝔼 gets stuck on it, --- so the protocol says what was asked for whether or not '_partial' goes on to --- park the run — once, and not once per attempt: a site '_partial' has parked --- 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 'unanswered(…)' --- lines counts the sites 𝔼 got stuck on rather than the passes the walk made --- over them (see '_parked', #1300). A firing an entry answers is charged to the --- '--max-firings' and '--max-seconds' budgets before it writes anything, so a --- run that spent either leaves no firing open in the protocol (see 'charged', --- #1472, #1607). --- --- 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 @@ -141,20 +60,6 @@ known <- recalled caller._memo form caller._steps._spent 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). A - -- firing that got stuck is kept the same way, as the λ function it got - -- stuck on, and the memo tells it only until something new is answered - -- after the firing began, since an operand that could not be brought down - -- may come down then (#1493, #1495, #1507). A firing inside which the step - -- budget ran out keeps its stall beside the steps it had spent, and the - -- memo tells it only to a firing that has spent at least as many, since - -- at a shallower site the operand may come down (#1514, #1521). A firing - -- that got stuck ends its block with a 'stuck' line naming the λ function, - -- whether it is kept or not (#1524). made :: Lambda -> IO (Expression, State) made entry = do charged caller @@ -178,10 +83,6 @@ mapM_ (retained caller._memo form stamp) (kept (exhausted' /= exhausted) failure) mapM_ (caller._saveEval . EvStuckOn (caller._nesting + 1)) (stranded failure) throwIO failure - -- What the memo keeps of a firing that never answered: the formation a - -- recursion was cut at, or the λ function the firing got stuck on, where - -- that is what the signal escaping it says, beside the steps the firing - -- had spent where the step budget ran out inside it and none elsewhere. kept :: Bool -> ReduceException -> Maybe Kept kept _ (Looping term) = Just (Looped term) kept _ (LoopingAt term _ _) = Just (Looped term) @@ -191,20 +92,10 @@ least :: Bool -> Int least True = caller._steps._spent least False = 0 - -- The λ function a firing got stuck on, where the signal escaping it says - -- it got stuck, which the protocol writes as the last line of the firing. stranded :: ReduceException -> Maybe T.Text stranded (Stuck name) = Just name stranded (StuckAt name _ _) = Just name stranded _ = 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. - -- Where the first firing got stuck, the firing gets stuck again at its own - -- site, on the same λ function and with nothing reduced under it, and a - -- 'stall' line under it says so (#1524). told :: Kept -> IO (Expression, State) told (Answered (built, normal)) = do caller._saveEval (EvFiring caller._nesting func caller._judgment caller._site) @@ -219,28 +110,6 @@ caller._saveEval (EvFiring caller._nesting func caller._judgment caller._site) caller._saveEval (EvStall (caller._nesting + 1) name) throwIO (Stuck name) - -- 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 - -- λ function no entry answers at all, and gets stuck on the very name that - -- parked the operand rather than on the λ function of this firing: an entry - -- answers this one, so blaming it would name a λ function the '--symbolic' - -- file carries where the one nothing answers stands one reduction deeper - -- (#1288). The name travels back in the state the parked run hands over, - -- since the signal it was made of stayed inside that run (see '_stuck'). - -- Every symbol dataizes to the very same datum, so the protocol is told - -- which unknown that datum was manufactured for rather than the datum - -- itself (see 'State'). - -- - -- The reduction runs on a universe of its own, so a signal escaping it - -- carries that universe's derivation and not the spine's; 'unparked' drops - -- it and lets the spine frame around this firing attach its own, which is - -- what keeps '--sequence' free of the synthetic attribute the operand was - -- reduced under. - -- - -- What the operand came down to goes on beside the substitution, the last - -- operand first, since the first of them is the condition a fork branches - -- on and a 'join' line one side of which reaches ⊥ names it (see 'paired'). down :: ReduceContext -> (Subst, State, [Either Int Bytes]) -> (Meta, Expression) -> IO (Subst, State, [Either Int Bytes]) down ctx (bound, state', conditions) (meta, term) = do placed <- operand term @@ -252,10 +121,6 @@ ctx._saveEval (EvData ctx._nesting meta._spelling term datum) bound' <- bind meta (MvBytes bytes) bound pure (bound', state'', datum : conditions) - -- Reduce one 'morph' operand through 𝕄 and bind the expression meta that - -- names it. Unlike a dataized one it may stay an unknown: a term carrying a - -- symbol is a perfectly good normal form, and standing it into the answer - -- is how a firing hands its own unknowns on. through :: ReduceContext -> (Subst, State) -> (Meta, Expression) -> IO (Subst, State) through ctx (bound, state') (meta, term) = do placed <- operand term @@ -263,29 +128,12 @@ ctx._saveEval (EvTerm ctx._nesting meta._spelling term normal) bound' <- bind meta (MvExpression normal) bound pure (bound', state'') - -- Rewrite a term another line of the entry has bound with the rules of the - -- line and bind the expression meta naming what it becomes (see - -- 'rewritten'). Nothing is reduced and nothing is minted: a rewrite is a - -- substitution the entry vouches for, exactly as an answer is, so the term - -- it makes is written to the protocol and bound as it is, which is what - -- lets a program bring the branches of a fork to one shape before they - -- are compared (#1409). The line is commented with the meta it rewrote, - -- the way a 'symbolize' line is, since no judgment of the calculus made it. 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 Nothing ctx._engine._normal) 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 - -- unknowns and bind the expression meta naming what it becomes. Nothing is - -- reduced here: what changes is that every datum of the term becomes a - -- symbol nobody worked out, so a normal form reached from a literal - -- compares with one reached from an unknown, which is what a later join of - -- two branches of a fork needs. What is known about each fresh symbol goes - -- into the protocol ahead of the line binding the term, since the term is - -- written with the symbols and the facts are what tells a constant among - -- them from an unknown. masked :: ReduceContext -> (Subst, State) -> (Meta, Expression) -> IO (Subst, State) masked ctx (bound, state') (meta, term) = do reduced <- buildExpressionThrows term bound @@ -297,28 +145,6 @@ where fact :: (Int, Bytes) -> Evaluation fact (fresh, bytes) = EvKnown ctx._nesting fresh bytes - -- Join two terms other lines of the entry have bound into one and bind the - -- expression meta naming it. Nothing is reduced here either: the two are - -- required to match verbatim and every pair of symbols they differ by - -- becomes one fresh symbol (see 'joined'), which is the one term standing - -- for either of them and so the one thing a fork can answer with. Two - -- terms differing anywhere else are no join at all and the firing gets - -- stuck the way a λ function no entry answers does, so '_partial' parks - -- the site rather than failing the whole run (#1246). - -- - -- What is known about each fresh symbol goes into the protocol ahead of - -- the line binding the term, the way a 'symbolize' line writes what it - -- knows, since a reader ties the join to the two values it was made from - -- by that fact alone and never by diffing the terms. - -- - -- One side reaching ⊥ is a join too, the one 'if. cond value ⊥' spells - -- "raise unless cond" with: the program raises on that side of the - -- condition and has a perfectly good value on the other. The protocol is - -- told on which side it raises, naming the condition by what the first - -- operand the entry dataized came down to, and the meta is bound to the - -- other side as it stands, which is the one value the fork can still - -- answer with. Both sides reaching ⊥ is no such case: they are one term - -- and join into ⊥ verbatim (#1405). paired :: ReduceContext -> Maybe (Either Int Bytes) -> (Subst, State) -> (Meta, (Meta, Meta)) -> IO (Subst, State) paired ctx condition (bound, state') (meta, (left, right)) = do one <- branch left @@ -329,7 +155,6 @@ (_, ExTermination) -> terminating "right" right one _ -> both one two where - -- The two sides joined symbol by symbol (see 'joined'). both :: Expression -> Expression -> IO (Subst, State) both one two = case joined one two state'._minted of Nothing -> throwIO (Stuck func) @@ -338,51 +163,16 @@ ctx._saveEval (EvJoin ctx._nesting meta._spelling (left._spelling, right._spelling) term) bound' <- bind meta (MvExpression term) bound pure (bound', state'{_minted = spent}) - -- 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. 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') - -- The term one side of the join is bound to, which is what a meta of - -- the entry reads out of the substitution the firing has made (see - -- 'earlier' in 'Lambdas': a 'join' line names metas bound above it and - -- nothing else, so there is always one to read). branch :: Meta -> IO Expression branch named = buildExpressionThrows (ExMeta named._name) bound fact :: (Int, (Int, Int)) -> Evaluation fact (fresh, pair) = EvJoined ctx._nesting fresh pair - -- Mint the fresh symbols the answer asks for, build it and reduce it - -- through 𝕄. A bare 𝜎 stands for an unknown nobody has named yet, so each - -- one is bound to the next symbol the run has not minted, and the state - -- 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). 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 - -- other one answers a normal form: 'Φ.number( φ ↦ ⟦ λ ⤍ 𝜎 ⟧ )' written in - -- the program morphs to the formation of the object, so the same term - -- answered by an entry has to morph to it too. Two terms of one forma that - -- do not look alike cannot be compared leaf by leaf, and comparing them is - -- what a fork of two branches is (#1268). The residual and the answer lines - -- of the protocol grow by the size of that formation, which is the price of - -- saying the same thing one way. - -- - -- Both terms go to the protocol, the built one before 'settled' is asked - -- about it and the normal one after, so the morphing is a step of the - -- 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). 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 @@ -397,9 +187,6 @@ mint bound (slot, fresh) = case combine (substSlot slot (MvFunction fresh)) bound of Just bound' -> pure bound' Nothing -> throwIO (userError (printf "A fresh symbol of λ function '%s' clashes with an existing binding" (T.unpack func))) - -- The operand an entry wrote, in the scope it is reduced in: ξ stands for - -- the formation being fired, so '$.x' is the x of it, and the calculus does - -- the reaching. operand :: Expression -> IO Expression operand term = caller._engine._contextualize term self bind :: Meta -> MetaValue -> Subst -> IO Subst @@ -409,16 +196,6 @@ throwIO (userError (printf "The meta '%s' of λ function '%s' clashes with an existing binding" (T.unpack meta._spelling) (T.unpack func))) --- The term with the rules of a 'rewrite' line applied to it. Every position of --- the term is tried, the outermost first, and the first rule whose pattern --- matches a position as a whole rewrites it with the first match it made; the --- position rewritten is not walked into again, so a rule whose result carries --- its own pattern rewrites it once and never loops. A position no rule matches --- is walked into, every binding and every argument of it, ρ among them, since --- the shape of a branch is the program's to say and phino has no say in where --- that shape is written. Nothing is normalized afterwards: the rules are the --- program's word on what one term stands for, and reducing their outcome would --- have phino second-guess it (#1409). rewritten :: [Y.Rule] -> RuleContext -> Expression -> IO Expression rewritten rules ctx = goExpr where @@ -446,18 +223,6 @@ goArgument (ArTau attr expr) = ArTau attr <$> goExpr expr goArgument (ArAlpha alpha expr) = ArAlpha alpha <$> goExpr expr --- Ask 𝕄 about a term and fire the λ of the formation it reaches, as long as an --- entry of the '--symbolic' file answers it, asking 𝕄 about every answer again: --- what comes back is the answer of the last firing, or nothing at all where --- nothing fired. This is the firing 'ml' makes without the dispatch that makes --- 'ml' make it — the one 𝕄 leaves to 𝔻. A λ no entry answers is left alone --- rather than fired and got stuck on, so what phino cannot compute stays as it --- was written with or without '_partial'; a λ function that cannot fire deeper --- on the spine still fails the run, exactly as it does under 𝕄 alone, and --- '_partial' parks it. A formation still waiting for its arguments is left --- alone too (see 'saturated'). A term standing as the --- target of a dispatch is where 'ml' has its say: the λ is fired only where the --- dispatched attribute is none of the formation's own (see 'demanded'). fired :: Maybe Attribute -> Expression -> Expression -> State -> ReduceContext -> IO (Maybe Expression, State) fired dispatched term univ state caller = do ctx <- deeper caller @@ -468,44 +233,14 @@ Right (_, state') -> pure (Nothing, state') Left failure -> parked state failure where - -- Whether the dispatch the term stands under demands the λ of the formation - -- 𝕄 reached. 'ml' fires that λ only where the dispatched attribute is none - -- of the formation's own, since 'dot' resolves the dispatch before 'ml' is - -- ever reached, and a walk firing it first answers a formation the dispatch - -- no longer fits (#1187). A term standing anywhere else is demanded by - -- nothing and the walk fires what 'mf' left bare, as it always has. demanded :: [Binding] -> Bool demanded bds = not (any bound bds) where bound :: Binding -> Bool bound (BiTau attr _) = Just attr == dispatched bound _ = False - -- The term the walk was handed, as 𝕄 leaves it. The chains it drops are - -- the walk's and not the spine's, which reports one step of its own (see - -- 'morph'), so a stuck λ function leaves without a derivation. reduced :: ReduceContext -> IO (Expression, State) reduced = settled term univ state - -- Fire the λ of the formation 𝕄 reached and go on from its answer, keeping - -- the answer of the last firing. A λ no entry of the '--symbolic' file - -- answers is not fired at all, which is what keeps the walk as total as 𝕄 - -- itself. The firing reports itself to '_saveEval', so the protocol and the - -- program agree on what was answered. - -- - -- A firing that cannot be made — an operand of the entry that never came - -- down to data, above all — is parked exactly as a term 𝕄 could not reduce - -- is, and for the same reason: the walk meets every λ function a program - -- declares and one of them answering nothing is no failure of the run but a - -- part of it phino cannot decide. Without this the signal left the walk - -- altogether and the binding after the one it stopped on was never entered, - -- so a single entry nothing could answer ended a run over a whole object - -- 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') @@ -516,16 +251,6 @@ (again, reached) <- fired dispatched answer univ answered ctx pure (Just (fromMaybe answer again), reached) Left failure -> parked state' failure - -- A site the walk cannot reduce — a λ function whose operands never came - -- down to data, or one the step budget ran out on — is left as it was - -- written and the walk goes on, which is what a partial morphing is: phino - -- stops where it cannot decide rather than failing the whole run. The state - -- the parked site had reached travels back, so the symbols it minted before - -- it stopped are never minted again; a signal carrying none of its own is - -- answered with the state the caller reached before it was raised, which is - -- the walk's state where 𝕄 was asked and the firing's where a firing was - -- made. The chain it parked on is dropped, since that chain is the walk's - -- and not the spine's. parked :: State -> ReduceException -> IO (Maybe Expression, State) parked _ (StuckAt _ _ reached) | caller._partial = pure (Nothing, reached) parked _ (OutOfStepsAt _ _ reached) | caller._partial = pure (Nothing, reached) @@ -537,44 +262,12 @@ 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 --- out of a firing, and the term the deep walk was handed on its way in. 𝕄 takes --- normal forms only and a term written in an entry, or taken from the program --- as it was written, is not necessarily one, so it is normalized against the --- universe first, exactly as '--inside' normalizes what it is handed. It is --- reduced against the universe itself rather than inside it: a term bound under --- an attribute of the universe reaches a ρ naming that attribute too, and --- neither of these two is a part of the program the way an operand of a firing --- is. Both chains are dropped, since what happens here is the protocol's --- business and not the spine's. settled :: Expression -> Expression -> State -> ReduceContext -> IO (Expression, State) settled term univ state ctx = do (normal, _) <- normalized term ((univ, Nothing) :| []) ctx ((morphed, _), state') <- morph' (normal, (univ, Nothing) :| []) univ state ctx pure (morphed, state') --- The same as 'lambda', but only for a formation that is saturated: one with --- every binding of it filled (see 'filled'). A void is an argument the program --- has not given yet, so such a formation is a method waiting to be applied --- rather than an application waiting to be computed, and firing it would hand --- the λ function a ∅ where it expects a value. 𝔻 needs no such guard, since it --- fires only what dataization demands and nothing demands a method; the deep --- walk meets every one a program declares — the method table of the object --- model above all — so it asks first (see 'deepened'). --- --- A binding holding ⊥ counts as filled only where the term the walk was handed --- wrote that ⊥ as an argument itself. A ⊥ the reduction made is no argument: --- the deep walk reduces a body in the scope of the formation around it, and a --- formation declaring ρ and standing unapplied still holds ρ ↦ ∅, so a ξ.ρ in --- that body comes back as ⊥ rather than as the object the next dispatch --- supplies (#1196). A ⊥ --- written as an argument is what the program meant, and 'if. cond value ⊥' is --- how it spells "raise unless cond", so a fork like that fires and its join --- says on which side it raises (#1405). An argument given by name covers the --- binding of that name; one given by position covers some binding, so there --- have to be as many of them as ⊥ bindings no name covers. A term handing --- nothing but ⊥ is still left alone, since there is no value for a firing to --- work with and all it could do is get stuck on one of them. saturated :: Expression -> [Binding] -> Maybe (T.Text, Expression) saturated term bds = case lambda bds of Just (func, ExFormation rest) @@ -585,20 +278,14 @@ positional :: Int valued :: Bool (named, positional, valued) = written term - -- Whether every ⊥ of the bindings is one the term wrote, beside some - -- argument that is not ⊥. given :: [Binding] -> Bool given rest = valued && length (filter unwritten rest) <= positional raising :: Binding -> Bool raising (BiTau _ ExTermination) = True raising _ = False - -- Whether a binding holds a ⊥ no argument given by name wrote. unwritten :: Binding -> Bool unwritten (BiTau attr ExTermination) = attr `notElem` named unwritten _ = False - -- The attributes the application chain of a term hands a literal ⊥ by - -- name, how many literal ⊥ it hands by position, and whether it hands - -- anything but ⊥ at all. written :: Expression -> ([Attribute], Int, Bool) written (ExApplication expr (ArTau attr ExTermination)) = let (attrs, count, other) = written expr in (attr : attrs, count, other) @@ -608,9 +295,6 @@ let (attrs, count, _) = written expr in (attrs, count, True) written _ = ([], 0, False) --- Whether a binding hands the formation something to work with. A void does --- not: it names an argument the program has still to supply. A ⊥ is told --- apart by 'saturated', which knows the term it was written in. filled :: Binding -> Bool filled (BiVoid _) = False filled _ = True diff --git a/src/Files.hs b/src/Files.hs --- a/src/Files.hs +++ b/src/Files.hs @@ -4,8 +4,6 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- This module accesses the filesystem: it ensures a file exists, --- collects every file path under a directory and replaces a file atomically. module Files (FsException (..), ensuredFile, allPathsIn, overwrite) where import Control.Exception (Exception, onException, throwIO) @@ -44,7 +42,6 @@ when exists (copyPermissions file temp) renameFile temp file --- Recursively collect all file paths in provided directory allPathsIn :: FilePath -> IO [FilePath] allPathsIn dir = do exists <- doesDirectoryExist dir diff --git a/src/Functions.hs b/src/Functions.hs --- a/src/Functions.hs +++ b/src/Functions.hs @@ -26,10 +26,6 @@ import Text.Printf (printf) import qualified Yaml as Y --- Names of build-term functions that need the full evaluation context --- (expression plus atom evaluation) and are therefore provided only by --- 'Dataize.execBuildTerm', not by 'buildTerm'. They are available while --- executing dataization and morphing rules, but not rewriting rules. execFunctions :: [String] execFunctions = ["evaluate", "morph"] @@ -76,8 +72,6 @@ _contextualize :: BuildTermMethod _contextualize = contextualizing contextualize --- The 'contextualize' function of a rule, carried out by the given 𝒞: the --- one of YAML or the one 'phino compile' wrote (#1617). contextualizing :: (Expression -> Expression -> IO Expression) -> BuildTermMethod contextualizing judgment [Y.ArgExpression expr, Y.ArgExpression context] subst = do expr' <- buildExpressionThrows expr subst @@ -85,22 +79,12 @@ TeExpression <$> judgment expr' context' contextualizing _ _ _ = 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 (nameIn universe form)) 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 --- not silently accepted. _randomTau :: BuildTermMethod _randomTau [] _ = TeAttribute . AtLabel <$> freshTau _randomTau _ _ = throwIO (userError "Function random-tau() requires exactly 0 arguments") @@ -156,7 +140,6 @@ "" -> pure (pat, rep, False) _ -> throwIO (userError "sed pattern must be in format s/pat/rep/[g]") _ -> throwIO (userError "sed pattern must start with s/") - -- Cut part from given string until regular slash. nextUntilSlash :: B.ByteString -> B.ByteString -> Bool -> (B.ByteString, B.ByteString) nextUntilSlash input acc escape = case B.uncons input of Nothing -> (acc, B.empty) diff --git a/src/Inference.hs b/src/Inference.hs --- a/src/Inference.hs +++ b/src/Inference.hs @@ -4,15 +4,6 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- The rules of 𝕄 and 𝔻 the way a run takes them, whichever engine runs them. --- A rule matched against a term and its universe comes to the premises it --- runs beside its spine, in the order it lists them, each handed on to what --- the rule builds of its answer, and to the conclusion it reaches once they --- all ran. The engine of YAML interprets a rule into them ('morphingOf', --- 'dataizationOf'), the one 'phino compile' writes builds them in Haskell out --- of the very same spine ('morphingSpine', 'dataizationSpine'), and 'Morph' --- and 'Dataize' run them, so the chain a run makes does not depend on which --- of the two built them (#1628). module Inference (Conclusion (..), Inference, Premises (..), Way (..), dataizationOf, dataizationSpine, direct, morphingOf, morphingSpine) where import AST @@ -27,37 +18,19 @@ import Text.Printf (printf) import qualified Yaml as Y --- One rule of 𝕄 or 𝔻 ready to run: what it makes of a term in a universe, --- which is nothing where the two do not match it and the premises it runs --- where they do, the first way they match it. The context tells its --- conditions the world and the normal forms of the engine. type Inference value = RuleContext -> Expression -> Expression -> IO (Maybe (Premises value)) --- The premises a rule runs beside its spine, in the order it lists them: 𝕄 --- of a term in a universe, 𝔼 of a formation in one, or 𝒞 of a term in a --- context, each handed on to what the rule builds of its answer, and the --- conclusion the rule comes to once they all ran. data Premises value = Morphs Expression Expression (Expression -> IO (Premises value)) | Evaluates Expression Expression (Expression -> IO (Premises value)) | Contextualizes Expression Expression (Expression -> IO (Premises value)) | Concludes (Conclusion value) --- What a rule concludes with: the value it answers, which a step of the --- label takes the chain to; or its judgment asked again, in the universe the --- rule names, of the term it built, once that term is reached the way the --- rule says. data Conclusion value = Answered (Judgment, String) value | Onward Way Expression Expression deriving (Eq, Show) --- How the term a judgment is asked about again is reached from the one its --- rule built: by a step of the label; by a step of the label and 𝒩 after it; --- the same, where the term is the universe the rule matched, which the run --- has named already, so the step takes the chain to that world and nothing is --- normalized (#1453); or by 𝕄 in the universe given, its steps spliced into --- the chain. data Way = Taken (Judgment, String) | Normalized (Judgment, String) @@ -65,13 +38,6 @@ | Staged Expression deriving (Eq, Show) --- What a rule of 𝕄 does once it matched, read off its premises: the ones it --- runs beside its spine, in the order it lists them, and the conclusion it --- comes to, the terms of both written with the metas of the rule; or why no --- run can take it. A rule no premise produces the conclusion of answers it, --- and a rule of any other kind is asked again of the argument of the 'morph' --- premise producing its conclusion, normalized where a 'normalize' premise --- produces that argument. morphingSpine :: Y.MorphRule -> Either String ([Y.Premise], Conclusion Expression) morphingSpine rule = case producer rule.nresult rule.premises of Nothing -> Right (rule.premises, Answered step rule.nresult) @@ -84,13 +50,6 @@ step :: (Judgment, String) step = (Morphing, rule.name) --- What a rule of 𝔻 does once it matched, read off its premises the way --- 'morphingSpine' reads those of 𝕄, where 'morph' may produce the argument of --- the 'dataize' premise too. A step of 𝔻 is labelled by the first premise the --- rule runs beside its spine — 'box' by its 'contextualize', 'fire' by its --- 'evaluate' — and taken by the judgment that premise runs; with none it is --- labelled blank where it normalizes and by the verb of its conclusion --- otherwise. dataizationSpine :: Y.DataizeRule -> Either String ([Y.Premise], Conclusion Bytes) dataizationSpine rule = case bytesProducer rule.dresult of Nothing -> Right (rule.premises, Answered (Dataization, rule.name) rule.dresult) @@ -112,21 +71,13 @@ labelled _ (premise : _) = label premise.operation labelled fallback [] = fallback --- The premise binding the given expression meta, if any. The conclusion of a --- rule and the argument of a continuation premise are looked up here to find --- the premise that produces them. producer :: Expression -> [Y.Premise] -> Maybe Y.Premise producer (ExMeta name) = find (\premise -> premise.result == name) producer _ = const Nothing --- The premises whose result meta is not bound by any of the given ones — the --- side-computations left once the spine premises are removed. excluding :: [Y.Premise] -> [Y.Premise] -> [Y.Premise] excluding premises removed = filter (\premise -> premise.result `notElem` map (.result) removed) premises --- What a step a premise takes is labelled with in the chain: the judgment the --- premise runs, which picks the arrow of the step in LaTeX (#1536), and its --- verb, which names the step. label :: Y.Operation -> (Judgment, String) label (Y.OpMorph _ _) = (Morphing, "morph") label (Y.OpNormalize _) = (Normalization, "normalize") @@ -134,19 +85,12 @@ label (Y.OpContextualize _ _) = (Contextualization, "contextualize") label (Y.OpDataize _ _) = (Dataization, "dataize") --- A rule of 𝕄 as the engine of YAML runs it (see 'interpreted'). morphingOf :: Y.MorphRule -> Inference Expression morphingOf rule = interpreted buildExpressionThrows (Y.Rule rule.name Nothing Nothing rule.match ExRoot rule.when Nothing Nothing) rule.ematch (morphingSpine rule) --- A rule of 𝔻 as the engine of YAML runs it (see 'interpreted'). dataizationOf :: Y.DataizeRule -> Inference Bytes dataizationOf rule = interpreted buildBytesThrows (Y.Rule rule.name Nothing Nothing rule.match ExRoot rule.when Nothing Nothing) rule.ematch (dataizationSpine rule) --- A rule of 𝕄 or 𝔻 the matcher matches, the pattern against the term and the --- pattern of the universe against the universe, its 'when' and its '𝑛' and --- '𝑘' metas checked the way those of a rewriting rule are, and the premises --- of its spine built out of the metas the first match bound, each binding its --- own meta to the answer it is handed. Only 𝕄, 𝔼 and 𝒞 run beside a spine. interpreted :: forall value. (value -> Subst -> IO value) -> Y.Rule -> Expression -> Either String ([Y.Premise], Conclusion value) -> Inference value interpreted build rule ematch spine ctx term univ = do matched <- matchExpressionWithRule' (matchExpression' ematch univ) term rule ctx @@ -177,8 +121,5 @@ refuse :: String -> IO a refuse reason = throwIO (userError (printf "The rule '%s' cannot be run, since %s" rule.name reason)) --- A rule of 𝕄 or 𝔻 'phino compile' turned into Haskell: a function telling --- every way the term and the universe match it, of which a run takes the --- first, as it takes the first match of a rule of YAML. direct :: (Expression -> Expression -> [Premises value]) -> Inference value direct rule _ term univ = pure (listToMaybe (rule term univ)) diff --git a/src/LaTeX.hs b/src/LaTeX.hs --- a/src/LaTeX.hs +++ b/src/LaTeX.hs @@ -95,16 +95,6 @@ argExpr (ArTau _ ex) = ex argExpr (ArAlpha _ ex) = ex -{- | Here we're trying to compress a sequence of expressions with \phinoMeet{} and \phinoAgain LaTeX functions. -We process the sequence of expressions and trying to find all sub-expressions in the first expression which are present -in the following expressions. Then we find the one which is the most frequently encountered. -If it's encountered in more than specific percentage (_meetPopularity) of the following expressions - we replace -it with \phinoAgain{} in the following expressions and with \phinoMeet{} in the first expression. -We then keep re-scanning that same first expression for further meets: the parts already factored out become -\phinoMeet{}/\phinoAgain{}, which the scanner skips, so each pass yields strictly fewer candidates and the loop -terminates. This lets a single step host several \phinoMeet{}s when it carries several independent recurring -sub-expressions, rather than only the single most frequent one. --} meetInExpressions :: [Expression] -> LatexContext -> [Expression] meetInExpressions exprs LatexContext{..} = go exprs 1 where @@ -157,18 +147,6 @@ , maybe "" (printf "\\phiExpression{%s} ") _expression ] --- Join the rendered steps with the arrows of the judgments that took them, so --- a chain mixing rules of 𝒩, 𝕄 and 𝔻 tells them apart (#1536). A step taken --- by a rule ends with the arrow of the rule's judgment, the rule referenced in --- its optional argument, and the step after it opens with the same arrow, bare --- (see 'arrows'). Every step after the first carries the two-space indent --- before its arrow, so it is rendered from base tab 1 rather than 0 (via --- 'baseTab'); this keeps a wrapped multi-line step's members nested one level --- below the line its arrow opens and its closing bracket aligned with that --- line. The first step opens with no arrow and stays at base tab 0. --- Each step is prefixed with the matching entry from 'comments', which is --- either empty or a '% ...'-commented header line ending in a newline (see --- 'stepComments'), so headers stay on their own line above the equation. body :: [String] -> [(a, Maybe (Judgment, String))] -> (Int -> a -> String) -> String body comments printed toLatex = intercalate @@ -189,16 +167,9 @@ baseTab 0 = 0 baseTab _ = 1 --- The judgment a chain stands at before each of its steps and after its last --- one, which is that of the latest rule it took. A chain stands at 𝒩 before it --- took any, since 'rewrite' is the only command whose chain can run out of --- steps before its first one, and it only normalizes. arrows :: [Maybe (Judgment, String)] -> [Judgment] arrows = scanl (\current rule -> maybe current fst rule) Normalization --- The arrow of the relation LaTeX writes a step taken by the judgment with. --- These are not the '\phinoNormalize' and the rest of 'explain', which print a --- whole judgment with its input and output. relation :: Judgment -> String relation Normalization = "\\phiNormalize" relation Morphing = "\\phiMorph" @@ -206,20 +177,12 @@ relation Evaluation = "\\phiEvaluate" relation Contextualization = "\\phiContextualize" --- LaTeX comment header lines for each step (see 'stepHeaders' in "Rewriter"), --- or empty strings when '--headers' is off. A '%' starts a LaTeX comment, so --- the header documents the '--sequence' chain without affecting the rendered --- equation. Each comment ends in a newline so the following step starts on a --- fresh line. stepComments :: [Rewritten] -> LatexContext -> [String] stepComments rewrittens LatexContext{_headers = enabled} = if enabled then map (printf "%% %s\n") (stepHeaders rewrittens) else map (const "") rewrittens --- Close the equation of a chain. One that ran out of steps trails off with the --- arrow of the judgment it stands at after its last step (see 'arrows'), and --- one that finished ends with a period, the way a single expression does. ending :: Bool -> Judgment -> LatexContext -> String ending True judgment ctx = printf " %s\n %s \\dots\n\\end{%s}" (relation judgment) (relation judgment) (phiquation ctx) ending False _ ctx = period ctx @@ -232,13 +195,6 @@ let (exprs, rules) = unzip rewrittens in if _compress then zip (meetInExpressions exprs ctx) rules else rewrittens --- Canonization runs after the meet compression, never before it: 'canonize' --- renumbers λ bindings by traversal position and restarts the counter for every --- expression, so the same logical lambda ends up with a different 'Fn' in --- different steps. Feeding those unstable names to the meet pass (which compares --- sub-expressions by structural equality) would stop identical sub-expressions --- from ever matching. So the meet pass sees the original names first, and only --- its output is canonized. canonizedRewrittens :: [Rewritten] -> LatexContext -> [Rewritten] canonizedRewrittens rewrittens LatexContext{_canonize = shouldCanonize} = if shouldCanonize then canonize rewrittens else rewrittens @@ -247,10 +203,6 @@ canonizedExpressions exprs LatexContext{_canonize = shouldCanonize} = if shouldCanonize then map canonizeExpr exprs else exprs --- Compress a sequence of focused sub-expressions the way 'compressedRewrittens' --- compresses whole expressions: the meet machinery factors recurring --- sub-expressions out across the sequence. Focusing happens before this, so the --- meet never replaces a root the focus must still descend through. compressedExpressions :: [Expression] -> LatexContext -> [Expression] compressedExpressions exprs ctx@LatexContext{..} = if _compress then meetInExpressions exprs ctx else exprs @@ -298,15 +250,9 @@ toLaTeX EX_PHI_AGAIN{..} = EX_PHI_AGAIN prefix idx (toLaTeX expr) toLaTeX EX_META{..} = EX_META (toLaTeX meta) toLaTeX EX_XI{} = EX_XI XI' - -- A non-finite double is printed as a dispatch off the root, so it becomes - -- one here too, with its name piped the way any other label is (see #1065) toLaTeX EX_NONFINITE{..} = EX_DISPATCH (EX_GLOBAL global) SPACE (toLaTeX (AT_LABEL (nonFiniteName nonfinite))) toLaTeX EX_BYTES{..} = EX_BYTES (toLaTeX bytes) - -- The one-binding sugar is kept, with spaces around its colon, the way - -- a dispatch keeps them around its dot (see #1527) toLaTeX EX_SINGLE{..} = EX_SINGLE (toLaTeX pair) SPACE (toLaTeX formation) - -- A string is escaped the way a label is, so a '%' in it cannot - -- comment out the rest of the equation (see #1429) toLaTeX EX_STRING{..} = EX_STRING (T.unpack (toLaTeX (T.pack str))) tab rhos toLaTeX expr = expr @@ -453,16 +399,12 @@ (joinedConditions rule.when rule.having) rule.where_ where - -- Join two maybe conditions into single one using Y.And if at least one is just. joinedConditions :: Maybe Y.Condition -> Maybe Y.Condition -> Maybe Y.Condition joinedConditions Nothing Nothing = Nothing joinedConditions first@(Just _) Nothing = first joinedConditions Nothing second@(Just _) = second 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) ⟿ ⟨conclusion, s_k⟩ --- below, where s_k is the final state threaded through the premises. explainMorphRule :: Y.MorphRule -> String explainMorphRule rule = inference @@ -475,9 +417,6 @@ where (premises, final) = premisesToLatex rule.premises --- Render a dataization rule as a LaTeX inference rule, with 𝔻(match, e, s_1) ⟿ --- ⟨conclusion, s_k⟩ as the conclusion below the line, s_k being the final threaded --- state. explainDataizeRule :: Y.DataizeRule -> String explainDataizeRule rule = inference @@ -490,9 +429,6 @@ where (premises, final) = premisesToLatex rule.premises --- Render a contextualization rule as a LaTeX inference rule, with 𝒞(match, c) ⟿ --- c-result as the conclusion below the line. 𝒞 carries no state, so its premises --- (all contextualizations) leave the state index untouched. explainContextualizeRule :: Y.ContextualizeRule -> String explainContextualizeRule rule = inference @@ -503,26 +439,14 @@ (fst (premisesToLatex rule.premises)) (phinoContextualize (renderExpr rule.match) (renderExpr rule.cmatch) (renderExpr rule.cresult)) --- The state metavariable for index 'n', rendered as s_1, s_2, … to mirror the --- n/n_1 convention used for terms. stateName :: Int -> String stateName n = "s_" ++ show n --- The state name for a rule's conclusion. The subscript exists only to --- distinguish the several states threaded through a rule's premises; when a --- rule threads a single state ('final' == 1) it carries no information, so the --- conclusion drops it and renders a bare 's'. Otherwise it keeps the --- subscripted form (s_1 … s_final) shared with the premises. conclusionStateName :: Int -> Int -> String conclusionStateName final index | final == 1 = "s" | otherwise = stateName index --- Render a rule's premises in order, threading the state through them. The rule --- 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 ('inferred' in 'Morph.hs'). Returns the --- rendered judgments and the final state index, which the conclusion returns. premisesToLatex :: [Y.Premise] -> ([String], Int) premisesToLatex = go 1 where @@ -533,11 +457,6 @@ (rendered, next) = premiseToLatex index premise (more, final) = go next rest --- One premise judgment in state s_index, rendered per its operation. The --- 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 universe their own --- operation names, so a premise is typeset as the rule wrote it (#1512). premiseToLatex :: Int -> Y.Premise -> (String, Int) premiseToLatex index premise = case premise.operation of Y.OpMorph arg universe -> (phinoMorph (renderExpr arg) (renderExpr universe) (stateName index) (stateName (index + 1)) (renderExpr (ExMeta premise.result)), index + 1) @@ -546,8 +465,6 @@ Y.OpEvaluate arg evalUniverse -> (phinoEvaluate (renderExpr arg) (renderExpr evalUniverse) (stateName index) (stateName (index + 1)) (renderExpr (ExMeta premise.result)), index + 1) Y.OpContextualize arg context -> (phinoContextualize (renderExpr arg) (renderExpr context) (renderExpr (ExMeta premise.result)), index) --- Assemble an inference block from a name, optional label, optional side --- condition, the premise judgments and the conclusion judgment. inference :: String -> String -> Maybe String -> Maybe Y.Condition -> [String] -> String -> String inference env name label cond premises conclusion = intercalate "\n" $ @@ -563,13 +480,6 @@ renderBytes :: Bytes -> String renderBytes bytes = T.unpack (render (toLaTeX (toCST' bytes :: BYTES))) --- Render a single normalization rule row through the \phinoNormalizationRule --- macro: an optional typeset label, name, left-hand side, right-hand side, the --- optional 'if' condition and 'where' extras. When the label is present it --- becomes the macro's first optional argument ('\macro[label]{name}'); when --- absent the optional argument is omitted entirely ('\macro{name}'). --- Morphing and dataization rules render as inference rules instead (see --- 'explainMorphRule' and 'explainDataizeRule'). trrule :: String -> Maybe String -> String -> String -> String -> Maybe Y.Condition -> Maybe [Y.Extra] -> String trrule macro label name lhs rhs cond extras = intercalate @@ -583,12 +493,6 @@ where labelArg = maybe "" (\symbol -> "[" ++ symbol ++ "]") label --- 𝕄, 𝔻 and 𝔼 carry the universe and thread the state from 'sIn' to a new --- 'sOut', 𝕄(input, e, sIn) ⟿ ⟨output, sOut⟩, so they render with the universe --- and incoming state as the middle arguments and the new term and outgoing --- state as the last two arguments: --- \phinoMorph{ input }{ e }{ sIn }{ output }{ sOut }. 𝒩 and 𝒞 carry neither --- universe nor state. phinoMorph :: String -> String -> String -> String -> String -> String phinoMorph input univ sIn sOut output = printf "\\phinoMorph{ %s }{ %s }{ %s }{ %s }{ %s }" input univ sIn output sOut @@ -625,10 +529,6 @@ let extras' = map ((`renderToLatex` defaultLatexContext) . extraToCST) extras in braced (intercalate (" " <> T.unpack (render AND) <> " ") extras') --- Every rule is bared before it is rendered: an index that tells a meta from no --- other within the rule is dropped, so a rule naming a single expression meta --- says 'e' and not 'e_1', the way a rule threading a single state says 's' and --- not 's_1' (see 'conclusionStateName' and #1260). explainRules :: [Y.Rule] -> String explainRules = intercalate "\n" . map (explainRule . lonely) diff --git a/src/Lambdas.hs b/src/Lambdas.hs --- a/src/Lambdas.hs +++ b/src/Lambdas.hs @@ -6,60 +6,6 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- Which λ functions exist is a property of the object model being reduced, not --- of the calculus. phino therefore implements none of them: it reads them from --- the YAML file given with '--symbolic', where each is an entry answering the --- firing with a term of the calculus: --- --- > - λ: L_number_plus --- > dataize: --- > 𝛿1: $.ρ --- > 𝛿2: $.x --- > 𝑛: Φ.number( φ ↦ Φ.bytes( φ ↦ ⟦ λ ⤍ 𝜎 ⟧ ) ) --- --- The 'λ' of an entry is a regular expression over λ names, matching the whole --- name, so a plain name means that one function while 'L_box_[0-9]+_number' --- stands for a family of them. It is unique: the lookup answers one entry or --- none. 'dataize' names the operands brought down through 𝔻, each binding a --- bytes meta 𝛿1, and 'morph' the ones reduced through 𝕄, each binding an --- expression meta 𝑛1; both are terms of the calculus, where ξ stands for the --- formation being fired, so '$.x' is its x, and Φ for the universe. The term --- under '𝑛' is what the firing answers with, and a bare 𝜎 in it mints a fresh --- symbol. --- --- 'rewrite' is the third block and reduces nothing either. Each line of it --- names a meta the entry has bound already under 'of' and a list of ordinary --- rules under 'rules', spelled the way a rule file spells one, and binds an --- expression meta of its own to that term with the rules applied to it (see --- 'rewritten' in 'Evaluate'). It is how a program brings two branches of a --- fork to one shape before they are compared: one literal of a bool and the --- answer of a firing are one value in two spellings, and nothing but the --- program knows that (#1409). --- --- 'symbolize' is the fourth block and reduces nothing at all. It takes a term --- an earlier block of the very same entry has already bound and binds an --- expression meta of its own to that term with every datum in it standing for --- an unknown, so a normal form reached from a literal is written the way one --- reached from an unknown is written and the two of them compare as --- expressions (see 'symbolized'). --- --- 'join' is the fifth block and reduces nothing either. It takes two metas the --- entry has bound already and binds one of its own to the two terms joined, --- which is what a branching λ function answers with: a fork stands for either --- of its branches and no one branch stands for both, so the shape both of them --- have, with a fresh symbol wherever they differ, is what the answer names --- (see 'joined'). --- --- An entry answers, it never computes: the job of these functions is symbolic --- morphing, so the answer carries a symbol standing for a value nobody worked --- out, and the data its 'dataize' operands came down to is not its to read. --- An answer mentioning a bytes meta is refused where the file is read. --- --- This module holds the entries and the four things reading one takes — the --- lookup of a λ name, the minting of the symbols an answer asks for, the --- standing of the data of a term into unknowns and the joining of two terms --- into one. Firing an entry is 𝔼's business and lives in 'Morph', which alone --- holds the judgments an entry reduces its operands with. module Lambdas ( Lambda (..) , LambdaException (..) @@ -97,22 +43,11 @@ import Yaml (referenceless) import qualified Yaml as Y --- One meta an entry of the file binds: the name the file spells it with, which --- is the name the protocol of '--protocol' reports it back under, and the name --- a substitution keeps it under, which is the one 𝜑-calculus gives it. The two --- differ — '𝑛1' against 'n1', '𝛿1' against 'd1' — so an entry is read through --- the very parser a rewriting rule's pattern is read through and never --- guesses. data Meta = Meta { _spelling :: Text , _name :: Text } --- One λ function phino may fire, as the file spells it: the key it is --- registered under, the operands it brings down to data, the operands it --- reduces to a normal form, the terms of those it rewrites with rules of its --- own, the terms of those it stands the data of into unknowns, the pairs of those it joins into one term and the term it answers --- with. data Lambda = Lambda { _key :: Text , _dataized :: [(Meta, Expression)] @@ -123,16 +58,10 @@ , _answer :: Expression } --- Every λ function phino may fire, in the order the file lists them: each key, --- a regular expression over λ names, paired with the entry it introduces. A --- lookup walks them top to bottom and the first key matching the whole name --- wins, so one entry may stand for a family of λ functions while a plain name, --- being a regular expression matching itself, keeps meaning that one function. newtype Lambdas = Lambdas [(Regex, Lambda)] data LambdaException - = -- The '--symbolic' file is not a list of λ function entries. - BrokenLambdas FilePath String + = BrokenLambdas FilePath String deriving anyclass (Exception) instance Show LambdaException where @@ -156,10 +85,6 @@ earlier (T.unpack key) lambda pure lambda where - -- The metas one block of an entry binds, each paired with the term it is - -- reduced from, ordered by the name of the meta: a YAML mapping keeps no - -- order of its own, so numbering the metas 𝛿1, 𝛿2, … and 𝑛1, 𝑛2, … is - -- what reduces them the way they are written. operands :: Text -> (Text -> Yaml.Parser Meta) -> Object -> Key -> Yaml.Parser [(Meta, Expression)] operands key kind entry name = do mapping <- entry .:? name .!= (Map.empty :: Map Text Expression) @@ -169,23 +94,14 @@ bound (meta, term) = do referenceless (T.unpack key) (T.unpack meta) term kind meta >>= \named -> pure (named, term) - -- The meta a 'morph' block binds: '𝑛1' is written the way 𝜑-calculus - -- writes it and stands for the same meta a rule's 'pattern' would bind, - -- so the parser of the calculus is what reads it here too. expressionMeta :: Text -> Yaml.Parser Meta expressionMeta meta = case parseExpression (T.unpack meta) of Right (ExMeta name) -> pure (Meta meta name) _ -> fail (printf "The operand '%s' is not an expression meta, such as '𝑛1'" (T.unpack meta)) - -- The meta a 'dataize' block binds, which is a bytes meta and not an - -- expression one, since what 𝔻 answers is data and nothing else. bytesMeta :: Text -> Yaml.Parser Meta bytesMeta meta = case parseBytes (T.unpack meta) of Right (BtMeta name) -> pure (Meta meta name) _ -> fail (printf "The operand '%s' is not a bytes meta, such as '𝛿1'" (T.unpack meta)) - -- The metas a 'join' block binds, each paired with the two it joins, - -- ordered by the name of the meta the way every other block is. A line - -- joins two metas and never three: it stands for a choice between two - -- branches, and a walk over three terms in parallel is no such choice. pairs :: String -> Object -> Yaml.Parser [(Meta, (Meta, Meta))] pairs key entry = do mapping <- entry .:? "join" .!= (Map.empty :: Map Text [Text]) @@ -203,13 +119,6 @@ (T.unpack meta) key ) - -- The metas a 'rewrite' block binds, each paired with the meta whose - -- term it rewrites and the rules it rewrites that term with, ordered by - -- the name of the meta the way every other block is. A rule is read the - -- way a rule file reads one, and on top of that a rule writing a symbol - -- into its result or reading a meta its match never bound is refused - -- here: a symbol is minted by a firing and never spelled by hand, and a - -- meta nothing bound is one the rule cannot be built with. rewrites :: String -> Object -> Yaml.Parser [(Meta, (Meta, [Y.Rule]))] rewrites key entry = do mapping <- entry .:? "rewrite" .!= (Map.empty :: Map Text Object) @@ -229,16 +138,10 @@ parsed <- parseJSON (Object body) bound parsed pure parsed - -- A bare 𝜎 or a numbered one written into a result: the one names a - -- symbol a rewrite has no business minting, since it is a - -- substitution the entry vouches for and no firing, and the other - -- one nobody minted at all. symbolless :: Expression -> Yaml.Parser () 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 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 () @@ -253,12 +156,6 @@ where known :: [Text] 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 - -- normal form yet and the blocks run in the order the entry lists them - -- here. A line naming anything else names a term nobody reduced, and the - -- file is wrong where it is read rather than half-way through a firing. earlier :: String -> Lambda -> Yaml.Parser () earlier key lambda = do rewrote <- goRewrites (map (_name . fst) lambda._morphed) lambda._rewritten @@ -288,23 +185,15 @@ (T.unpack meta._spelling) key ) - -- A bare 𝜎 is the one anonymous meta an answer may carry, since minting - -- a fresh symbol is exactly what it asks for; every other one names a - -- match the entry never made. sigmas :: String -> Expression -> Yaml.Parser () sigmas key answer = case [kind | Slot kind _ <- slots answer, kind /= "S"] of [] -> pure () kind : _ -> fail (printf "The anonymous meta '!%s' cannot be referenced in the '𝑛' of λ function '%s'" (T.unpack kind) key) - -- An entry answers a term carrying a symbol and never a value it worked - -- out, so the data its operands came down to is not its to read. dataless :: String -> Expression -> Yaml.Parser () dataless key answer | computes answer = fail (printf "The '𝑛' of λ function '%s' reads data, while a symbolic answer may mention nothing but 𝜎" key) | otherwise = pure () --- Whether a term reads data — carries a bytes meta anywhere inside it — which --- is what tells an answer that computes from one that merely stands for an --- unknown. computes :: Expression -> Bool computes = goExpr where @@ -328,16 +217,9 @@ goBytes (BtAny _) = True goBytes _ = False --- No λ function at all: every one of them gets stuck. This is what a run --- without '--symbolic' fires against. emptyLambdas :: Lambdas emptyLambdas = Lambdas [] --- Read the λ functions from a YAML file. A key that is no regular expression, --- a key two entries share, an entry with no answer under '𝑛', an answer --- reading data and malformed YAML all fail here, before any reduction starts, --- so a run never gets half-way through a derivation to discover that one of --- its λ functions cannot be read at all. readLambdas :: FilePath -> IO Lambdas readLambdas path = do entries <- Yaml.decodeFileEither path >>= either broken pure @@ -349,16 +231,10 @@ where broken :: Yaml.ParseException -> IO [Lambda] broken failure = throwIO (BrokenLambdas path (Yaml.prettyPrintParseException failure)) - -- Two entries under one key are one entry too many: nothing tells them - -- apart any more, so the second is unreachable and the file is wrong - -- rather than merely redundant. unique :: [Lambda] -> Lambda -> IO () unique entries entry | length (filter ((== entry._key) . (._key)) entries) == 1 = pure () | otherwise = throwIO (BrokenLambdas path (printf "the key '%s' is used by more than one entry" (T.unpack entry._key))) - -- The key as the regular expression it is, made to match the whole name, - -- so that a plain name means that one λ function and not every name it is - -- a part of. keyed :: Lambda -> IO (Regex, Lambda) keyed entry = do compiled <- compile compUTF8 execBlank (encodeUtf8 ("^(?:" <> entry._key <> ")$")) @@ -367,9 +243,6 @@ unreadable key (_, failure) = throwIO (BrokenLambdas path (printf "the key '%s' is not a regular expression: %s" (T.unpack key) failure)) - -- Two keys matching one λ name leave the entry that answers it to the - -- order the file lists them in, so the file is wrong as soon as there is - -- such a name, whether or not either key spells it (#1440). overlaps :: FilePath -> [(Regex, Lambda)] -> IO () overlaps file registered = mapM (spoken . snd) registered >>= check where @@ -393,56 +266,17 @@ ) (shared one other) --- The entry whose key matches the whole λ name, if any. There is at most one: --- the keys are unique, so a name either has a λ function or has none at all. matched :: Lambdas -> Text -> Maybe Lambda matched (Lambdas entries) func = snd <$> find (\(key, _) -> matchTest key (encodeUtf8 func)) entries --- The fresh symbols an answer asks for, one per bare 𝜎 it was written with, --- each paired with the slot that asked for it, together with the count of --- symbols the run has minted once they are taken. Uniqueness is the state's --- job and not the file's: the state 𝑠 threaded through 𝕄, 𝔻 and 𝔼 carries how --- many symbols the run has minted so far, so every firing takes the next names --- and no two unknowns are ever spelled alike. The names are sequential rather --- than random, which keeps a symbolic run reproducible. minted :: Expression -> Int -> ([(Slot, Function)], Int) minted answer spent = (zip fresh [FnSymbol idx | idx <- [spent + 1 ..]], spent + length fresh) where fresh :: [Slot] fresh = [slot | slot@(Slot kind _) <- slots answer, kind == "S"] --- What a walk standing the data of a term into unknowns carries from one --- sub-term to the next: how many symbols the run has minted once everything --- left of this sub-term is standing, and what is known about each symbol --- minted along the way, the last of them first. type Minting = (Int, [(Int, Bytes)]) --- The term with every datum of it standing for an unknown instead: each --- 'Δ ⤍ b' binding becomes a 'λ ⤍ 𝜎k' naming a fresh symbol, one per --- occurrence, so '⟦ Δ ⤍ b ⟧' reads as '⟦ λ ⤍ 𝜎k ⟧' and a normal form --- reached from a literal is written the way one reached from an unknown is --- written, the two of them comparing as expressions. It is the binding and not --- the formation around it that changes, since a datum carries a ρ of its own --- and so does the unknown it is put beside. A term nobody worked a value out --- in passes through unchanged. --- --- Only the φ chain is walked. A term carries the value it stands for where --- that chain ends, so a datum anywhere else says nothing about the term and is --- left alone, the whole subtree of it (see 'denoted'). What sits under ρ --- belongs to the object around this one, and a normal form drags the universe --- it was reduced inside along under ρ, so a walk reaching into it would stand --- the data of the whole program into unknowns to say one thing about one term. --- What sits under a method is code and not data: the literals of --- 'neg ↦ ⟦ φ ↦ ξ.ρ.times( -1 ) ⟧' are the body of something nobody has called, --- and minting a symbol per literal of every method a carrier declares would --- write dozens of unknowns nobody reads for one value that is read (#1293). --- --- What is known about each fresh symbol comes back beside the term: the data --- dataizing the formation it names answers. That is a fact about the symbol --- and no binding of it — a 𝜎 is the name of a λ function, neither a datum --- nor a term — which is why it travels apart from the term rather than inside --- it. The count of symbols the run has minted once they are taken comes back --- too, uniqueness being the state's job here exactly as it is in 'minted'. symbolized :: Expression -> Int -> (Expression, [(Int, Bytes)], Int) symbolized term spent = case goExpr term (spent, []) of (masked, (spent', known)) -> (masked, reverse known, spent') @@ -471,10 +305,6 @@ let (bd', minting') = goBinding bd minting (rest', minting'') = goBindings rest minting' in (bd' : rest', minting'') - -- One binding of a formation stood into unknowns. The Δ of the formation - -- is its value and becomes a symbol; its φ is where the value of a term - -- that has no Δ is reached, so the walk goes on through it; every other - -- binding is carried as it was written, the whole subtree of it. goBinding :: Binding -> Minting -> (Binding, Minting) goBinding (BiDelta bts) (spent', known) = (BiLambda (FnSymbol fresh), (fresh, (fresh, bts) : known)) @@ -493,46 +323,11 @@ let (expr', minting') = goExpr expr minting in (ArAlpha alpha expr', minting') --- What a walk joining two terms carries from one sub-term to the next: how --- many symbols the run has minted once everything left of this sub-term is --- joined, the fresh symbol every pair of differing symbols was given, since --- one pair met twice is one choice and not two, and those pairs in the order --- they were met, the last of them first. type Joining = (Int, Map (Int, Int) Int, [(Int, (Int, Int))]) --- The two terms joined into the one term standing for either of them, which is --- what a fork of two branches answers with: neither branch is the answer, the --- value being the one nobody has picked, and the shape both of them have is. --- The walk goes over the two in parallel and requires them to match verbatim, --- with one exception: where a 'λ ⤍ 𝜎A' binding meets a different 'λ ⤍ 𝜎B' one --- it mints a fresh symbol and stands it there, and the same pair met again --- further down gets that very symbol, since the branch it came from is one --- choice however often the two terms differ by it. Two identical branches join --- into that same term and nothing is minted at all. Only the φ chain is --- compared, exactly as 'symbolized' stands only that chain into unknowns: --- everything else is carried from the first branch, since the value of a --- branch is where its φ chain ends and what sits under ρ or under a method is --- none of it (see 'goBinding' below). --- --- Any other difference — a datum against a symbol, two different data, a --- binding one of them carries and the other does not — is no join, and nothing --- comes back: a fork whose branches differ in structure is stuck the way a λ --- function no entry answers is, and bringing two such branches to one shape is --- the program's business rather than phino's, which its entry does in a --- 'rewrite' block (#1409). This is why a datum is never joined with anything --- and why a branch carrying one goes through 'symbolized' first (#1246). --- --- What each fresh symbol stands for comes back beside the term, the two --- symbols it was minted for in the order the branches were given, since --- dataizing its formation answers what dataizing one of the two answers and --- that is a fact about the symbol rather than a binding of it. The count of --- symbols the run has minted once they are taken comes back too, uniqueness --- being the state's business here exactly as it is in 'minted'. joined :: Expression -> Expression -> Int -> Maybe (Expression, [(Int, (Int, Int))], Int) joined left right spent = taking <$> goExpr left right (spent, Map.empty, []) where - -- The term the walk built, with what it minted put back in the order the - -- pairs were met and the count of symbols the run has spent by then. taking :: (Expression, Joining) -> (Expression, [(Int, (Int, Int))], Int) taking (term, (spent', _, made)) = (term, reverse made, spent') goExpr :: Expression -> Expression -> Joining -> Maybe (Expression, Joining) @@ -565,24 +360,6 @@ (bds, joining'') <- goBindings rest rest' joining' pure (bd : bds, joining'') goBindings _ _ _ = Nothing - -- One binding of each term joined. A λ binding naming a symbol is the one - -- place the two may differ, since a symbol is a value nobody worked out - -- and the two branches standing one each is exactly what a fork is. The φ - -- of a formation is walked into, that being where the value of the branch - -- is reached; every other binding is taken from the first branch, the whole - -- subtree of it, and never compared at all. - -- - -- That is the rule ρ has always followed, read off what a branch is rather - -- than off the attribute: what sits under ρ belongs to the object around - -- this one, and the two branches of a fork are reduced in scopes of their - -- own — each inside the universe its own operand was reduced in — so their - -- ρ differ wherever that reduction left a trace, and a walk comparing them - -- would refuse every fork whose branches 𝕄 reached by two different routes. - -- A method is the same: its body is code nobody has called, so two branches - -- differing inside one are not two values, and minting a symbol per literal - -- of every method the carrier declares writes unknowns nobody reads - -- (#1293). The shape the answer keeps is the first branch's, methods and - -- all, so the program can go on dispatching on what the fork answered. goBinding :: Binding -> Binding -> Joining -> Maybe (Binding, Joining) goBinding (BiLambda (FnSymbol one)) (BiLambda (FnSymbol two)) joining | one /= two = case picked (one, two) joining of @@ -607,10 +384,6 @@ goArgument one two joining | one == two = Just (one, joining) | otherwise = Nothing - -- The fresh symbol standing for one pair of differing symbols, and what - -- the walk carries once it is taken: a pair met before keeps the symbol it - -- was given already, and one met for the first time takes the next name - -- the run has not minted. picked :: (Int, Int) -> Joining -> (Int, Joining) picked pair joining@(spent', names, made) | Just name <- Map.lookup pair names = (name, joining) @@ -619,8 +392,5 @@ fresh :: Int fresh = spent' + 1 --- The last symbol a program already carries, which is where minting starts: a --- program written by an earlier run holds symbols of its own, and a fresh one --- must never be spelled like one of them. taken :: Expression -> Int taken program = maximum (0 : symbols program) diff --git a/src/Language.hs b/src/Language.hs --- a/src/Language.hs +++ b/src/Language.hs @@ -1,18 +1,6 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- The set of λ names the key of a '--symbolic' entry matches, as the automaton --- recognizing it, so that two keys can be asked for a name they both match. --- Testing one key against the text of the other misses a name neither key --- spells, such as 'L_number_plus' of 'L_[a-z]+_plus' and 'L_number_[a-z]+', --- and leaves the answer to the order the file lists them in (#1440). --- --- A key is read as the regular expressions of PCRE that describe a regular --- language: characters, escapes, classes, the dot, groups, alternation and --- quantifiers, lazy ones too. What goes beyond that, such as a back reference, --- a lookaround or an anchor, is refused, since two such keys cannot be told --- apart for certain. The dot stands for every character but a new line, and --- '\d', '\w' and '\s' for their ASCII sets, the way PCRE reads them. module Language (Language, language, shared) where import Data.Char (isAlphaNum, isDigit) @@ -23,26 +11,20 @@ import Text.Printf (printf) import Text.Read (readMaybe) --- A set of characters, as sorted and disjoint ranges. newtype Span = Span [(Char, Char)] --- A regular expression, as the key spells it. data Pattern = Chars Span | Chain [Pattern] | Choice [Pattern] | Repeat Int (Maybe Int) Pattern --- A move of the automaton: to a state for free, or on a character of a span. data Edge = Free Int | Step Span Int --- The automaton recognizing the names a key matches, as the edges leaving --- every state, starting at the state 0 and accepting at the state 1. newtype Language = Language (Map.Map Int [Edge]) --- The language of a key, or the reason it cannot be read as one. language :: Text -> Either String Language language key = do (pattern, rest) <- choice (T.unpack key) @@ -172,8 +154,6 @@ | low <= high = collect (Span [(low, high)] : done) rest | otherwise = Left "a range runs backwards" --- A name both languages hold, if there is one, found by walking the two --- automata side by side until both accept at once. shared :: Language -> Language -> Maybe Text shared (Language left) (Language right) = go (Set.singleton (0, 0)) [((0, 0), [])] where @@ -196,7 +176,6 @@ edges :: Map.Map Int [Edge] -> Int -> [Edge] edges table state = Map.findWithDefault [] state table --- The automaton of a pattern, from the state 0 to the state 1. automaton :: Pattern -> Language automaton pattern = Language (Map.fromListWith (flip (++)) [(from, [edge]) | (from, edge) <- snd (build pattern 0 1 2)]) where @@ -222,7 +201,6 @@ build (Repeat low high inner) from to next = build (Chain [inner, Repeat (low - 1) (subtract 1 <$> high) inner]) from to next --- Every character in any of the spans. union :: [Span] -> Span union spans = Span (merge (Set.toAscList (Set.fromList (concat [ranges | Span ranges <- spans])))) where @@ -236,7 +214,6 @@ | char == maxBound = char | otherwise = succ char --- Every character outside the span. complement :: Span -> Span complement (Span ranges) = Span (go minBound ranges) where @@ -246,13 +223,10 @@ | high == maxBound = [(from, pred low) | from < low] | otherwise = [(from, pred low) | from < low] ++ go (succ high) rest --- Every character in both spans. meet :: Span -> Span -> Span meet (Span first) (Span second) = Span [(max low low', min high high') | (low, high) <- first, (low', high') <- second, max low low' <= min high high'] --- A character of the span, a small letter if it has one, so the name an error --- quotes reads like a λ name, and nothing if the span is empty. sample :: Span -> Maybe Char sample (Span ranges) = case [max low 'a' | (low, high) <- ranges, max low 'a' <= min high 'z'] ++ [low | (low, _) <- ranges] of diff --git a/src/Logger.hs b/src/Logger.hs --- a/src/Logger.hs +++ b/src/Logger.hs @@ -31,9 +31,6 @@ 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 diff --git a/src/Margin.hs b/src/Margin.hs --- a/src/Margin.hs +++ b/src/Margin.hs @@ -32,8 +32,6 @@ withMargin' cfg EX_DISPATCH{..} = EX_DISPATCH (withMargin' cfg expr) space attr withMargin' cfg EX_PHI_AGAIN{..} = EX_PHI_AGAIN prefix idx (withMargin' cfg expr) withMargin' _ EX_PHI_MEET{..} = EX_PHI_MEET prefix idx (toSingleLine expr) - -- The asset of a one-binding sugar is followed by a colon and the attribute, - -- so it gets that much less of the margin to be laid out in withMargin' cfg@(extra, margin) ex@EX_SINGLE{pair = PA_TAU{..}, ..} = let single = toSingleLine ex asset = withMargin' (extra, margin - lengthOf attr - 1) expr @@ -42,7 +40,7 @@ let single = toSingleLine ex main = withMargin' cfg expr singleMain = toSingleLine main - extra' = T.length (last (T.lines (render main))) + 4 -- 2 spaces + 2 braces around argument + extra' = T.length (last (T.lines (render main))) + 4 arg' = withMargin' (indt, margin) argument singleArg = toSingleLine arg' in if @@ -82,17 +80,17 @@ instance WithMargin PAIR where withMargin' (extra, margin) pa@PA_TAU{..} = let single = toSingleLine pa - extra' = extra + lengthOf attr + lengthOf arrow + 2 -- indent + attr + arrow + 2 spaces + extra' = extra + lengthOf attr + lengthOf arrow + 2 pa' = PA_TAU attr arrow (withMargin' (extra', margin) expr) in if lengthOf single + extra <= margin then single else pa' withMargin' (extra, margin) pa@PA_ALPHA{..} = let single = toSingleLine pa - extra' = extra + lengthOf alpha + lengthOf arrow + 2 -- indent + alpha + arrow + 2 spaces + extra' = extra + lengthOf alpha + lengthOf arrow + 2 pa' = PA_ALPHA alpha arrow (withMargin' (extra', margin) expr) in if lengthOf single + extra <= margin then single else pa' withMargin' (extra, margin) pa@PA_FORMATION{..} = let single = toSingleLine pa - extra' = extra + lengthOf attr + lengthOf voids + lengthOf arrow + 4 -- indent + 2 braces + 2 spaces + voids + extra' = extra + lengthOf attr + lengthOf voids + lengthOf arrow + 4 pa' = PA_FORMATION attr voids arrow (withMargin' (extra', margin) expr) in if lengthOf single + extra <= margin then single else pa' withMargin' _ pa = pa diff --git a/src/Matcher.hs b/src/Matcher.hs --- a/src/Matcher.hs +++ b/src/Matcher.hs @@ -4,8 +4,6 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- The goal of the module is to traverse given AST and build substitutions --- from meta variables to appropriate meta values module Matcher where import AST @@ -14,48 +12,34 @@ import Data.Maybe (catMaybes) import Data.Text (Text) --- Meta value --- The right part of substitution data MetaValue - = MvAttribute Attribute -- !t - | MvIndex Int -- α𝑖 - | MvBytes Bytes -- !b - | MvBindings [Binding] -- !B - | MvFunction Function -- !F - | MvExpression Expression -- !e + = MvAttribute Attribute + | MvIndex Int + | MvBytes Bytes + | MvBindings [Binding] + | MvFunction Function + | MvExpression Expression deriving (Eq, Show) --- The left-hand side of a substitution: a meta-variable the rule author named --- and may reference from a result, or an anonymous slot that only the pattern --- it was written in can address data Meta = Named Text | Anon Slot deriving (Eq, Ord, Show) --- Substitution --- Shows the match of meta variable to meta value newtype Subst = Subst (Map Meta MetaValue) deriving (Eq, Show) --- A way to match a pattern expression against a target expression, yielding --- the substitutions under which they agree. type MatchExpressionFunc = Expression -> Expression -> [Subst] --- Empty substitution substEmpty :: Subst substEmpty = Subst Map.empty --- Singleton substitution with one (key -> value) pair substSingle :: Text -> MetaValue -> Subst substSingle key value = Subst (Map.singleton (Named key) value) --- Singleton substitution binding one anonymous slot substSlot :: Slot -> MetaValue -> Subst substSlot slot value = Subst (Map.singleton (Anon slot) value) --- Combine two substitutions into a single one --- Fails if values by the same keys are not equal combine :: Subst -> Subst -> Maybe Subst combine (Subst a) (Subst b) = go (Map.toList b) a where @@ -84,9 +68,6 @@ | ptn == tgt = [substEmpty] | otherwise = [] --- A λ meta stands for any λ name at all — an ordinary one and a symbol alike, --- since a symbol is a name nothing answers and not a variable of the rule --- language (see 'FnSymbol'). Every other pair matches only itself. matchFunction :: Function -> Function -> [Subst] matchFunction (FnMeta meta) tgt | named tgt = [substSingle meta (MvFunction tgt)] @@ -96,8 +77,6 @@ | ptn == tgt = [substEmpty] | otherwise = [] --- Whether a λ function is a name a program wrote rather than a meta-variable --- a rule wrote. named :: Function -> Bool named (Function _) = True named (FnSymbol _) = True @@ -119,7 +98,6 @@ matchArgument (ArAlpha palpha pexp) (ArAlpha talpha texp) = combineMany (matchAlpha palpha talpha) (matchExpression' pexp texp) matchArgument _ _ = [] --- Match bindings with ordering matchBindings :: [Binding] -> [Binding] -> [Subst] matchBindings [] [] = [substEmpty] matchBindings [] _ = [] @@ -128,15 +106,6 @@ matchBindings (pb : pbs) (tb : tbs) = combineMany (matchBinding pb tb) (matchBindings pbs tbs) matchBindings _ _ = [] --- A meta binding stands for any leading run of the target bindings, so every --- way of splitting the target into that run and the rest is tried. The rest is --- carried down one binding at a time instead of being cut out of the target --- anew at every index, which is what made a formation of N bindings cost N --- walks of itself rather than one, and the run itself is put together only --- where the pattern after it matched, so a split the pattern throws away costs --- nothing to name. A meta binding with nothing after it takes the whole rest in --- one step: the pattern is out of bindings, so the only split that matches is --- the one leaving nothing behind (#1316). matchBindingsMeta :: (MetaValue -> Subst) -> [Binding] -> [Binding] -> [Subst] matchBindingsMeta bind [] tbs = [bind (MvBindings tbs)] matchBindingsMeta bind pbs tbs = go [] tbs @@ -166,13 +135,6 @@ | otherwise = [] matchExpression' _ _ = [] --- 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 @@ -192,14 +154,9 @@ goAttribute attr = attr pinned _ _ = id --- Match expression with deep nested expression(s) matching matchExpressionDeep :: MatchExpressionFunc 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 @@ -221,19 +178,9 @@ 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 @@ -251,11 +198,6 @@ 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 @@ -287,11 +229,6 @@ same (AtAny _) _ = True same pattr tattr = pattr == tattr --- Every place of the term a rule matches at as a whole, in the order the deep --- matcher finds them, each beside what the rule makes of it there, once for --- every way it matches. The rule is a function of the place alone, the way --- 'phino compile' writes one, and it is asked about every place the deep --- matcher looks at, told whether it matches only a redex (#1617). sites :: forall a. Bool -> (Expression -> [a]) -> Expression -> [(Expression, a)] sites redex rule tgt = go tgt [] where @@ -309,28 +246,27 @@ inside (BiTau _ expr) rest = go expr rest inside _ rest = rest --- Whether a rule matches at some place of the term the deep matcher looks at, --- told whether it matches only a redex (see 'sites'). -anywhere :: Bool -> (Expression -> Bool) -> Expression -> Bool -anywhere redex rule = go +hits :: forall a. [(Int, Bool, Maybe Expression -> Expression -> [a])] -> Maybe Expression -> Expression -> [Int] +hits rules universe tgt = go [tgt] rules where - go :: Expression -> Bool - go expr - | redex && inert expr = False - | otherwise = rule expr || below expr - below :: Expression -> Bool - below (ExFormation bds) = any inside bds - below (ExDispatch expr _) = go expr - below (ExApplication expr (ArTau _ arg)) = go expr || go arg - below (ExApplication expr (ArAlpha _ arg)) = go expr || go arg - below _ = False - inside :: Binding -> Bool - inside (BiTau _ expr) = go expr - inside _ = False + go :: [Expression] -> [(Int, Bool, Maybe Expression -> Expression -> [a])] -> [Int] + go [] _ = [] + go _ [] = [] + go (expr : rest) pending + | inert expr && and [redex | (_, redex, _) <- pending] = go rest pending + | otherwise = case [idx | (idx, redex, rule) <- pending, not (redex && inert expr), not (null (rule universe expr))] of + [] -> go (below expr rest) pending + met -> met ++ go (below expr rest) [rule | rule@(idx, _, _) <- pending, idx `notElem` met] + below :: Expression -> [Expression] -> [Expression] + below (ExFormation bds) rest = foldr inside rest bds + below (ExDispatch expr _) rest = expr : rest + below (ExApplication expr (ArTau _ arg)) rest = expr : arg : rest + below (ExApplication expr (ArAlpha _ arg)) rest = expr : arg : rest + below _ rest = rest + inside :: Binding -> [Expression] -> [Expression] + inside (BiTau _ expr) rest = expr : rest + inside _ rest = rest --- Every way of cutting the bindings in two, the leading run first and the rest --- second, the shortest leading run first, which is the order a meta binding --- tries them in (see 'matchBindingsMeta'). splits :: [Binding] -> [([Binding], [Binding])] splits = go [] where diff --git a/src/Merge.hs b/src/Merge.hs --- a/src/Merge.hs +++ b/src/Merge.hs @@ -48,8 +48,6 @@ ws <- mapM (uncurry mergeBinding) collisions pure (unmarked (xs' <> ys' <> ws)) where - -- A 'Package' λ marks a pure path segment; when only one side carries it, - -- the other side is a real object and the marker goes away (#1197) unmarked :: [Binding] -> [Binding] unmarked bindings | any marker xs == any marker ys = bindings diff --git a/src/Metas.hs b/src/Metas.hs --- a/src/Metas.hs +++ b/src/Metas.hs @@ -1,13 +1,6 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- The goal of the module is to collect the meta-variables a term was written --- with and to drop the index from the ones that stand alone in their kind. --- Every name starts with the sigil of the kind it belongs to -- 'e', 'n', 'k', --- 't', 'B', 'd', 'F' or 'i' -- and carries an index after it, which is there to --- tell one meta of a kind from another. A term naming a kind just once has --- nothing to tell apart, so the index counts nothing and the sigil may stand --- alone, the way an anonymous meta stands. module Metas (Metas (..), lonely) where import AST @@ -18,15 +11,10 @@ import Text.Read (readMaybe) class Metas a where - -- The names of the meta-variables the term was written with, an anonymous - -- one named by the sigil of its kind alone metas :: a -> [Text] - -- The term with each of the given names cut down to the sigil it starts with bare :: [Text] -> a -> a --- The term with the index dropped from every name whose kind it mentions once, --- since an index that tells a meta from no other only slows the reader down lonely :: (Metas a) => a -> a lonely term = bare (filter alone named) term where @@ -39,14 +27,10 @@ indexed :: Text -> Bool indexed name = isJust (readMaybe (T.unpack (T.drop 1 name)) :: Maybe Int) --- A name stands for the meta-variable it names, so it answers with itself and --- sheds its index when asked to instance Metas Text where metas name = [name] bare names name = if name `elem` names then T.take 1 name else name --- An anonymous meta is known by the sigil of its kind, which is the name every --- meta of that kind is cut down to, and there is nothing in it to shed instance Metas Slot where metas (Slot kind _) = [kind] bare _ slot = slot @@ -119,8 +103,6 @@ bare names (BtMeta name) = BtMeta (bare names name) bare _ bts = bts --- A symbol 𝜎1 is a name and not a meta-variable, so nothing counts it among --- the metas and nothing sheds the index that tells one symbol from another instance Metas Function where metas (FnMeta name) = metas name metas (FnAny slot) = metas slot diff --git a/src/Misc.hs b/src/Misc.hs --- a/src/Misc.hs +++ b/src/Misc.hs @@ -1,7 +1,6 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- This module provides commonly used helper functions for other modules module Misc ( toDouble , fqnToAttrs @@ -21,12 +20,10 @@ import Data.Maybe (catMaybes) import Text.Printf (printf) --- Unwrap a pure 'Either String' in IO, throwing the built exception on 'Left' orThrow :: (Exception e) => (String -> e) -> Either String a -> IO a orThrow _ (Right value) = pure value orThrow asException (Left err) = throwIO (asException err) --- Extract attributes from bindings attributesFromBindings :: [Binding] -> [Attribute] attributesFromBindings [] = [] attributesFromBindings bds = catMaybes (attributesFromBindings' bds) @@ -39,7 +36,6 @@ Left msg -> throwIO (userError msg) Right _ -> pure bds --- Check if given binding list consists of unique attributes uniqueBindings :: [Binding] -> Either String [Binding] uniqueBindings bds = case repeated bds of Just attr -> @@ -51,13 +47,6 @@ ) _ -> Right bds --- Transform dispatch to list of attributes --- >>> fqnToAttrs (ExDispatch (ExDispatch (ExDispatch ExRoot (AtLabel "org")) (AtLabel "eolang")) (AtLabel "number")) --- Just [org,eolang,number] --- >>> fqnToAttrs (ExFormation []) --- Nothing --- >>> fqnToAttrs ExRoot --- Just [] fqnToAttrs :: Expression -> Maybe [Attribute] fqnToAttrs expr = go expr <&> reverse where @@ -66,7 +55,5 @@ go (ExDispatch ex at) = go ex <&> (:) at go _ = Nothing --- >>> toDouble 5 --- 5.0 toDouble :: Int -> Double toDouble = fromIntegral diff --git a/src/Morph.hs b/src/Morph.hs --- a/src/Morph.hs +++ b/src/Morph.hs @@ -11,14 +11,6 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- The Morphing function 𝕄 and the machinery every reduction of the calculus is --- threaded with: the context, the step budget, the signals a stuck run raises --- and the plumbing that reads a rule's premises. 𝔻 lives in 'Dataize' and 𝔼 in --- 'Evaluate', both of which import this module; the edges pointing back — the --- 'dataize' operand of a λ function, which is a dataization, and the firing of --- a λ function itself, which is an evaluation — are injected as '_reduce', --- '_evaluate' and '_fire' rather than imported (see 'ReductionFunc' and --- 'EvaluationFunc'). module Morph (Answer, Deadline (..), Kept (..), ReduceContext (..), ReduceException (..), EvaluationFunc, FiringFunc, Memo (..), ReductionFunc, Morphed, Steps (..), Tally (..), boxed, charged, counted, deeper, emptyState, enter, entering, execBuildTerm, inferred, insideUniverse, isLambda, lambda, leadsTo, memoized, morph, morph', morphing, normalized, onward, parking, recalled, retained, starved, tallied, timed, universed, unparked) where import AST @@ -52,250 +44,63 @@ import Text.Printf (printf) import Yaml (ExtraArgument (..)) --- A term together with the derivation that reached it: what one frame of a --- judgment's spine is handed and hands on. type Morphed = (Expression, NonEmpty Rewritten) --- How the morphing side reaches back to the dataization one. A λ function --- brings its 'dataize' operands down through 𝔻, and that is a whole run of a --- judgment 𝕄 has no business knowing about, since 'Dataize' imports 'Morph' --- and not the other way round. The reduction is therefore injected into the --- context, the way 'Deps' injects '_buildTerm', and 'Dataize' supplies its own --- 'reduction' for it. What comes back is data or nothing at all, since an --- operand 𝔻 could not bring down to bytes leaves the firing that asked for it --- with nothing to bind. The state 𝑠 goes in and comes back out, so the symbols --- a nested run mints are counted in the same sequence as the ones around it. type ReductionFunc = Expression -> ReduceContext -> Expression -> State -> IO (Maybe Bytes, State) --- How 𝕄 reaches the Evaluation function 𝔼, which lives in 'Evaluate' and --- imports this module for the machinery every judgment shares. 𝔼 is what the --- 'ml' and 'fire' rules ask for through an 'evaluate' premise, and it answers --- with a normal form, so the rule that asked needs no 'normalize' after it. The --- edge is injected rather than imported, exactly as 'ReductionFunc' injects the --- 𝔻 one, and 'Evaluate' supplies its own 'evaluation' for it. It is handed the --- formation to fire and the universe to fire it in, and the state goes in and --- comes back out. type EvaluationFunc = ReduceContext -> State -> Expression -> Expression -> IO (Expression, State) --- How the deep walk reaches 𝔼. Like 'EvaluationFunc' it answers a normal form, --- or nothing at all where nothing fired: the walk stands that answer back into --- the program, and what a firing stands there has to look like what the program --- itself would have morphed to, or the two cannot be compared (#1268). The --- first argument is the attribute the term stands dispatched under, which is --- what tells a λ the dispatch demands from one it does not. type FiringFunc = Maybe Attribute -> Expression -> Expression -> State -> ReduceContext -> IO (Maybe Expression, State) --- The initial, empty state a run of 𝕄 or 𝔻 starts from: nothing minted and --- nothing manufactured yet. The 'State' type itself lives in 'Deps' next to --- 'BuildTermMethod'. emptyState :: State emptyState = State 0 Nothing Nothing --- How many steps of the 𝕄/𝔻 recursion one branch of a derivation may take --- ('_limit', the '--max-steps' option) and how many the branch reaching this --- point has already taken ('_spent'). 𝕄 and 𝔻 recurse into each other, into the --- premises of their own rules and into the λ functions they fire, so a budget local to --- one of those chains is reset by the next nested call and bounds nothing (see --- #1052). This one rides in the context that every such path — the spine, the --- side-premises, '_dataize' and '_morph' — already carries, so a nested call --- inherits the count of the call that made it. It bounds depth, not total work: --- a premise passes its count down but not back, so siblings each descend from --- the same '_spent'. Bounding every branch is enough to terminate, since a rule --- has finitely many premises. data Steps = Steps { _limit :: Int , _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 } --- How many seconds the whole run may take ('_seconds', the '--max-seconds' --- option) and the reading of the monotonic clock it has to stop at --- ('_until'). Like 'Tally' it bounds the whole run and not one branch, and it --- bounds what neither count does: a run inside both of them may still take --- longer than its caller can wait, and a caller that kills it from outside --- leaves a protocol whose elements nobody closed (#1607). The first frame --- the deadline refuses ends the run, so the protocol says it once. A worker --- of '--jobs' reads the clock on its own, writes its refusal among its own --- records and ends its binding there; gathering stops at the first binding --- that failed, so the protocol carries that refusal and no other (#1619). data Deadline = Deadline { _seconds :: Int , _until :: Double } --- 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 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). A firing --- that got stuck is kept as well, as the λ function it got stuck on, since a --- fork whose branches never join was fired afresh at every read of it (#1493). --- A stall is a fact about the firing and not about the formation, though: a --- branch often stays unjoined only because an operand inside it could not yet --- be brought down, and the walk brings it down a few steps later. So a stall --- is kept beside the number of answers the memo held when its firing began, --- and it is told to a later firing only while the memo holds no more, since --- an operand that could not be reduced can only be reduced once something new --- was answered, the answers of the firing's own nested firings included --- (#1495, #1507). A firing inside which the step budget ran out is no stall --- of the formation at all, since the budget a firing has depends on how deep --- its site stands, and the same formation fired at a shallower site brings --- the operand down; so the memo counts every time the budget runs out, and a --- stall is not kept where that count grew while its firing ran (#1514). An --- answer the formation made is told before any stall of it, whichever came --- first. 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 (Int, Kept))) (IORef Int) (IORef Int) (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, the --- formation a recursion was cut at while it was being fired, or the λ function --- the firing got stuck on, beside the fewest steps a firing must have spent to --- be told that stall: none for a stall of the formation's own, and the steps --- the stuck firing had spent for a stall the step budget made, since a firing --- with more of the budget left may bring the operand down (#1514, #1521). data Kept = Answered Answer | Looped Expression | Stalled T.Text Int --- 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 --- 'dataize'', 'morph'' and on to the λ functions, and the state 's' is threaded the same --- way (see 'State'). The working expression needed for normalization is taken --- from the head of the step chain, so no separate wrapper type is threaded --- around. data ReduceContext = ReduceContext { _locator :: Expression - , -- Where in the universe the term being reduced stands, which is what a - -- firing of 𝔼 is written under: the protocol names the entry that answered - -- and this names the part of the program the answer belongs to, since one - -- entry answers the same way wherever it is fired and only the site tells - -- two firings of it apart (#1302). It starts as the aim of the run itself - -- ('_locator', the '--locator' option, or the binding '--inside' mints) and - -- the '--deep' walk refines it as it enters a binding, so a λ fired inside - -- an object is written under the locator of that object. It is refined no - -- further than a locator reaches: the head of a dispatch and the argument - -- of an application stand under no attribute of any formation, so a firing - -- there is written under the nearest binding the walk entered, which is - -- where the term it fired against stands. It is kept apart from '_locator' - -- because that one is where a derivation is spliced back into the working - -- expression ('leadsTo', 'normalized'), and the walk reduces terms no - -- locator of the universe aims at. - _site :: Expression - , -- The world this run reduces in, as Φ denotes it: the program in normal - -- form. Normalization is handed it so that 'dot', dispatching off a - -- formation, can tell the whole program from a part of it and decorate the - -- body with the name Φ rather than with the program itself; writing the - -- program out would copy it into the term, and into every term that term - -- then dispatches, until the copies weigh hundreds of times what the - -- program does (#1318). Nothing until a run works it out ('universed'), - -- once, and every frame below inherits what the first one named. - _universe :: Maybe Expression + , _site :: Expression + , _universe :: Maybe Expression , _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 - , -- When the whole run has to stop (see 'Deadline'), or nothing where - -- '--max-seconds' asks for no such limit. - _deadline :: Maybe Deadline - , -- 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 + , _tally :: Maybe Tally + , _deadline :: Maybe Deadline + , _memo :: Maybe Memo , _nesting :: Int , _depthSensitive :: Bool , _shuffle :: Bool , _partial :: Bool , _deep :: Bool - , -- How many workers the '--deep' walk morphs the bindings of the formation - -- it starts at on, side by side, which is the '--jobs' option (see - -- 'deepened'). One is the walk taking them one after another, the way it - -- always has, and a worker walks what its binding holds with one. - _jobs :: Int + , _jobs :: Int , _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 - -- which of the two asked the question nothing answered. Every frame of 𝕄 - -- names itself here and every frame of 𝔻 does the same, so what a firing - -- reads is the judgment of the frame it was fired from and never of one - -- above it (#1300). - _judgment :: Judgment - , -- The λ functions this run has already got stuck on and written an - -- 'unanswered(…)' to the protocol for. A parked site stays in the residue - -- exactly as it was written, so the '_deep' walk over that residue reaches - -- it again and 𝕄 fires 𝔼 on it once more, only to find out what the spine - -- already found 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 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 + , _judgment :: Judgment + , _parked :: [T.Text] + , _entered :: Seen , _symbolic :: Lambdas , _buildTerm :: BuildTermFunc , _reduce :: ReductionFunc @@ -303,18 +108,9 @@ , _fire :: FiringFunc , _saveStep :: SaveStepFunc , _saveEval :: SaveEvalFunc - , -- What runs the built-in rules of the calculus (see 'Engine'): the YAML - -- interpreted, or the Haskell 'phino compile' wrote (#1617, #1628). - _engine :: Engine + , _engine :: Engine } --- Which of the budgets a run spent, with the limit it was given: the depth --- one branch may descend ('--max-steps', see 'Steps'), the firings the whole --- run may make ('--max-firings', see 'Tally') or the cycles one normalization --- may take ('--max-cycles', see 'normalized'). All are the same signal to --- '_partial', which parks any as a site that never finishes, and differ only --- in what the message names. The seconds of '--max-seconds' are none of --- them, since a run out of time has no site to park (see 'OutOfTime'). data Budget = Depth Int | Firings Int @@ -322,65 +118,14 @@ data ReduceException = OutOfSteps Budget - | -- The deadline of '--max-seconds' passed (see 'Deadline'), with the - -- seconds the run was given. Unlike a spent budget it is no stuck site: a - -- run out of time is out of it wherever it stands, and parking one site - -- only lets the run go on rewriting and walking the rest of the term for - -- as long as that takes (#1619). So no frame attaches a derivation to it - -- and '_partial' parks nothing on it: it ends the run with or without - -- '_partial'. - OutOfTime Int - | -- 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, - -- so there is nothing to answer with. The name is that of the function 𝔼 - -- actually failed on, which for a chain of dispatches is the innermost one, - -- since 'ml' reduces a head before the function above it fires. - Stuck T.Text - | -- A 'Stuck' caught by a frame of the 𝕄/𝔻 spine, together with the - -- derivation and the state that frame had reached (see 'parking'). The head - -- of the chain is the working expression with the stuck application left - -- intact and everything reduced before it already in place: the residual - -- program that '_partial' turns into the 'Residual' outcome. The state - -- travels with it, so the symbols a parked run minted are never minted - -- again. - StuckAt T.Text (NonEmpty Rewritten) State - | -- An 'OutOfSteps' caught by a spine frame, carrying that frame's derivation - -- 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 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 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 - -- formation whose φ is a void nothing filled. It carries the term and the - -- state the frame that met it had reached. A run of 𝔻 fails on it, with or - -- without '_partial', but an operand of a firing that meets it parks that - -- firing under '_partial' the way an unanswered λ function does, since the - -- dead end is a property of the program rather than of phino (#1401). - Undataizable Expression State - | -- 𝕄 was handed a term no morphing rule matches. 𝕄 maps normal forms to - -- formations and every normal form is covered by some rule, so the term - -- is not a normal form: 'morph' does not normalize what it is given, such - -- as a dispatch off a formation with neither φ nor λ, which normalization - -- would reduce (#1442). It carries the term. - Unmorphable Expression + | OutOfTime Int + | Stuck T.Text + | StuckAt T.Text (NonEmpty Rewritten) State + | OutOfStepsAt Budget (NonEmpty Rewritten) State + | Looping Expression + | LoopingAt Expression (NonEmpty Rewritten) State + | Undataizable Expression State + | Unmorphable Expression deriving anyclass (Exception) instance Show ReduceException where @@ -401,21 +146,6 @@ show (Undataizable _ _) = "no dataization rule matched" show (Unmorphable term) = printf "Morphing expects a normal form, but no morphing rule matches: %s" (printExpression term) --- Charge one step of the 𝕄/𝔻 recursion to the budget, refusing to descend once --- it is gone. '--max-cycles' and '--max-depth' bound only the normalization run --- inside a single step, so before this the recursion itself was unbounded and a --- term that never reduces to bytes kept 𝕄 and 𝔻 calling each other forever --- (#1052). Rewriting hands back whatever it has reached when it runs out of --- cycles; 𝔻 has no partial answer to give, so an exhausted budget always throws, --- with or without '--depth-sensitive'. The memo is told every time it throws, --- so a stall the budget made is kept as a stall of that budget and not of the --- formation (see 'Kept', #1514, #1521). The protocol is told too, with the --- site the frame stood at, so a firing the budget starved no longer reads as --- one that went well (#1524), and a frame of 𝕄 standing at a whole universe --- does not spell it on every line (#1531). The clock is read here as well as --- where a λ function fires, since a run may spend its time rewriting and --- walking terms that fire nothing, and every such frame passes through here --- (#1619). deeper :: ReduceContext -> IO ReduceContext deeper ctx@ReduceContext{_steps = Steps limit spent} = do clocked ctx @@ -429,21 +159,12 @@ starve Nothing = pure () starve (Just (Memo _ _ exhausted _)) = modifyIORef' exhausted (+ 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) --- The deadline a run starts from where '--max-seconds' gives a limit: that --- many seconds from now. timed :: Maybe Int -> IO (Maybe Deadline) timed = traverse (\cap -> Deadline cap . (+ fromIntegral cap) <$> getMonotonicTime) --- Charge one firing of a λ function to the budgets of the whole run, refusing --- to fire once the deadline has passed (see 'clocked') or the tally is gone --- (see 'Tally'). 'deeper' bounds how far one branch descends, which stops a --- recursion that nests but not one that widens, and neither count stops a run --- that is merely slow. charged :: ReduceContext -> IO () charged ctx = do clocked ctx @@ -455,8 +176,6 @@ when (fired >= cap) (throwIO (OutOfSteps (Firings cap))) writeIORef count (fired + 1) --- Refuse to go on once the deadline of '--max-seconds' has passed (see --- 'Deadline'), which ends the run (see 'expired'). clocked :: ReduceContext -> IO () clocked ctx = mapM_ clock ctx._deadline where @@ -465,27 +184,15 @@ now <- getMonotonicTime when (now >= due) (expired ctx cap) --- End the run out of time (see 'OutOfTime'). The refusal is told to the --- protocol, with the judgment of the frame refused and the site it stood at, --- at the depth its line would have stood at, so a run out of time reads as one --- and leaves the protocol closed and whole, with the refusal as its last line --- (#1607, #1619). expired :: ReduceContext -> Int -> IO a expired ctx cap = do ctx._saveEval (EvTimeout ctx._nesting cap ctx._judgment ctx._site) throwIO (OutOfTime cap) --- 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 0 <*> newIORef 0 <*> newIORef Set.empty) memoized _ = pure Nothing --- What the memo keeps for the formation, if this run fired it already (see --- 'Memo'): an answer before anything else, and a stall only while nothing was --- answered after it and only to a firing that has spent at least the steps --- kept beside it (see 'Kept'); nothing where the run keeps no memo at all. recalled :: Maybe Memo -> Expression -> Int -> IO (Maybe Kept) recalled Nothing _ _ = pure Nothing recalled (Just (Memo store answers _ _)) form spent = do @@ -501,22 +208,14 @@ answered (Answered _) = True answered _ = False --- How many answers the memo holds (see 'Memo'); none where the run keeps no --- memo at all. counted :: Maybe Memo -> IO Int counted Nothing = pure 0 counted (Just (Memo _ answers _ _)) = readIORef answers --- How many times the step budget has run out in this run (see 'Memo'); never --- where the run keeps no memo at all. starved :: Maybe Memo -> IO Int starved Nothing = pure 0 starved (Just (Memo _ _ exhausted _)) = readIORef exhausted --- Keep what firing the formation came to, for the next firing of it, stamped --- with the count of answers the memo held when that firing began, so that --- what the firing answered inside itself counts as answered after it (see --- 'Memo', #1507). retained :: Maybe Memo -> Expression -> Int -> Kept -> IO () retained Nothing _ _ _ = pure () retained (Just (Memo store answers _ _)) form stamp kept = do @@ -525,31 +224,14 @@ Answered _ -> modifyIORef' answers (+ 1) _ -> pure () --- 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 --- frame it reaches is the one to record where the derivation stopped: the head --- of that frame's chain is the working expression with the stuck application --- intact and everything reduced before it already in place. The same holds for --- 'OutOfSteps': a term cycling through the universe is no more a failure of the --- chain than a missing λ function is, and under '_partial' it deserves the same --- parked residual (#1078). Outer frames see the '…At' signals and let them --- pass, since their chains are prefixes of that one; a side-computation running --- on a chain of its own strips the chain off again (see 'unparked') before the --- signal reaches the spine. parking :: NonEmpty Rewritten -> State -> IO a -> IO a parking seq state action = action `catch` rethrow where @@ -559,11 +241,6 @@ rethrow (Looping term) = throwIO (LoopingAt term seq state) rethrow failure = throwIO failure --- Strip the derivation off a stuck λ function escaping a side-computation that --- ran on a chain of its own — a firing reducing an operand of its own, or a --- 'morph' premise through '_morph'. That chain is not the spine's, so it is --- dropped and the spine frame around the side-computation attaches its own --- (see 'parking'). unparked :: IO a -> IO a unparked action = action `catch` rethrow where @@ -573,53 +250,9 @@ rethrow (LoopingAt term _ _) = throwIO (Looping term) rethrow failure = throwIO failure --- 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). --- The search is pure, and under 'Plausible' one comparison may take longer than --- the whole run may, since 'within' looks for the formation entered above at --- every depth of the one about to be entered, and on two deep terms it takes --- more than a second even with the answers of the call kept (#1623). The --- deadline of '--max-seconds' cuts the search while it runs, and the refusal --- stands where the formation would have opened (#1622). enter :: Expression -> ReduceContext -> IO ReduceContext enter form ctx = maybe (pure ctx) remembered ctx._acyclic where @@ -643,15 +276,6 @@ 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 @@ -659,8 +283,6 @@ | 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 @@ -671,50 +293,15 @@ 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 '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', run by the engine (see '_morphing' of --- 'Engine'): the first matching rule's premises are evaluated and its --- conclusion 'nresult' is built, in the universe the concluding premise names, --- which every rule spells as the one it was matched in (#1512). The clauses --- are disjoint (see #856, #860), so their declaration order must not be --- load-bearing; when '_shuffle' is on (the '--shuffle' flag) the rules are --- shuffled before 'inferred' walks them to exercise that invariant — mirroring --- normalization's "apply until they stop matching". A genuinely --- order-independent step stays deterministic; a hidden overlap surfaces as a --- nondeterministic failure rather than staying silently green. --- The 'morph' premise that produces the conclusion is the spine: when --- its argument comes from a 'normalize' premise, the rewriter runs over that --- argument and its individual steps (alpha, copy, dot, …) are spliced into the --- chain before morphing continues (see 'onward'). Every other premise is a --- side-computation evaluated in isolation by 'inferred', its own steps --- discarded. morph' :: Morphed -> Expression -> State -> ReduceContext -> IO (Morphed, State) morph' (expr, seq) univ state caller = do ctx <- deeper =<< entering expr =<< universed univ caller{_judgment = Morphing} @@ -729,21 +316,6 @@ morph' morphed world state'' ctx Nothing -> throwIO (Unmorphable expr) --- Morph the expression located at '_locator' — 𝕄 asked on its own, the way --- 'dataize' asks 𝔻. The whole input expression is itself the universe Φ (the 'e' --- argument) threaded through 𝕄, so it is passed both as the located target and --- as the universe; the default locator Q therefore morphs the top formation, --- which 'mf' hands back unchanged, and '_locator' is how one aims 𝕄 at a --- subterm. Unlike 𝔻, 𝕄 is total: it stops at the first formation it reaches --- ('mf') and never demands bytes, and where no formation is reachable it answers --- with the terminator ⊥ ('dead', 'xi', 'mg', 'mad', 'maad') rather than failing. --- Only the λ functions 'ml' fires can still get stuck, and '_partial' parks --- them just as it does under 𝔻: the answer is then the residual subterm the --- spine had reached, taken from '_locator' of its working expression. Stopping --- at the first formation leaves everything that formation holds as it was --- written, which is what '_deep' walks into before the answer is handed back --- (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 caller@ReduceContext{..} = do ctx <- universed universe caller @@ -757,31 +329,15 @@ Left (OutOfStepsAt _ seq parked) | _partial -> do residue <- locatedExpression _locator (fst (NE.head seq)) 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 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'). 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 :: 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 - -- prints. walked :: ReduceContext -> Expression -> NonEmpty Rewritten -> State -> IO (Expression, [Rewritten], State) walked walker morphed seq state' | not _deep = pure (morphed, reverse (NE.toList seq), state') @@ -790,39 +346,11 @@ seq' <- leadsTo seq (Morphing, "deep") deep walker pure (deep, reverse (NE.toList seq'), state'') --- Walk what 𝕄 answered with, entering everything it left as it was written — --- the mechanism behind '--deep' ('_deep'). 𝕄 navigates a term to the first --- formation it reaches and 'mf' hands that formation back with its bindings --- untouched, since firing a bare λ is 𝔻's business; 𝔻 in turn follows the one --- path dataization demands and ends in bytes. A part of a program that nothing --- demands — the argument of a λ function that cannot fire, for one — is --- therefore reduced by neither, and the object structure is lost to the one --- that does reduce it (#1124). This walk demands nothing either. It asks 𝕄 --- about every sub-expression and, where 𝕄 lands on a formation whose λ the --- '--symbolic' file answers, fires it and asks 𝕄 about the answer again (see --- '_fire', which 'Evaluate' answers with its own 'fired'). A sub-expression on --- whose way a λ function fired is replaced by the --- answer of the last firing; where none fired it stays as it was written and --- only its own parts are walked, so the calls no entry answers keep their names --- and what comes back is still the same program, reduced as far as the file --- allows. Every entry is charged to the '--max-steps' budget, which is what --- bounds the walk. Under '--jobs' the bindings of the formation the walk --- starts at are walked side by side rather than one after another (see --- 'spread'). deepened :: Expression -> Expression -> State -> ReduceContext -> IO (Expression, State) deepened expr univ state ctx = step (if ctx._jobs > 1 then spread else parts) (Just ctx._site) Nothing ExXi expr state ctx where - -- A term as it was written, together with the locator naming it where one - -- does and with what its free ξ stands for: the formation the walk entered - -- it from, without the binding it came from, exactly the context the 'dot' - -- rule hands a dispatched body. At the top there is no such formation, so ξ - -- stands for itself and contextualization leaves the term alone, and the - -- locator is the one the whole run was aimed at. go :: Maybe Expression -> Maybe Attribute -> Expression -> Expression -> State -> ReduceContext -> IO (Expression, State) go = step parts - -- The same, with the parts of the term walked the way the first argument - -- walks them, which only the term the walk starts at is walked by other - -- than 'parts'. step :: (Maybe Expression -> Expression -> Expression -> State -> ReduceContext -> IO (Expression, State)) -> Maybe Expression -> Maybe Attribute -> Expression -> Expression -> State -> ReduceContext -> IO (Expression, State) step walk standing dispatched context term state' caller = do let here = sited standing caller @@ -831,26 +359,9 @@ placed <- ctx._engine._contextualize walked context (answer, answered) <- ctx'._fire dispatched placed univ walkedState ctx' pure (fromMaybe walked answer, answered) - -- The context a term is walked in, aimed at the term itself where a locator - -- names it. Where none does, the aim stays where it was: a firing standing - -- deeper in a term than a locator reaches belongs to the last binding the - -- walk entered, and saying that is saying where it is (see '_site'). sited :: Maybe Expression -> ReduceContext -> ReduceContext sited Nothing caller = caller sited (Just loc) caller = caller{_site = loc} - -- The parts of a term nothing fired on, walked one by one and put back - -- where they were, so the term keeps the shape it was written in. Only a - -- binding of a formation carries the locator further: the head of a - -- dispatch and both sides of an application stand under no attribute, so - -- what they hold is entered with no locator of its own. An abstract - -- formation, one holding a void, is a method nobody applied: its body is - -- parametric, walking it can only end in ⊥ or a stuck term, and a λ there - -- dataizing a parameter would end the whole run, so it is handed back as it - -- was written (#1393). A void ρ counts like any other: a formation holds - -- one only where the program declared it, so it is a method waiting for - -- the receiver a dispatch hands it, and its ξ.ρ can only collapse to ⊥ - -- wherever it stands, in a copy that kept its ρ or in one 'skip' dropped - -- it from (#1397, #1414). parts :: Maybe Expression -> Expression -> Expression -> State -> ReduceContext -> IO (Expression, State) parts _ _ term@(ExFormation bds) state' _ | any abstract bds = pure (term, state') @@ -865,26 +376,9 @@ (applied, state''') <- argument context arg state'' caller pure (ExApplication entered applied, state''') parts _ _ term state' _ = pure (term, state') - -- Whether a binding is a void, which makes the formation holding it a - -- method nobody applied (see 'parts'). abstract :: Binding -> Bool abstract (BiVoid _) = True abstract _ = False - -- The parts of the term the walk starts at, walked the way 'parts' walks - -- them, except that the bindings of a formation are walked side by side, - -- as many at once as '--jobs' says (#1534). Each is a root of its own: it - -- is walked from the state the spine left, with a memo, a tally and a - -- source of fresh names of its own and its protocol kept aside, so what - -- it comes to depends on the binding alone and not on which worker got - -- where first. What the workers made is gathered in the order of the - -- bindings, and that order is what the symbols are numbered in: a binding - -- numbers what it mints from the floor the spine left, and gathering - -- raises that by what the bindings before it minted, in its answer and in - -- its protocol alike, so the answer and the protocol name a symbol the way - -- one walk over the bindings would have. The protocol of a binding is - -- written whole once it and every binding before it are done. Which - -- binding is entered at all is decided up front, by the walk itself, the - -- way 'bindings' decides it. spread :: Maybe Expression -> Expression -> Expression -> State -> ReduceContext -> IO (Expression, State) spread standing _ form@(ExFormation bds) state' caller | not (any abstract bds) = do @@ -924,22 +418,10 @@ (bd, walked) <- either throwIO (pure . ($ offset)) outcome pure (bd : done, maybe offset (\after -> after._minted - floor') walked, fromMaybe current walked) spread standing context term state' caller = parts standing context term state' caller - -- The term builder a binding walked on a worker of its own mints its - -- fresh names with: the one of the run, except that 'random-tau' draws - -- from the source of the binding (see 'tausOf'). minting :: IO T.Text -> BuildTermFunc -> BuildTermFunc minting tau build func | func == "random-tau" = \args subst -> if null args then TeAttribute . AtLabel <$> tau else build func args subst | otherwise = build func - -- Walk the bindings of a formation left to right, threading the state - -- through them. Only what the formation itself holds is entered: ρ names - -- 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. A binding - -- the walk has entered in another copy of the same object of the world is - -- left as it was written (see 'fresh'), unless its body reads the copy it - -- stands in (see 'closed'). 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 @@ -954,14 +436,6 @@ 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 @@ -976,13 +450,6 @@ 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 @@ -990,28 +457,18 @@ unless seen (visit caller._memo object attr) pure (not seen) fresh _ _ _ = pure True - -- Whether a body cannot see the copy it stands in, that is, holds no ξ - -- outside the formations nested in it, since the ξ of a nested formation - -- is that formation. Two copies filling their voids differently make two - -- different programs of a body reading ξ, so the walk of one tells nothing - -- about the other and such a body is walked in every copy (#1485). closed :: Expression -> Bool closed ExXi = False closed (ExDispatch target _) = closed target closed (ExApplication target (ArTau _ arg)) = closed target && closed arg closed (ExApplication target (ArAlpha _ arg)) = closed target && closed arg closed _ = 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. scope :: Attribute -> [Binding] -> Expression scope attr bds = ExFormation (filter (not . named) bds) where named :: Binding -> Bool named (BiTau attr' _) = attr' == attr named _ = False - -- Both sides of an application stand in the same context: the term it - -- applies is walked by the caller and the argument it binds is walked here. argument :: Expression -> Argument -> State -> ReduceContext -> IO (Argument, State) argument context (ArTau attr arg) state' caller = do (entered, state'') <- go Nothing Nothing context arg state' caller @@ -1020,14 +477,6 @@ (entered, state'') <- go Nothing Nothing context arg state' caller pure (ArAlpha alpha entered, state'') --- What the first of the rules 𝕄 or 𝔻 walks concludes with about 'expr' in --- 'univ', once the premises it runs beside its spine have run, in the order --- it lists them, each in isolation: a 'morph' and an 'evaluate' reduce on a --- fresh chain and discard it, a 'contextualize' is pure, and the state is --- threaded through, so the symbols 𝔼 mints and those of a 'morph' come back --- to the frame that asked. Nothing where no rule matches. The conditions of a --- rule are checked the way the matcher checks them, with the world the frame --- reduces in and the normal forms of the engine. inferred :: Expression -> Expression -> State -> ReduceContext -> [In.Inference value] -> IO (Maybe (In.Conclusion value, State)) inferred expr univ state ctx rules = do ordered <- if ctx._shuffle then shuffle rules else pure rules @@ -1047,15 +496,6 @@ next answer >>= premised state'' premised state' (In.Contextualizes term context next) = ctx._engine._contextualize term context >>= next >>= premised state' --- Reach the term a rule of 𝕄 or 𝔻 asks its judgment about again from the one --- the rule built, the way the rule says (see 'Way'): a step of the rule, the --- same followed by 𝒩, whose steps splice into the chain, or 𝕄 in the universe --- the rule gives, whose steps splice in too. A 'normalize' 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). onward :: NonEmpty Rewritten -> State -> In.Way -> Expression -> ReduceContext -> IO (Morphed, State) onward seq state (In.Taken step) expr ctx = do seq' <- leadsTo seq step expr ctx @@ -1069,21 +509,11 @@ Nothing -> onward seq state (In.Normalized step) expr ctx onward seq state (In.Staged stage) expr ctx = morph' (expr, seq) stage state ctx --- Take a step of the chain: the term at its head is taken to 'expr' by the --- rule, which is named and tagged with the judgment it belongs to (#1536). leadsTo :: NonEmpty Rewritten -> (Judgment, String) -> Expression -> ReduceContext -> IO (NonEmpty Rewritten) leadsTo ((current, _) :| rest) rule expr ReduceContext{..} = do updated <- withLocatedExpression _locator expr current pure ((updated, Nothing) :| (current, Just rule) : rest) --- Reduce 'expr' to its normal form through the normalization rewriter, embedding --- it at '_locator' into the working expression taken from the head of the step --- chain so the rewriter sees the surrounding context. Splices the individual --- steps (alpha, copy, dot, …) into the chain and returns the normalized --- expression together with the extended sequence. A rewriter that ran out of --- '--max-cycles' hands back a term that is not a normal form, which neither 𝕄 --- nor 𝔻 accepts, so the exhausted budget is signalled instead and '_partial' --- parks the site the way it parks any other (#1496). normalized :: Expression -> NonEmpty Rewritten -> ReduceContext -> IO (Expression, NonEmpty Rewritten) normalized expr seq ctx@ReduceContext{..} = do whole <- withLocatedExpression _locator expr (fst (NE.head seq)) @@ -1094,41 +524,16 @@ expr' <- locatedExpression _locator (fst rw) pure (expr', seq') where - -- Switch the reduction context to a rewriting context for normalization, - -- disabling the must-checker and breakpoints. rewriteContext :: ReduceContext -> RewriteContext rewriteContext ReduceContext{..} = - RewriteContext _locator _maxDepth _maxCycles _depthSensitive _universe _buildTerm _engine._normal MtDisabled Nothing _saveStep + RewriteContext _locator _maxDepth _maxCycles _depthSensitive _universe _buildTerm _engine._normal _engine._matching MtDisabled Nothing _saveStep --- Name the world a run reduces in, where nothing has named it yet: the program --- in normal form, which is what Φ denotes and what 'dot' compares a dispatched --- formation against before it writes 'ρ ↦ Φ' (see '_universe'). Every frame of --- 𝕄 and of 𝔻 asks, and only the first one of a run answers, since the context --- travels down the recursion and what it names travels with it. The walk that --- works it out is itself given no world, so it folds nothing while it is --- deciding what the world is. universed :: Expression -> ReduceContext -> IO ReduceContext universed _ ctx@ReduceContext{_universe = Just _} = pure ctx universed univ ctx = do (normal, _) <- normalized univ ((univ, Nothing) :| []) ctx{_locator = ExRoot, _saveStep = dontSaveStep} pure ctx{_universe = Just normal} --- Bind 'expr' to a synthetic attribute of the universe and reduce it to a --- normal form there, handing back the extended universe together with the --- locator that aims at the binding. This is the trick phino has always played --- to reduce a sub-expression that is not part of the program — the operand a --- λ function names under 'dataize' or 'morph', above all — and it is also --- the contract of the '--inside' option, so a caller asking phino to reduce a --- part of the formation it was given does not have to splice it into the text --- of the universe by hand. 𝔻 and 𝕄 accept normal forms only and an expression --- handed in from outside is not necessarily one (a dispatch off a formation, --- '⟦ x ↦ 6, ρ ↦ 5 ⟧.x', is not), so it is normalized against the extended --- universe before either judgment sees it. The context comes back aimed at that --- binding, so the caller hands the extended universe and the context it got --- straight to 'dataize' or 'morph'. The site every firing is written under --- moves with the aim, so a λ function fired while such a term is being reduced --- is written under the synthetic binding it was bound to and not under whatever --- the run around it was aimed at (see '_site'). insideUniverse :: Expression -> Expression -> ReduceContext -> IO (Expression, ReduceContext) insideUniverse expr univ ctx@ReduceContext{_buildTerm = buildTerm} = case univ of ExFormation bds -> do @@ -1139,44 +544,22 @@ pure (ExFormation (BiTau attr normal : bds), aiming{_universe = extended attr normal}) _ -> throwIO (userError "Can't reduce an expression inside a universe which is not a formation") where - -- What Φ denotes inside the extended universe. Normalization works binding - -- by binding, so the normal form of the extension is the normal form of - -- the universe with the already-normalized term bound in front of it, and - -- no second walk of the world is needed to name it (see '_universe'). A - -- run that has not named its world yet leaves it unnamed here too, and the - -- frame below works it out. extended :: Attribute -> Expression -> Maybe Expression extended attr normal = case ctx._universe of Just (ExFormation bds) -> Just (ExFormation (BiTau attr normal : bds)) _ -> Nothing --- Morph a term that is not part of the program, the way 'reduction' in --- 'Dataize' dataizes one: bound to a synthetic attribute of the universe and --- reduced there (see 'insideUniverse'), since 𝕄 takes normal forms only and an --- operand taken out of a formation as it was written is not necessarily one. --- This is what a 'morph' operand of a λ function is reduced with, and the --- dataizing sibling of it reaches 'Dataize' through '_reduce'. morphing :: Expression -> ReduceContext -> Expression -> State -> IO (Expression, State) morphing univ ctx expr state = do (universe, aiming) <- insideUniverse expr univ ctx (morphed, _, state') <- morph universe state aiming pure (morphed, state') --- Augment the injected, context-free term builder with the dataization and --- morphing operations that need the universe: 'evaluate' fires a λ function and --- 'morph' morphs a sub-expression. 𝔼 ('evaluate') takes the universe as an --- explicit second expression argument, while 𝕄 ('morph') is handed the threaded --- 'univ'. Every other function is delegated unchanged. This is the matcher's --- condition path (guards in 'when'/'having'), which has no state to thread, so 𝔼 --- and 𝕄 run here on a fresh, empty state whose result is discarded; the --- premises of a rule, which thread the state, are run by 'inferred'. execBuildTerm :: Expression -> ReduceContext -> BuildTermFunc execBuildTerm _ ctx "evaluate" = evaluated ctx execBuildTerm univ ctx "morph" = _morph univ ctx execBuildTerm _ ctx func = _buildTerm ctx func --- The Evaluation function 𝔼 exposed as a build-term function, the formation --- and the universe built out of the substitution. evaluated :: ReduceContext -> BuildTermMethod evaluated ctx [ArgExpression expr, ArgExpression universe] subst = do form <- buildExpressionThrows expr subst @@ -1184,20 +567,12 @@ TeExpression . fst <$> ctx._evaluate ctx emptyState form world evaluated _ _ _ = throwIO (userError "Function evaluate() requires exactly 2 expression arguments") --- The Morphing function 𝕄 exposed as a build-term function so a rule can morph --- a sub-expression in its 'where' (see 'detached'). _morph :: Expression -> ReduceContext -> BuildTermMethod _morph univ ctx [ArgExpression expr] subst = do built <- buildExpressionThrows expr subst TeExpression . fst <$> detached built univ emptyState ctx _morph _ _ _ _ = throwIO (userError "Function morph() requires exactly 1 expression argument") --- Morph 'expr' in 'univ' on a chain of its own, the way a 'morph' premise --- beside the spine does (the 'md' and 'ma' rules morph the head before --- re-attaching it). The step chain is discarded: the producing rule splices --- the surrounding normalization steps itself, and a stuck λ met on the way --- leaves without it (see 'unparked'). The state is threaded through and the --- new state returned alongside the morphed term. detached :: Expression -> Expression -> State -> ReduceContext -> IO (Expression, State) detached expr univ state ctx = unparked $ do ((morphed, _), state') <- morph' (expr, (univ, Nothing) :| []) univ state ctx diff --git a/src/Must.hs b/src/Must.hs --- a/src/Must.hs +++ b/src/Must.hs @@ -33,21 +33,21 @@ let loPart = if null loStr then Nothing else readMaybe loStr hiPart = if null hiStr then Nothing else readMaybe hiStr in case (loPart, hiPart, null loStr, null hiStr) of - (Nothing, Nothing, False, False) -> [] -- Invalid range: non-numeric values - (Nothing, Nothing, True, True) -> [(MtRange Nothing Nothing, "")] -- Empty range '..' round-trips + (Nothing, Nothing, False, False) -> [] + (Nothing, Nothing, True, True) -> [(MtRange Nothing Nothing, "")] (Nothing, Just hi, True, False) -> [(MtRange Nothing (Just hi), "") | hi >= 0] (Just lo, Nothing, False, True) -> [(MtRange (Just lo) Nothing, "") | lo >= 0] (Just lo, Just hi, False, False) -> [(MtRange (Just lo) (Just hi), "") | lo >= 0 && hi >= 0 && lo <= hi] - _ -> [] -- Invalid range format - _ -> [] -- Invalid range: expected format like '3..5', '3..', or '..5' + _ -> [] + _ -> [] parseExact :: String -> [(Must, String)] parseExact str = case readMaybe str of Just n | n >= 0 -> [(if n == 0 then MtDisabled else MtExact n, "")] - Just _ -> [] -- Invalid value: must be non-negative - Nothing -> [] -- Invalid value: expected integer + Just _ -> [] + Nothing -> [] inRange :: Must -> Int -> Bool inRange MtDisabled _ = True @@ -58,7 +58,6 @@ checkMin = maybe True (<= actual) minVal checkMax = maybe True (>= actual) maxVal --- | Check if a value exceeds the upper bound of the range exceedsUpperBound :: Must -> Int -> Bool exceedsUpperBound MtDisabled _ = False exceedsUpperBound (MtExact n) current = current > n diff --git a/src/Parser.hs b/src/Parser.hs --- a/src/Parser.hs +++ b/src/Parser.hs @@ -4,7 +4,6 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- The goal of the module is to parse given phi expression to AST module Parser ( parseExpression , parseExpressionThrows @@ -63,19 +62,15 @@ show CouldNotParseAttribute{..} = printf "Couldn't parse given attribute, cause: %s" message show CouldNotParseNumber{..} = printf "Couldn't parse given number to 'Φ.number', cause: %s" message --- White space consumer whiteSpace :: Parser () whiteSpace = L.space space1 empty empty --- Lexeme that ignores white spaces after lexeme :: Parser a -> Parser a lexeme = L.lexeme whiteSpace --- Strict symbol (or sequence of symbols) with ignored white spaces after symbol :: String -> Parser String symbol = L.symbol whiteSpace --- Parsed as String then packed to Text once; BiLambda keeps String so function stays String label' :: Parser T.Text label' = lexeme $ do first <- oneOf ['a' .. 'z'] @@ -120,10 +115,6 @@ global :: Parser String global = choice [ascii 'Q', symbol "Φ"] --- A one-letter ASCII token that a function name may start with, `Q` or `T`, --- which is no such token where it is a function name itself or the start of --- one, so `Q:λ` and `Qx:λ` stay the λ functions `Q` and `Qx` in the --- one-binding sugar of #1385 ascii :: Char -> Parser String ascii letter = lexeme (try (pure <$> char letter <* notFollowedBy (satisfy named <|> '_' <$ lambdaOf))) where @@ -135,13 +126,6 @@ metaSuffix :: Parser String metaSuffix = lexeme (many (oneOf ('_' : '-' : ['0' .. '9'] ++ ['a' .. 'z'] ++ ['A' .. 'Z']) "meta suffix")) --- A meta-variable, written either in ASCII ('!t') or in Unicode ('𝜏'). The --- suffix tells the two kinds apart: with one the variable is named and a rule --- may reference it from its result, without one it is an anonymous slot --- pinned to the offset it starts at, unique within the parsed term. Named --- variables are packed to Text once here; all AST meta fields are Text. A --- suffix of '0' is no name but a first index written wrong: every index of the --- calculus starts with one, so the whole term is refused where it stands. metaVar :: Char -> String -> Parser (Either Slot T.Text) metaVar ch uni = do offset <- getOffset @@ -159,11 +143,6 @@ else Right (T.pack (ch : suf)) ) --- A symbol standing where a λ name stands: 𝜎1, a name nothing answers, or a --- bare 𝜎, which asks for a fresh one. It is spelled the way every meta of the --- calculus is spelled, indexed or not, so 'metaVar' reads it, but what comes --- back is a name and not a meta-variable: an index becomes the symbol it --- numbers and a bare one the slot that tells it apart from its siblings. sigma :: Parser Function sigma = metaVar 'S' "𝜎" >>= either (pure . FnFresh) numbered where @@ -183,11 +162,6 @@ | isDigit ch || ('A' <= ch && ch <= 'F') = return ch | otherwise = fail ("expected 0-9 or A-F, got " ++ show ch) --- bytes --- 0. meta: !b --- 1. empty: -- --- 2. one byte: 01- --- 3. many bytes: 01-02-...-FF bytes :: Parser Bytes bytes = lexeme @@ -216,23 +190,12 @@ ( DataNumber ( numToBts ( case sign of - -- Negate the Double rather than the Scientific so that a zero - -- literal preserves its sign: Scientific has no negative zero, - -- but negate on Double yields -0.0, a distinct IEEE-754 value. Just '-' -> negate (toRealFloat unsigned) _ -> toRealFloat unsigned ) ) ) --- An expression head that starts with the root: either one of the three --- non-finite doubles named off it — `Φ.nan`, `Φ.pinf` and `Φ.ninf`, read back --- into the very 'DataNumber' the sweet printer collapsed, which keeps --- print-then-parse idempotent (see #1065) — or the root itself. The label after --- the root is parsed once, here, so an ordinary dispatch such as `Φ.number` --- costs no more than it did before the three names existed; an attribute the --- label parser rejects (ρ, φ, a meta) is left to 'exTail', as is any further --- dispatch or application root :: Parser Expression root = do _ <- global @@ -269,19 +232,17 @@ case readHex hexDigits of [(n, "")] -> if n >= 0xD800 && n <= 0xDBFF - then -- High surrogate, look for low surrogate - do - _ <- string "\\u" - lowHexDigits <- count 4 hexDigitChar - case readHex lowHexDigits of - [(low, "")] -> - if low >= 0xDC00 && low <= 0xDFFF - then do - -- Valid surrogate pair, combine them - let codePoint = 0x10000 + ((n - 0xD800) * 0x400) + (low - 0xDC00) - return (chr codePoint) - else fail ("Invalid low surrogate: \\u" ++ lowHexDigits) - _ -> fail ("Invalid low surrogate hex: \\u" ++ lowHexDigits) + then do + _ <- string "\\u" + lowHexDigits <- count 4 hexDigitChar + case readHex lowHexDigits of + [(low, "")] -> + if low >= 0xDC00 && low <= 0xDFFF + then do + let codePoint = 0x10000 + ((n - 0xD800) * 0x400) + (low - 0xDC00) + return (chr codePoint) + else fail ("Invalid low surrogate: \\u" ++ lowHexDigits) + _ -> fail ("Invalid low surrogate hex: \\u" ++ lowHexDigits) else if n >= 0xDC00 && n <= 0xDFFF then fail ("Unexpected low surrogate: \\u" ++ hexDigits) @@ -297,9 +258,6 @@ [(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 @@ -325,59 +283,31 @@ rb :: Parser String rb = symbol ")" --- The name a λ binding carries: a function, a meta standing for one, or a symbol lambdaName :: Parser Function lambdaName = choice [Function . T.pack <$> function, try (either FnAny FnMeta <$> metaVar 'F' "𝑓"), sigma] --- The colon that attaches an attribute to what stands before it, making a --- formation of one binding out of the two (see #1385) colon :: Parser String colon = symbol ":" --- A formation of one binding written as its asset followed by a colon and the --- attribute it is bound to, the way the sugar of #1385 spells it: --- `FF-AA:Δ` is `⟦ Δ ⤍ FF-AA ⟧`, `𝜎1:λ` is `⟦ λ ⤍ 𝜎1 ⟧` and `∅:a` is --- `⟦ a ↦ ∅ ⟧`. A τ binding, `ξ.a:φ` for `⟦ φ ↦ ξ.a ⟧`, is no head but a tail, --- since it attaches to a whole expression (see 'exTail'). Bytes and λ names --- look like numbers and function-like heads, so their shapes are only --- committed to once the attribute after the colon is read. Each of the three --- is a head of its own in 'exHead', standing right before the first head it --- could be taken for and opened by a look at a character it must start with, --- so the heads a program is mostly made of never try it. alone :: Parser Binding -> Parser Expression alone bd = ExFormation . pure <$> bd --- `FF-AA:Δ`, `--:D` or `𝛿1:Δ` deltaHead :: Parser Expression deltaHead = lookAhead (satisfy (\ch -> isDigit ch || ('A' <= ch && ch <= 'F') || ch `elem` ("-!𝛿" :: String))) >> alone (try (BiDelta <$> bytes <* colon <* choice [symbol "D", symbol "Δ"])) --- `Plus:λ`, `𝜎1:λ` or `!F1:L` lambdaHead :: Parser Expression lambdaHead = lookAhead (satisfy (\ch -> isAsciiUpper ch || ch `elem` ("!𝑓𝜎" :: String))) >> alone (try (BiLambda <$> lambdaName <* colon <* choice [symbol "L", symbol "λ"])) --- `∅:a` or `?:a` voidHead :: Parser Expression voidHead = alone (choice [symbol "?", symbol "∅"] >> colon >> BiVoid <$> attribute) metaBinding :: Parser Binding metaBinding = either BiAny BiMeta <$> metaVar 'B' "𝐵" --- binding --- 1. delta --- 2. meta delta --- 3. meta --- 4. lambda --- 5. meta lambda --- 6. void --- 7. tau --- --- Every alternative commits as soon as the token that tells it apart from its --- siblings is consumed, so a failure deeper in the binding keeps its own --- position instead of being rewound to the beginning of the binding. binding :: Parser Binding binding = choice @@ -397,15 +327,9 @@ ] "binding" where - -- A void followed by a colon is no void of this binding but the head of - -- a one-binding formation the binding is bound to, as in `x ↦ ∅:a` blank :: Parser String blank = arrow >> choice [symbol "?", symbol "∅"] <* notFollowedBy colon --- inlined void attribute --- 1. label --- 2. rho --- 3. phi void' :: Parser Attribute void' = choice @@ -418,11 +342,6 @@ return AtPhi ] --- attribute --- 1. label --- 2. meta --- 3. rho --- 4. phi attribute :: Parser Attribute attribute = choice @@ -431,13 +350,9 @@ ] "attribute" --- index meta: !i, 𝑖 indexVar :: Parser (Either Slot T.Text) indexVar = metaVar 'i' "𝑖" --- alpha --- 1. index: ~0, α0 --- 2. meta: α𝑖, ~!i alpha :: Parser Alpha alpha = do _ <- choice [symbol "~", symbol "α"] @@ -447,9 +362,6 @@ ] "alpha" --- application argument --- 1. tau: ↦ --- 2. alpha: ↦ argument :: Parser Argument argument = choice @@ -463,7 +375,6 @@ Left msg -> fail msg Right bds' -> return bds' --- formation formationBindings :: Parser [Binding] formationBindings = do _ <- choice [symbol "[[", symbol "⟦"] @@ -477,15 +388,6 @@ rsb :: Parser String rsb = choice [symbol "]]", symbol "⟧"] --- head part of expression --- 1. formation --- 2. this --- 3. global, or an attribute or non-finite double named off it --- 4. termination --- 5. meta expression --- 6. full attribute -> sugar for $.attr --- 7. one-binding formation of a Δ, λ or void binding -> sugar for ⟦ Δ ⤍ FF- ⟧, --- each standing before the first head it could be taken for exHead :: Parser Expression exHead = choice @@ -514,10 +416,6 @@ application :: Expression -> [Argument] -> Expression application = foldl ExApplication --- tail optional part of application --- 1. any head + dispatch --- 2. any head except $ and Q + application --- 3. any head + colon and attribute -> sugar for ⟦ attr ↦ head ⟧ exTail :: Expression -> Parser Expression exTail expr = choice @@ -558,7 +456,6 @@ expr <- exHead exTail expr --- Entry point parse' :: String -> Parser a -> String -> Either String a parse' name parser input = do let parsed = diff --git a/src/Pool.hs b/src/Pool.hs --- a/src/Pool.hs +++ b/src/Pool.hs @@ -3,13 +3,6 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- A handful of workers taking independent actions off one list, which is --- how the '--deep' walk under '--jobs' morphs the bindings of the formation --- it starts at side by side (#1534). What the actions gave is folded in the --- order they were listed and not in the order they finished, so whatever --- the fold writes, the protocol above all, comes out the same however the --- workers were scheduled, and it comes out as soon as an action and every --- one before it are done rather than once the slowest of them is. module Pool (pooled) where import Control.Concurrent (QSem, ThreadId, forkIO, killThread, newQSem, signalQSem, waitQSem) @@ -17,10 +10,6 @@ import Control.Exception (SomeException, bracket_, finally, mask, throwIO, try) import Control.Monad (foldM) --- Run the actions, at most as many at once as the first argument says, and --- fold what they gave in the order they were listed. An action that threw --- has its exception thrown once everything listed before it is folded, and --- the actions still running are stopped then, since nobody waits for them. pooled :: forall a b. Int -> [IO a] -> (b -> a -> IO b) -> b -> IO b pooled width actions fold start = do gate <- newQSem (max 1 width) diff --git a/src/Printer.hs b/src/Printer.hs --- a/src/Printer.hs +++ b/src/Printer.hs @@ -47,13 +47,9 @@ printExpression' :: Expression -> PrintConfig -> String printExpression' = printExpressionWith (const id) --- Like 'printExpression'', but drops every ρ binding from the rendered --- expression (the '--hide-rho' switch). See 'withoutRho'. printExpressionHidingRho' :: Expression -> PrintConfig -> String printExpressionHidingRho' = printExpressionWith withoutRho --- Shared rendering pipeline with a hook applied to the sugared CST, right --- before encoding and margin wrapping. printExpressionWith :: (SugarType -> EXPRESSION -> EXPRESSION) -> Expression -> PrintConfig -> String printExpressionWith hide ex (sugar, encoding, line, margin) = T.unpack $ render (withLineFormat line $ withMargin margin $ withEncoding encoding $ hide sugar $ withSugarType sugar $ expressionToCST ex) @@ -86,10 +82,6 @@ printBytes :: Bytes -> String printBytes bts = T.unpack $ render (toCST bts (0, NO_EOL) :: BYTES) --- The λ function alone, without the binding that carries it: the name of an --- ordinary one, the 𝜎 of a symbol, the sigil of a rule's meta. It is read off --- the binding's own CST, so the spelling stays where every other spelling of --- the calculus lives. printFunction :: Function -> String printFunction fun = T.unpack (spelled (toCST (BiLambda fun) (0, NO_EOL) :: PAIR)) where @@ -115,10 +107,6 @@ printMetaValue (MvBindings bds) config = printExpression' (ExFormation bds) config printMetaValue (MvFunction fun) _ = printFunction fun --- An anonymous slot is reported under the bare sigil it was written with, --- just as a named meta is reported under its name. Two slots of one kind --- therefore share a line label while keeping their own values, which is all --- the report can say about a variable no rule may refer back to. printMeta :: Meta -> String printMeta (Named name) = T.unpack name printMeta (Anon (Slot kind _)) = T.unpack kind diff --git a/src/Random.hs b/src/Random.hs --- a/src/Random.hs +++ b/src/Random.hs @@ -35,13 +35,6 @@ rest' <- generate rest pure (ch : rest') --- The 'strings' set grows monotonically over a process, so a pattern with a --- bounded space (e.g. '%d', which has exactly 10,000 values) eventually gets --- exhausted. Trying again forever would hang, so the search gives up after a --- bounded number of attempts and reports the collision space instead. The --- limit is well above the largest realistic space (10,000) so that finding the --- last free value of a nearly-full space still succeeds with overwhelming --- probability: (9999/10000)^100000 ≈ 4.5e-5. maxAttempts :: Int maxAttempts = 100000 @@ -68,16 +61,11 @@ randomized ('%' : ch : rest) = ch == 'd' || ch == 'x' || randomized rest randomized (_ : rest) = randomized rest --- Fast Fisher-Yates with mutable vectors. --- The function is generated by ChatGPT and claimed as --- fastest approach comparing to usage IOArray. --- >>> shuffle [1..20] --- [7,15,5,18,13,19,3,11,20,2,1,8,14,16,17,12,9,10,6,4] shuffle :: [a] -> IO [a] shuffle xs = do gen <- newIOGenM =<< newStdGen let n = length xs - v <- V.thaw (V.fromList xs) -- Mutable copy + v <- V.thaw (V.fromList xs) forM_ [n - 1, n - 2 .. 1] $ \i -> do j <- uniformRM (0, i) gen M.swap v i j diff --git a/src/Render.hs b/src/Render.hs --- a/src/Render.hs +++ b/src/Render.hs @@ -302,7 +302,6 @@ 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" @@ -315,14 +314,7 @@ instance Render EXTRA where render EXTRA{func = "contextualize", args = arg : rest, ..} = "\\phinoContextualize{ " <> render arg <> " }{ " <> T.intercalate ", " (map render rest) <> " }{ " <> render meta <> " }" - -- 𝕄 carries the universe and threads a state, 𝕄(n, e, s_1), so a 'morph' extra - -- renders with the universe metavariable 'e' and the incoming state 's_1' as its - -- 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. The rule never writes the - -- universe, since phino knows it where the rule applies (#1460), so the name - -- and the formation it stands for are the two sides of one relation. render EXTRA{func = "named", args = [form], ..} = "\\phinoNamed{ " <> render meta <> " }{ " <> render form <> " }" render EXTRA{..} = render meta <> " \\coloneqq " <> macro func <> "{ " <> T.intercalate ", " (map render args) <> " }" where diff --git a/src/Replacer.hs b/src/Replacer.hs --- a/src/Replacer.hs +++ b/src/Replacer.hs @@ -1,8 +1,6 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- The goal of the module is to traverse through the expression with replacing --- pattern sub expression with target expressions module Replacer ( replaceExpression , replaceExpressionFast @@ -39,10 +37,6 @@ let (expr', ptns', repls') = func (expr, ptns, repls) 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)) | inert expr && not (inert ptn) = state @@ -61,11 +55,6 @@ _ -> state replaceExpression' state = state --- Every pair of a pattern and a replacement stands for one match, so a pair --- is spent once it replaces something in the bindings of a formation, and the --- bindings a replacement brings in are searched only with the pairs still --- left. That is what ends the walk, as it ends the regular one, rather than a --- cap on how deep the walk goes, which dropped every match below it (#1391). replaceBindingsFast :: Expression -> ReplaceState [Binding] -> ReplaceState [Binding] replaceBindingsFast _ state@(_, [], _) = state replaceBindingsFast _ state@(_, _, []) = state diff --git a/src/Rewriter.hs b/src/Rewriter.hs --- a/src/Rewriter.hs +++ b/src/Rewriter.hs @@ -9,7 +9,7 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module Rewriter (Seen, direct, fast, interpreted, rewrite, RewriteContext (..), Rewritten, Rewrittens, Rewrittens', seenInsert, seenMember, stepHeaders) where +module Rewriter (Seen, direct, every, fast, interpreted, rewrite, RewriteContext (..), Rewritten, Rewrittens, Rewrittens', seenInsert, seenMember, stepHeaders) where import AST import Builder @@ -17,6 +17,9 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Set (Set) +import qualified Data.Set as Set import Deps import Locator (locatedExpression, withLocatedExpression) import Logger (logDebug) @@ -29,41 +32,22 @@ import Text.Printf (printf) import qualified Yaml as Y -type RewriteState = (NonEmpty Rewritten, Seen, Bool) +type RewriteState = (NonEmpty Rewritten, Expression, Seen, Bool, Maybe (Set Int)) --- Loop-detection store. It maps a cheap fixed-size digest of an expression (see --- 'hashExpression') to the full expressions that produced that digest. A --- digest collision is resolved by a slow, exact structural (==) comparison, --- so loops are still detected soundly while the common (no collision) case --- stays O(1) on the digest instead of O(expressionSize) per lookup/insert. type Seen = Map.Map Int [Expression] --- Has this exact expression been seen before? The digest lookup is fast; the --- (==) check runs only on a digest match, guarding against hash collisions. seenMember :: Int -> Expression -> Seen -> Bool seenMember digest expr seen = maybe False (elem expr) (Map.lookup digest seen) --- Remember an expression under its digest, keeping any earlier collisions. seenInsert :: Int -> Expression -> Seen -> Seen seenInsert digest expr = Map.insertWith (++) digest [expr] --- A step of a rewriting chain: the expression, and the rule that took it to --- the next one, named and tagged with the judgment it belongs to, which is how --- a chain of 𝕄 or 𝔻 mixing rules of several judgments tells them apart (#1536). type Rewritten = (Expression, Maybe (Judgment, String)) type Rewrittens = (NonEmpty Rewritten, Bool) type Rewrittens' = ([Rewritten], Bool) --- Build a header line for every step of a rewriting chain. The chain is --- '[(e0, Just r0), ..., (en, Nothing)]', where 'ri' is the rule applied to 'ei' --- to produce 'e(i+1)' (see 'leadsTo'). A step's header names the rule that --- produced its expression, together with the AST node counts before and after --- that rule, e.g. "=== Step #4, Rule 'STOP', 32t -> 43t". The very first step is --- the input, which no rule produced, so it carries only its number: --- "=== Step #1". The 'N nodes -> M nodes' pair matches the debug log emitted --- while rewriting. stepHeaders :: [Rewritten] -> [String] stepHeaders chain = zipWith3 header [1 ..] chain (Nothing : map Just chain) where @@ -84,18 +68,10 @@ , _maxDepth :: Int , _maxCycles :: Int , _depthSensitive :: Bool - , -- 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 + , _universe :: Maybe Expression , _buildTerm :: BuildTermFunc - , -- Whether a term is a normal form, which a '𝑛' or '𝑘' meta of a rule asks - -- (see '_normal' of 'RuleContext'). - _normal :: Expression -> Bool + , _normal :: Expression -> Bool + , _matching :: Maybe Expression -> Expression -> Set Int , _must :: Must , _breakpoint :: Maybe String , _saveStep :: SaveStepFunc @@ -133,21 +109,12 @@ rul expr --- Build pattern and result expression and replace patterns to results in given expression buildAndReplace' :: ToReplace -> ReplaceExpressionFunc -> IO Expression buildAndReplace' (expr, ptn, res, substs) func = do ptns <- buildExpressionsThrows ptn substs repls <- buildExpressionsThrows res substs pure (func (expr, ptns, map const repls)) --- If pattern and replacement are appropriate for fast replacing - does it. --- Pattern and replacement expressions can be used in fast replacing only if --- 1. they are both formations --- 2. they start and end with the same meta bindings, e.g. [!B1, ..., !B2] --- 3. the does not have meta bindings between first and last meta bindings --- In such case we can just replace bindings one by one without building whole expression. --- You can find more details in this ticket: https://github.com/objectionary/phino/issues/321 --- If we don't meet the conditions above - just do a regular replacing tryBuildAndReplaceFast :: ToReplace -> IO Expression tryBuildAndReplaceFast state@(expr, ptn@(ExFormation (_ : pbds)), res@(ExFormation (_ : rbds)), substs) | fast ptn res = do @@ -158,8 +125,6 @@ buildAndReplace' state replaceExpression tryBuildAndReplaceFast state = buildAndReplace' state replaceExpression --- Whether a rule of the pattern and the result is replaced the fast way (see --- 'tryBuildAndReplaceFast'). fast :: Expression -> Expression -> Bool fast (ExFormation _pbds@(pbd : pbds)) (ExFormation _rbds@(rbd : rbds)) = startsAndEndsWithMeta _pbds @@ -184,9 +149,6 @@ _ -> False fast _ _ = False --- The step a rule of YAML takes: the matcher finds every place the rule --- matches at and the builder and the replacer rewrite them (see --- 'tryBuildAndReplaceFast'). interpreted :: Y.Rule -> Step interpreted rule = Step rule.name applied where @@ -196,16 +158,6 @@ [] -> pure Nothing matched -> Just <$> tryBuildAndReplaceFast (expr, rule.pattern, rule.result, matched) --- The step a rule 'phino compile' turned into Haskell takes: the rule is a --- function telling what it rewrites a term to where the term matches it as a --- whole, and the places it matches at are found in the order the matcher --- finds them (see 'sites') and replaced in that order, exactly as the replacer --- replaces those of a rule of YAML. A place inside what an earlier one was --- rewritten to is therefore a step of its own, as it is for the matcher, and --- the chain of steps does not depend on which of the two ran (#1617). The --- flag says whether the rule matches only a redex (see 'R.redex'). --- The function is told the world the term stands in, where one is known, --- which is what the 'named' function of a rule reads. direct :: String -> Bool -> (Maybe Expression -> Expression -> [Expression]) -> Step direct name redex rewritten = Step name applied where @@ -214,50 +166,49 @@ [] -> Nothing found -> Just (replaceExpression (expr, map fst found, map (const . snd) found)) --- The function returns tuple (X, Y, Z) where --- - X is sequence of expressions; --- - Y is Set of unique expressions after each rule application. It allows to stop the rewriting if we're getting --- into loop and get back to an expression which we've already got before --- - Z is boolean flag which tells us if we reach breakpoint. If unmatched rule is equal to breakpoint rule - entire --- rewriting must be stopped and original expression must be returned -rewrite' :: RewriteState -> [Step] -> Int -> RewriteContext -> IO RewriteState +every :: [Step] -> Maybe Expression -> Expression -> Set Int +every steps _ _ = Set.fromList (zipWith const [0 ..] steps) + +rewrite' :: RewriteState -> [(Int, Step)] -> Int -> RewriteContext -> IO RewriteState rewrite' state [] _ _ = pure state -rewrite' state (rule : rest) iteration ctx@RewriteContext{..} = do - state' <- _rewrite state 1 - case state' of - (_, _, True) -> pure state' - _ -> rewrite' state' rest iteration ctx +rewrite' (rewrittens, located, unique, stop, found) ((idx, rule) : rest) iteration ctx@RewriteContext{..} + | Set.member idx matched || _breakpoint == Just (_name rule) = + _rewrite (rewrittens, located, unique, stop, Just matched) 1 >>= \case + state'@(_, _, _, True, _) -> pure state' + state' -> rewrite' state' rest iteration ctx + | otherwise = rewrite' (rewrittens, located, unique, stop, Just matched) rest iteration ctx where + matched :: Set Int + matched = fromMaybe (_matching _universe located) found _rewrite :: RewriteState -> Int -> IO RewriteState - _rewrite (_rewrittens@((current, _) :| _), _unique, _) _count = + _rewrite (_rewrittens@((current, _) :| _), expression, _unique, _, _found) _count = let ruleName = _name rule in if _count - 1 == _maxDepth then do logDebug (printf "Max amount of rewriting cycles (%d) for rule '%s' has been reached, rewriting is stopped" _maxDepth ruleName) if _depthSensitive then do - exhausted <- applicable current [rule] ctx + exhausted <- applicable expression [rule] ctx if exhausted then throwIO (StoppedOnLimit "max-depth" _maxDepth) - else pure (_rewrittens, _unique, False) - else pure (_rewrittens, _unique, False) + else pure (_rewrittens, expression, _unique, False, _found) + else pure (_rewrittens, expression, _unique, False, _found) else do logDebug (printf "Starting rewriting cycle for rule '%s': %d out of %d" ruleName _count _maxDepth) - expression <- locatedExpression _locator current _applied rule (RuleContext _buildTerm _universe _normal) expression >>= \case Nothing -> do logDebug (printf "Rule '%s' does not match, rewriting is stopped" ruleName) if _breakpoint == Just ruleName then do logDebug (printf "Rule '%s' is a breakpoint, dropping down all the previous rewritings..." ruleName) - pure (_rewrittens, _unique, True) - else pure (_rewrittens, _unique, False) + pure (_rewrittens, expression, _unique, True, _found) + else pure (_rewrittens, expression, _unique, False, _found) Just expr -> do logDebug (printf "Rule '%s' has been matched and applied" ruleName) if expression == expr then do logDebug (printf "Applied '%s', no changes made" ruleName) - pure (_rewrittens, _unique, False) + pure (_rewrittens, expression, _unique, False, _found) else let digest = hashExpression expr in if seenMember digest expr _unique @@ -273,52 +224,44 @@ ) updated <- withLocatedExpression _locator expr current _saveStep updated - _rewrite (leadsTo updated, seenInsert digest expr _unique, False) (_count + 1) + _rewrite (leadsTo updated, expr, seenInsert digest expr _unique, False, Nothing) (_count + 1) where leadsTo :: Expression -> NonEmpty Rewritten leadsTo next = let (head', _) :| rest = _rewrittens in (next, Nothing) :| (head', Just (Normalization, _name rule)) : rest --- Tells whether any of the rules still matches the located expression. A run --- with nothing left to rewrite after its last allowed step has finished, not --- run out of its limit, so --depth-sensitive lets it pass (#1439) applicable :: Expression -> [Step] -> RewriteContext -> IO Bool -applicable current rules RewriteContext{..} = do - expression <- locatedExpression _locator current - go expression rules - where - go :: Expression -> [Step] -> IO Bool - go _ [] = pure False - go expression (rule : rest) = - _applied rule (RuleContext _buildTerm _universe _normal) expression >>= \case - Nothing -> go expression rest - Just _ -> pure True +applicable _ [] _ = pure False +applicable expression (rule : rest) ctx@RewriteContext{..} = + _applied rule (RuleContext _buildTerm _universe _normal) expression >>= \case + Nothing -> applicable expression rest ctx + Just _ -> pure True --- Rewrite the expression by provided locator from RewriteContext rewrite :: Expression -> [Step] -> RewriteContext -> IO Rewrittens rewrite expr rules ctx@RewriteContext{..} = do - (rewrittens, exceeded) <- _rewrite ((expr, Nothing) :| [], Map.empty, False) 0 + located <- locatedExpression _locator expr + (rewrittens, exceeded) <- _rewrite ((expr, Nothing) :| [], located, Map.empty, False, Nothing) 0 pure (NE.reverse rewrittens, exceeded) where _rewrite :: RewriteState -> Int -> IO Rewrittens - _rewrite state@(rewrittens@((current, _) :| _), _, _) count + _rewrite state@(rewrittens@((current, _) :| _), expression, _, _, _) count | not (inRange _must count) && count > 0 && exceedsUpperBound _must count = throwIO (MustStopBefore _must count) | count == _maxCycles && not (inRange _must count) = throwIO (MustBeGoing _must count) | count == _maxCycles = do logDebug (printf "Max amount of rewriting cycles for all rules (%d) has been reached, rewriting is stopped" _maxCycles) if _depthSensitive then do - exhausted <- applicable current rules ctx + exhausted <- applicable expression rules ctx if exhausted then throwIO (StoppedOnLimit "max-cycles" _maxCycles) else pure (rewrittens, False) else pure (rewrittens, True) | otherwise = do logDebug (printf "Starting rewriting cycle for all rules: %d out of %d" count _maxCycles) - rewrite' state rules count ctx >>= \case - (_, _, True) -> pure ((expr, Nothing) :| [], False) -- breakpoint, return original expression - state'@(rewrittens'@((current', _) :| _), _, False) -> + rewrite' state (zip [0 ..] rules) count ctx >>= \case + (_, _, _, True, _) -> pure ((expr, Nothing) :| [], False) + state'@(rewrittens'@((current', _) :| _), _, _, False, _) -> if length rewrittens' == length rewrittens || current' == current then do logDebug "Rewriting is stopped since it has no effect" diff --git a/src/Rule.hs b/src/Rule.hs --- a/src/Rule.hs +++ b/src/Rule.hs @@ -37,40 +37,17 @@ import Yaml (normalizationRules) import qualified Yaml as Y --- 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). A '𝑛' or --- '𝑘' meta asks whether a term is a normal form, which is a question about the --- built-in normalization rules, so the context carries the answer the engine --- running them gives, the YAML read at run time or the Haskell 'phino compile' --- wrote (#1617). data RuleContext = RuleContext { _buildTerm :: BuildTermFunc , _universe :: Maybe Expression , _normal :: Expression -> Bool } --- One rewriting rule ready to run: its name, which the chain, '--breakpoint' --- and the step headers show, and what it makes of a whole term, rewriting --- every place it matches at once. The answer is nothing where the rule --- matches nowhere, and the term, changed or not, where it matches somewhere, --- since the rewriter tells the two apart. A step is either a rule of YAML the --- matcher interprets or a rule 'phino compile' turned into Haskell, and the --- rewriter cannot tell one from the other (#1617). data Step = Step { _name :: String , _applied :: RuleContext -> Expression -> IO (Maybe Expression) } --- Whether any normalization rule applies to the term or to a place inside it: --- its pattern, its '𝑛' and '𝑘' metas and its 'when' hold, whatever its 'where' --- makes of them, which is what the compiled 'nf' asks too. A function of --- 'where' may fail where the rule applies, as 'contextualize' of 'dot' fails on --- '⟦ x ↦ 𝑒9.y ⟧.x', since no rule of 𝒞 takes a meta (#1630). Here we use --- unsafePerformIO because we're sure that conditions which are used in --- normalization rules do not throw an exception. matchesAnyNormalizationRule :: Expression -> RuleContext -> Bool matchesAnyNormalizationRule expr ctx = matchesAnyNormalizationRule' expr normalizationRules ctx where @@ -80,34 +57,23 @@ let matched = unsafePerformIO (admitted (deep rule) [substEmpty] expr rule ctx) in not (null matched) || matchesAnyNormalizationRule' expr rules ctx --- Returns True if given expression is in the normal form isNF :: Expression -> RuleContext -> Bool isNF expr ctx = normalWith (`matchesAnyNormalizationRule` ctx) expr --- Whether a term is a normal form by the rules of YAML, the answer an engine --- that interprets them gives to a '𝑛' or '𝑘' meta (see '_normal'). The rules --- are matched with a context of their own, since a normal form is a property --- of the term alone. normal :: Expression -> Bool normal expr = isNF expr (RuleContext buildTerm Nothing normal) --- Whether a term is a normal form, told whether some normalization rule --- matches somewhere inside a given term. A few shapes are decided before any --- rule is asked, since the rules themselves decide them the same way. normalWith :: (Expression -> Bool) -> Expression -> Bool normalWith _ ExXi = True normalWith _ ExRoot = True normalWith _ ExTermination = True normalWith _ (ExDispatch ExXi _) = True normalWith _ (ExDispatch ExRoot _) = True -normalWith _ (ExDispatch ExTermination _) = False -- dd rule -normalWith _ (ExApplication ExTermination _) = False -- dc rule +normalWith _ (ExDispatch ExTermination _) = False +normalWith _ (ExApplication ExTermination _) = False normalWith _ (ExFormation []) = True normalWith matching (ExFormation bds) = normalBindings bds || not (matching (ExFormation bds)) where - -- Returns True if all given bindings are 100% in normal form: each one is - -- a Δ, a λ or a void, and no Δ stands beside a λ, since 'dl' turns such a - -- formation into ⊥ (#1437) normalBindings :: [Binding] -> Bool normalBindings bds = all inert bds && not (any delta bds && any lambda bds) inert :: Binding -> Bool @@ -123,11 +89,6 @@ lambda _ = False normalWith matching expr = not (matching expr) --- Whether the term a '𝑛' or '𝑘' meta of a rule holds is a normal form by the --- given test, the way the matcher tells it (see '_nf'): the matcher reads a --- term that is itself a meta as one more meta to look up, and finds nothing --- bound to it, so such a term is no normal form. A program holds no meta, so --- only a term handed to a judgment by hand tells this apart. normalHeld :: (Expression -> Bool) -> Expression -> Bool normalHeld _ (ExMeta _) = False normalHeld _ (ExAny _) = False @@ -154,16 +115,12 @@ met <- meetCondition' cond subst ctx pure [subst | null met] --- 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 [] --- Convert a 'Number' to an 'Int' under the given substitution, resolving --- index metas, binding lengths and formation domains. numToInt :: Y.Number -> Subst -> Maybe Int numToInt (Y.MetaIndex meta) (Subst mp) = case M.lookup (Named meta) mp of Just (MvIndex idx) -> Just idx @@ -177,8 +134,6 @@ numToInt (Y.Literal num) _ = Just num numToInt _ _ = Nothing --- How many of the bindings are attributes a positional argument may fill: --- every one but Δ, λ and ρ, which is what 'domain' of a rule counts. domainOf :: [Binding] -> Int domainOf = length . filter notAsset where @@ -206,19 +161,12 @@ Just (MvAttribute found) -> attr == found _ -> False compareAttrs left right _ = right == left --- Both sides are built under the substitution before they are compared, so a --- side written as a whole term — '⟦𝐵1, 𝜏1 ↦ 𝑛1, 𝐵2⟧' and not merely a meta --- standing for one — is compared as the term it stands for rather than as the --- pattern it was written as. A side holding a meta nothing bound cannot be --- built, and an equality nobody can work out does not hold. _eq (Y.CmpExpr left) (Y.CmpExpr right) subst _ = case (buildExpression left subst, buildExpression right subst) of (Right left', Right right') -> pure [subst | left' == right'] (_, _) -> pure [] _eq _ _ _ _ = pure [] --- Hold if the left number is strictly greater than the right one. Only --- numeric comparables are ordered; anything else fails to hold. _gt :: Y.Comparable -> Y.Comparable -> Subst -> RuleContext -> IO [Subst] _gt (Y.CmpNum left) (Y.CmpNum right) subst _ = case (numToInt left subst, numToInt right subst) of (Just left_, Just right_) -> pure [subst | left_ > right_] @@ -234,14 +182,6 @@ _ -> pure [] _nf expr subst ctx = pure [subst | _normal ctx expr] --- An expression is xi-free when it contains no ξ outside of a formation: it is --- Φ, ⊥, a formation, a dispatch with a xi-free subject, or an application with --- a xi-free subject and argument. ⊥ holds no ξ to capture, so it is xi-free --- (and 'isNF ⊥ = True' already), which lets the copy rule accept a ⊥ argument. --- Together with a normal-form check this is what makes an expression absolute --- (𝒦 ⊆ 𝒩); the '𝑘' meta-variable applies this xi-free check first (cheap, --- structural, rules out the ξ-recursion the normal-form check could loop on) --- and the normal-form check second. _absolute :: Expression -> Subst -> RuleContext -> IO [Subst] _absolute (ExMeta meta) (Subst mp) ctx = case M.lookup (Named meta) mp of Just (MvExpression expr) -> _absolute expr (Subst mp) ctx @@ -251,7 +191,6 @@ _ -> pure [] _absolute expr subst _ = pure [subst | xiFree expr] --- Whether the term holds no ξ outside of a formation (see '_absolute'). xiFree :: Expression -> Bool xiFree (ExFormation _) = True xiFree ExRoot = True @@ -261,15 +200,12 @@ xiFree (ExDispatch e _) = xiFree e xiFree _ = False --- Hold when the given expression is a formation (an abstraction ⟦…⟧). A meta --- is resolved first, so 'binding 𝑛' inspects whatever 𝑛 is bound to. _isFormation :: Expression -> Subst -> RuleContext -> IO [Subst] _isFormation (ExMeta meta) (Subst mp) ctx = case M.lookup (Named meta) mp of Just (MvExpression expr) -> _isFormation expr (Subst mp) ctx _ -> pure [] _isFormation expr subst _ = pure [subst | isFormation expr] --- Whether the term is a formation (see '_isFormation'). isFormation :: Expression -> Bool isFormation (ExFormation _) = True isFormation _ = False @@ -295,15 +231,12 @@ partOf expr (BiTau _ expr' : rest) = expr == expr' || partOf expr rest partOf expr (_ : rest) = partOf expr rest --- Hold if none of the given attributes is present in the union of the --- bindings captured by the given binding metas. _disjoint :: [Attribute] -> [Binding] -> Subst -> RuleContext -> IO [Subst] _disjoint attrs bindings subst _ = 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 @@ -328,9 +261,6 @@ meetCondition' (Y.Disjoint attrs bds) = _disjoint attrs bds meetCondition' (Y.IsFormation expr) = _isFormation expr --- For each substitution check if it meetCondition to given condition --- If substitution does not meet the condition - it's thrown out --- and is not used in replacement meetCondition :: Y.Condition -> [Subst] -> RuleContext -> IO [Subst] meetCondition _ [] _ = pure [] meetCondition cond (subst : rest) ctx = do @@ -341,10 +271,6 @@ case first of [] -> pure next sbt : _ -> pure (sbt : next) - -- A condition that raises is treated as not met: that is the policy - -- #1079 questions, and it stays until the maintainers answer. The - -- silence on top of it is nobody's friend — say what raised, at debug - -- level, so a broken 'when'/'having' can be found with --log-level=debug Left err -> do logDebug (printf "Condition %s raised and was treated as not met: %s" (show cond) (displayException err)) meetCondition cond rest ctx @@ -353,7 +279,6 @@ meetMaybeCondition Nothing substs _ = pure substs meetMaybeCondition (Just cond) substs ctx = meetCondition cond substs ctx --- Extend list of given substitutions with extra substitutions from 'where' yaml rule section extraSubstitutions :: [Subst] -> Maybe [Y.Extra] -> RuleContext -> IO [Subst] extraSubstitutions substs extras RuleContext{..} = case extras of Nothing -> pure substs @@ -402,12 +327,6 @@ 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, --- '𝑘'/'!k' absolute) lives in its own 'n'-/'k'-prefixed key-space, so a --- pattern may freely mix them with plain '𝑒' captures. An anonymous meta --- carries the same prefix as the sigil it was written with, so a bare '𝑛' is --- held to the normal form just as '𝑛1' is. metasWithPrefix :: T.Text -> Expression -> [Expression] metasWithPrefix prefix = nub . go where @@ -431,28 +350,14 @@ 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 expr rule = matchExpressionBy (deep rule) [substEmpty] expr rule --- The deep matcher of the rule, asked only where its pattern fits somewhere in --- the term (see 'matchExpressionWithRule'). deep :: Y.Rule -> MatchExpressionFunc deep rule ptn tgt | reachable' (redex rule) ptn tgt = matchExpressionDeep' (redex rule) ptn tgt | otherwise = [] --- 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' @@ -478,19 +383,9 @@ 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 --- and morphing driver, where a rule applies to the entire configuration rather --- than to nested redexes. The leading '[Subst]' seeds matching with pre-bound --- meta-variables: the morphing driver passes the global universe bound to 'e', --- the second argument of 𝕄(n, e), so the 'universe' rule reads it directly instead --- of through a 'global()' build-term function. Pass '[substEmpty]' for no seed. matchExpressionWithRule' :: [Subst] -> Expression -> Y.Rule -> RuleContext -> IO [Subst] matchExpressionWithRule' = matchExpressionBy matchExpression' --- The seed substitutions are combined into every match, so a pre-bound meta in --- the seed is dropped only when the pattern binds the same name to a different --- value; rules that do not mention the name simply carry it along unused. matchExpressionBy :: MatchExpressionFunc -> [Subst] -> Expression -> Y.Rule -> RuleContext -> IO [Subst] matchExpressionBy matcher seed expr rule ctx = do when' <- admitted matcher seed expr rule ctx @@ -508,8 +403,6 @@ when (null met) (logDebug "The 'having' condition wasn't met") pure met --- The matches of the rule its pattern, its '𝑛' and '𝑘' metas and its 'when' --- let through, before its 'where' and its 'having' are asked anything. admitted :: MatchExpressionFunc -> [Subst] -> Expression -> Y.Rule -> RuleContext -> IO [Subst] admitted matcher seed expr rule ctx = let ptn = rule.pattern @@ -519,9 +412,6 @@ logDebug (printf "Pattern from rule '%s' was not matched:\n%s" rule.name (printExpression' ptn logPrintConfig)) pure [] else do - -- A '𝑘' meta-variable is absolute (𝒦 ⊆ 𝒩): check it is xi-free first - -- (cheap, structural), then fold its name into the same normal-form - -- check used for '𝑛' metas, so 'isNF' is applied in a single place. inXiFree <- foldlM (\substs mt -> meetCondition (Y.Absolute mt) substs ctx) matched (kMetas ptn) inNf <- foldlM (\substs mt -> meetCondition (Y.NF mt) substs ctx) inXiFree (nfMetas ptn ++ kMetas ptn) if null inNf diff --git a/src/Slots.hs b/src/Slots.hs --- a/src/Slots.hs +++ b/src/Slots.hs @@ -1,10 +1,6 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- The goal of the module is to collect the anonymous meta-variable slots a --- term was written with. A rule binds them where it matches and nowhere else, --- so every other part of a rule is asked for its slots and rejected when it --- has any. module Slots (Slots (..), anonymous) where import AST @@ -13,8 +9,6 @@ class Slots a where slots :: a -> [Slot] --- The kind sigil of the first anonymous meta a term was written with, if any, --- so a caller can word its own complaint about a term that must have none anonymous :: (Slots a) => a -> Maybe Text anonymous term = case slots term of [] -> Nothing diff --git a/src/Sugar.hs b/src/Sugar.hs --- a/src/Sugar.hs +++ b/src/Sugar.hs @@ -21,14 +21,6 @@ data SugarType = SWEET | SALTY deriving (Eq, Show) --- Drop every ρ binding (ρ ↦ ∅, ρ ↦ e and ρ(…) ↦ e) from a rendered CST, the --- effect of the '--hide-rho' switch. Both formation bindings and application arguments are stripped; --- dispatches such as ξ.ρ are left untouched. A formation left empty by the --- strip collapses to the compact '⟦⟧' layout, and an application left with no --- argument collapses to its bare callee (no leftover 'e()'). In the SWEET --- syntax a formation left with one binding takes the sugar of #1385, 'ξ.a:φ', --- the way it would have taken it had the ρ never been there; the SALTY one --- has no such sugar. withoutRho :: SugarType -> EXPRESSION -> EXPRESSION withoutRho sugar = goExpr where @@ -48,7 +40,6 @@ | isRho pair = goExpr formation | otherwise = EX_SINGLE (goPair pair) space (goExpr formation) goExpr expr = expr - -- Formation bindings: drop the ρ pairs, recurse into whatever remains. goBinding :: BINDING -> BINDING goBinding empty@BI_EMPTY{} = empty goBinding BI_META{..} = BI_META meta (goBindings bindings) tab @@ -61,16 +52,10 @@ goBindings BDS_PAIR{..} | isRho pair = goBindings bindings | otherwise = BDS_PAIR eol tab (goPair pair) (goBindings bindings) - -- Turn the tail chain back into a head binding once its leading pair was - -- dropped; the promoted pair is already stripped and recursed by 'goBindings'. promote :: TAB -> BINDINGS -> BINDING promote tab (BDS_EMPTY _) = BI_EMPTY tab promote tab (BDS_PAIR _ _ pair bindings) = BI_PAIR pair bindings tab promote tab (BDS_META _ _ meta bindings) = BI_META meta bindings tab - -- Application arguments: drop the ρ pairs too, the way 'goBinding' does for - -- formations. 'Nothing' means nothing survived the strip, so 'goExpr' - -- collapses the whole application to its bare callee instead of leaving an - -- empty 'e()'. Positional arguments ('AA_EXPRS') carry no ρ, so they stay. goArgument :: APP_ARGUMENT -> Maybe APP_ARGUMENT goArgument (AA_TAU (APP_BINDING pair)) | isRho pair = Nothing @@ -103,12 +88,10 @@ [] -> PA_TAU attr arrow (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 - -- Whether the only binding of a formation has the one-binding sugar sugared :: PAIR -> Bool sugared PA_TAU{attr = AT_DELTA{}} = False sugared PA_TAU{attr = AT_LAMBDA{}} = False @@ -122,20 +105,6 @@ isRho PA_FORMATION{attr = AT_RHO _} = True isRho _ = False --- By default CST is generated with all possible syntax sugar --- The main purpose of this class is to get rid of syntax sugar --- |----------------------------|-----------------------------------------------------| --- | sugar | verbose version | --- |----------------------------|-----------------------------------------------------| --- | a1 -> a2 | a1 ↦ $.a2 | --- | a -> 42 | Q.number(Q.bytes([[ D> 40-45-00-00-00-00-00-00 ]])) | --- | a -> Q.nan | Q.number(Q.bytes([[ D> 7F-F8-00-00-00-00-00-00 ]])) | --- | a -> "Hey" | Q.number(Q.bytes([[ D> 48-65-79 ]])) | --- | e:a | [[ a -> e ]], and so for D, L and ? (see #1385) | --- | a1(a2, a3, ...) -> [[ B ]] | a1 -> [[ a2 -> ?, a3 -> ?, ..., B ]] | --- | e(e0, e1, ...) | e(~0 -> e0, ~1 -> e1, ...) | --- | e(a1 -> e1, a2 -> e2, ...) | e(a1 -> e1)(a2 -> e2)... | --- |----------------------------|-----------------------------------------------------| class ToSalty a where toSalty :: a -> a diff --git a/src/Tau.hs b/src/Tau.hs --- a/src/Tau.hs +++ b/src/Tau.hs @@ -3,14 +3,6 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- Uniqueness of generated 𝜏-labels is the engine's job, not the caller's. --- Instead of asking every 'random-tau' call site to hand over the names it --- must steer clear of, we scan the document once at the start of a run and --- remember every attribute label it already uses. Each minted name is added --- back to that set so later firings (the fixpoint loop re-applies rules across --- cycles) never reuse one. A monotonic cursor advances past taken indices so --- minting never rescans the document. Names are sequential rather than --- random, which makes the rewritten output deterministic. module Tau (seedTaus, freshTau, tausOf) where import AST @@ -21,21 +13,13 @@ import qualified Data.Text as T import GHC.IO (unsafePerformIO) --- The set of attribute labels already taken in the document being rewritten, --- paired with a monotonic cursor pointing at the next candidate index. taus :: IORef (Set Text, Int) {-# NOINLINE taus #-} taus = unsafePerformIO (newIORef (Set.empty, 0)) --- Scan the expression once and seed the avoid-set with every attribute label it --- contains, resetting the cursor back to the start. seedTaus :: Expression -> IO () seedTaus expr = writeIORef taus (exprLabels expr, 0) --- Mint a fresh, deterministic 𝜏-label that collides with no taken name, --- advancing the cursor past taken indices and recording the new name so it is --- never handed out again. Atomic so concurrent callers cannot mint duplicates --- or lose updates. freshTau :: IO Text freshTau = atomicModifyIORef' taus advance where @@ -43,13 +27,6 @@ let (minted, idx) = mint taken cursor in ((Set.insert minted taken, idx + 1), minted) --- A source of fresh names of its own for one entry of a run under '--jobs', --- which morphs the bindings of a formation side by side (#1534). The names --- carry the entry, 'a🌵7-0' for the seventh binding, so no two entries mint --- one name and none of them mints a name the run itself does, and they are --- counted per entry, so what an entry is named does not depend on which --- worker got to a name first. The names the document took when the source --- was made are skipped, the way 'freshTau' skips them. tausOf :: Int -> IO (IO Text) tausOf entry = do (taken, _) <- readIORef taus @@ -61,11 +38,9 @@ let (minted, idx) = mint' (T.pack ("a🌵" <> show entry <> "-")) taken cursor in ((Set.insert minted taken, idx + 1), minted) --- Find the first index at or after the cursor whose name is still free. mint :: Set Text -> Int -> (Text, Int) mint = mint' "a🌵" --- The same, for names spelled with the given stem. mint' :: Text -> Set Text -> Int -> (Text, Int) mint' stem taken idx | name `Set.member` taken = mint' stem taken (idx + 1) diff --git a/src/XMIR.hs b/src/XMIR.hs --- a/src/XMIR.hs +++ b/src/XMIR.hs @@ -57,14 +57,8 @@ , _atoms :: Atoms } --- The result type an atom of the EO parser carries in its @atom attribute, --- like 'Φ.number', keyed by the name of its λ function. The type is no name --- phino can read, so it lives beside the λ binding and not in it (#1389) type Atoms = M.Map T.Text String --- The 7-character Git SHA of the phino build that produced the document, --- matching the XMIR schema pattern [0-9a-f]{7}. When built outside a git --- checkout gitrev yields "UNKNOWN", which the schema allows us to omit. gitRevision :: String gitRevision = take 7 $(gitHash) @@ -178,16 +172,12 @@ formationBinding (BiVoid (AtLabel label)) _ = pure (Just (object [("name", T.unpack label), ("base", "∅")] [])) formationBinding binding _ = throwIO (UnsupportedBinding binding) --- Render a bound attribute as a named element: a formation nests its bindings --- right inside it, while any other expression is carried by the @base attribute namedBinding :: String -> Expression -> XmirContext -> IO Node namedBinding name (ExFormation bds) ctx = object [("name", name)] <$> nestedBindings bds ctx namedBinding name expr ctx = do (base, children) <- expression expr ctx pure (object [("name", name), ("base", base)] children) --- Render a formation's bindings as child nodes, honoring '--hide-rho' by --- dropping every ρ, void or bound, before it reaches the nodes (#1076) nestedBindings :: [Binding] -> XmirContext -> IO [Node] nestedBindings bds ctx@XmirContext{..} = catMaybes <$> mapM (`formationBinding` ctx) bds' where @@ -206,10 +196,6 @@ ExDispatch _ _ -> programToXMIR expr ctx ExRoot -> programToXMIR expr ctx _ -> throwIO (UnsupportedTopExpression expr) --- The top of a '--partial' residual and the result of 'merge' are arbitrary --- formations: several τ/λ bindings, voids and a bound ρ. The schema allows a --- single under , so the formation goes beneath one attribute-free --- whose children are its bindings; 'xmirToPhi' reads that shape back (#1076) expressionToXMIR expr@(ExFormation bds) ctx = documentWith ctx [] expr rootNodes where @@ -223,23 +209,14 @@ isElement _ = False expressionToXMIR expr _ = throwIO (UnsupportedTopExpression expr) --- The bindings of a formation on the package spine, without the void ρ it may --- declare: the spine holds no object a dispatch could bind ρ in, so a ρ ↦ ∅ --- there has nowhere to go in XMIR and is not what tells a program apart withoutVoidRho :: [Binding] -> [Binding] withoutVoidRho = filter (/= BiVoid AtRho) --- A program document: the package spine is peeled off the top level into --- and the single binding left becomes the root element programToXMIR :: Expression -> XmirContext -> IO Document programToXMIR expr ctx = do (pckg, expr') <- getPackage expr documentWith ctx pckg expr (rootNodes expr' ctx) where - -- Extract package from given expression - -- The function returns tuple (X, Y), where - -- - X: list of package parts - -- - Y: root object expression getPackage :: Expression -> IO ([String], Expression) getPackage ex@(ExFormation bds) = case withoutVoidRho bds of [BiTau (AtLabel label) inner@(ExFormation inner')] | packaged inner' -> nested label inner @@ -252,8 +229,6 @@ nested label inner = do (pckg, expr') <- getPackage inner pure (T.unpack label : pckg, expr') - -- A formation of one binding and the λ marking a package, whatever void ρ - -- it may declare besides packaged :: [Binding] -> Bool packaged bds = case withoutVoidRho bds of [_, BiLambda (Function "Package")] -> True @@ -264,8 +239,6 @@ rootNodes (ExFormation [bd]) c = nestedBindings [bd] c rootNodes ex _ = throwIO (UnsupportedExpression ex) --- Assemble the document: timing attributes, the listing, --- when the expression carries a package, and the root nodes below them documentWith :: XmirContext -> [String] -> Expression -> IO [Node] -> IO Document documentWith XmirContext{..} pckg expr rootsIO = do started <- getCurrentTime @@ -305,14 +278,6 @@ [] ) where - -- Returns metas Node with package: - -- - -- - -- package - -- - -- - -- - -- metasWithPackage :: String -> Node metasWithPackage package = NodeElement @@ -350,9 +315,6 @@ escapeChar '\'' = "'" escapeChar ch = [ch] --- Escape just the characters that are mandatory in XML text content ('&' and --- '<'); '>' and the quotes are optional there and staying literal keeps the --- content readable, e.g. the '->' arrow inside a . escapeXMLText :: String -> String escapeXMLText = concatMap escapeChar where @@ -361,7 +323,6 @@ escapeChar '<' = "<" escapeChar ch = [ch] --- Add indentation (2 spaces per level). indent :: Int -> TB.Builder indent n = TB.fromText (T.replicate n (T.pack " ")) @@ -372,8 +333,6 @@ newline :: TB.Builder newline = TB.fromString "\n" --- >>> printElement 0 (element "doc" [("a", ""), ("b", ""), ("c", ""), ("d", ""), ("e", "")] []) True --- "\n" printElement :: Int -> Element -> Bool -> TB.Builder printElement indentLevel (Element name attrs nodes) eol | null nodes = @@ -420,11 +379,9 @@ printRawText (NodeContent t) = TB.fromText t printRawText _ = mempty --- >>> printNode 0 (NodeComment (T.pack "--hello--")) --- "\n" printNode :: Int -> Node -> TB.Builder -printNode _ (NodeContent t) = TB.fromText t -- print text exactly as-is -printNode i (NodeElement e) = printElement i e True -- pretty-print elements +printNode _ (NodeContent t) = TB.fromText t +printNode i (NodeElement e) = printElement i e True printNode i (NodeComment t) = indent i <> TB.fromString "