phino 0.0.109 → 0.0.110
raw patch · 20 files changed
+486/−93 lines, 20 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Render: renderFunc :: Render a => Text -> a -> Text
+ AST: dataBytes :: Bytes -> Expression
+ Bytes: btsAnd :: Bytes -> Bytes -> Maybe Bytes
+ Bytes: btsConcat :: Bytes -> Bytes -> Bytes
+ Bytes: btsEqual :: Bytes -> Bytes -> Bool
+ Bytes: btsNot :: Bytes -> Bytes
+ Bytes: btsOr :: Bytes -> Bytes -> Maybe Bytes
+ Bytes: btsShift :: Int -> Bytes -> Bytes
+ Bytes: btsSize :: Bytes -> Int
+ Bytes: btsSlice :: Int -> Int -> Bytes -> Maybe Bytes
Files
- README.md +40/−33
- phino.cabal +1/−1
- src/AST.hs +9/−12
- src/Bytes.hs +125/−2
- src/CLI/Helpers.hs +19/−16
- src/Dataize.hs +77/−1
- src/Functions.hs +1/−1
- src/Must.hs +1/−1
- src/Random.hs +2/−1
- src/Regexp.hs +7/−1
- src/Render.hs +3/−3
- src/Rule.hs +6/−6
- src/XMIR.hs +24/−10
- test/BuilderSpec.hs +12/−0
- test/CLISpec.hs +12/−0
- test/DataizeSpec.hs +125/−0
- test/MustSpec.hs +3/−3
- test/RandomSpec.hs +2/−2
- test/RegexpSpec.hs +10/−0
- test/XMIRSpec.hs +7/−0
README.md view
@@ -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. <!-- benchmark_end -->@@ -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
phino.cabal view
@@ -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 <https://github.com/objectionary/phino#readme>
src/AST.hs view
@@ -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]))
src/Bytes.hs view
@@ -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
src/CLI/Helpers.hs view
@@ -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
src/Dataize.hs view
@@ -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
src/Functions.hs view
@@ -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 =
src/Must.hs view
@@ -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) ->
src/Random.hs view
@@ -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)
src/Regexp.hs view
@@ -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])
src/Render.hs view
@@ -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
src/Rule.hs view
@@ -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"
src/XMIR.hs view
@@ -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
test/BuilderSpec.hs view
@@ -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
test/CLISpec.hs view
@@ -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 ↦ [[ ]]) ⟧" $
test/DataizeSpec.hs view
@@ -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 )")+ ]
test/MustSpec.hs view
@@ -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" $
test/RandomSpec.hs view
@@ -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
test/RegexpSpec.hs view
@@ -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"
test/XMIRSpec.hs view
@@ -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