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.106 +cabal install --overwrite-policy=always phino-0.0.109 phino --version ``` @@ -132,6 +132,13 @@ phino rewrite --normalize hello.phi ``` +Both flags may be combined, so that your own rules are applied +alongside the built-in ones, in a single rewriting session: + +```bash +phino rewrite --normalize --rule=my-rule.yaml hello.phi +``` + Some rules mint fresh synthetic names via the `random-string` built-in. To keep the output reproducible across runs, `phino` seeds the random generator deterministically with `0` by default. Use `--seed` to pick a different seed: @@ -447,55 +454,55 @@ === parse/phi === warmup: 3 iterations batches: 10 x 1 - total: 1279870.467 μs - avg: 127987.047 μs - min: 117457.988 μs - max: 156105.148 μs - std dev: 15737.223 μs + total: 1169007.436 μs + avg: 116900.744 μs + min: 100971.842 μs + max: 151797.838 μs + std dev: 17291.748 μs === parse/xmir === warmup: 3 iterations batches: 10 x 1 - total: 7617419.851 μs - avg: 761741.985 μs - min: 686228.460 μs - max: 914941.984 μs - std dev: 59800.299 μs + total: 5597441.785 μs + avg: 559744.178 μs + min: 513882.882 μs + max: 594965.205 μs + std dev: 25969.225 μs === rewrite/normalize === warmup: 3 iterations batches: 10 x 1 - total: 603364.936 μs - avg: 60336.494 μs - min: 58688.247 μs - max: 62431.021 μs - std dev: 1196.183 μs + total: 462608.655 μs + avg: 46260.866 μs + min: 45419.580 μs + max: 46969.027 μs + std dev: 488.480 μs === print/sweet/multiline === warmup: 3 iterations batches: 10 x 1 - total: 4208011.890 μs - avg: 420801.189 μs - min: 400713.926 μs - max: 442532.655 μs - std dev: 16080.251 μs + total: 2470222.565 μs + avg: 247022.256 μs + min: 237266.284 μs + max: 257086.226 μs + std dev: 5473.812 μs === print/sweet/flat === warmup: 3 iterations batches: 10 x 1 - total: 4195034.891 μs - avg: 419503.489 μs - min: 403618.144 μs - max: 432523.908 μs - std dev: 9981.104 μs + total: 2445638.241 μs + avg: 244563.824 μs + min: 229281.911 μs + max: 294227.329 μs + std dev: 17698.464 μs === print/salty/multiline === warmup: 3 iterations batches: 10 x 1 - total: 13849441.895 μs - avg: 1384944.189 μs - min: 1372281.323 μs - max: 1410740.491 μs - std dev: 10841.096 μs + total: 8935463.749 μs + avg: 893546.375 μs + min: 857992.909 μs + max: 945729.836 μs + std dev: 27023.850 μs ``` The results were calculated in [this GHA job][benchmark-gha] -on 2026-07-24 at 23:39, +on 2026-08-28 at 21:26, on Linux with 4 CPUs. @@ -544,4 +551,4 @@ [jna]: https://github.com/java-native-access/jna [jna-native]: https://github.com/java-native-access/jna/blob/master/src/com/sun/jna/Native.java [jeo]: https://github.com/objectionary/jeo-maven-plugin -[benchmark-gha]: https://github.com/objectionary/phino/actions/runs/30134184768 +[benchmark-gha]: https://github.com/objectionary/phino/actions/runs/33210677726 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.109 +version: 0.0.110 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 @@ -228,15 +228,12 @@ pattern DataObject label bts <- (matchDataObject -> Just (label, bts)) where DataObject label bts = - ExApplication - (BaseObject label) - ( ArTau - (AtLabel "as-bytes") - ( ExApplication - (BaseObject "bytes") - ( ArTau - (AtLabel "data") - (ExFormation [BiDelta bts, BiVoid AtRho]) - ) - ) - ) + ExApplication (BaseObject label) (ArTau (AtLabel "as-bytes") (dataBytes bts)) + +-- The bytes object Φ.bytes(data ↦ ⟦ Δ ⤍ …, ρ ↦ ∅ ⟧) — what a 'bytes' atom +-- yields and what a 'DataObject' carries under its 'as-bytes' argument +dataBytes :: Bytes -> Expression +dataBytes bts = + ExApplication + (BaseObject "bytes") + (ArTau (AtLabel "data") (ExFormation [BiDelta bts, BiVoid AtRho])) diff --git a/src/Bytes.hs b/src/Bytes.hs --- a/src/Bytes.hs +++ b/src/Bytes.hs @@ -4,7 +4,9 @@ -- 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. +-- 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 @@ -12,12 +14,20 @@ , btsToStr , btsToNum , btsToUnescapedStr + , btsAnd + , btsOr + , btsNot + , btsConcat + , btsEqual + , btsSize + , btsSlice + , btsShift ) where import AST import Data.Binary.IEEE754 -import Data.Bits (Bits (shiftL, shiftR), (.&.), (.|.)) +import Data.Bits (Bits (complement, shiftL, shiftR), (.&.), (.|.)) import qualified Data.ByteString as B import Data.ByteString.Builder (toLazyByteString, word64BE) import Data.ByteString.Lazy (unpack) @@ -198,3 +208,116 @@ -- "5" btsToUnescapedStr :: Bytes -> String btsToUnescapedStr bytes = T.unpack (T.decodeUtf8 (B.pack (btsToWord8 bytes))) + +-- 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 (.|.) + +zipBytes :: (Word8 -> Word8 -> Word8) -> Bytes -> Bytes -> Maybe Bytes +zipBytes op left right + | length lefts /= length rights = Nothing + | otherwise = Just (word8ToBytes (zipWith op lefts rights)) + where + lefts :: [Word8] + lefts = btsToWord8 left + 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 + | otherwise = Just (word8ToBytes (take len (drop start octets))) + where + 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 + | bits < 0 = word8ToBytes (map leftwards indices) + | otherwise = word8ToBytes (map rightwards indices) + where + octets :: [Word8] + octets = btsToWord8 bts + size :: Int + size = length octets + indices :: [Int] + indices = [0 .. size - 1] + modulo :: Int + modulo = abs bits `mod` 8 + offset :: Int + offset = abs bits `div` 8 + octet :: Int -> Word8 + octet index = octets !! index + rightwards :: Int -> Word8 + rightwards index + | source < 0 = 0 + | source > 0 = shifted .|. ((octet (source - 1) `shiftL` (8 - modulo)) .&. carry) + | otherwise = shifted + where + source :: Int + source = index - offset + shifted :: Word8 + shifted = octet source `shiftR` modulo + carry :: Word8 + carry = 0xFF `shiftL` (8 - modulo) + leftwards :: Int -> Word8 + leftwards index + | source >= size = 0 + | source + 1 < size = shifted .|. ((octet (source + 1) `shiftR` (8 - modulo)) .&. carry) + | otherwise = shifted + where + source :: Int + source = index + offset + shifted :: Word8 + shifted = octet source `shiftL` modulo + carry :: Word8 + carry = (0x01 `shiftL` modulo) - 1 diff --git a/src/CLI/Helpers.hs b/src/CLI/Helpers.hs --- a/src/CLI/Helpers.hs +++ b/src/CLI/Helpers.hs @@ -112,29 +112,32 @@ printCtxToLatexCtx PrintCtx{..} = LatexContext _sugar _line _margin _nonumber _compress _canonize _meetPopularity _meetLength _focus _expression _label _meetPrefix _headers --- Get rules for rewriting depending on provided flags +-- 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 <- - if normalize - then do - let rules' = normalizationRules - logDebug (printf "The --normalize option is provided, %d built-it normalization rules are used" (length rules')) - pure rules' - else - if null rules - then do - logDebug "No --rule and no --normalize options are provided, no rules are used" - pure [] - else do - logDebug (printf "Using rules from files: [%s]" (intercalate ", " rules)) - yamls <- mapM ensuredFile rules - mapM (Y.yamlRule >=> validateRewriteRule) yamls + ordered <- (++) <$> builtin <*> custom if shuffle then do logDebug "The --shuffle option is provided, rules are used in random order" R.shuffle ordered else pure ordered + where + builtin :: IO [Y.Rule] + builtin + | normalize = do + logDebug (printf "The --normalize option is provided, %d built-it normalization rules are used" (length normalizationRules)) + pure normalizationRules + | otherwise = pure [] + custom :: IO [Y.Rule] + custom + | null rules = do + logDebug "No --rule option is provided, no user rules are used" + pure [] + | otherwise = do + logDebug (printf "Using rules from files: [%s]" (intercalate ", " rules)) + yamls <- mapM ensuredFile 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 diff --git a/src/Dataize.hs b/src/Dataize.hs --- a/src/Dataize.hs +++ b/src/Dataize.hs @@ -13,9 +13,10 @@ import AST import Builder (buildBytesThrows, buildExpressionThrows) -import Bytes (btsToNum, numToBts) +import Bytes (btsAnd, btsConcat, btsEqual, btsNot, btsOr, btsShift, btsSize, btsSlice, btsToNum, numToBts, strToBts) import Control.Exception (throwIO) import Control.Monad (foldM) +import Data.Int (Int32) import Data.List (find, partition) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE @@ -367,6 +368,29 @@ asNumber BtEmpty = Nothing asNumber bts = Just (either toDouble id (btsToNum bts)) +-- An operand that EO reads as a Java 'int' — a shift distance or a slice bound. +-- 'Expect.at(…).that(Integer)' turns down anything but a whole number inside the +-- 32-bit range, and so does this, leaving the atom with ⊥ +asInt :: Bytes -> Maybe Int +asInt bts + | btsSize bts /= 8 = Nothing + | otherwise = case btsToNum bts of + Left num | num >= fromIntegral (minBound :: Int32) && num <= fromIntegral (maxBound :: Int32) -> Just num + _ -> Nothing + +-- An atom whose EO signature ends in '/Q.bool' hands back one of the two bool +-- objects of the universe, exactly what 'Data.ToPhi(boolean)' does in the runtime +boolean :: Bool -> Expression +boolean True = BaseObject "true" +boolean False = BaseObject "false" + +-- Both bitwise atoms take ρ and 'b' and reject operands of different lengths +bitwise :: (Bytes -> Bytes -> Maybe Bytes) -> Expression -> Expression -> State -> DataizeContext -> IO (Expression, State) +bitwise op self univ state ctx = do + (b, bstate) <- _dataize (ExDispatch self (AtLabel "b")) univ state ctx + (rho, rstate) <- _dataize (ExDispatch self AtRho) univ bstate ctx + pure (maybe ExTermination dataBytes (op rho b), rstate) + atom :: T.Text -> Expression -> Expression -> State -> DataizeContext -> IO (Expression, State) atom "L_number_plus" self univ state ctx = do (left, lstate) <- _dataize (ExDispatch self (AtLabel "x")) univ state ctx @@ -389,6 +413,58 @@ then pure (DataNumber (numToBts first), rstate) else pure (ExDispatch self (AtLabel "y"), rstate) _ -> pure (ExTermination, rstate) +atom "L_number_div" self univ state ctx = do + (x, xstate) <- _dataize (ExDispatch self (AtLabel "x")) univ state ctx + (rho, rstate) <- _dataize (ExDispatch self AtRho) univ xstate ctx + case (asNumber x, asNumber rho) of + (Just divisor, Just dividend) -> pure (DataNumber (numToBts (dividend / divisor)), rstate) + _ -> pure (ExTermination, rstate) +atom "L_number_gt" self univ state ctx = do + (x, xstate) <- _dataize (ExDispatch self (AtLabel "x")) univ state ctx + (rho, rstate) <- _dataize (ExDispatch self AtRho) univ xstate ctx + case (asNumber x, asNumber rho) of + (Just threshold, Just value) -> pure (boolean (value > threshold), rstate) + _ -> pure (ExTermination, rstate) +atom "L_bytes_and" self univ state ctx = bitwise btsAnd self univ state ctx +atom "L_bytes_or" self univ state ctx = bitwise btsOr self univ state ctx +atom "L_bytes_not" self univ state ctx = do + (rho, rstate) <- _dataize (ExDispatch self AtRho) univ state ctx + pure (dataBytes (btsNot rho), rstate) +atom "L_bytes_concat" self univ state ctx = do + (b, bstate) <- _dataize (ExDispatch self (AtLabel "b")) univ state ctx + (rho, rstate) <- _dataize (ExDispatch self AtRho) univ bstate ctx + pure (dataBytes (btsConcat rho b), rstate) +atom "L_bytes_eq" self univ state ctx = do + (b, bstate) <- _dataize (ExDispatch self (AtLabel "b")) univ state ctx + (rho, rstate) <- _dataize (ExDispatch self AtRho) univ bstate ctx + pure (boolean (btsEqual rho b), rstate) +atom "L_bytes_size" self univ state ctx = do + (rho, rstate) <- _dataize (ExDispatch self AtRho) univ state ctx + pure (DataNumber (numToBts (fromIntegral (btsSize rho))), rstate) +atom "L_bytes_right" self univ state ctx = do + (x, xstate) <- _dataize (ExDispatch self (AtLabel "x")) univ state ctx + (rho, rstate) <- _dataize (ExDispatch self AtRho) univ xstate ctx + case asInt x of + Just bits -> pure (dataBytes (btsShift bits rho), rstate) + Nothing -> pure (ExTermination, rstate) +atom "L_bytes_slice" self univ state ctx = do + (start, sstate) <- _dataize (ExDispatch self (AtLabel "start")) univ state ctx + (len, lstate) <- _dataize (ExDispatch self (AtLabel "len")) univ sstate ctx + (rho, rstate) <- _dataize (ExDispatch self AtRho) univ lstate ctx + case (asInt start, asInt len) of + (Just from, Just count) + | from >= 0 && count >= 0 -> + pure (maybe (cantSlice from count (btsSize rho)) dataBytes (btsSlice from count rho), rstate) + _ -> pure (ExTermination, rstate) + where + -- A window past the end of the array does not stop EO: it copies the + -- 'cant-slice' fallback, applies the complaint to it and lets the caller + -- decide. A caller that left 'cant-slice' unbound gets ⊥ out of the dispatch + cantSlice :: Int -> Int -> Int -> Expression + cantSlice from count size = + ExApplication + (ExDispatch self (AtLabel "cant-slice")) + (ArAlpha (Alpha 0) (DataString (strToBts (printf "cannot slice '%d' bytes from offset '%d' of bytes of size %d" count from size)))) atom func _ _ _ _ = throwIO (userError (printf "Atom '%s' does not exist" (T.unpack func))) -- Augment the injected, context-free term builder with the dataization and diff --git a/src/Functions.hs b/src/Functions.hs --- a/src/Functions.hs +++ b/src/Functions.hs @@ -208,7 +208,7 @@ bds <- buildBindingThrows bd subst next <- buildBindings args' pure (bds ++ next) - buildBindings _ = throwIO (userError "Function 'go can work with bindings only") + buildBindings _ = throwIO (userError "Function join() can work with bindings only") go :: [Binding] -> Set.Set Attribute -> IO [Binding] go [] _ = pure [] go (bd : bds) attrs = diff --git a/src/Must.hs b/src/Must.hs --- a/src/Must.hs +++ b/src/Must.hs @@ -34,7 +34,7 @@ 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) -> [] -- Invalid range: empty range '..' + (Nothing, Nothing, True, True) -> [(MtRange Nothing Nothing, "")] -- Empty range '..' round-trips (Nothing, Just hi, True, False) -> [(MtRange Nothing (Just hi), "") | hi >= 0] (Just lo, Nothing, False, True) -> diff --git a/src/Random.hs b/src/Random.hs --- a/src/Random.hs +++ b/src/Random.hs @@ -13,6 +13,7 @@ import GHC.IO (unsafePerformIO) import System.Random (newStdGen, randomRIO) import System.Random.Stateful (newIOGenM, uniformRM) +import Text.Printf (printf) strings :: IORef (Set String) {-# NOINLINE strings #-} @@ -25,7 +26,7 @@ 'x' -> replicateM 8 $ do v <- randomRIO (0, 15) pure (intToDigit v) - 'd' -> show <$> randomRIO (0 :: Int, 9999) + 'd' -> printf "%04d" <$> randomRIO (0 :: Int, 9999) _ -> pure ['%', ch] next <- generate rest pure (rep ++ next) diff --git a/src/Regexp.hs b/src/Regexp.hs --- a/src/Regexp.hs +++ b/src/Regexp.hs @@ -89,4 +89,10 @@ (_, rest2) = B.splitAt len rest1 groups <- extractGroups regex bs let replacement = substituteGroups rep groups - go rest2 (B.concat [acc, before, replacement]) + if len == 0 + then + let next = B.take 1 rest2 + in if B.null next + then return $ B.concat [acc, before, replacement] + else go (B.drop 1 rest2) (B.concat [acc, before, replacement, next]) + else go rest2 (B.concat [acc, before, replacement]) diff --git a/src/Render.hs b/src/Render.hs --- a/src/Render.hs +++ b/src/Render.hs @@ -264,6 +264,9 @@ render CO_ABSOLUTE{..} = "\\phinoAbsolute{ " <> render expr <> " }" render CO_NOT{condition = CO_FORMATION{..}} = "\\phinoNotFormation{ " <> render expr <> " }" render CO_NOT{..} = renderFunc "not" condition + where + renderFunc :: Render a => Text -> a -> Text + renderFunc func renderable = func <> "\\lparen " <> render renderable <> " \\rparen" render CO_COMPARE{..} = render left <> " " <> render equal <> " " <> render right render CO_MATCHES{..} = "matches\\lparen " <> T.pack regex <> ", " <> render expr <> " \\rparen" render CO_PART_OF{..} = "part-of\\lparen " <> render expr <> ", " <> render binding <> " \\rparen" @@ -279,9 +282,6 @@ renderGroups [group] = render group renderGroups gs = "\\lparen " <> T.intercalate " \\cup " (map render gs) <> " \\rparen" render CO_EMPTY = "" - -renderFunc :: Render a => Text -> a -> Text -renderFunc func renderable = func <> "\\lparen " <> render renderable <> " \\rparen" instance Render EXTRA_ARG where render ARG_ATTR{..} = render attr diff --git a/src/Rule.hs b/src/Rule.hs --- a/src/Rule.hs +++ b/src/Rule.hs @@ -352,12 +352,6 @@ goArgument (ArTau _ expr) = go expr goArgument (ArAlpha _ expr) = go expr -nfMetaNames :: Expression -> [T.Text] -nfMetaNames = metaNamesWithPrefix "n" - -kMetaNames :: Expression -> [T.Text] -kMetaNames = metaNamesWithPrefix "k" - matchExpressionWithRule :: Expression -> Y.Rule -> RuleContext -> IO [Subst] matchExpressionWithRule = matchExpressionBy matchExpression [substEmpty] @@ -410,3 +404,9 @@ met <- meetMaybeCondition rule.having extended ctx when (null met) (logDebug "The 'having' condition wasn't met") pure met + where + nfMetaNames :: Expression -> [T.Text] + nfMetaNames = metaNamesWithPrefix "n" + + kMetaNames :: Expression -> [T.Text] + kMetaNames = metaNamesWithPrefix "k" diff --git a/src/XMIR.hs b/src/XMIR.hs --- a/src/XMIR.hs +++ b/src/XMIR.hs @@ -143,23 +143,26 @@ expression expr _ = throwIO (UnsupportedExpression expr) formationBinding :: Binding -> XmirContext -> IO (Maybe Node) -formationBinding (BiTau (AtLabel label) (ExFormation bds)) ctx = do - inners <- nestedBindings bds ctx - pure (Just (object [("name", T.unpack label)] inners)) -formationBinding (BiTau (AtLabel label) expr) ctx = do - (base, children) <- expression expr ctx - pure (Just (object [("name", T.unpack label), ("base", base)] children)) +formationBinding (BiTau (AtLabel label) expr) ctx = Just <$> namedBinding (T.unpack label) expr ctx +formationBinding (BiTau AtRho expr) ctx = Just <$> namedBinding (show AtRho) expr ctx formationBinding (BiTau AtPhi expr) ctx = do (base, children) <- expression expr ctx pure (Just (object [("name", show AtPhi), ("base", base)] children)) -formationBinding (BiTau AtRho _) _ = pure Nothing formationBinding (BiDelta bytes) _ = pure (Just (NodeContent (T.pack (printBytes bytes)))) -formationBinding (BiLambda _) _ = pure (Just (object [("name", show AtLambda)] [])) +formationBinding (BiLambda (Function name)) _ = pure (Just (object [("name", show AtLambda)] [NodeContent name])) formationBinding (BiVoid AtRho) _ = pure Nothing formationBinding (BiVoid AtPhi) _ = pure (Just (object [("name", show AtPhi), ("base", "∅")] [])) formationBinding (BiVoid (AtLabel label)) _ = pure (Just (object [("name", T.unpack label), ("base", "∅")] [])) 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) + nestedBindings :: [Binding] -> XmirContext -> IO [Node] nestedBindings bds ctx = catMaybes <$> mapM (`formationBinding` ctx) bds @@ -188,7 +191,8 @@ (Prologue [] Nothing []) ( element "object" - [ ("dob", formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S" now) + [ ("author", "phino") + , ("dob", formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S" now) , ("ms", "0") , ("revision", "1234567") , ("time", time now) @@ -391,15 +395,17 @@ name <- getAttr "name" cur bds <- mapM (`xmirToFormationBinding` (name : fqn)) (cur C.$/ C.element (toName "o")) >>= uniqueBindings' case name of - "λ" -> pure (BiLambda (Function (T.pack (intercalate "_" ("L" : reverse fqn))))) + "λ" -> BiLambda . Function <$> lambdaFunction ('α' : _) -> throwIO (InvalidXMIRFormat "Formation child @name can't start with α" cur) "φ" -> pure (BiTau AtPhi (ExFormation (withVoidRho bds))) + "ρ" -> pure (BiTau AtRho (ExFormation (withVoidRho bds))) _ -> pure (BiTau (AtLabel (T.pack name)) (ExFormation (withVoidRho bds))) | otherwise = do name <- getAttr "name" cur base <- getAttr "base" cur attr <- case name of "φ" -> pure AtPhi + "ρ" -> pure AtRho ('α' : _) -> throwIO (InvalidXMIRFormat "Formation child @name can't start with α" cur) _ -> pure (AtLabel (T.pack name)) case base of @@ -407,6 +413,14 @@ _ -> do expr <- xmirToExpression cur fqn pure (BiTau attr expr) + where + -- The λ function name is carried by the text of the marker element. XMIR + -- coming from elsewhere holds no name, so fall back to the position in the + -- tree, which is the only hint left + lambdaFunction :: IO T.Text + lambdaFunction + | hasText cur = T.strip . T.pack <$> getText cur + | otherwise = pure (T.pack (intercalate "_" ("L" : reverse fqn))) xmirToExpression :: C.Cursor -> [String] -> IO Expression xmirToExpression cur fqn diff --git a/test/BuilderSpec.hs b/test/BuilderSpec.hs --- a/test/BuilderSpec.hs +++ b/test/BuilderSpec.hs @@ -100,6 +100,18 @@ [substSingle "e1" (MvExpression (ExDispatch ExRoot (AtLabel "x")))] `shouldThrow` anyException + describe "contextualize" $ do + it "replaces a xi expression with the context" $ + contextualize ExXi (ExFormation [BiVoid AtRho]) `shouldBe` ExFormation [BiVoid AtRho] + it "keeps a root expression untouched" $ + contextualize ExRoot (ExFormation [BiVoid AtRho]) `shouldBe` ExRoot + it "keeps an empty formation untouched" $ + contextualize (ExFormation [BiVoid AtRho]) (ExFormation [BiVoid AtRho, BiVoid AtRho]) + `shouldBe` ExFormation [BiVoid AtRho] + it "recurses into a dispatch application" $ + contextualize (ExDispatch ExXi (AtLabel "z")) (ExFormation [BiVoid AtRho]) + `shouldBe` ExDispatch (ExFormation [BiVoid AtRho]) (AtLabel "z") + describe "build with duplicate attributes in bindings" $ do it "build binding with duplicates" $ buildBinding (BiMeta "B") (substSingle "B" (MvBindings [BiVoid AtRho, BiVoid AtRho])) `shouldSatisfy` isLeft diff --git a/test/CLISpec.hs b/test/CLISpec.hs --- a/test/CLISpec.hs +++ b/test/CLISpec.hs @@ -406,6 +406,12 @@ ["rewrite", rule "evaluate-in-rewrite.yaml"] ["Function 'evaluate' in rule 'uses-evaluate' is available only for dataization and morphing, not for rewriting"] + it "names the join function in the error message" $ + withStdin "⟦⟧" $ + testCLIFailed + ["rewrite", rule "join-broken.yaml"] + ["Function join() can work with bindings only"] + it "normalizes with --normalize flag" $ testCLISucceeded ["rewrite", "--normalize", resource "normalize.phi", "--margin=25"] @@ -421,6 +427,12 @@ , "⟧" ] ] + + it "normalizes and applies --rule at the same time" $ + withStdin "⟦ k ↦ ⟦ m ↦ ⟦ Δ ⤍ 01- ⟧ ⟧.m, j ↦ ⟦ λ ⤍ Marker ⟧ ⟧" $ + testCLISucceeded + ["rewrite", "--normalize", rule "marker.yaml", "--sweet"] + ["⟦ k ↦ ⟦ Δ ⤍ 01-, ρ ↦ ⟦ m ↦ ⟦ Δ ⤍ 01- ⟧ ⟧ ⟧, j ↦ ⟦ Δ ⤍ FF- ⟧ ⟧"] it "normalizes from stdin" $ withStdin "⟦ a ↦ ⟦ b ↦ ∅ ⟧ (b ↦ [[ ]]) ⟧" $ diff --git a/test/DataizeSpec.hs b/test/DataizeSpec.hs --- a/test/DataizeSpec.hs +++ b/test/DataizeSpec.hs @@ -51,6 +51,66 @@ (value, _) <- dataize expr (defaultDataizeContext loc') value `shouldBe` res +-- The 12 primitive λ-atoms every EO data operation reduces to, declared the way +-- 'number.eo' and 'bytes.eo' declare them, so a case below only has to spell the +-- expression under φ. Alongside them stand the objects the atoms hand results +-- to: 'string' carries the 'cant-slice' complaint, while 'true' and 'false' fill +-- in for the real bool objects, since the single byte an EO bool dataizes to is +-- all these cases assert. +primitives :: String -> String +primitives src = + unlines + [ "[[" + , " bytes -> [[" + , " data -> ?," + , " @ -> $.data," + , " and -> [[ b -> ?, L> L_bytes_and ]]," + , " or -> [[ b -> ?, L> L_bytes_or ]]," + , " not -> [[ L> L_bytes_not ]]," + , " concat -> [[ b -> ?, L> L_bytes_concat ]]," + , " eq -> [[ b -> ?, L> L_bytes_eq ]]," + , " size -> [[ L> L_bytes_size ]]," + , " right -> [[ x -> ?, L> L_bytes_right ]]," + , " slice -> [[ start -> ?, len -> ?, cant-slice -> ?, L> L_bytes_slice ]]" + , " ]]," + , " number -> [[" + , " as-bytes -> ?," + , " @ -> $.as-bytes," + , " plus -> [[ x -> ?, L> L_number_plus ]]," + , " times -> [[ x -> ?, L> L_number_times ]]," + , " div -> [[ x -> ?, L> L_number_div ]]," + , " gt -> [[ x -> ?, L> L_number_gt ]]" + , " ]]," + , " string -> [[ as-bytes -> ?, @ -> $.as-bytes ]]," + , " true -> [[ @ -> [[ D> 01- ]] ]]," + , " false -> [[ @ -> [[ D> 00- ]] ]]," + , " @ -> " ++ src + , "]]" + ] + +-- Wrap a hex literal into the bytes object that EO source spells as a bare '20-1F' +raw :: String -> String +raw bts = "Q.bytes( data -> [[ D> " ++ bts ++ " ]] )" + +testAtom :: [(String, String, Bytes)] -> Spec +testAtom useCases = + forM_ useCases $ \(name, src, res) -> + it name $ do + expr <- parseExpressionThrows (primitives src) + loc <- parseExpressionThrows "Q" + (value, _) <- dataize expr (defaultDataizeContext loc) + value `shouldBe` res + +-- An atom with no answer yields ⊥, which stops the whole dataization +testStuckAtom :: [(String, String)] -> Spec +testStuckAtom useCases = + forM_ useCases $ \(name, src) -> + it name $ do + expr <- parseExpressionThrows (primitives src) + loc <- parseExpressionThrows "Q" + dataize expr (defaultDataizeContext loc) + `shouldThrow` (\e -> "terminator" `isInfixOf` show (e :: SomeException)) + spec :: Spec spec = do describe "morph" $ @@ -402,3 +462,68 @@ , BtOne "2A" ) ] + + describe "atoms" $ do + testAtom + [ ("divides a positive dividend", "256.div( 16 )", BtMany ["40", "30", "00", "00", "00", "00", "00", "00"]) + , ("divides by zero into infinity", "2.div( 0 )", BtMany ["7F", "F0", "00", "00", "00", "00", "00", "00"]) + , ("tells 1000 is greater than 200", "1000.gt( 200 )", BtOne "01") + , ("tells 42 is not greater than 42.5", "42.gt( 42.5 )", BtOne "00") + , ("tells zero is greater than a negative", "0.gt( -5 )", BtOne "01") + , + ( "conjoins two long bytes" + , raw "02-EF-D4-05-5E-78-3A" ++ ".and( " ++ raw "12-33-C1-B5-5E-71-55" ++ " )" + , BtMany ["02", "23", "C0", "05", "5E", "70", "10"] + ) + , + ( "disjoins negative bytes with one" + , raw "FF-FF-FF-FF-00-00-00-00" ++ ".or( " ++ raw "00-00-00-00-00-00-00-01" ++ " )" + , BtMany ["FF", "FF", "FF", "FF", "00", "00", "00", "01"] + ) + , ("inverts bytes", raw "CA-FE-BE-BE" ++ ".not", BtMany ["35", "01", "41", "41"]) + , + ( "concats two long bytes" + , raw "02-EF-D4-05-5E-78-3A" ++ ".concat( " ++ raw "12-33-C1-B5-5E-71-55" ++ " )" + , BtMany ["02", "EF", "D4", "05", "5E", "78", "3A", "12", "33", "C1", "B5", "5E", "71", "55"] + ) + , + ( "concats bytes with empty ones" + , raw "05-5E-78" ++ ".concat( " ++ raw "--" ++ " )" + , BtMany ["05", "5E", "78"] + ) + , ("counts the size of bytes", raw "F1-20-5F-EC-B5-90-32" ++ ".size", BtMany ["40", "1C", "00", "00", "00", "00", "00", "00"]) + , ("tells equal bytes are equal", raw "CA-FE" ++ ".eq( " ++ raw "CA-FE" ++ " )", BtOne "01") + , ("tells different bytes are not equal", raw "CA-FE" ++ ".eq( " ++ raw "CA-FF" ++ " )", BtOne "00") + , ("takes a part of bytes", raw "20-1F-EE-B5-90" ++ ".slice( 1, 3 )", BtMany ["1F", "EE", "B5"]) + , + ( "shifts right an even negative" + , raw "C0-43-00-00-00-00-00-00" ++ ".right( 1 )" + , BtMany ["60", "21", "80", "00", "00", "00", "00", "00"] + ) + , + ( "shifts right minus one" + , raw "BF-F0-00-00-00-00-00-00" ++ ".right( 4 )" + , BtMany ["0B", "FF", "00", "00", "00", "00", "00", "00"] + ) + , + ( "shifts right by the integer minimum" + , raw "BF-F0-00-00-00-00-00-00" ++ ".right( -2147483648 )" + , BtMany ["00", "00", "00", "00", "00", "00", "00", "00"] + ) + , + ( "recovers from an out-of-bounds slice" + , raw "20-1F-EE-B5-90" ++ ".slice( 3, 10, [[ message -> ?, @ -> \"recovered\" ]] )" + , BtMany ["72", "65", "63", "6F", "76", "65", "72", "65", "64"] + ) + , + ( "recovers from a slice whose start plus length overflows" + , raw "20-1F-EE-B5-90" ++ ".slice( 2000000000, 2000000000, [[ message -> ?, @ -> \"recovered\" ]] )" + , BtMany ["72", "65", "63", "6F", "76", "65", "72", "65", "64"] + ) + ] + testStuckAtom + [ ("cannot conjoin bytes of different lengths", raw "20-1F" ++ ".and( " ++ raw "CA-FE-BE" ++ " )") + , ("cannot disjoin bytes of different lengths", raw "20-1F" ++ ".or( " ++ raw "CA-FE-BE" ++ " )") + , ("cannot slice from an offset beyond the int range", raw "20-1F-EE-B5-90" ++ ".slice( 3000000000, 1 )") + , ("cannot slice a negative length", raw "20-1F-EE-B5-90" ++ ".slice( 1, -1 )") + ] diff --git a/test/MustSpec.hs b/test/MustSpec.hs --- a/test/MustSpec.hs +++ b/test/MustSpec.hs @@ -121,9 +121,9 @@ it desc $ (readMaybe input :: Maybe Must) `shouldBe` expected ) - describe "Read instance rejects empty range" $ - it "fails on dots only" $ - (readMaybe ".." :: Maybe Must) `shouldBe` Nothing + describe "Read instance parses empty range" $ + it "round-trips dots only" $ + (readMaybe ".." :: Maybe Must) `shouldBe` Just (MtRange Nothing Nothing) describe "Read instance rejects invalid range with negative minimum" $ it "fails on negative min" $ diff --git a/test/RandomSpec.hs b/test/RandomSpec.hs --- a/test/RandomSpec.hs +++ b/test/RandomSpec.hs @@ -44,10 +44,10 @@ result `shouldSatisfy` all isDigit describe "randomString with %d pattern length" $ - it "generates 1-4 digit number" $ do + it "generates a fixed 4-digit number" $ do result <- randomString "%d" let len = length result - len `shouldSatisfy` (\l -> l >= 1 && l <= 4) + len `shouldBe` 4 describe "randomString with %x pattern" $ it "generates hex digits" $ do diff --git a/test/RegexpSpec.hs b/test/RegexpSpec.hs --- a/test/RegexpSpec.hs +++ b/test/RegexpSpec.hs @@ -248,3 +248,13 @@ regex <- R.compile (B.pack "\\bword\\b") result <- R.replaceAll regex (B.pack "WORD") (B.pack "word in a word") result `shouldBe` B.pack "WORD in a WORD" + + it "terminates on an empty-match pattern (anchored ^)" $ do + regex <- R.compile (B.pack "^") + result <- R.replaceAll regex (B.pack "X") (B.pack "hello") + result `shouldBe` B.pack "XhXeXlXlXoX" + + it "terminates on an empty regex pattern" $ do + regex <- R.compile B.empty + result <- R.replaceAll regex (B.pack "X") (B.pack "hello") + result `shouldBe` B.pack "XhXeXlXlXoX" diff --git a/test/XMIRSpec.hs b/test/XMIRSpec.hs --- a/test/XMIRSpec.hs +++ b/test/XMIRSpec.hs @@ -237,3 +237,10 @@ (null failed) (expectationFailure ("Failed xpaths:\n - " ++ intercalate "\n - " failed ++ "\nXMIR is:\n" ++ printXMIR xmir')) ) + + describe "XMIR round-trip" $ + it "keeps λ function name and bound ρ" $ do + expr <- parseExpressionThrows "[[ k -> [[ x -> ?, L> Lorg_eolang_number_plus, ^ -> [[ y -> ? ]] ]] ]]" + xmir' <- expressionToXMIR expr defaultXmirContext + back <- xmirToPhi xmir' + back `shouldBe` expr