phino 0.0.94 → 0.0.95

raw patch · 36 files changed

+525/−498 lines, 36 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• phino.cabal +4/−1
• resources/normalize/dl.yaml +14/−0
• src/AST.hs +63/−0
• src/Builder.hs +9/−18
• src/Bytes.hs +200/−0
• src/CLI/Helpers.hs +5/−4
• src/CLI/Validators.hs +6/−5
• src/CST.hs +13/−8
• src/Condition.hs +2/−4
• src/Dataize.hs +2/−0
• src/Encoding.hs +6/−3
• src/Files.hs +46/−0
• src/Functions.hs +10/−9
• src/LaTeX.hs +13/−10
• src/Lining.hs +6/−3
• src/Margin.hs +9/−28
• src/Matcher.hs +6/−6
• src/Misc.hs +19/−342
• src/Parser.hs +7/−13
• src/Random.hs +21/−3
• src/Regexp.hs +3/−0
• src/Render.hs +6/−3
• src/Rewriter.hs +1/−2
• src/Rule.hs +1/−1
• src/Sugar.hs +24/−22
• src/XMIR.hs +2/−3
• src/Yaml.hs +15/−1
• test/CLISpec.hs +5/−0
• test/CSTSpec.hs +1/−1
• test/FilterSpec.hs +1/−1
• test/ParserSpec.hs +1/−1
• test/PrinterSpec.hs +0/−2
• test/RewriterSpec.hs +1/−1
• test/RuleSpec.hs +1/−1
• test/XMIRSpec.hs +1/−1
• test/YamlSpec.hs +1/−1

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: phino-version: 0.0.94+version: 0.0.95 license: MIT synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions description: Please see the README on GitHub at <https://github.com/objectionary/phino#readme>@@ -27,6 +27,7 @@     -Wincomplete-record-updates     -Wincomplete-uni-patterns     -Wmissing-home-modules+    -Wmissing-signatures     -Wpartial-fields     -Wredundant-constraints @@ -35,6 +36,7 @@   exposed-modules:     AST     Builder+    Bytes     Canonizer     CLI     CLI.Helpers@@ -47,6 +49,7 @@     Dataize     Deps     Encoding+    Files     Filter     Functions     LaTeX

@@ -0,0 +1,14 @@+# SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+# SPDX-License-Identifier: MIT+---+name: dl+pattern: ⟦𝐵⟧+result: ⊥+when:+  and:+    - in:+        - Δ+        - 𝐵+    - in:+        - λ+        - 𝐵

@@ -1,5 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}  -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT@@ -157,3 +160,63 @@ countNodes (ExPhiMeet _ _ expr) = countNodes expr countNodes (ExPhiAgain _ _ expr) = countNodes expr countNodes _ = 1++matchBaseObject :: Expression -> Maybe T.Text+matchBaseObject (ExDispatch ExRoot (AtLabel label)) = Just label+matchBaseObject _ = Nothing++pattern BaseObject :: T.Text -> Expression+pattern BaseObject label <- (matchBaseObject -> Just label)+  where+    BaseObject label = ExDispatch ExRoot (AtLabel label)++-- Minimal matcher function (required for view pattern)+matchDataObject :: Expression -> Maybe (T.Text, Bytes)+matchDataObject (ExApplication outer (ArAlpha (Alpha 0) inner)) = case (matchOuter outer, matchInner inner) of+  (Just label, Just bts) -> Just (label, bts)+  _ -> Nothing+  where+    matchOuter :: Expression -> Maybe T.Text+    matchOuter (BaseObject label) = Just label+    matchOuter (ExPhiAgain _ _ (BaseObject label)) = Just label+    matchOuter _ = Nothing+    matchInner :: Expression -> Maybe Bytes+    matchInner (ExPhiAgain _ _ inner') = matchInner inner'+    matchInner inner' = matchInner' inner'+    matchInner' :: Expression -> Maybe Bytes+    matchInner' (ExApplication bytes (ArAlpha (Alpha 0) formation)) = case (matchesBytes bytes, matchFormation formation) of+      (True, Just bts) -> Just bts+      _ -> Nothing+    matchInner' _ = Nothing+    matchesBytes :: Expression -> Bool+    matchesBytes (BaseObject "bytes") = True+    matchesBytes (ExPhiAgain _ _ (BaseObject "bytes")) = True+    matchesBytes _ = False+    matchFormation :: Expression -> Maybe Bytes+    matchFormation (ExFormation [BiDelta bts, BiVoid AtRho]) = Just bts+    matchFormation (ExPhiAgain _ _ (ExFormation [BiDelta bts, BiVoid AtRho])) = Just bts+    matchFormation _ = Nothing+matchDataObject _ = Nothing++pattern DataString :: Bytes -> Expression+pattern DataString bts = DataObject "string" bts++pattern DataNumber :: Bytes -> Expression+pattern DataNumber bts = DataObject "number" bts++pattern DataObject :: T.Text -> Bytes -> Expression+pattern DataObject label bts <- (matchDataObject -> Just (label, bts))+  where+    DataObject label bts =+      ExApplication+        (BaseObject label)+        ( ArAlpha+            (Alpha 0)+            ( ExApplication+                (BaseObject "bytes")+                ( ArAlpha+                    (Alpha 0)+                    (ExFormation [BiDelta bts, BiVoid AtRho])+                )+            )+        )

@@ -23,12 +23,12 @@ where  import AST-import Control.Exception (Exception, throwIO)+import Control.Exception (Exception) import qualified Data.Map.Strict as Map import Data.Text (Text) import qualified Data.Text as T import Matcher-import Misc (uniqueBindings)+import Misc (orThrow, uniqueBindings) import Printer import Text.Printf (printf) @@ -136,32 +136,23 @@   Right (ExFormation bds') buildExpression (ExMeta meta) (Subst mp) = case Map.lookup meta mp of   Just (MvExpression expr) ->-    let res = Right expr-     in case expr of-          ExFormation bds -> uniqueBindings bds >> res-          _ -> res+    case expr of+      ExFormation bds -> uniqueBindings bds >> Right expr+      _ -> Right expr   _ -> Left (metaMsg meta) buildExpression expr _ = Right expr  buildBytesThrows :: Bytes -> Subst -> IO Bytes-buildBytesThrows bytes subst = case buildBytes bytes subst of-  Right bts -> pure bts-  Left msg -> throwIO (CouldNotBuildBytes bytes msg)+buildBytesThrows bytes subst = orThrow (CouldNotBuildBytes bytes) (buildBytes bytes subst)  buildBindingThrows :: Binding -> Subst -> IO [Binding]-buildBindingThrows bd subst = case buildBinding bd subst of-  Right bds -> pure bds-  Left msg -> throwIO (CouldNotBuildBinding bd msg)+buildBindingThrows bd subst = orThrow (CouldNotBuildBinding bd) (buildBinding bd subst)  buildAttributeThrows :: Attribute -> Subst -> IO Attribute-buildAttributeThrows attr subst = case buildAttribute attr subst of-  Right attr' -> pure attr'-  Left msg -> throwIO (CouldNotBuildAttribute attr msg)+buildAttributeThrows attr subst = orThrow (CouldNotBuildAttribute attr) (buildAttribute attr subst)  buildExpressionThrows :: Expression -> Subst -> IO Expression-buildExpressionThrows expr subst = case buildExpression expr subst of-  Right built -> pure built-  Left msg -> throwIO (CouldNotBuildExpression expr msg)+buildExpressionThrows expr subst = orThrow (CouldNotBuildExpression expr) (buildExpression expr subst)  -- Build a several expression from one expression and several substitutions buildExpressionsThrows :: Expression -> [Subst] -> IO [Expression]

@@ -0,0 +1,200 @@+{-# LANGUAGE OverloadedStrings #-}++-- 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.+module Bytes+  ( numToBts+  , strToBts+  , bytesToBts+  , btsToStr+  , btsToNum+  , btsToUnescapedStr+  )+where++import AST+import Data.Binary.IEEE754+import Data.Bits (Bits (shiftL, shiftR), (.&.), (.|.))+import qualified Data.ByteString as B+import Data.ByteString.Builder (toLazyByteString, word64BE)+import Data.ByteString.Lazy (unpack)+import qualified Data.ByteString.Lazy.UTF8 as U+import Data.Char (chr, isDigit, isPrint, ord)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Word (Word64, Word8)+import Numeric (readHex)+import Text.Printf (printf)++-- >>> 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]+btsToWord8 (BtMany bts) = map hexByte bts+btsToWord8 (BtMeta mt) = error $ "Cannot convert meta bytes to Word8; " ++ T.unpack mt++hexByte :: String -> Word8+hexByte [hi, lo] = (nibble hi `shiftL` 4) .|. nibble lo+  where+    nibble :: Char -> Word8+    nibble c+      | isDigit c = fromIntegral (ord c - ord '0')+      | c >= 'A' && c <= 'F' = fromIntegral (ord c - ord 'A' + 10)+      | c >= 'a' && c <= 'f' = fromIntegral (ord c - ord 'a' + 10)+      | otherwise = error ("Invalid hex digit: " ++ [c])+hexByte bt = case readHex bt of+  [(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)+word8ToBytes bts = BtMany (map toHex bts)++toHex :: Word8 -> String+toHex w = [digit (w `shiftR` 4), digit (w .&. 0x0F)]+  where+    digit :: Word8 -> Char+    digit n+      | 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+   in if length bytes /= 8+        then error $ "Expected 8 bytes for conversion, got " ++ show (length bytes)+        else+          let word = toWord64BE bytes+              val = wordToDouble word+           in if isNaN val || isInfinite val || isNegativeZero val+                then Right val+                else case properFraction val of+                  (n, 0.0) -> Left n+                  _ -> Right val+  where+    toWord64BE :: [Word8] -> Word64+    toWord64BE [a, b, c, d, e, f, g, h] =+      fromIntegral a `shiftL` 56+        .|. fromIntegral b `shiftL` 48+        .|. fromIntegral c `shiftL` 40+        .|. fromIntegral d `shiftL` 32+        .|. fromIntegral e `shiftL` 24+        .|. fromIntegral f `shiftL` 16+        .|. fromIntegral g `shiftL` 8+        .|. 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))))++-- >>> 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 =+  if length str == 3 && last str == '-'+    then BtOne (init str)+    else 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)+  where+    escapeStr :: String -> String+    escapeStr = concatMap escapeChar+      where+        escapeChar :: Char -> String+        escapeChar '"' = "\\\""+        escapeChar '\\' = "\\\\"+        escapeChar '\n' = "\\n"+        escapeChar '\t' = "\\t"+        escapeChar c+          | isPrint c && c /= '\\' && c /= '"' = [c]+          | otherwise = printf "\\x%02x" (ord c)++-- >>> 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)))

@@ -16,13 +16,14 @@ import Data.Maybe import Deps (SaveStepFunc, saveStep) import Encoding+import Files (ensuredFile) import Functions (execFunctions) import LaTeX (LatexContext (..), defaultMeetLength, defaultMeetPopularity, expressionToLaTeX, programToLaTeX, rewrittensToLatex) import Locator (locatedExpression) import Logger-import qualified Misc as M import Parser (parseProgramThrows) import qualified Printer as P+import qualified Random as R import Rewriter (Rewrittens') import System.IO (getContents') import Text.Printf (printf)@@ -50,7 +51,7 @@ readInput inputFile' = case inputFile' of   Just pth -> do     logDebug (printf "Reading from file: '%s'" pth)-    readFile =<< M.ensuredFile pth+    readFile =<< ensuredFile pth   Nothing -> do     logDebug "Reading from stdin"     getContents' `catch` (\(e :: SomeException) -> throwIO (CouldNotReadFromStdin (show e)))@@ -101,12 +102,12 @@             pure []           else do             logDebug (printf "Using rules from files: [%s]" (intercalate ", " rules))-            yamls <- mapM M.ensuredFile rules+            yamls <- mapM ensuredFile rules             mapM (Y.yamlRule >=> validateRewriteRule) yamls   if shuffle     then do       logDebug "The --shuffle option is provided, rules are used in random order"-      M.shuffle ordered+      R.shuffle ordered     else pure ordered  -- Pass a user-supplied rewriting rule through unchanged, or fail fast if it

@@ -22,12 +22,12 @@ validatedDispatches opt = traverse (parseExpressionThrows >=> asDispatch)   where     asDispatch :: Expression -> IO Expression-    asDispatch expr = asDispatch' expr+    asDispatch expr = go expr       where-        asDispatch' :: Expression -> IO Expression-        asDispatch' ex@ExRoot = pure ex-        asDispatch' disp@(ExDispatch ex _) = asDispatch' ex >> pure disp-        asDispatch' _ =+        go :: Expression -> IO Expression+        go ex@ExRoot = pure ex+        go disp@(ExDispatch ex _) = go ex >> pure disp+        go _ =           invalidCLIArguments             ( printf                 "Only dispatch expression started with Φ (or Q) can be used in --%s, but given: %s"@@ -41,6 +41,7 @@ validateLatexOptions _ bools strings ints = do   let (bools', opts) = unzip bools       msg = "The --%s option can stay together with --output=latex only"+      callback :: (Maybe a, String) -> IO ()       callback (maybe', opt) = when (isJust maybe') (invalidCLIArguments (printf msg opt))   validateBoolOpts (zip bools' (map (printf msg) opts))   forM_ strings callback

@@ -11,8 +11,8 @@ module CST where  import AST+import Bytes (btsToNum, btsToStr) import qualified Data.Text as T-import Misc import qualified Yaml as Y  data LCB = LCB | BIG_LCB@@ -162,6 +162,13 @@   | 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, ...)+  deriving (Eq, Show)+ data EXPRESSION   = EX_GLOBAL {global :: GLOBAL}   | EX_XI {xi :: XI}@@ -169,9 +176,7 @@   | 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, tau :: APP_BINDING, eol' :: EOL, tab' :: TAB, indent :: Int} -- e(a1 -> e1)-  | EX_APPLICATION_TAUS {expr :: EXPRESSION, space :: SPACE, eol :: EOL, tab :: TAB, taus :: BINDING, eol' :: EOL, tab' :: TAB, indent :: Int} -- e(a1 -> e1)(a2 -> e2)(...)-  | EX_APPLICATION_EXPRS {expr :: EXPRESSION, space :: SPACE, eol :: EOL, tab :: TAB, args :: APP_ARG, eol' :: EOL, tab' :: TAB, indent :: Int} -- e(e1, e2, ...)+  | EX_APPLICATION {expr :: EXPRESSION, space :: SPACE, eol :: EOL, tab :: TAB, argument :: APP_ARGUMENT, eol' :: EOL, tab' :: TAB, indent :: Int} -- e(...)   | EX_STRING {str :: String, tab :: TAB, rhos :: [Argument]}   | EX_NUMBER {num :: Either Int Double, tab :: TAB, rhos :: [Argument]}   | EX_META {meta :: META}@@ -365,22 +370,22 @@           else             if null exs               then-                EX_APPLICATION_TAUS+                EX_APPLICATION                   ex'                   NO_SPACE                   eol                   (TAB next)-                  (toCST ts (next, eol) :: BINDING)+                  (AA_TAUS (toCST ts (next, eol) :: BINDING))                   eol                   (TAB tabs)                   next               else-                EX_APPLICATION_EXPRS+                EX_APPLICATION                   ex'                   NO_SPACE                   eol                   (TAB next)-                  (toCST exs (next, eol))+                  (AA_EXPRS (toCST exs (next, eol)))                   eol                   (TAB tabs)                   next

@@ -7,8 +7,8 @@ module Condition (parseCondition, parseConditionThrows) where  import Control.Exception (Exception)-import Control.Exception.Base (throwIO) import Data.Void (Void)+import Misc (orThrow) import Parser (PhiParser (..), phiParser) import Text.Megaparsec import Text.Megaparsec.Char@@ -166,6 +166,4 @@     Left err -> Left (errorBundlePretty err)  parseConditionThrows :: String -> IO Y.Condition-parseConditionThrows cnd = case parseCondition cnd of-  Right cond -> pure cond-  Left err -> throwIO (CouldNotParseCondition err)+parseConditionThrows cnd = orThrow CouldNotParseCondition (parseCondition cnd)

@@ -13,6 +13,7 @@  import AST import Builder (buildBytesThrows, buildExpressionThrows)+import Bytes (btsToNum, numToBts) import Control.Exception (throwIO) import Control.Monad (foldM) import Data.List (find, partition)@@ -24,6 +25,7 @@ import Matcher (MetaValue (..), Subst (..), combine, matchExpression', substEmpty, substSingle) import Misc import Must (Must (..))+import Random (shuffle) import Rewriter (RewriteContext (RewriteContext), Rewritten, rewrite) import Rule (RuleContext (RuleContext), matchExpressionWithRule') import Text.Printf (printf)

@@ -28,9 +28,7 @@   toASCII EX_TERMINATION{} = EX_TERMINATION T   toASCII EX_FORMATION{..} = EX_FORMATION LSB' eol tab (toASCII binding) eol' tab' RSB'   toASCII EX_DISPATCH{..} = EX_DISPATCH (toASCII expr) space (toASCII attr)-  toASCII EX_APPLICATION{..} = EX_APPLICATION (toASCII expr) space eol tab (toASCII tau) eol' tab' indent-  toASCII EX_APPLICATION_TAUS{..} = EX_APPLICATION_TAUS (toASCII expr) space eol tab (toASCII taus) eol' tab' indent-  toASCII EX_APPLICATION_EXPRS{..} = EX_APPLICATION_EXPRS (toASCII expr) space eol tab (toASCII args) eol' tab' indent+  toASCII EX_APPLICATION{..} = EX_APPLICATION (toASCII expr) space eol tab (toASCII argument) eol' tab' indent   toASCII EX_META{meta = META{hd = N, ..}} = EX_META (META EXCL N' rest)   toASCII EX_META{meta = META{hd = K, ..}} = EX_META (META EXCL K' rest)   toASCII EX_META{..} = EX_META (META EXCL E' (rest meta))@@ -50,6 +48,11 @@   toASCII BDS_PAIR{..} = BDS_PAIR eol tab (toASCII pair) (toASCII bindings)   toASCII BDS_META{..} = BDS_META eol tab (META EXCL B' (rest meta)) (toASCII bindings)   toASCII bds = bds++instance ToASCII APP_ARGUMENT where+  toASCII (AA_TAU tau) = AA_TAU (toASCII tau)+  toASCII (AA_TAUS taus) = AA_TAUS (toASCII taus)+  toASCII (AA_EXPRS args) = AA_EXPRS (toASCII args)  instance ToASCII APP_ARG where   toASCII APP_ARG{..} = APP_ARG (toASCII expr) (toASCII args)

@@ -0,0 +1,46 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE RecordWildCards #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++-- This module accesses the filesystem: it ensures a file exists and+-- collects every file path under a directory.+module Files (FsException (..), ensuredFile, allPathsIn) where++import Control.Exception (Exception, throwIO)+import Control.Monad (forM)+import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)+import System.FilePath ((</>))+import Text.Printf (printf)++data FsException+  = FileDoesNotExist {_file :: FilePath}+  | DirectoryDoesNotExist {_dir :: FilePath}+  deriving (Exception)++instance Show FsException where+  show FileDoesNotExist{..} = printf "File '%s' does not exist" _file+  show DirectoryDoesNotExist{..} = printf "Directory '%s' does not exist" _dir++ensuredFile :: FilePath -> IO FilePath+ensuredFile pth = do+  exists <- doesFileExist pth+  if exists then pure pth else throwIO (FileDoesNotExist pth)++-- Recursively collect all file paths in provided directory+allPathsIn :: FilePath -> IO [FilePath]+allPathsIn dir = do+  exists <- doesDirectoryExist dir+  names <- if exists then listDirectory dir else throwIO (DirectoryDoesNotExist dir)+  let nested = map (dir </>) names+  paths <-+    forM+      nested+      ( \path -> do+          isDir <- doesDirectoryExist path+          if isDir+            then allPathsIn path+            else return [path]+      )+  return (concat paths)

@@ -7,6 +7,7 @@  import AST import Builder+import Bytes (btsToNum, btsToUnescapedStr, numToBts, strToBts) import Control.Exception (throwIO) import Control.Monad (when) import qualified Data.ByteString.Char8 as B@@ -199,7 +200,7 @@ _join [] _ = pure (TeBindings []) _join args subst = do   bds <- buildBindings args-  TeBindings <$> join' bds Set.empty+  TeBindings <$> go bds Set.empty   where     buildBindings :: [Y.ExtraArgument] -> IO [Binding]     buildBindings [] = pure []@@ -207,23 +208,23 @@       bds <- buildBindingThrows bd subst       next <- buildBindings args'       pure (bds ++ next)-    buildBindings _ = throwIO (userError "Function 'join' can work with bindings only")-    join' :: [Binding] -> Set.Set Attribute -> IO [Binding]-    join' [] _ = pure []-    join' (bd : bds) attrs =+    buildBindings _ = throwIO (userError "Function 'go can work with bindings only")+    go :: [Binding] -> Set.Set Attribute -> IO [Binding]+    go [] _ = pure []+    go (bd : bds) attrs =       case attributeFromBinding bd of         Just attr           | Set.member attr attrs ->               if attr == AtRho || attr == AtDelta || attr == AtLambda-                then join' bds attrs+                then go bds attrs                 else do                   new <- case bd of                     BiTau _ ex -> (`BiTau` ex) <$> freshAttr                     BiVoid _ -> BiVoid <$> freshAttr                     other -> pure other-                  (new :) <$> join' bds attrs-          | otherwise -> (bd :) <$> join' bds (Set.insert attr attrs)-        Nothing -> (bd :) <$> join' bds attrs+                  (new :) <$> go bds attrs+          | otherwise -> (bd :) <$> go bds (Set.insert attr attrs)+        Nothing -> (bd :) <$> go bds attrs     freshAttr :: IO Attribute     freshAttr = do       term <- _randomTau [] subst

@@ -97,12 +97,12 @@ it with \phinoAgain{} in following programs and with \phinoMeet{} in first program. -} meetInPrograms :: [Program] -> LatexContext -> [Program]-meetInPrograms prog LatexContext{..} = meetInPrograms' prog 1+meetInPrograms prog LatexContext{..} = go prog 1   where-    meetInPrograms' :: [Program] -> Int -> [Program]-    meetInPrograms' [] _ = []-    meetInPrograms' [program] _ = [program]-    meetInPrograms' (first : rest) idx =+    go :: [Program] -> Int -> [Program]+    go [] _ = []+    go [program] _ = [program]+    go (first : rest) idx =       let met = map (meetInProgram first _meetLength) rest           unique = nub (concat met)           (frequent, _) =@@ -115,7 +115,7 @@               )               (Nothing, 0)               unique-          next = first : meetInPrograms' rest idx+          next = first : go rest idx        in case frequent of             Just expr ->               case matchProgram expr first of@@ -126,7 +126,7 @@                       rest' = zipWith (\prgm exprs -> replaceProgram (prgm, exprs, map (const (ExPhiAgain _meetPrefix idx)) exprs)) rest met'                       found = filter (not . null) met'                    in if length met' > 1 && toDouble (length found) / toDouble (length met') >= popularity-                        then program' : meetInPrograms' rest' (idx + 1)+                        then program' : go rest' (idx + 1)                         else next                 [] -> next             _ -> next@@ -229,9 +229,7 @@ instance ToLaTeX EXPRESSION where   toLaTeX EX_ATTR{..} = EX_ATTR (toLaTeX attr)   toLaTeX EX_FORMATION{..} = EX_FORMATION lsb eol tab (toLaTeX binding) eol' tab' rsb-  toLaTeX EX_APPLICATION{..} = EX_APPLICATION (toLaTeX expr) SPACE eol tab (toLaTeX tau) eol' tab' indent-  toLaTeX EX_APPLICATION_TAUS{..} = EX_APPLICATION_TAUS (toLaTeX expr) SPACE eol tab (toLaTeX taus) eol' tab' indent-  toLaTeX EX_APPLICATION_EXPRS{..} = EX_APPLICATION_EXPRS (toLaTeX expr) SPACE eol tab (toLaTeX args) eol' tab' indent+  toLaTeX EX_APPLICATION{..} = EX_APPLICATION (toLaTeX expr) SPACE eol tab (toLaTeX argument) eol' tab' indent   toLaTeX EX_DISPATCH{..} = EX_DISPATCH (toLaTeX expr) SPACE (toLaTeX attr)   toLaTeX EX_PHI_MEET{..} = EX_PHI_MEET prefix idx (toLaTeX expr)   toLaTeX EX_PHI_AGAIN{..} = EX_PHI_AGAIN prefix idx (toLaTeX expr)@@ -299,6 +297,11 @@ instance ToLaTeX BYTES where   toLaTeX (BT_META meta) = BT_META (toLaTeX meta)   toLaTeX bts = BT_PIPED bts++instance ToLaTeX APP_ARGUMENT where+  toLaTeX (AA_TAU tau) = AA_TAU (toLaTeX tau)+  toLaTeX (AA_TAUS taus) = AA_TAUS (toLaTeX taus)+  toLaTeX (AA_EXPRS args) = AA_EXPRS (toLaTeX args)  instance ToLaTeX APP_ARG where   toLaTeX APP_ARG{..} = APP_ARG (toLaTeX expr) (toLaTeX args)

@@ -26,9 +26,7 @@   toSingleLine EX_FORMATION{lsb, binding = bd@BI_EMPTY{}, rsb} = EX_FORMATION lsb NO_EOL NO_TAB bd NO_EOL NO_TAB rsb   toSingleLine EX_FORMATION{..} = EX_FORMATION lsb NO_EOL TAB' (toSingleLine binding) NO_EOL TAB' rsb   toSingleLine EX_DISPATCH{..} = EX_DISPATCH (toSingleLine expr) space attr-  toSingleLine EX_APPLICATION{..} = EX_APPLICATION (toSingleLine expr) space NO_EOL TAB' (toSingleLine tau) NO_EOL TAB' indent-  toSingleLine EX_APPLICATION_TAUS{..} = EX_APPLICATION_TAUS (toSingleLine expr) space NO_EOL TAB' (toSingleLine taus) NO_EOL TAB' indent-  toSingleLine EX_APPLICATION_EXPRS{..} = EX_APPLICATION_EXPRS (toSingleLine expr) space NO_EOL TAB' (toSingleLine args) NO_EOL TAB' indent+  toSingleLine EX_APPLICATION{..} = EX_APPLICATION (toSingleLine expr) space NO_EOL TAB' (toSingleLine argument) NO_EOL TAB' indent   toSingleLine EX_PHI_MEET{..} = EX_PHI_MEET prefix idx (toSingleLine expr)   toSingleLine EX_PHI_AGAIN{..} = EX_PHI_AGAIN prefix idx (toSingleLine expr)   toSingleLine expr = expr@@ -51,6 +49,11 @@   toSingleLine PA_ALPHA{..} = PA_ALPHA alpha arrow (toSingleLine expr)   toSingleLine PA_FORMATION{..} = PA_FORMATION attr voids arrow (toSingleLine expr)   toSingleLine pair = pair++instance ToSingleLine APP_ARGUMENT where+  toSingleLine (AA_TAU tau) = AA_TAU (toSingleLine tau)+  toSingleLine (AA_TAUS taus) = AA_TAUS (toSingleLine taus)+  toSingleLine (AA_EXPRS args) = AA_EXPRS (toSingleLine args)  instance ToSingleLine APP_ARG where   toSingleLine APP_ARG{..} = APP_ARG (toSingleLine expr) (toSingleLine args)

@@ -43,38 +43,19 @@         main = withMargin' cfg expr         singleMain = toSingleLine main         extra' = T.length (last (T.lines (render main))) + 4 -- 2 spaces + 2 braces around argument-        arg = withMargin' (indt, margin) tau-        singleArg = toSingleLine arg+        arg' = withMargin' (indt, margin) argument+        singleArg = toSingleLine arg'      in if           | lengthOf single + extra <= margin -> single-          | lengthOf singleMain + extra <= margin -> EX_APPLICATION singleMain space EOL tab arg EOL tab' indent+          | lengthOf singleMain + extra <= margin -> EX_APPLICATION singleMain space EOL tab arg' EOL tab' indent           | lengthOf singleArg + extra' <= margin -> EX_APPLICATION main space NO_EOL TAB' singleArg NO_EOL TAB' indent-          | otherwise -> EX_APPLICATION main space EOL tab arg EOL tab' indent-  withMargin' cfg@(extra, margin) ex@EX_APPLICATION_EXPRS{tab = tab@(TAB indt), ..} =-    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 arguments-        exprs = withMargin' (indt, margin) args-        singleExprs = toSingleLine exprs-     in if-          | lengthOf single + extra <= margin -> single-          | lengthOf singleMain + extra <= margin -> EX_APPLICATION_EXPRS singleMain space EOL tab exprs EOL tab' indent-          | lengthOf singleExprs + extra' <= margin -> EX_APPLICATION_EXPRS main space NO_EOL TAB' singleExprs NO_EOL TAB' indent-          | otherwise -> EX_APPLICATION_EXPRS main space EOL tab exprs EOL tab' indent-  withMargin' cfg@(extra, margin) ex@EX_APPLICATION_TAUS{tab = tab@(TAB indt), ..} =-    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 arguments-        taus' = withMargin' (indt, margin) taus-        singleTaus = toSingleLine taus'-     in if-          | lengthOf single + extra <= margin -> single-          | lengthOf singleMain + extra <= margin -> EX_APPLICATION_TAUS singleMain space EOL tab taus' EOL tab' indent-          | lengthOf singleTaus + extra' <= margin -> EX_APPLICATION_TAUS main space NO_EOL TAB' singleTaus NO_EOL TAB' indent-          | otherwise -> EX_APPLICATION_TAUS main space EOL tab taus' EOL tab' indent+          | otherwise -> EX_APPLICATION main space EOL tab arg' EOL tab' indent   withMargin' _ ex = ex++instance WithMargin APP_ARGUMENT where+  withMargin' cfg (AA_TAU tau) = AA_TAU (withMargin' cfg tau)+  withMargin' cfg (AA_TAUS taus) = AA_TAUS (withMargin' cfg taus)+  withMargin' cfg (AA_EXPRS args) = AA_EXPRS (withMargin' cfg args)  instance WithMargin APP_BINDING where   withMargin' cfg APP_BINDING{..} = APP_BINDING (withMargin' cfg pair)

@@ -42,15 +42,15 @@ -- 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) = combine' (Map.toList b) a+combine (Subst a) (Subst b) = go (Map.toList b) a   where-    combine' :: [(Text, MetaValue)] -> Map Text MetaValue -> Maybe Subst-    combine' [] acc = Just (Subst acc)-    combine' ((key, value) : rest) acc = case Map.lookup key acc of+    go :: [(Text, MetaValue)] -> Map Text MetaValue -> Maybe Subst+    go [] acc = Just (Subst acc)+    go ((key, value) : rest) acc = case Map.lookup key acc of       Just found-        | found == value -> combine' rest acc+        | found == value -> go rest acc         | otherwise -> Nothing-      Nothing -> combine' rest (Map.insert key value acc)+      Nothing -> go rest (Map.insert key value acc)  combineMany :: [Subst] -> [Subst] -> [Subst] combineMany xs xy = catMaybes [combine x y | x <- xs, y <- xy]

@@ -1,141 +1,33 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ViewPatterns #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT  -- This module provides commonly used helper functions for other modules module Misc-  ( numToBts-  , strToBts-  , bytesToBts-  , btsToStr-  , btsToNum-  , withVoidRho+  ( withVoidRho   , recoverFormations-  , allPathsIn-  , ensuredFile-  , shuffle   , toDouble-  , btsToUnescapedStr   , fqnToAttrs   , attributesFromBindings   , attributesFromBindings'   , attributeFromBinding   , uniqueBindings   , uniqueBindings'-  , validateYamlObject-  , matchDataObject-  , pattern DataObject-  , pattern DataString-  , pattern DataNumber-  , pattern BaseObject+  , orThrow   ) where  import AST import Control.Exception-import Control.Monad-import Data.Aeson (Object)-import qualified Data.Aeson.Key as Key-import qualified Data.Aeson.KeyMap as KeyMap-import Data.Binary.IEEE754-import Data.Bits (Bits (shiftL, shiftR), (.&.), (.|.))-import qualified Data.ByteString as B-import Data.ByteString.Builder (toLazyByteString, word64BE)-import Data.ByteString.Lazy (unpack)-import qualified Data.ByteString.Lazy.UTF8 as U-import Data.Char (chr, isDigit, isPrint, ord)+import Data.Functor ((<&>)) import Data.List (intercalate) import Data.Maybe (catMaybes) import qualified Data.Set as Set-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Vector as V-import qualified Data.Vector.Mutable as M-import Data.Word (Word64, Word8)-import Numeric (readHex)---- import Printer (printExpression)--import Data.Functor ((<&>))-import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)-import System.FilePath ((</>))-import System.Random.Stateful import Text.Printf (printf) -data FsException-  = FileDoesNotExist {_file :: FilePath}-  | DirectoryDoesNotExist {_dir :: FilePath}-  deriving (Exception)--instance Show FsException where-  show FileDoesNotExist{..} = printf "File '%s' does not exist" _file-  show DirectoryDoesNotExist{..} = printf "Directory '%s' does not exist" _dir--matchBaseObject :: Expression -> Maybe T.Text-matchBaseObject (ExDispatch ExRoot (AtLabel label)) = Just label-matchBaseObject _ = Nothing--pattern BaseObject :: T.Text -> Expression-pattern BaseObject label <- (matchBaseObject -> Just label)-  where-    BaseObject label = ExDispatch ExRoot (AtLabel label)---- Minimal matcher function (required for view pattern)-matchDataObject :: Expression -> Maybe (T.Text, Bytes)-matchDataObject (ExApplication outer (ArAlpha (Alpha 0) inner)) = case (matchOuter outer, matchInner inner) of-  (Just label, Just bts) -> Just (label, bts)-  _ -> Nothing-  where-    matchOuter :: Expression -> Maybe T.Text-    matchOuter (BaseObject label) = Just label-    matchOuter (ExPhiAgain _ _ (BaseObject label)) = Just label-    matchOuter _ = Nothing-    matchInner :: Expression -> Maybe Bytes-    matchInner (ExPhiAgain _ _ inner') = matchInner inner'-    matchInner inner' = matchInner' inner'-    matchInner' :: Expression -> Maybe Bytes-    matchInner' (ExApplication bytes (ArAlpha (Alpha 0) formation)) = case (matchesBytes bytes, matchFormation formation) of-      (True, Just bts) -> Just bts-      _ -> Nothing-    matchInner' _ = Nothing-    matchesBytes :: Expression -> Bool-    matchesBytes (BaseObject "bytes") = True-    matchesBytes (ExPhiAgain _ _ (BaseObject "bytes")) = True-    matchesBytes _ = False-    matchFormation :: Expression -> Maybe Bytes-    matchFormation (ExFormation [BiDelta bts, BiVoid AtRho]) = Just bts-    matchFormation (ExPhiAgain _ _ (ExFormation [BiDelta bts, BiVoid AtRho])) = Just bts-    matchFormation _ = Nothing-matchDataObject _ = Nothing--pattern DataString :: Bytes -> Expression-pattern DataString bts = DataObject "string" bts--pattern DataNumber :: Bytes -> Expression-pattern DataNumber bts = DataObject "number" bts--pattern DataObject :: T.Text -> Bytes -> Expression-pattern DataObject label bts <- (matchDataObject -> Just (label, bts))-  where-    DataObject label bts =-      ExApplication-        (BaseObject label)-        ( ArAlpha-            (Alpha 0)-            ( ExApplication-                (BaseObject "bytes")-                ( ArAlpha-                    (Alpha 0)-                    (ExFormation [BiDelta bts, BiVoid AtRho])-                )-            )-        )+-- 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 attribute from binding attributeFromBinding :: Binding -> Maybe Attribute@@ -180,18 +72,18 @@  -- Add void rho binding to the end of the list of any rho binding is not present withVoidRho :: [Binding] -> [Binding]-withVoidRho bds = withVoidRho' bds False+withVoidRho bds = go bds False   where-    withVoidRho' :: [Binding] -> Bool -> [Binding]-    withVoidRho' [] hasRho = [BiVoid AtRho | not hasRho]-    withVoidRho' (bd : rest) hasRho =+    go :: [Binding] -> Bool -> [Binding]+    go [] hasRho = [BiVoid AtRho | not hasRho]+    go (bd : rest) hasRho =       case bd of         BiMeta _ -> bd : rest         BiVoid (AtMeta _) -> bd : rest         BiTau (AtMeta _) _ -> bd : rest-        BiVoid AtRho -> bd : withVoidRho' rest True-        BiTau AtRho _ -> bd : withVoidRho' rest True-        _ -> bd : withVoidRho' rest hasRho+        BiVoid AtRho -> bd : go rest True+        BiTau AtRho _ -> bd : go rest True+        _ -> bd : go rest hasRho  -- Recursively ensure all formations have a BiVoid AtRho binding (ρ ↦ ∅). -- Fixes in-memory ExFormation [] to ExFormation [BiVoid AtRho] after rewriting,@@ -218,229 +110,14 @@ -- >>> fqnToAttrs ExRoot -- Just [] fqnToAttrs :: Expression -> Maybe [Attribute]-fqnToAttrs expr = fqnToAttrs' expr <&> reverse+fqnToAttrs expr = go expr <&> reverse   where-    fqnToAttrs' :: Expression -> Maybe [Attribute]-    fqnToAttrs' ExRoot = Just []-    fqnToAttrs' (ExDispatch ex at) = fqnToAttrs' ex <&> (:) at-    fqnToAttrs' _ = Nothing--ensuredFile :: FilePath -> IO FilePath-ensuredFile pth = do-  exists <- doesFileExist pth-  if exists then pure pth else throwIO (FileDoesNotExist pth)---- Recursively collect all file paths in provided directory-allPathsIn :: FilePath -> IO [FilePath]-allPathsIn dir = do-  exists <- doesDirectoryExist dir-  names <- if exists then listDirectory dir else throwIO (DirectoryDoesNotExist dir)-  let nested = map (dir </>) names-  paths <--    forM-      nested-      ( \path -> do-          isDir <- doesDirectoryExist path-          if isDir-            then allPathsIn path-            else return [path]-      )-  return (concat paths)+    go :: Expression -> Maybe [Attribute]+    go ExRoot = Just []+    go (ExDispatch ex at) = go ex <&> (:) at+    go _ = Nothing  -- >>> toDouble 5 -- 5.0 toDouble :: Int -> Double toDouble = fromIntegral---- >>> 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]-btsToWord8 (BtMany bts) = map hexByte bts-btsToWord8 (BtMeta mt) = error $ "Cannot convert meta bytes to Word8; " ++ T.unpack mt--hexByte :: String -> Word8-hexByte [hi, lo] = (nibble hi `shiftL` 4) .|. nibble lo-  where-    nibble c-      | isDigit c = fromIntegral (ord c - ord '0')-      | c >= 'A' && c <= 'F' = fromIntegral (ord c - ord 'A' + 10)-      | c >= 'a' && c <= 'f' = fromIntegral (ord c - ord 'a' + 10)-      | otherwise = error ("Invalid hex digit: " ++ [c])-hexByte bt = case readHex bt of-  [(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)-word8ToBytes bts = BtMany (map toHex bts)--toHex :: Word8 -> String-toHex w = [digit (w `shiftR` 4), digit (w .&. 0x0F)]-  where-    digit n-      | 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-   in if length bytes /= 8-        then error $ "Expected 8 bytes for conversion, got " ++ show (length bytes)-        else-          let word = toWord64BE bytes-              val = wordToDouble word-           in if isNaN val || isInfinite val || isNegativeZero val-                then Right val-                else case properFraction val of-                  (n, 0.0) -> Left n-                  _ -> Right val-  where-    toWord64BE :: [Word8] -> Word64-    toWord64BE [a, b, c, d, e, f, g, h] =-      fromIntegral a `shiftL` 56-        .|. fromIntegral b `shiftL` 48-        .|. fromIntegral c `shiftL` 40-        .|. fromIntegral d `shiftL` 32-        .|. fromIntegral e `shiftL` 24-        .|. fromIntegral f `shiftL` 16-        .|. fromIntegral g `shiftL` 8-        .|. 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))))---- >>> 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 =-  if length str == 3 && last str == '-'-    then BtOne (init str)-    else 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)-  where-    escapeStr :: String -> String-    escapeStr = concatMap escapeChar-      where-        escapeChar '"' = "\\\""-        escapeChar '\\' = "\\\\"-        escapeChar '\n' = "\\n"-        escapeChar '\t' = "\\t"-        escapeChar c-          | isPrint c && c /= '\\' && c /= '"' = [c]-          | otherwise = printf "\\x%02x" (ord c)---- >>> 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)))---- 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-  forM_ [n - 1, n - 2 .. 1] $ \i -> do-    j <- uniformRM (0, i) gen-    M.swap v i j-  V.toList <$> V.freeze v--validateYamlObject :: (MonadFail a) => Object -> [String] -> a ()-validateYamlObject v keys = do-  let present = filter (`KeyMap.member` v) (map Key.fromString keys)-      current = KeyMap.keys v-  when-    (length current > 1)-    (fail ("Exactly one condition type is expected, when multiple condition types specified: " ++ show current))-  when-    (null present)-    (fail (printf "Unknown condition type '%s', expected one of: %s" (show current) (show keys)))

@@ -24,7 +24,8 @@ where  import AST-import Control.Exception (Exception, throwIO)+import Bytes (numToBts, strToBts)+import Control.Exception (Exception) import Control.Monad (guard) import Data.Char (isAsciiLower, isDigit) import Data.Scientific (toRealFloat)@@ -145,6 +146,7 @@   s <- hexDigitChar >>= upperHex   return [f, s]   where+    upperHex :: Char -> Parser Char     upperHex ch       | isDigit ch || ('A' <= ch && ch <= 'F') = return ch       | otherwise = fail ("expected 0-9 or A-F, got " ++ show ch)@@ -494,9 +496,7 @@ parseNumber = parse' "number" number  parseNumberThrows :: String -> IO Expression-parseNumberThrows num = case parseNumber num of-  Right num' -> pure num'-  Left err -> throwIO (CouldNotParseNumber err)+parseNumberThrows num = orThrow CouldNotParseNumber (parseNumber num)  parseAttribute :: String -> Either String Attribute parseAttribute = parse' "attribute" attribute@@ -508,22 +508,16 @@ parseIndex = parse' "index meta" index'  parseAttributeThrows :: String -> IO Attribute-parseAttributeThrows attr = case parseAttribute attr of-  Right attr' -> pure attr'-  Left err -> throwIO (CouldNotParseAttribute err)+parseAttributeThrows attr = orThrow CouldNotParseAttribute (parseAttribute attr)  parseExpression :: String -> Either String Expression parseExpression = parse' "expression" expression  parseExpressionThrows :: String -> IO Expression-parseExpressionThrows ex = case parseExpression ex of-  Right expr -> pure expr-  Left err -> throwIO (CouldNotParseExpression err)+parseExpressionThrows ex = orThrow CouldNotParseExpression (parseExpression ex)  parseProgram :: String -> Either String Program parseProgram = parse' "program" program  parseProgramThrows :: String -> IO Program-parseProgramThrows prg = case parseProgram prg of-  Right prog -> pure prog-  Left err -> throwIO (CouldNotParseProgram err)+parseProgramThrows prg = orThrow CouldNotParseProgram (parseProgram prg)

@@ -1,15 +1,18 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module Random (randomString) where+module Random (randomString, shuffle) where -import Control.Monad (replicateM)+import Control.Monad (forM_, replicateM) import Data.Char (intToDigit) import Data.IORef (IORef, modifyIORef', newIORef, readIORef) import Data.Set (Set) import qualified Data.Set as Set+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as M import GHC.IO (unsafePerformIO)-import System.Random (randomRIO)+import System.Random (newStdGen, randomRIO)+import System.Random.Stateful (newIOGenM, uniformRM)  strings :: IORef (Set String) {-# NOINLINE strings #-}@@ -48,3 +51,18 @@     randomized [] = False     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+  forM_ [n - 1, n - 2 .. 1] $ \i -> do+    j <- uniformRM (0, i) gen+    M.swap v i j+  V.toList <$> V.freeze v

@@ -44,6 +44,7 @@ substituteGroups :: B.ByteString -> [B.ByteString] -> B.ByteString substituteGroups rep groups = B.concat (go (B.unpack rep))   where+    go :: String -> [B.ByteString]     go [] = []     go ('$' : rest) =       let (digits, afterDigits) = span isDigit rest@@ -54,6 +55,7 @@                   val = fromMaybe (B.pack ('$' : digits)) (safeIndex idx groups)                in val : go afterDigits     go (c : rest) = B.singleton c : go rest+    safeIndex :: Int -> [B.ByteString] -> Maybe B.ByteString     safeIndex i xs       | i >= 0 && i < length xs = Just (xs !! i)       | otherwise = Nothing@@ -75,6 +77,7 @@ replaceAll :: R.Regex -> B.ByteString -> B.ByteString -> IO B.ByteString replaceAll regex rep input = go input B.empty   where+    go :: B.ByteString -> B.ByteString -> IO B.ByteString     go bs acc = do       result <- R.execute regex bs       case result of

@@ -183,6 +183,11 @@   render BI_PAIR{..} = render pair <> render bindings   render BI_META{..} = render meta <> render bindings +instance Render APP_ARGUMENT where+  render (AA_TAU tau) = render tau+  render (AA_TAUS taus) = render taus+  render (AA_EXPRS args) = render args+ instance Render APP_ARG where   render APP_ARG{..} = render expr <> render args @@ -200,9 +205,7 @@   render EX_TERMINATION{..} = render termination   render EX_FORMATION{..} = render lsb <> render eol <> render tab <> render binding <> render eol' <> render tab' <> render rsb   render EX_DISPATCH{..} = render expr <> render space <> "." <> render space <> render attr-  render EX_APPLICATION{..} = render expr <> render space <> "(" <> render eol <> render tab <> render tau <> render eol' <> render tab' <> ")"-  render EX_APPLICATION_TAUS{..} = render expr <> render space <> "(" <> render eol <> render tab <> render taus <> render eol' <> render tab' <> ")"-  render EX_APPLICATION_EXPRS{..} = render expr <> render space <> "(" <> render eol <> render tab <> render args <> render eol' <> render tab' <> ")"+  render EX_APPLICATION{..} = render expr <> render space <> "(" <> render eol <> render tab <> render argument <> render eol' <> render tab' <> ")"   render EX_STRING{..} = "\"" <> render str <> "\""   render EX_NUMBER{..} = either (T.pack . show) (T.pack . show) num   render EX_META{..} = render meta

@@ -104,8 +104,7 @@ buildAndReplace' (expr, ptn, res, substs) func = do   ptns <- buildExpressionsThrows ptn substs   repls <- buildExpressionsThrows res substs-  let repls' = map const repls-  pure (func (expr, ptns, repls'))+  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

@@ -15,6 +15,7 @@   , buildBindingThrows   , buildExpressionThrows   )+import Bytes (btsToUnescapedStr) import Control.Exception.Base (SomeException, try) import Control.Monad (when) import qualified Data.ByteString.Char8 as B@@ -27,7 +28,6 @@ import GHC.IO (unsafePerformIO) import Logger (logDebug) import Matcher-import Misc (btsToUnescapedStr) import Printer import Regexp (match) import Text.Printf (printf)

@@ -1,7 +1,6 @@ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} @@ -11,8 +10,9 @@ module Sugar (toSalty, withSugarType, SugarType (..), ToSalty) where  import AST+import Bytes (numToBts, strToBts) import CST-import Misc (numToBts, strToBts, toDouble, pattern BaseObject)+import Misc (toDouble)  withSugarType :: (ToSalty a) => SugarType -> a -> a withSugarType SWEET node = node@@ -66,8 +66,8 @@   toSalty EX_DISPATCH{..} = EX_DISPATCH (toSalty expr) space attr   toSalty EX_FORMATION{lsb, binding = bd@BI_EMPTY{}, rsb} = EX_FORMATION lsb NO_EOL TAB' (toSalty (bdWithVoidRho bd)) NO_EOL TAB' rsb   toSalty EX_FORMATION{..} = EX_FORMATION lsb eol tab (toSalty (bdWithVoidRho binding)) eol' tab' rsb-  toSalty EX_APPLICATION{..} = EX_APPLICATION (toSalty expr) space EOL (TAB indent) (toSalty tau) EOL (TAB (indent - 1)) indent-  toSalty EX_APPLICATION_TAUS{..} =+  toSalty EX_APPLICATION{argument = AA_TAU tau, ..} = EX_APPLICATION (toSalty expr) space EOL (TAB indent) (AA_TAU (toSalty tau)) EOL (TAB (indent - 1)) indent+  toSalty EX_APPLICATION{argument = AA_TAUS taus, ..} =     foldl       toApplication       expr@@ -75,7 +75,7 @@     where       toApplication :: EXPRESSION -> PAIR -> EXPRESSION       toApplication exp pair =-        EX_APPLICATION (toSalty exp) space EOL (TAB indent) (APP_BINDING (toSalty pair)) EOL (TAB (indent - 1)) indent+        EX_APPLICATION (toSalty exp) space EOL (TAB indent) (AA_TAU (APP_BINDING (toSalty pair))) EOL (TAB (indent - 1)) indent       tauToPairs :: BINDING -> [PAIR]       tauToPairs BI_PAIR{..} = pair : tausToPairs bindings       tauToPairs BI_EMPTY{} = []@@ -84,7 +84,7 @@       tausToPairs BDS_EMPTY{} = []       tausToPairs BDS_PAIR{..} = pair : tausToPairs bindings       tausToPairs (BDS_META _ _ mt _) = error $ "BDS_META " ++ show mt ++ " unexpected in tausToPairs"-  toSalty EX_APPLICATION_EXPRS{..} = toSalty (EX_APPLICATION_TAUS expr space EOL (TAB indent) (argToBinding args tab) EOL (TAB (indent - 1)) indent)+  toSalty EX_APPLICATION{argument = AA_EXPRS args, ..} = toSalty (EX_APPLICATION expr space EOL (TAB indent) (AA_TAUS (argToBinding args tab)) EOL (TAB (indent - 1)) indent)     where       argToBinding :: APP_ARG -> TAB -> BINDING       argToBinding APP_ARG{..} =@@ -116,28 +116,30 @@ saltifyPrimitive base bytes data' tb@TAB{..} rhos =   let next = TAB (indent + 1)    in toSalty-        ( EX_APPLICATION_TAUS+        ( EX_APPLICATION             base             NO_SPACE             EOL             next-            ( BI_PAIR-                ( PA_ALPHA-                    (AL_IDX ALPHA 0)-                    ARROW-                    ( EX_APPLICATION_EXPRS-                        bytes-                        NO_SPACE-                        EOL-                        (TAB (indent + 2))-                        (APP_ARG data' AAS_EMPTY)-                        EOL-                        next-                        (indent + 2)+            ( AA_TAUS+                ( BI_PAIR+                    ( PA_ALPHA+                        (AL_IDX ALPHA 0)+                        ARROW+                        ( EX_APPLICATION+                            bytes+                            NO_SPACE+                            EOL+                            (TAB (indent + 2))+                            (AA_EXPRS (APP_ARG data' AAS_EMPTY))+                            EOL+                            next+                            (indent + 2)+                        )                     )+                    (toCST rhos (indent + 1, EOL))+                    next                 )-                (toCST rhos (indent + 1, EOL))-                next             )             EOL             tb

@@ -20,6 +20,7 @@ where  import AST+import Bytes (btsToNum, btsToStr, bytesToBts) import Control.Exception (Exception (displayException), throwIO) import Data.Bifunctor (bimap) import Data.Foldable (foldlM)@@ -356,9 +357,7 @@   Left err -> Left (displayException err)  parseXMIRThrows :: String -> IO Document-parseXMIRThrows xmir = case parseXMIR xmir of-  Right doc -> pure doc-  Left err -> throwIO (CouldNotParseXMIR err)+parseXMIRThrows xmir = orThrow CouldNotParseXMIR (parseXMIR xmir)  xmirToPhi :: Document -> IO Program xmirToPhi xmir =

@@ -13,14 +13,28 @@ import AST import Control.Applicative (asum) import Data.Aeson+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.ByteString as BS import Data.FileEmbed (embedDir, embedFile) import Data.Text (Text, unpack) import Data.Yaml (Parser) import qualified Data.Yaml as Yaml import GHC.Generics (Generic)-import Misc (validateYamlObject) import Parser+import Text.Printf (printf)++-- Fail unless the object names exactly one of the expected keys+validateYamlObject :: (MonadFail a) => Object -> [String] -> a ()+validateYamlObject v keys+  | length current > 1 = fail ("Exactly one condition type is expected, when multiple condition types specified: " ++ show current)+  | null present = fail (printf "Unknown condition type '%s', expected one of: %s" (show current) (show keys))+  | otherwise = pure ()+  where+    present :: [Key.Key]+    present = filter (`KeyMap.member` v) (map Key.fromString keys)+    current :: [Key.Key]+    current = KeyMap.keys v  parseJSON' :: String -> (String -> Either String a) -> Value -> Parser a parseJSON' nm func =

@@ -1003,6 +1003,11 @@             , "  { T }"             , "  { }"             , "  { }"+            , "\\phinoNormalizationRule{dl}"+            , "  { [[ B ]] }"+            , "  { T }"+            , "  { D \\in B \\;\\text{and}\\; L \\in B }"+            , "  { }"             , "\\phinoNormalizationRule{dot}"             , "  { [[ B_1, \\tau -> n, B_2 ]] . \\tau }"             , "  { e ( \\phiTerminal{\\rho} -> [[ B_1, \\tau -> n, B_2 ]] ) }"

@@ -14,10 +14,10 @@ import Data.Text qualified as T import Data.Yaml qualified as Yaml import Encoding (Encoding (ASCII), withEncoding)+import Files (allPathsIn) import GHC.Generics (Generic) import Lining (LineFormat (SINGLELINE), withLineFormat) import Margin (defaultMargin, withMargin)-import Misc import Parser (parseProgramThrows) import Render (Render (render)) import Sugar

@@ -15,11 +15,11 @@ import Data.Aeson import Data.Yaml qualified as Yaml import Encoding (Encoding (UNICODE))+import Files (allPathsIn) import Filter qualified as F import GHC.Generics (Generic) import Lining (LineFormat (MULTILINE)) import Margin (defaultMargin)-import Misc import Parser (parseExpressionThrows, parseProgramThrows) import Printer (printProgram') import Sugar (SugarType (SALTY))

@@ -10,7 +10,7 @@ import AST import Control.Monad (forM_) import Data.Either (isLeft, isRight)-import Misc+import Files (allPathsIn) import Parser import System.FilePath (takeBaseName) import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, anyException, describe, it, runIO, shouldBe, shouldReturn, shouldSatisfy, shouldThrow)

@@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-}  -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT@@ -15,7 +14,6 @@ import Encoding (Encoding (..)) import Lining (LineFormat (..)) import Margin (defaultMargin)-import Misc (pattern DataNumber) import Parser (parseExpression) import Printer import Sugar (SugarType (..))

@@ -15,9 +15,9 @@ import Data.List.NonEmpty qualified as NE import Data.Yaml qualified as Yaml import Deps (dontSaveStep)+import Files (allPathsIn, ensuredFile) import Functions (buildTerm) import GHC.Generics-import Misc (allPathsIn, ensuredFile) import Must (Must (..)) import Parser (parseProgramThrows) import Printer (printProgram)

@@ -11,10 +11,10 @@ import Control.Monad import Data.Aeson import Data.Yaml qualified as Y+import Files (allPathsIn) import Functions (buildTerm) import GHC.Generics import Matcher-import Misc import Printer (printSubsts) import Rule (RuleContext (RuleContext), isNF, meetCondition) import System.FilePath

@@ -15,8 +15,8 @@ import Data.List (intercalate) import Data.Text qualified as T import Data.Yaml qualified as Yaml+import Files (allPathsIn) import GHC.Generics (Generic)-import Misc (allPathsIn) import Parser (parseExpressionThrows, parseProgramThrows) import System.FilePath (makeRelative) import Test.Hspec (Spec, anyException, describe, expectationFailure, it, runIO, shouldBe, shouldThrow)

@@ -13,7 +13,7 @@ import Data.Text qualified as T import Data.Text.Encoding (encodeUtf8) import Data.Yaml qualified as Yaml-import Misc+import Files (allPathsIn) import System.FilePath import Test.Hspec (Spec, describe, it, runIO, shouldBe, shouldReturn, shouldSatisfy, shouldThrow) import Yaml (ContextualizeRule (..), DataizeRule (..), MorphRule (..), contextualizationRules, dataizationRules, morphingRules, yamlRule)