phino 0.0.0.17 → 0.0.0.18
raw patch · 22 files changed
+627/−345 lines, 22 filesdep +arraydep +regex-tdfadep +transformersPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: array, regex-tdfa, transformers
API changes (from Hackage documentation)
- Ast: BiMetaDelta :: String -> Binding
- Builder: TeAttribute :: Attribute -> Term
- Builder: TeExpression :: Expression -> Term
- Builder: buildTermFromFunction :: String -> [ExtraArgument] -> Subst -> Program -> Maybe Term
- Builder: data Term
- Dataize: [maxDepth] :: DataizeContext -> Integer
- Dataize: [program] :: DataizeContext -> Program
- Dataize: defaultDataizeContext :: Program -> DataizeContext
- Misc: hexToNum :: String -> Either Integer Double
- Misc: hexToStr :: String -> String
- Misc: numToHex :: Double -> String
- Misc: strToHex :: String -> String
- Rewriter: [maxDepth] :: RewriteContext -> Integer
- Rewriter: [program] :: RewriteContext -> Program
- Rewriter: defaultRewriteContext :: Program -> RewriteContext
- Rewriter: instance GHC.Exception.Type.Exception Rewriter.RewriteException
- Rewriter: instance GHC.Show.Show Rewriter.RewriteException
+ Ast: BtEmpty :: Bytes
+ Ast: BtMany :: [String] -> Bytes
+ Ast: BtMeta :: String -> Bytes
+ Ast: BtOne :: String -> Bytes
+ Ast: countNodes :: Program -> Integer
+ Ast: data Bytes
+ Ast: instance GHC.Classes.Eq Ast.Bytes
+ Ast: instance GHC.Generics.Generic Ast.Bytes
+ Ast: instance GHC.Show.Show Ast.Bytes
+ Builder: CouldNotBuildAttribute :: Attribute -> Subst -> BuildException
+ Builder: CouldNotBuildBinding :: Binding -> Subst -> BuildException
+ Builder: CouldNotBuildBytes :: Bytes -> Subst -> BuildException
+ Builder: CouldNotBuildExpression :: Expression -> Subst -> BuildException
+ Builder: [_attr] :: BuildException -> Attribute
+ Builder: [_bd] :: BuildException -> Binding
+ Builder: [_bts] :: BuildException -> Bytes
+ Builder: [_expr] :: BuildException -> Expression
+ Builder: [_subst] :: BuildException -> Subst
+ Builder: buildAttributeThrows :: Attribute -> Subst -> IO Attribute
+ Builder: buildBindingThrows :: Binding -> Subst -> IO [Binding]
+ Builder: buildBytes :: Bytes -> Subst -> Maybe Bytes
+ Builder: buildBytesThrows :: Bytes -> Subst -> IO Bytes
+ Builder: buildExpressionThrows :: Expression -> Subst -> IO (Expression, Expression)
+ Builder: data BuildException
+ Builder: instance GHC.Exception.Type.Exception Builder.BuildException
+ Builder: instance GHC.Show.Show Builder.BuildException
+ Dataize: [_buildTerm] :: DataizeContext -> BuildTermFunc
+ Dataize: [_maxDepth] :: DataizeContext -> Integer
+ Dataize: [_program] :: DataizeContext -> Program
+ Functions: argToStrBytes :: ExtraArgument -> Subst -> Program -> IO String
+ Functions: buildTermFromFunction :: String -> [ExtraArgument] -> Subst -> Program -> IO Term
+ Functions: perlToPosix :: ByteString -> ByteString
+ Misc: btsToNum :: Bytes -> Either Integer Double
+ Misc: btsToStr :: Bytes -> String
+ Misc: btsToUnescapedStr :: Bytes -> String
+ Misc: bytesToBts :: String -> Bytes
+ Misc: numToBts :: Double -> Bytes
+ Misc: strToBts :: String -> Bytes
+ Parser: parseBytes :: String -> Either String Bytes
+ Pretty: instance Prettyprinter.Internal.Pretty Ast.Bytes
+ Pretty: instance Prettyprinter.Internal.Pretty Yaml.ExtraArgument
+ Pretty: prettyBytes :: Bytes -> String
+ Pretty: prettyExpression' :: Expression -> String
+ Pretty: prettyExtraArg :: ExtraArgument -> String
+ Pretty: prettySubst :: Subst -> String
+ Replacer: instance GHC.Exception.Type.Exception Replacer.ReplaceException
+ Replacer: instance GHC.Show.Show Replacer.ReplaceException
+ Replacer: replaceProgramThrows :: Program -> [Expression] -> [Expression] -> IO Program
+ Rewriter: [_buildTerm] :: RewriteContext -> BuildTermFunc
+ Rewriter: [_maxDepth] :: RewriteContext -> Integer
+ Rewriter: [_program] :: RewriteContext -> Program
+ Term: TeAttribute :: Attribute -> Term
+ Term: TeBytes :: Bytes -> Term
+ Term: TeExpression :: Expression -> Term
+ Term: data Term
+ Term: type BuildTermFunc = String -> [ExtraArgument] -> Subst -> Program -> IO Term
+ Yaml: ArgBytes :: Bytes -> ExtraArgument
+ Yaml: instance Data.Aeson.Types.FromJSON.FromJSON Ast.Bytes
- Ast: BiDelta :: String -> Binding
+ Ast: BiDelta :: Bytes -> Binding
- Builder: buildExpressions :: Expression -> [Subst] -> Maybe [(Expression, Expression)]
+ Builder: buildExpressions :: Expression -> [Subst] -> IO [(Expression, Expression)]
- Dataize: DataizeContext :: Program -> Integer -> DataizeContext
+ Dataize: DataizeContext :: Program -> Integer -> BuildTermFunc -> DataizeContext
- Dataize: dataize :: Program -> DataizeContext -> IO (Maybe String)
+ Dataize: dataize :: Program -> DataizeContext -> IO (Maybe Bytes)
- Dataize: dataize' :: Expression -> DataizeContext -> IO (Maybe String)
+ Dataize: dataize' :: Expression -> DataizeContext -> IO (Maybe Bytes)
- Matcher: MvBytes :: String -> MetaValue
+ Matcher: MvBytes :: Bytes -> MetaValue
- Misc: pattern DataObject :: String -> String -> Expression
+ Misc: pattern DataObject :: String -> Bytes -> Expression
- Rewriter: RewriteContext :: Program -> Integer -> RewriteContext
+ Rewriter: RewriteContext :: Program -> Integer -> BuildTermFunc -> RewriteContext
- Rewriter: rewrite :: Program -> Program -> [Rule] -> IO Program
+ Rewriter: rewrite :: Program -> [Rule] -> RewriteContext -> IO Program
Files
- phino.cabal +7/−2
- src/Ast.hs +43/−23
- src/Builder.hs +70/−49
- src/CLI.hs +11/−8
- src/Dataize.hs +20/−21
- src/Functions.hs +142/−0
- src/Logger.hs +2/−4
- src/Matcher.hs +4/−4
- src/Misc.hs +98/−72
- src/Parser.hs +18/−28
- src/Pretty.hs +32/−3
- src/Replacer.hs +21/−1
- src/Rewriter.hs +76/−76
- src/Term.hs +18/−0
- src/XMIR.hs +8/−8
- src/Yaml.hs +6/−1
- test/BuilderSpec.hs +10/−9
- test/DataizeSpec.hs +18/−14
- test/MatcherSpec.hs +11/−11
- test/ParserSpec.hs +8/−8
- test/ReplacerSpec.hs +2/−2
- test/RewriterSpec.hs +2/−1
phino.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 name: phino-version: 0.0.0.17+version: 0.0.0.18 license: MIT synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions description: Please see the README on GitHub at <https://github.com/objectionary/phino#readme>@@ -34,6 +34,8 @@ Yaml, Condition, Dataize,+ Functions,+ Term, Misc, Logger, Pretty,@@ -62,7 +64,10 @@ vector, random, xml-conduit ^>=1.10,- time ^>=1.12+ time ^>=1.12,+ transformers,+ regex-tdfa,+ array default-language: Haskell2010 -- Executable using the library
src/Ast.hs view
@@ -1,42 +1,62 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -- This module represents Ast tree for parsed phi-calculus program module Ast where+ import GHC.Generics (Generic) -newtype Program = Program Expression -- Q -> expr+newtype Program = Program Expression -- Q -> expr deriving (Eq, Show) data Expression- = ExFormation [Binding] -- [bindings]- | ExThis -- $- | ExGlobal -- Q- | ExTermination -- T- | ExMeta String -- !e- | ExApplication Expression Binding -- expr(attr -> expr)- | ExDispatch Expression Attribute -- expr.attr- | ExMetaTail Expression String -- expr * !t+ = ExFormation [Binding] -- [bindings]+ | ExThis+ | ExGlobal -- Q+ | ExTermination -- T+ | ExMeta String -- !e+ | ExApplication Expression Binding -- expr(attr -> expr)+ | ExDispatch Expression Attribute -- expr.attr+ | ExMetaTail Expression String -- expr * !t deriving (Eq, Show, Generic) data Binding- = BiTau Attribute Expression -- attr -> expr- | BiMeta String -- !B- | BiDelta String -- D> 1F-2A- | BiMetaDelta String -- D> !b- | BiVoid Attribute -- attr -> ?- | BiLambda String -- L> Function- | BiMetaLambda String -- L> !F+ = BiTau Attribute Expression -- attr -> expr+ | BiMeta String -- !B+ | BiDelta Bytes -- Δ ⤍ 1F-2A+ | BiVoid Attribute -- attr ↦ ?+ | BiLambda String -- λ ⤍ Function+ | BiMetaLambda String -- λ ⤍ !F deriving (Eq, Show, Generic) +data Bytes+ = BtEmpty -- --+ | BtOne String -- 1F-+ | BtMany [String] -- 00-01-02-...04+ | BtMeta String -- !b+ deriving (Eq, Show, Generic)+ data Attribute- = AtLabel String -- attr- | AtAlpha Integer -- ~1- | AtPhi -- @- | AtRho -- ^- | AtLambda -- λ, used only in yaml conditions- | AtDelta -- Δ, used only in yaml conditions- | AtMeta String -- !a+ = AtLabel String -- attr+ | AtAlpha Integer -- α1+ | AtPhi -- φ+ | AtRho -- ρ+ | AtLambda -- λ, used only in yaml conditions+ | AtDelta -- Δ, used only in yaml conditions+ | AtMeta String -- !a deriving (Eq, Show, Generic)++countNodes :: Program -> Integer+countNodes (Program expr) = countNodes' expr+ where+ countNodes' :: Expression -> Integer+ countNodes' ExGlobal = 1+ countNodes' ExTermination = 1+ countNodes' ExThis = 1+ countNodes' (ExApplication expr' (BiTau attr bexpr')) = 2 + countNodes' expr' + countNodes' bexpr'+ countNodes' (ExDispatch expr' attr) = 2 + countNodes' expr'+ countNodes' (ExFormation bds) = 1 + sum (map (\case BiTau attr expr' -> countNodes' expr'; _ -> 1) bds)+ countNodes' _ = 0
src/Builder.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE RecordWildCards #-}+ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT @@ -7,22 +10,55 @@ module Builder ( buildExpressions, buildExpression,- buildTermFromFunction,+ buildExpressionThrows, buildAttribute,+ buildAttributeThrows, buildBinding,+ buildBindingThrows,+ buildBytes,+ buildBytesThrows, contextualize,- Term (..),+ BuildException (..), ) where import Ast+import Control.Exception (Exception, throwIO) import qualified Data.Map.Strict as Map import Matcher-import Pretty (prettyAttribute)+import Pretty (prettyAttribute, prettyBinding, prettyExpression, prettySubst, prettyBytes)+import Text.Printf (printf) import Yaml (ExtraArgument (..)) -data Term = TeExpression Expression | TeAttribute Attribute+data BuildException+ = CouldNotBuildExpression {_expr :: Expression, _subst :: Subst}+ | CouldNotBuildAttribute {_attr :: Attribute, _subst :: Subst}+ | CouldNotBuildBinding {_bd :: Binding, _subst :: Subst}+ | CouldNotBuildBytes {_bts :: Bytes, _subst :: Subst}+ deriving (Exception) +instance Show BuildException where+ show CouldNotBuildExpression {..} =+ printf+ "Couldn't build given expression with provided substitutions\n--Expression: %s\n--Substitutions: %s"+ (prettyExpression _expr)+ (prettySubst _subst)+ show CouldNotBuildAttribute {..} =+ printf+ "Couldn't build given attribute with provided substitutions\n--Attribute: %s\n--Substitutions: %s"+ (prettyAttribute _attr)+ (prettySubst _subst)+ show CouldNotBuildBinding {..} =+ printf+ "Couldn't build given binding with provided substitutions\n--Binding: %s\n--Substitutions: %s"+ (prettyBinding _bd)+ (prettySubst _subst)+ show CouldNotBuildBytes {..} =+ printf+ "Couldn't build given bytes with provided substitutions\n--Bytes: %s\n--Substitutions: %s"+ (prettyBytes _bts)+ (prettySubst _subst)+ contextualize :: Expression -> Expression -> Program -> Expression contextualize ExGlobal _ (Program expr) = expr contextualize ExThis expr _ = expr@@ -40,6 +76,12 @@ _ -> Nothing buildAttribute attr _ = Just attr +buildBytes :: Bytes -> Subst -> Maybe Bytes+buildBytes (BtMeta meta) (Subst mp) = case Map.lookup meta mp of+ Just (MvBytes bytes) -> Just bytes+ _ -> Nothing+buildBytes bts _ = Just bts+ -- Build binding -- The function returns [Binding] because the BiMeta is always attached -- to the list of bindings@@ -54,9 +96,9 @@ buildBinding (BiMeta meta) (Subst mp) = case Map.lookup meta mp of Just (MvBindings bds) -> Just bds _ -> Nothing-buildBinding (BiMetaDelta meta) (Subst mp) = case Map.lookup meta mp of- Just (MvBytes bytes) -> Just [BiDelta bytes]- _ -> Nothing+buildBinding (BiDelta bytes) subst = do+ bts <- buildBytes bytes subst+ Just [BiDelta bts] buildBinding (BiMetaLambda meta) (Subst mp) = case Map.lookup meta mp of Just (MvFunction func) -> Just [BiLambda func] _ -> Nothing@@ -105,47 +147,26 @@ _ -> Nothing buildExpression expr _ = Just (expr, defaultScope) -buildTermFromFunction :: String -> [ExtraArgument] -> Subst -> Program -> Maybe Term-buildTermFromFunction "contextualize" [ArgExpression expr, ArgExpression context] subst prog = do- (expr', _) <- buildExpression expr subst- (context', _) <- buildExpression context subst- return (TeExpression (contextualize expr' context' prog))-buildTermFromFunction "scope" [ArgExpression expr] subst prog = do- (expr', scope) <- buildExpression expr subst- return (TeExpression scope)-buildTermFromFunction "random-tau" args subst _ = do- attrs <- argsToAttrs args- return (TeAttribute (AtLabel (randomTau 0 attrs)))- where- argsToAttrs :: [ExtraArgument] -> Maybe [String]- argsToAttrs [] = Just []- argsToAttrs (arg : rest) = case arg of- ArgExpression _ -> argsToAttrs rest- ArgAttribute attr -> do- attr' <- buildAttribute attr subst- rest' <- argsToAttrs rest- Just (prettyAttribute attr' : rest')- ArgBinding bd -> do- bds <- buildBinding bd subst- rest' <- argsToAttrs rest- Just (attrsFromBindings bds ++ rest')- attrsFromBindings :: [Binding] -> [String]- attrsFromBindings [] = []- attrsFromBindings (bd : bds) =- let attr = case bd of- BiTau attr _ -> attr- BiDelta _ -> AtDelta- BiLambda _ -> AtLambda- BiVoid attr -> attr- in prettyAttribute attr : attrsFromBindings bds- randomTau :: Integer -> [String] -> String- randomTau _ [] = cactoos- randomTau idx attrs =- let tau = if idx == 0 then cactoos else cactoos ++ show idx- in if tau `elem` attrs then randomTau (idx + 1) attrs else tau- cactoos = "a🌵"-buildTermFromFunction _ _ _ _ = Nothing+buildBytesThrows :: Bytes -> Subst -> IO Bytes+buildBytesThrows bytes subst = case buildBytes bytes subst of+ Just bts -> pure bts+ _ -> throwIO (CouldNotBuildBytes bytes subst) +buildBindingThrows :: Binding -> Subst -> IO [Binding]+buildBindingThrows bd subst = case buildBinding bd subst of+ Just bds -> pure bds+ _ -> throwIO (CouldNotBuildBinding bd subst)++buildAttributeThrows :: Attribute -> Subst -> IO Attribute+buildAttributeThrows attr subst = case buildAttribute attr subst of+ Just attr' -> pure attr'+ _ -> throwIO (CouldNotBuildAttribute attr subst)++buildExpressionThrows :: Expression -> Subst -> IO (Expression, Expression)+buildExpressionThrows expr subst = case buildExpression expr subst of+ Just built -> pure built+ _ -> throwIO (CouldNotBuildExpression expr subst)+ -- Build a several expression from one expression and several substitutions-buildExpressions :: Expression -> [Subst] -> Maybe [(Expression, Expression)]-buildExpressions expr = traverse (buildExpression expr)+buildExpressions :: Expression -> [Subst] -> IO [(Expression, Expression)]+buildExpressions expr = traverse (buildExpressionThrows expr)
src/CLI.hs view
@@ -16,15 +16,17 @@ import Data.Char (toLower, toUpper) import Data.List (intercalate) import Data.Version (showVersion)-import Dataize (dataize, DataizeContext (DataizeContext))+import Dataize (DataizeContext (DataizeContext), dataize)+import Functions (buildTermFromFunction)+import qualified Functions import Logger import Misc (ensuredFile) import qualified Misc import Options.Applicative import Parser (parseProgramThrows) import Paths_phino (version)-import Pretty (PrintMode (SALTY, SWEET), prettyProgram')-import Rewriter (rewrite', RewriteContext (RewriteContext))+import Pretty (PrintMode (SALTY, SWEET), prettyProgram', prettyBytes)+import Rewriter (RewriteContext (RewriteContext), rewrite') import System.Exit (ExitCode (..), exitFailure) import System.IO (getContents') import Text.Printf (printf)@@ -179,7 +181,7 @@ input <- readInput inputFile rules' <- getRules program <- parseProgram input inputFormat- rewritten <- rewrite' program rules' (RewriteContext program maxDepth)+ rewritten <- rewrite' program rules' (RewriteContext program maxDepth buildTermFromFunction) logDebug (printf "Printing rewritten 𝜑-program as %s" (show outputFormat)) out <- printProgram rewritten outputFormat printMode putStrLn out@@ -194,8 +196,9 @@ else if normalize then do- logDebug "The --normalize option is provided, built-it normalization rules are used"- pure normalizationRules+ 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 throwIO (InvalidRewriteArguments "no --rule, no --normalize, no --nothing are provided")@@ -217,8 +220,8 @@ validateMaxDepth maxDepth input <- readInput inputFile prog <- parseProgram input inputFormat- dataized <- dataize prog (DataizeContext prog maxDepth)- maybe (throwIO CouldNotDataize) putStrLn dataized+ dataized <- dataize prog (DataizeContext prog maxDepth buildTermFromFunction)+ maybe (throwIO CouldNotDataize) (putStrLn . prettyBytes) dataized where validateMaxDepth :: Integer -> IO () validateMaxDepth depth =
src/Dataize.hs view
@@ -4,7 +4,7 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module Dataize (morph, dataize, dataize', DataizeContext (..), defaultDataizeContext) where+module Dataize (morph, dataize, dataize', DataizeContext (..)) where import Ast import Builder (contextualize)@@ -13,20 +13,19 @@ import Data.List (partition) import Misc import Rewriter (RewriteContext (RewriteContext), rewrite')+import Term (BuildTermFunc) import Text.Printf (printf) import XMIR (XmirContext (XmirContext)) import Yaml (normalizationRules) data DataizeContext = DataizeContext- { program :: Program,- maxDepth :: Integer+ { _program :: Program,+ _maxDepth :: Integer,+ _buildTerm :: BuildTermFunc } -defaultDataizeContext :: Program -> DataizeContext-defaultDataizeContext prog = DataizeContext prog 25- switchContext :: DataizeContext -> RewriteContext-switchContext DataizeContext {..} = RewriteContext program maxDepth+switchContext DataizeContext {..} = RewriteContext _program _maxDepth _buildTerm maybeBinding :: (Binding -> Bool) -> [Binding] -> (Maybe Binding, [Binding]) maybeBinding _ [] = (Nothing, [])@@ -81,10 +80,10 @@ Just obj -> pure (Just (ExDispatch obj attr)) _ -> pure Nothing withTail (ExFormation bds) ctx = formation bds ctx-withTail (ExDispatch (ExDispatch ExGlobal (AtLabel label)) attr) (DataizeContext {program = Program expr}) = case phiDispatch label expr of+withTail (ExDispatch (ExDispatch ExGlobal (AtLabel label)) attr) (DataizeContext {_program = Program expr}) = case phiDispatch label expr of Just obj -> pure (Just (ExDispatch obj attr)) _ -> pure Nothing-withTail (ExDispatch ExGlobal (AtLabel label)) (DataizeContext {program = Program expr}) = pure (phiDispatch label expr)+withTail (ExDispatch ExGlobal (AtLabel label)) (DataizeContext {_program = Program expr}) = pure (phiDispatch label expr) withTail (ExDispatch expr attr) ctx = do exp' <- withTail expr ctx case exp' of@@ -128,10 +127,10 @@ -- BOX: D([B1, 𝜑 -> e, B2]) -> D(С(e)) if [B1,B2] has no delta/lambda, where С(e) - contextualization -- NORM: D(e1) -> D(e2) if e2 := M(e1) and e1 is not primitive -- nothing otherwise-dataize :: Program -> DataizeContext -> IO (Maybe String)+dataize :: Program -> DataizeContext -> IO (Maybe Bytes) dataize (Program expr) = dataize' expr -dataize' :: Expression -> DataizeContext -> IO (Maybe String)+dataize' :: Expression -> DataizeContext -> IO (Maybe Bytes) dataize' ExTermination _ = pure Nothing dataize' (ExFormation bds) ctx = case maybeDelta bds of (Just (BiDelta bytes), _) -> pure (Just bytes)@@ -139,7 +138,7 @@ (Just (BiTau AtPhi expr), bds') -> case maybeLambda bds' of (Just (BiLambda _), _) -> throwIO (userError "The 𝜑 and λ can't be present in formation at the same time") (_, _) ->- let expr' = contextualize expr (ExFormation bds) (program ctx)+ let expr' = contextualize expr (ExFormation bds) (_program ctx) in dataize' expr' ctx (Nothing, _) -> case maybeLambda bds of (Just (BiLambda _), _) -> do@@ -163,30 +162,30 @@ right <- dataize' (ExDispatch self AtRho) ctx case (left, right) of (Just left', Just right') -> do- let first = either toDouble id (hexToNum left')- second = either toDouble id (hexToNum right')+ let first = either toDouble id (btsToNum left')+ second = either toDouble id (btsToNum right') sum = first + second- pure (Just (DataObject "number" (numToHex sum)))+ pure (Just (DataObject "number" (numToBts sum))) _ -> pure Nothing atom "L_org_eolang_number_times" self ctx = do left <- dataize' (ExDispatch self (AtLabel "x")) ctx right <- dataize' (ExDispatch self AtRho) ctx case (left, right) of (Just left', Just right') -> do- let first = either toDouble id (hexToNum left')- second = either toDouble id (hexToNum right')+ let first = either toDouble id (btsToNum left')+ second = either toDouble id (btsToNum right') sum = first * second- pure (Just (DataObject "number" (numToHex sum)))+ pure (Just (DataObject "number" (numToBts sum))) _ -> pure Nothing atom "L_org_eolang_number_eq" self ctx = do x <- dataize' (ExDispatch self (AtLabel "x")) ctx rho <- dataize' (ExDispatch self AtRho) ctx case (x, rho) of (Just x', Just rho') -> do- let self' = either toDouble id (hexToNum rho')- first = either toDouble id (hexToNum x')+ let self' = either toDouble id (btsToNum rho')+ first = either toDouble id (btsToNum x') if self' == first- then pure (Just (DataObject "number" (numToHex first)))+ then pure (Just (DataObject "number" (numToBts first))) else pure (Just (ExDispatch self (AtLabel "y"))) _ -> pure Nothing atom func _ _ = throwIO (userError (printf "Atom '%s' does not exist" func))
+ src/Functions.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE OverloadedStrings #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module Functions where++import Ast+import Builder+import Control.Exception (throwIO)+import Data.Array ((!))+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as B+import Data.Maybe (catMaybes, mapMaybe)+import Matcher+import Misc+import Pretty+import Term+import Text.Printf (printf)+import Text.Regex.TDFA+import Yaml++argToStrBytes :: ExtraArgument -> Subst -> Program -> IO String+argToStrBytes (ArgBytes bytes) subst _ = do+ bts <- buildBytesThrows bytes subst+ pure (btsToUnescapedStr bts)+argToStrBytes (ArgExpression expr) subst prog = do+ (TeBytes bts) <- buildTermFromFunction "dataize" [ArgExpression expr] subst prog+ pure (btsToUnescapedStr bts)+argToStrBytes arg _ _ = throwIO (userError (printf "Can't extract bytes from given argument: %s" (prettyExtraArg arg)))++-- Translate perl-like shorthand characters to posix equivalent.+-- >>> perlToPosix "\\s+\\W"+-- "[[:space:]]+[^[:alnum:]_]"+perlToPosix :: B.ByteString -> B.ByteString+perlToPosix bs = go bs B.empty+ where+ go input acc+ | B.null input = acc+ | B.isPrefixOf "\\s" input = go (B.drop 2 input) (acc `B.append` "[[:space:]]")+ | B.isPrefixOf "\\S" input = go (B.drop 2 input) (acc `B.append` "[^[:space:]]")+ | B.isPrefixOf "\\d" input = go (B.drop 2 input) (acc `B.append` "[[:digit:]]")+ | B.isPrefixOf "\\D" input = go (B.drop 2 input) (acc `B.append` "[^[:digit:]]")+ | B.isPrefixOf "\\w" input = go (B.drop 2 input) (acc `B.append` "[[:alnum:]_]")+ | B.isPrefixOf "\\W" input = go (B.drop 2 input) (acc `B.append` "[^[:alnum:]_]")+ | B.head input == '\\' && B.length input >= 2 =+ let escapedChar = B.take 2 input+ in go (B.drop 2 input) (acc `B.append` escapedChar)+ | otherwise = go (B.tail input) (acc `B.snoc` B.head input)++buildTermFromFunction :: String -> [ExtraArgument] -> Subst -> Program -> IO Term+buildTermFromFunction "contextualize" [ArgExpression expr, ArgExpression context] subst prog = do+ (expr', _) <- buildExpressionThrows expr subst+ (context', _) <- buildExpressionThrows context subst+ pure (TeExpression (contextualize expr' context' prog))+buildTermFromFunction "contextualize" _ _ _ = throwIO (userError "Function contextualize() requires exactly 2 arguments as expression")+buildTermFromFunction "scope" [ArgExpression expr] subst _ = do+ (expr', scope) <- buildExpressionThrows expr subst+ pure (TeExpression scope)+buildTermFromFunction "scope" _ _ _ = throwIO (userError "Function scope() requires exactly 1 argument as expression")+buildTermFromFunction "random-tau" args subst _ = do+ attrs <- argsToAttrs args+ pure (TeAttribute (AtLabel (randomTau 0 attrs)))+ where+ argsToAttrs :: [ExtraArgument] -> IO [String]+ argsToAttrs [] = pure []+ argsToAttrs (arg : rest) = case arg of+ ArgExpression _ -> argsToAttrs rest+ ArgAttribute attr -> do+ attr' <- buildAttributeThrows attr subst+ rest' <- argsToAttrs rest+ pure (prettyAttribute attr' : rest')+ ArgBinding bd -> do+ bds <- buildBindingThrows bd subst+ rest' <- argsToAttrs rest+ pure (attrsFromBindings bds ++ rest')+ ArgBytes _ -> throwIO (userError "Bytes can't be argument of random-tau() function")+ attrsFromBindings :: [Binding] -> [String]+ attrsFromBindings [] = []+ attrsFromBindings (bd : bds) =+ let attr = case bd of+ BiTau attr _ -> attr+ BiDelta _ -> AtDelta+ BiLambda _ -> AtLambda+ BiVoid attr -> attr+ in prettyAttribute attr : attrsFromBindings bds+ randomTau :: Integer -> [String] -> String+ randomTau idx attrs =+ let cactoos = "a🌵"+ tau = if idx == 0 then cactoos else cactoos ++ show idx+ in if tau `elem` attrs then randomTau (idx + 1) attrs else tau+buildTermFromFunction "dataize" [ArgExpression expr] subst _ = do+ (expr', _) <- buildExpressionThrows expr subst+ case expr' of+ DataObject _ bytes -> pure (TeBytes bytes)+ _ -> throwIO (userError "Only data objects are supported by 'dataize' function now")+buildTermFromFunction "dataize" _ _ _ = throwIO (userError "Function dataize() requires exactly 1 argument as expression")+buildTermFromFunction "concat" args subst prog = do+ args' <- traverse (\arg -> argToStrBytes arg subst prog) args+ pure (TeExpression (DataObject "string" (strToBts (concat args'))))+buildTermFromFunction "sed" [tgt, ptn] subst prog = do+ [tgt', ptn'] <- traverse (\arg -> argToStrBytes arg subst prog) [tgt, ptn]+ (pat, rep, global) <- parse (B.pack ptn')+ let pat' = perlToPosix pat+ res =+ if global+ then replaceAll pat' rep (B.pack tgt')+ else replaceFirst pat' rep (B.pack tgt')+ pure (TeExpression (DataObject "string" (strToBts (B.unpack res))))+ where+ parse :: B.ByteString -> IO (B.ByteString, B.ByteString, Bool)+ parse input =+ case B.stripPrefix "s/" input of+ Just rest ->+ let parts = B.split '/' rest+ in case parts of+ [pat, rep, "g"] -> pure (pat, rep, True)+ [pat, rep, ""] -> pure (pat, rep, False)+ [pat, rep] -> pure (pat, rep, False)+ _ ->+ throwIO+ (userError "The 'sed' 2nd argument must consist of three parts separated by '/', the last part must be either empty or 'g'")+ _ -> throwIO (userError "The 'sed' 2nd argument must start with 's/'")+ replaceFirst :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString+ replaceFirst pat rep input =+ let result :: MatchResult B.ByteString+ result = input =~ pat+ in if mrMatch result == ""+ then input+ else BS.concat [mrBefore result, rep, mrAfter result]+ replaceAll :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString+ replaceAll pat rep input =+ let matches = getAllMatches (input =~ pat :: AllMatches [] (Int, Int))+ in go 0 matches+ where+ go offset [] = BS.drop offset input+ go offset ((start, len) : rest) =+ let prefix = BS.take (start - offset) (BS.drop offset input)+ newOffset = start + len+ in BS.concat [prefix, rep, go newOffset rest]+buildTermFromFunction "sed" _ _ _ = throwIO (userError "Function sed() requires exactly 2 dataizable arguments")+buildTermFromFunction func _ _ _ = throwIO (userError (printf "Function %s() is not supported or does not exist" func))
src/Logger.hs view
@@ -7,7 +7,7 @@ logWarning, logError, setLogLevel,- LogLevel(DEBUG, INFO, WARNING, ERROR, NONE),+ LogLevel (DEBUG, INFO, WARNING, ERROR, NONE), ) where @@ -15,8 +15,6 @@ import Data.IORef (IORef, newIORef, readIORef, writeIORef) import GHC.IO (unsafePerformIO) import System.IO-import Text.Printf (printf)-import Options.Applicative (ReadM) data LogLevel = DEBUG | INFO | WARNING | ERROR | NONE deriving (Show, Ord, Eq, Bounded, Enum, Read)@@ -25,7 +23,7 @@ logger :: IORef Logger {-# NOINLINE logger #-}-logger = unsafePerformIO (newIORef (Logger INFO))+logger = unsafePerformIO (newIORef (Logger DEBUG)) setLogLevel :: LogLevel -> IO () setLogLevel lvl = writeIORef logger (Logger lvl)
src/Matcher.hs view
@@ -16,7 +16,7 @@ -- The right part of substitution data MetaValue = MvAttribute Attribute -- !a- | MvBytes String -- !b+ | MvBytes Bytes -- !b | MvBindings [Binding] -- !B | MvFunction String -- !F | MvExpression Expression Expression -- !e, the second expression is scope, which is closest formation@@ -70,10 +70,10 @@ matchBinding :: Binding -> Binding -> Expression -> [Subst] matchBinding (BiVoid pattr) (BiVoid tattr) _ = matchAttribute pattr tattr-matchBinding (BiDelta pbts) (BiDelta tbts) _- | pbts == tbts = [substEmpty]+matchBinding (BiDelta (BtMeta meta)) (BiDelta tdata) _ = [substSingle meta (MvBytes tdata)] +matchBinding (BiDelta pdata) (BiDelta tdata) _+ | pdata == tdata = [substEmpty] | otherwise = []-matchBinding (BiMetaDelta meta) (BiDelta tBts) _ = [substSingle meta (MvBytes tBts)] matchBinding (BiLambda pFunc) (BiLambda tFunc) _ | pFunc == tFunc = [substEmpty] | otherwise = []
src/Misc.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-}@@ -8,14 +9,16 @@ -- This module provides commonly used helper functions for other modules module Misc- ( numToHex,- strToHex,- hexToStr,- hexToNum,+ ( numToBts,+ strToBts,+ bytesToBts,+ btsToStr,+ btsToNum, withVoidRho, allPathsIn, ensuredFile, shuffle,+ btsToUnescapedStr, pattern DataObject, ) where@@ -27,7 +30,7 @@ import Data.Bits (Bits (shiftL), (.|.)) import qualified Data.Bits as IOArray import qualified Data.ByteString as B-import Data.ByteString.Builder (toLazyByteString, word64BE)+import Data.ByteString.Builder (toLazyByteString, word64BE, word8) import Data.ByteString.Lazy (unpack) import qualified Data.ByteString.Lazy.UTF8 as U import Data.Char (chr, isPrint, ord)@@ -53,7 +56,7 @@ show DirectoryDoesNotExist {..} = printf "Directory '%s' does not exist" dir -- Minimal matcher function (required for view pattern)-matchDataoObject :: Expression -> Maybe (String, String)+matchDataoObject :: Expression -> Maybe (String, Bytes) matchDataoObject ( ExApplication (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel label))@@ -70,7 +73,7 @@ ) = Just (label, bts) matchDataoObject _ = Nothing -pattern DataObject :: String -> String -> Expression+pattern DataObject :: String -> Bytes -> Expression pattern DataObject label bts <- (matchDataoObject -> Just (label, bts)) where DataObject label bts =@@ -124,35 +127,43 @@ ) return (concat paths) --- >>> hexToBts "40-14-00-00-00-00-00-00"+-- >>> 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]--- >>> hexToBts "68-65-6C-6C-6F"--- [104,101,108,108,111]--- >>> hexToBts "01-01"--- [1,1]-hexToBts :: String -> [Word8]-hexToBts = map readHexByte . splitOnDash- where- splitOnDash = words . map (\c -> if c == '-' then ' ' else c)- readHexByte hx = case readHex hx of- [(v, "")] -> fromIntegral v- _ -> error $ "Invalid hex byte: " ++ hx+btsToWord8 :: Bytes -> [Word8]+btsToWord8 BtEmpty = []+btsToWord8 (BtOne bt) = case readHex bt of+ [(hex, "")] -> [fromIntegral hex]+ _ -> error $ "Invalid hex byte; " ++ bt+btsToWord8 (BtMany []) = []+btsToWord8 (BtMany (bt : bts)) =+ let [next] = btsToWord8 (BtOne bt)+ in next : btsToWord8 (BtMany bts) -btsToHex :: [Word8] -> String-btsToHex bts = intercalate "-" (map (printf "%02X") bts)+-- >>> word8ToBytes [64, 20, 0]+-- BtMany ["40","14","00"]+word8ToBytes :: [Word8] -> Bytes+word8ToBytes [] = BtEmpty+word8ToBytes [w8] = BtOne (printf "%02X" w8)+word8ToBytes bts = BtMany (map (printf "%02X") bts) --- Convert hex string back to Double--- >>> hexToNum "40-14-00-00-00-00-00-00"+-- Convert Bytes back to Double+-- >>> btsToNum (BtMany ["40", "14", "00", "00", "00", "00", "00", "00"]) -- Left 5--- >>> hexToNum "BF-D0-00-00-00-00-00-00"+-- >>> btsToNum (BtMany ["BF", "D0", "00", "00", "00", "00", "00", "00"]) -- Right (-0.25)--- >>> hexToNum "40-45-00-00-00-00-00-00"+-- >>> btsToNum (BtMany ["40", "45", "00", "00", "00", "00", "00", "00"]) -- Left 42--- >>> hexToNum "40-45"+-- >>> btsToNum (BtMany ["40", "45"]) -- Expected 8 bytes for conversion, got 2-hexToNum :: String -> Either Integer Double-hexToNum hx =- let bytes = hexToBts hx+btsToNum :: Bytes -> Either Integer Double+btsToNum hx =+ let bytes = btsToWord8 hx in if length bytes /= 8 then error $ "Expected 8 bytes for conversion, got " ++ show (length bytes) else@@ -174,58 +185,64 @@ .|. fromIntegral h toWord64BE _ = error "Expected 8 bytes for Double" --- >>> numToHex 0.0--- "00-00-00-00-00-00-00-00"--- >>> numToHex 42--- "40-45-00-00-00-00-00-00"--- >>> numToHex (-0.25)--- "BF-D0-00-00-00-00-00-00"--- >>> numToHex 5--- "40-14-00-00-00-00-00-00"-numToHex :: Double -> String-numToHex num = btsToHex (unpack (toLazyByteString (word64BE (doubleToWord num))))+-- >>> 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)))) --- >>> strToHex "hello"--- "68-65-6C-6C-6F"--- >>> strToHex "world"--- "77-6F-72-6C-64"--- >>> strToHex ""--- "--"--- >>> strToHex "h"--- "68-"--- >>> strToHex "h\""--- "68-22"--- >>> strToHex "\x01\x01"--- "01-01"-strToHex :: String -> String-strToHex "" = "--"-strToHex [ch] = btsToHex (unpack (U.fromString [ch])) ++ "-"-strToHex str = btsToHex (unpack (U.fromString str))+-- >>> 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 :: 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"--- >>> hexToStr "68-65-6C-6C-6F"+-- >>> btsToStr (BtMany ["68", "65", "6C", "6C", "6F"]) -- "hello"--- >>> hexToStr "--"--- ""--- >>> hexToStr "68-"+-- >>> btsToStr (BtOne "68") -- "h"--- >>> hexToStr "77-6F-72-6C-64"+-- >>> btsToStr (BtMany ["77", "6F", "72", "6C", "64"]) -- "world"--- >>> hexToStr ""+-- >>> btsToStr BtEmpty -- ""--- >>> hexToStr "68-22"+-- >>> btsToStr (BtMany ["68", "22"]) -- "h\\\""--- >>> hexToStr "01-02"+-- >>> btsToStr (BtMany ["01", "02"]) -- "\\x01\\x02"-hexToStr :: String -> String-hexToStr "--" = ""-hexToStr [] = ""-hexToStr hx = escapeStr (T.unpack $ T.decodeUtf8 $ B.pack (hexToBts cleaned))+btsToStr :: Bytes -> String+btsToStr BtEmpty = ""+btsToStr bytes = escapeStr (btsToUnescapedStr bytes) where- -- Remove trailing dash if present (from single-char case)- cleaned :: String- cleaned = if not (null hx) && last hx == '-' then init hx else hx- escapeStr :: String -> String escapeStr = concatMap escapeChar where@@ -237,11 +254,20 @@ | 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 :: 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]--- [12,15,5,14,1,7,17,10,9,16,13,11,6,4,18,2,19,20,3,8]+-- [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
src/Parser.hs view
@@ -12,6 +12,7 @@ parseExpressionThrows, parseAttribute, parseBinding,+ parseBytes, ) where @@ -24,7 +25,7 @@ import Data.Text.Internal.Fusion.Size (lowerBound) import Data.Void import GHC.Char (chr)-import Misc (numToHex, strToHex, withVoidRho)+import Misc import Numeric (readHex) import Text.Megaparsec import Text.Megaparsec.Char (alphaNumChar, char, digitChar, hexDigitChar, letterChar, lowerChar, space1, string, upperChar)@@ -42,21 +43,6 @@ show CouldNotParseProgram {..} = printf "Couldn't parse given phi program, cause: %s" message show CouldNotParseExpression {..} = printf "Couldn't parse given phi program, cause: %s" message -dataExpression :: String -> String -> Expression-dataExpression obj bts =- ExApplication- (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel obj))- ( BiTau- (AtAlpha 0)- ( ExApplication- (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "bytes"))- ( BiTau- (AtAlpha 0)- (ExFormation [BiDelta bts, BiVoid AtRho])- )- )- )- -- White space consumer whiteSpace :: Parser () whiteSpace = L.space space1 empty empty@@ -186,22 +172,26 @@ | otherwise = fail ("expected 0-9 or A-F, got " ++ show ch) -- bytes+-- 0. meta: !b -- 1. empty: -- -- 2. one byte: 01- -- 3. many bytes: 01-02-...-FF-bytes :: Parser String+bytes :: Parser Bytes bytes = lexeme ( choice- [ symbol "--",+ [ BtMeta <$> meta' 'd' "δ",+ symbol "--" >> return BtEmpty, try $ do first <- byte rest <- some $ do- dash <- char '-'- bte <- byte- return (dash : bte)- return (first ++ concat rest),- byte >>= \bte -> char '-' >>= \dash -> return (bte ++ [dash])+ _ <- char '-'+ byte+ return (BtMany (first : rest)),+ do+ bte <- byte+ _ <- char '-'+ return (BtOne bte) ] <?> "bytes" )@@ -245,9 +235,6 @@ try $ do _ <- delta BiDelta <$> bytes,- try $ do- _ <- delta- BiMetaDelta <$> meta 'b', try metaBinding, try $ do _ <- lambda@@ -345,11 +332,11 @@ Just '-' -> negate unsigned _ -> unsigned )- return (dataExpression "number" (numToHex num)),+ return (DataObject "number" (numToBts num)), lexeme $ do _ <- char '"' str <- manyTill (choice [escapedChar, noneOf ['\\', '"']]) (char '"')- return (dataExpression "string" (strToHex str)),+ return (DataObject "string" (strToBts str)), try (ExMeta <$> meta' 'e' "𝑒"), ExDispatch ExThis <$> fullAttribute ]@@ -438,6 +425,9 @@ case parsed of Right parsed' -> Right parsed' Left err -> Left (errorBundlePretty err)++parseBytes :: String -> Either String Bytes+parseBytes = parse' "bytes" bytes parseBinding :: String -> Either String Binding parseBinding = parse' "binding" binding
src/Pretty.hs view
@@ -5,12 +5,16 @@ module Pretty ( prettyExpression,+ prettyExpression', prettyProgram, prettyProgram', prettyAttribute, prettySubsts, prettySubsts',+ prettySubst, prettyBinding,+ prettyBytes,+ prettyExtraArg, PrintMode (SWEET, SALTY), ) where@@ -21,6 +25,8 @@ import Prettyprinter import Prettyprinter.Render.String (renderString) import Misc+import Data.List (intercalate)+import Yaml (ExtraArgument (..)) data PrintMode = SWEET | SALTY deriving (Eq)@@ -46,6 +52,18 @@ prettyDashedArrow :: Doc ann prettyDashedArrow = pretty "⤍" +instance Pretty ExtraArgument where+ pretty (ArgExpression expr) = pretty (Formatted (SWEET, expr))+ pretty (ArgBinding bd) = pretty (Formatted (SWEET, bd))+ pretty (ArgAttribute attr) = pretty attr+ pretty (ArgBytes bytes) = pretty bytes++instance Pretty Bytes where+ pretty BtEmpty = pretty "--"+ pretty (BtOne bt) = pretty bt <> pretty "-"+ pretty (BtMany bts) = pretty (intercalate "-" bts)+ pretty (BtMeta meta) = prettyMeta meta+ instance Pretty Attribute where pretty (AtLabel name) = pretty name pretty (AtAlpha index) = pretty "α" <> pretty index@@ -77,7 +95,6 @@ pretty (Formatted (_, BiMeta meta)) = prettyMeta meta pretty (Formatted (_, BiDelta bytes)) = pretty "Δ" <+> prettyDashedArrow <+> pretty bytes pretty (Formatted (_, BiMetaLambda meta)) = pretty "λ" <+> prettyDashedArrow <+> prettyMeta meta- pretty (Formatted (_, BiMetaDelta meta)) = pretty "Δ" <+> prettyDashedArrow <+> prettyMeta meta pretty (Formatted (_, BiVoid attr)) = pretty attr <+> prettyArrow <+> pretty "∅" pretty (Formatted (_, BiLambda func)) = pretty "λ" <+> prettyDashedArrow <+> pretty func @@ -109,8 +126,8 @@ instance Pretty (Formatted Expression) where pretty (Formatted (SWEET, ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang"))) = pretty "Φ̇"- pretty (Formatted (SWEET, DataObject "string" bytes)) = pretty "\"" <> pretty (hexToStr bytes) <> pretty "\""- pretty (Formatted (SWEET, DataObject "number" bytes)) = either pretty pretty (hexToNum bytes)+ pretty (Formatted (SWEET, DataObject "string" bytes)) = pretty "\"" <> pretty (btsToStr bytes) <> pretty "\""+ pretty (Formatted (SWEET, DataObject "number" bytes)) = either pretty pretty (btsToNum bytes) pretty (Formatted (SWEET, DataObject other bytes)) = pretty (Formatted (SALTY, DataObject other bytes)) pretty (Formatted (mode, ExFormation [binding])) = case binding of BiTau _ _ -> vsep [pretty "⟦", indent 2 (pretty (Formatted (mode, binding))), pretty "⟧"]@@ -182,9 +199,18 @@ prettyBinding :: Binding -> String prettyBinding binding = render (Formatted (SALTY, binding)) +prettyExtraArg :: ExtraArgument -> String+prettyExtraArg = render++prettyBytes :: Bytes -> String+prettyBytes = render+ prettyAttribute :: Attribute -> String prettyAttribute = render +prettySubst :: Subst -> String+prettySubst = render+ prettySubsts :: [Subst] -> String prettySubsts = render @@ -193,6 +219,9 @@ prettyExpression :: Expression -> String prettyExpression expr = render (Formatted (SALTY, expr))++prettyExpression' :: Expression -> String+prettyExpression' expr = render (Formatted (SWEET, expr)) prettyProgram :: Program -> String prettyProgram prog = render (Formatted (SALTY, prog))
src/Replacer.hs view
@@ -1,13 +1,28 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE RecordWildCards #-}+ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -- The goal of the module is to traverse though the Program with replacing -- pattern sub expression with target expressions-module Replacer (replaceProgram) where+module Replacer (replaceProgram, replaceProgramThrows) where import Ast+import Control.Exception (Exception, throwIO) import Matcher (Tail (TaApplication, TaDispatch))+import Pretty (prettyExpression, prettyProgram)+import Text.Printf (printf) +newtype ReplaceException = CouldNotReplace {prog :: Program}+ deriving (Exception)++instance Show ReplaceException where+ show CouldNotReplace {..} =+ printf+ "Couldn't replace expression in program, lists of patterns and targets has different lengths\nProgram: %s"+ (prettyProgram prog)+ replaceBindings :: [Binding] -> [Expression] -> [Expression] -> ([Binding], [Expression], [Expression]) replaceBindings bds [] [] = (bds, [], []) replaceBindings [] ptns repls = ([], ptns, repls)@@ -45,3 +60,8 @@ let (expr', _, _) = replaceExpression expr ptns repls in Just (Program expr') | otherwise = Nothing++replaceProgramThrows :: Program -> [Expression] -> [Expression] -> IO Program+replaceProgramThrows prog ptns repls = case replaceProgram prog ptns repls of+ Just prog' -> pure prog'+ _ -> throwIO (CouldNotReplace prog)
src/Rewriter.hs view
@@ -1,109 +1,108 @@-{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module Rewriter (rewrite, rewrite', RewriteContext (..), defaultRewriteContext) where+module Rewriter (rewrite, rewrite', RewriteContext (..)) where import Ast import Builder import qualified Condition as C-import Control.Exception+import Data.Foldable (foldlM) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe, isJust) import Debug.Trace (trace) import Logger (logDebug)-import Matcher (MetaValue (MvAttribute, MvBindings, MvExpression), Subst (Subst), combine, combineMany, defaultScope, matchProgram, substEmpty, substSingle)+import Matcher (MetaValue (MvAttribute, MvBindings, MvExpression, MvBytes), Subst (Subst), combine, combineMany, defaultScope, matchProgram, substEmpty, substSingle) import Misc (ensuredFile) import Parser (parseProgram, parseProgramThrows)-import Pretty (PrintMode (SWEET), prettyAttribute, prettyExpression, prettyProgram, prettyProgram', prettySubsts)-import Replacer (replaceProgram)+import Pretty (PrintMode (SWEET), prettyAttribute, prettyExpression, prettyExpression', prettyProgram, prettyProgram', prettySubsts, prettyBytes)+import Replacer (replaceProgram, replaceProgramThrows)+import Term import Text.Printf import Yaml (ExtraArgument (..)) import qualified Yaml as Y data RewriteContext = RewriteContext- { program :: Program,- maxDepth :: Integer+ { _program :: Program,+ _maxDepth :: Integer,+ _buildTerm :: BuildTermFunc } -defaultRewriteContext :: Program -> RewriteContext-defaultRewriteContext prog = RewriteContext prog 25--data RewriteException- = CouldNotBuild {expr :: Expression, substs :: [Subst]}- | CouldNotReplace {prog :: Program, ptn :: Expression, res :: Expression}- deriving (Exception)--instance Show RewriteException where- show CouldNotBuild {..} =- printf- "Couldn't build given expression with provided substitutions\n--Expression: %s\n--Substitutions: %s"- (prettyExpression expr)- (prettySubsts substs)- show CouldNotReplace {..} =- printf- "Couldn't replace expression in program by pattern\nProgram: %s\n--Pattern: %s\n--Result: %s"- (prettyProgram prog)- (prettyExpression ptn)- (prettyExpression res)- -- Build pattern and result expression and replace patterns to results in given program buildAndReplace :: Program -> Expression -> Expression -> [Subst] -> IO Program-buildAndReplace program ptn res substs =- case (buildExpressions ptn substs, buildExpressions res substs) of- (Just ptns, Just repls) ->- let repls' = map fst repls- ptns' = map fst ptns- in case replaceProgram program ptns' repls' of- Just prog -> pure prog- _ -> throwIO (CouldNotReplace program ptn res)- (Nothing, _) -> throwIO (CouldNotBuild ptn substs)- (_, Nothing) -> throwIO (CouldNotBuild res substs)+buildAndReplace program ptn res substs = do+ ptns <- buildExpressions ptn substs+ repls <- buildExpressions res substs+ let repls' = map fst repls+ ptns' = map fst ptns+ replaceProgramThrows program ptns' repls' -- Extend list of given substitutions with extra substitutions from 'where' yaml rule section-extraSubstitutions :: Program -> Maybe [Y.Extra] -> [Subst] -> [Subst]-extraSubstitutions prog extras substs = case extras of- Nothing -> substs- Just extras' ->- catMaybes- [ foldl- ( \(Just subst') extra -> do- name <- case Y.meta extra of- ArgExpression (ExMeta name) -> Just name- ArgAttribute (AtMeta name) -> Just name- ArgBinding (BiMeta name) -> Just name- _ -> Nothing- let func = Y.function extra- args = Y.args extra- term <- buildTermFromFunction func args subst' prog- let meta = case term of- TeExpression expr -> MvExpression expr defaultScope- TeAttribute attr -> MvAttribute attr- combine (substSingle name meta) subst'- )- (Just subst)- extras'- | subst <- substs- ]+extraSubstitutions :: Maybe [Y.Extra] -> [Subst] -> RewriteContext -> IO [Subst]+extraSubstitutions extras substs RewriteContext {..} = case extras of+ Nothing -> pure substs+ Just extras' -> do+ res <-+ sequence+ [ foldlM+ ( \(Just subst') extra -> do+ let maybeName = case Y.meta extra of+ ArgExpression (ExMeta name) -> Just name+ ArgAttribute (AtMeta name) -> Just name+ ArgBinding (BiMeta name) -> Just name+ ArgBytes (BtMeta name) -> Just name+ _ -> Nothing+ func = Y.function extra+ args = Y.args extra+ term <- _buildTerm func args subst' _program+ meta <- case term of+ TeExpression expr -> do+ logDebug (printf "Function %s() returned expression:\n%s" func (prettyExpression' expr))+ pure (MvExpression expr defaultScope)+ TeAttribute attr -> do+ logDebug (printf "Function %s() returned attribute:\n%s" func (prettyAttribute attr))+ pure (MvAttribute attr)+ TeBytes bytes -> do+ logDebug (printf "Function %s() returned bytes: %s" func (prettyBytes bytes))+ pure (MvBytes bytes)+ case maybeName of+ Just name -> pure (combine (substSingle name meta) subst')+ _ -> pure Nothing+ )+ (Just subst)+ extras'+ | subst <- substs+ ]+ pure (catMaybes res) -rewrite :: Program -> Program -> [Y.Rule] -> IO Program-rewrite program _ [] = pure program-rewrite program program' (rule : rest) = do+rewrite :: Program -> [Y.Rule] -> RewriteContext -> IO Program+rewrite program [] _ = pure program+rewrite program (rule : rest) ctx = do let ptn = Y.pattern rule res = Y.result rule condition = Y.when rule prog <- case C.matchProgramWithCondition ptn condition program of Nothing -> pure program Just matched -> do- let substs = extraSubstitutions program' (Y.where_ rule) matched+ let ruleName = fromMaybe "unknown" (Y.name rule)+ logDebug (printf "Rule '%s' has been matched, applying..." ruleName)+ substs <- extraSubstitutions (Y.where_ rule) matched ctx prog' <- buildAndReplace program ptn res substs- logDebug (printf "%s\n%s" (fromMaybe "unknown" (Y.name rule)) (prettyProgram' prog' SWEET))+ if program == prog'+ then logDebug (printf "Applied '%s', no changes made" ruleName)+ else+ logDebug+ ( printf+ "Applied '%s' (%d nodes -> %d nodes):\n%s"+ ruleName+ (countNodes program)+ (countNodes prog')+ (prettyProgram' prog' SWEET)+ ) pure prog'- rewrite prog program' rest+ rewrite prog rest ctx -- @todo #169:30min Memorize previous rewritten programs. Right now in order not to -- get an infinite recursion during rewriting we just count have many times we apply@@ -113,19 +112,20 @@ -- been memorized - we fail because we got into infinite recursion. Ofc we should keep counting -- rewriting cycles if program just only grows on each rewriting. rewrite' :: Program -> [Y.Rule] -> RewriteContext -> IO Program-rewrite' prog rules RewriteContext {..} = _rewrite prog 0+rewrite' prog rules ctx = _rewrite prog 0 where _rewrite :: Program -> Integer -> IO Program _rewrite prog count = do- logDebug (printf "Starting rewriting cycle %d out of %d" count maxDepth)- if count == maxDepth+ let depth = _maxDepth ctx+ logDebug (printf "Starting rewriting cycle %d out of %d" count depth)+ if count == depth then do- logDebug (printf "Max amount of rewriting cycles is reached, rewriting is stopped")+ logDebug (printf "Max amount of rewriting cycles has been reached, rewriting is stopped") pure prog else do- rewritten <- rewrite prog program rules+ rewritten <- rewrite prog rules ctx if rewritten == prog then do- logDebug "Rewriting is stopped since it does not affect program anymore"+ logDebug "No rule matched, rewriting is stopped" pure rewritten else _rewrite rewritten (count + 1)
+ src/Term.hs view
@@ -0,0 +1,18 @@+-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++-- The main goal of this module is breking cyclic dependency:+-- Dataize -> Functions -> Rewriter -> Dataize+-- Here we provide custom type BuildTermFunc and add it to+-- RewriteContext and DataizeContext. Now Dataize and Rewrite depends+-- only on Term module. This allows us to use Rewriter and Dataize in+-- Functions module because Rewriter does not depend on Functions anymore.+module Term where+ +import Yaml+import Matcher+import Ast++data Term = TeExpression Expression | TeAttribute Attribute | TeBytes Bytes++type BuildTermFunc = String -> [ExtraArgument] -> Subst -> Program -> IO Term
src/XMIR.hs view
@@ -28,7 +28,7 @@ import Data.Version (showVersion) import Misc import Paths_phino (version)-import Pretty (PrintMode, prettyAttribute, prettyBinding, prettyExpression, prettyProgram')+import Pretty (PrintMode, prettyAttribute, prettyBinding, prettyBytes, prettyExpression, prettyProgram') import Text.Printf (printf) import Text.Read (readMaybe) import qualified Text.Read as TR@@ -96,13 +96,13 @@ let bts = object [("as", prettyAttribute (AtAlpha 0)), ("base", "Q.org.eolang.bytes")]- [object [] [NodeContent (T.pack bytes)]]+ [object [] [NodeContent (T.pack (prettyBytes bytes))]] in pure ( "Q.org.eolang.number", if omitComments then [bts] else- [ NodeComment (T.pack (either show show (hexToNum bytes))),+ [ NodeComment (T.pack (either show show (btsToNum bytes))), bts ] )@@ -110,13 +110,13 @@ let bts = object [("as", prettyAttribute (AtAlpha 0)), ("base", "Q.org.eolang.bytes")]- [object [] [NodeContent (T.pack bytes)]]+ [object [] [NodeContent (T.pack (prettyBytes bytes))]] in pure ( "Q.org.eolang.string", if omitComments then [bts] else- [ NodeComment (T.pack ('"' : hexToStr bytes ++ "\"")),+ [ NodeComment (T.pack ('"' : btsToStr bytes ++ "\"")), bts ] )@@ -143,7 +143,7 @@ (base, children) <- expression expr ctx pure (Just (object [("name", label), ("base", base)] children)) formationBinding (BiTau AtRho _) _ = pure Nothing-formationBinding (BiDelta bytes) _ = pure (Just (NodeContent (T.pack bytes)))+formationBinding (BiDelta bytes) _ = pure (Just (NodeContent (T.pack (prettyBytes bytes)))) formationBinding (BiLambda func) _ = pure (Just (object [("name", "λ")] [])) formationBinding (BiVoid AtRho) _ = pure Nothing formationBinding (BiVoid AtPhi) _ = pure (Just (object [("name", "φ"), ("base", "∅")] []))@@ -430,8 +430,8 @@ pure (ExApplication expr (BiTau as (ExFormation (withVoidRho bds)))) | not (hasAttr "base" arg) && hasText arg = do as <- asToAttr arg idx- text <- getText arg- pure (ExApplication expr (BiTau as (ExFormation [BiDelta text, BiVoid AtRho])))+ bytes <- getText arg+ pure (ExApplication expr (BiTau as (ExFormation [BiDelta (bytesToBts bytes), BiVoid AtRho]))) | otherwise = do as <- asToAttr arg idx arg' <- xmirToExpression arg fqn
src/Yaml.hs view
@@ -41,6 +41,9 @@ Right attr -> pure attr ) +instance FromJSON Bytes where+ parseJSON = parseJSON' "Bytes" parseBytes+ instance FromJSON Expression where parseJSON = parseJSON' "Expression" parseExpression @@ -98,7 +101,8 @@ asum [ ArgAttribute <$> parseJSON v, ArgBinding <$> parseJSON v,- ArgExpression <$> parseJSON v+ ArgExpression <$> parseJSON v,+ ArgBytes <$> parseJSON v ] instance FromJSON Extra where@@ -139,6 +143,7 @@ = ArgAttribute Attribute | ArgExpression Expression | ArgBinding Binding+ | ArgBytes Bytes deriving (Generic, Show) data Extra = Extra
test/BuilderSpec.hs view
@@ -8,7 +8,7 @@ import Control.Monad import Data.Map.Strict qualified as Map import Matcher-import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, describe, it, shouldBe)+import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, anyException, describe, it, shouldBe, shouldThrow) test :: (Show a, Eq a) => (a -> Subst -> Maybe (a, a)) -> [(String, a, [(String, MetaValue)], Maybe (a, a))] -> SpecWith (Arg Expectation) test function useCases =@@ -81,15 +81,16 @@ ] describe "buildExpressions" $ do- it "!e => [(!e >> Q.x), (!e >> $.y)] => [Q.x, $.y]" $- buildExpressions- (ExMeta "e")- [ substSingle "e" (MvExpression (ExDispatch ExGlobal (AtLabel "x")) defaultScope),- substSingle "e" (MvExpression (ExDispatch ExThis (AtLabel "y")) defaultScope)- ]- `shouldBe` Just [(ExDispatch ExGlobal (AtLabel "x"), defaultScope), (ExDispatch ExThis (AtLabel "y"), defaultScope)]+ it "!e => [(!e >> Q.x), (!e >> $.y)] => [Q.x, $.y]" $ do+ built <-+ buildExpressions+ (ExMeta "e")+ [ substSingle "e" (MvExpression (ExDispatch ExGlobal (AtLabel "x")) defaultScope),+ substSingle "e" (MvExpression (ExDispatch ExThis (AtLabel "y")) defaultScope)+ ]+ built `shouldBe` [(ExDispatch ExGlobal (AtLabel "x"), defaultScope), (ExDispatch ExThis (AtLabel "y"), defaultScope)] it "!e => [(!e1 >> Q.x)] => X" $ buildExpressions (ExMeta "e") [substSingle "e1" (MvExpression (ExDispatch ExGlobal (AtLabel "x")) defaultScope)]- `shouldBe` Nothing+ `shouldThrow` anyException
test/DataizeSpec.hs view
@@ -3,12 +3,16 @@ module DataizeSpec (spec) where -import Ast (Attribute (AtLabel, AtPhi, AtRho), Binding (BiDelta, BiTau, BiVoid), Expression (ExApplication, ExDispatch, ExFormation, ExGlobal, ExTermination, ExThis), Program (Program))+import Ast import Control.Monad-import Dataize (dataize, dataize', morph, defaultDataizeContext, DataizeContext)+import Dataize (dataize, dataize', morph, DataizeContext (DataizeContext)) import Parser (parseProgramThrows) import Test.Hspec+import Functions (buildTermFromFunction) +defaultDataizeContext :: Program -> DataizeContext+defaultDataizeContext prog = DataizeContext prog 25 buildTermFromFunction+ test :: (Eq a, Show a) => (Expression -> DataizeContext -> IO (Maybe a)) -> [(String, Expression, Expression, Maybe a)] -> Spec test func useCases = forM_ useCases $ \(desc, input, prog, output) ->@@ -16,7 +20,7 @@ res <- func input (defaultDataizeContext (Program prog)) res `shouldBe` output -testDataize :: [(String, String, String)] -> Spec+testDataize :: [(String, String, Bytes)] -> Spec testDataize useCases = forM_ useCases $ \(name, prog, res) -> it name $ do@@ -29,7 +33,7 @@ describe "morph" $ test morph- [ ("[[ D> 00- ]] => [[ D> 00- ]]", ExFormation [BiDelta "00-"], ExGlobal, Just (ExFormation [BiDelta "00-"])),+ [ ("[[ D> 00- ]] => [[ D> 00- ]]", ExFormation [BiDelta (BtOne "00")], ExGlobal, Just (ExFormation [BiDelta (BtOne "00")])), ("T => T", ExTermination, ExGlobal, Just ExTermination), ("$ => X", ExThis, ExGlobal, Nothing), ("Q => X", ExGlobal, ExGlobal, Nothing),@@ -43,17 +47,17 @@ describe "dataize" $ test dataize'- [ ("[[ D> 00- ]] => 00-", ExFormation [BiDelta "00-"], ExGlobal, Just "00-"),+ [ ("[[ D> 00- ]] => 00-", ExFormation [BiDelta (BtOne "00")], ExGlobal, Just (BtOne "00")), ("T => X", ExTermination, ExGlobal, Nothing), ( "[[ @ -> [[ D> 00-]] ]] => 00-",- ExFormation [BiTau AtPhi (ExFormation [BiDelta "00-", BiVoid AtRho]), BiVoid AtRho],+ ExFormation [BiTau AtPhi (ExFormation [BiDelta (BtOne "00"), BiVoid AtRho]), BiVoid AtRho], ExGlobal,- Just "00-"+ Just (BtOne "00") ), ( "[[ x -> [[ D> 01- ]] ]].x => 01-",- ExDispatch (ExFormation [BiTau (AtLabel "x") (ExFormation [BiDelta "01-", BiVoid AtRho]), BiVoid AtRho]) (AtLabel "x"),+ ExDispatch (ExFormation [BiTau (AtLabel "x") (ExFormation [BiDelta (BtOne "01"), BiVoid AtRho]), BiVoid AtRho]) (AtLabel "x"), ExGlobal,- Just "01-"+ Just (BtOne "01") ), ( "[[ @ -> [[ x -> [[ D> 01-, y -> ? ]](y -> [[ ]]) ]].x ]] => 01-", ExFormation@@ -65,7 +69,7 @@ (AtLabel "x") ( ExApplication ( ExFormation- [ BiDelta "01-",+ [ BiDelta (BtOne "01"), BiVoid (AtLabel "y"), BiVoid AtRho ]@@ -78,7 +82,7 @@ ) ], ExGlobal,- Just "01-"+ Just (BtOne "01") ) ] @@ -102,7 +106,7 @@ " @ -> 5.plus(5)", "]]" ],- "40-24-00-00-00-00-00-00"+ BtMany ["40", "24", "00", "00", "00", "00", "00", "00"] ), ( "Fahrenheit", unlines@@ -125,7 +129,7 @@ " c -> 25", "]]" ],- "40-53-40-00-00-00-00-00"+ BtMany ["40", "53", "40", "00", "00", "00", "00", "00"] ), ( "Factorial", unlines@@ -155,6 +159,6 @@ " @ -> $.fac(3)", "]]" ],- "40-18-00-00-00-00-00-00"+ BtMany ["40", "18", "00", "00", "00", "00", "00", "00"] ) ]
test/MatcherSpec.hs view
@@ -117,13 +117,13 @@ ), ( "[[!B]] => T:[[x -> ?, D> 01-, L> Func]] => (!B >> T)", [BiMeta "B"],- [BiVoid (AtLabel "x"), BiDelta "01-", BiLambda "Func"],+ [BiVoid (AtLabel "x"), BiDelta (BtOne "01"), BiLambda "Func"], defaultScope,- [[("B", MvBindings [BiVoid (AtLabel "x"), BiDelta "01-", BiLambda "Func"])]]+ [[("B", MvBindings [BiVoid (AtLabel "x"), BiDelta (BtOne "01"), BiLambda "Func"])]] ), ( "[[D> 00-]] => [[D> 00-, L> Func]] => []",- [BiDelta "00-"],- [BiDelta "00-", BiLambda "Func"],+ [BiDelta (BtOne "00")],+ [BiDelta (BtOne "00"), BiLambda "Func"], defaultScope, [] ),@@ -147,9 +147,9 @@ ), ( "[[!B1, !x -> ?, !B2]] => [[y -> ?, D> -> 00-, L> Func]] => (!x >> y, !B1 >> [[]], !B2 >> [[D> -> 00-, L> Func]])", [BiMeta "B1", BiVoid (AtMeta "x"), BiMeta "B2"],- [BiVoid (AtLabel "y"), BiDelta "00-", BiLambda "Func"],+ [BiVoid (AtLabel "y"), BiDelta (BtOne "00"), BiLambda "Func"], defaultScope,- [[("B1", MvBindings []), ("B2", MvBindings [BiDelta "00-", BiLambda "Func"]), ("x", MvAttribute (AtLabel "y"))]]+ [[("B1", MvBindings []), ("B2", MvBindings [BiDelta (BtOne "00"), BiLambda "Func"]), ("x", MvAttribute (AtLabel "y"))]] ), ( "[[!x -> ?, !y -> ?]] => [[a -> ?, b -> ?]] => (!x >> a, !y >> b)", [BiVoid (AtMeta "x"), BiVoid (AtMeta "y")],@@ -170,8 +170,8 @@ [[("B", MvBindings [BiTau (AtLabel "x") ExGlobal, BiTau (AtLabel "y") ExThis])]] ), ( "[[L> Func, D> 00-]] => [[D> 00-, L> Func]] => []",- [BiLambda "Func", BiDelta "00-"],- [BiDelta "00-", BiLambda "Func"],+ [BiLambda "Func", BiDelta (BtOne "00")],+ [BiDelta (BtOne "00"), BiLambda "Func"], defaultScope, [] ),@@ -397,9 +397,9 @@ let Subst joined = maybeCombined (Subst (Map.singleton "first" (MvAttribute AtPhi)))- (Subst (Map.singleton "second" (MvBytes "00-")))+ (Subst (Map.singleton "second" (MvBytes (BtOne "00")))) Map.lookup "first" joined `shouldBe` Just (MvAttribute AtPhi)- Map.lookup "second" joined `shouldBe` Just (MvBytes "00-")+ Map.lookup "second" joined `shouldBe` Just (MvBytes (BtOne "00")) it "leave values in the same substs" $ do let rho = MvAttribute AtRho first =@@ -419,7 +419,7 @@ Subst ( Map.fromList [ ("x", MvAttribute AtRho),- ("y", MvBytes "1F-")+ ("y", MvBytes (BtOne "1F")) ] ) second = Subst (Map.singleton "x" (MvAttribute AtPhi))
test/ParserSpec.hs view
@@ -60,11 +60,11 @@ ("[[!a -> !e1]]", Just (ExFormation [BiTau (AtMeta "a") (ExMeta "e1")])), ("Q * !t", Just (ExMetaTail ExGlobal "t")), ("[[]](x -> $) * !t1", Just (ExMetaTail (ExApplication (ExFormation [BiVoid AtRho]) (BiTau (AtLabel "x") ExThis)) "t1")),- ("[[D> --]]", Just (ExFormation [BiDelta "--", BiVoid AtRho])),- ("[[D> 1F-]]", Just (ExFormation [BiDelta "1F-", BiVoid AtRho])),- ("[[\n L> Func,\n D> 00-\n]]", Just (ExFormation [BiLambda "Func", BiDelta "00-", BiVoid AtRho])),- ("[[D> 1F-2A-00]]", Just (ExFormation [BiDelta "1F-2A-00", BiVoid AtRho])),- ("[[D> !b0]]", Just (ExFormation [BiMetaDelta "b0", BiVoid AtRho])),+ ("[[D> --]]", Just (ExFormation [BiDelta BtEmpty, BiVoid AtRho])),+ ("[[D> 1F-]]", Just (ExFormation [BiDelta (BtOne "1F"), BiVoid AtRho])),+ ("[[\n L> Func,\n D> 00-\n]]", Just (ExFormation [BiLambda "Func", BiDelta (BtOne "00"), BiVoid AtRho])),+ ("[[D> 1F-2A-00]]", Just (ExFormation [BiDelta (BtMany ["1F", "2A", "00"]), BiVoid AtRho])),+ ("[[D> !d0]]", Just (ExFormation [BiDelta (BtMeta "d0"), BiVoid AtRho])), ("[[L> Function]]", Just (ExFormation [BiLambda "Function", BiVoid AtRho])), ("[[L> !F3]]", Just (ExFormation [BiMetaLambda "F3", BiVoid AtRho])), ("[[x() -> [[]] ]]", Just (ExFormation [BiTau (AtLabel "x") (ExFormation [BiVoid AtRho]), BiVoid AtRho])),@@ -161,7 +161,7 @@ (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "bytes")) ( BiTau (AtAlpha 0)- (ExFormation [BiDelta "40-14-00-00-00-00-00-00", BiVoid AtRho])+ (ExFormation [BiDelta (BtMany ["40", "14", "00", "00", "00", "00", "00", "00"]), BiVoid AtRho]) ) ) )@@ -180,7 +180,7 @@ (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "bytes")) ( BiTau (AtAlpha 0)- (ExFormation [BiDelta "40-14-00-00-00-00-00-00", BiVoid AtRho])+ (ExFormation [BiDelta (BtMany ["40", "14", "00", "00", "00", "00", "00", "00"]), BiVoid AtRho]) ) ) )@@ -198,7 +198,7 @@ (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "bytes")) ( BiTau (AtAlpha 0)- (ExFormation [BiDelta "68-65-6C-6C-6F", BiVoid AtRho])+ (ExFormation [BiDelta (BtMany ["68", "65", "6C", "6C", "6F"]), BiVoid AtRho]) ) ) )
test/ReplacerSpec.hs view
@@ -47,8 +47,8 @@ ), ("Q -> [[]] => ([], [$]) => X", Program (ExFormation []), [], [ExThis], Nothing), ( "Q -> [[L> Func, D> 00-]] => ([ [[L> Func, D> 00-]] ], [Q]) => Q -> Q",- Program (ExFormation [BiLambda "Func", BiDelta "00-"]),- [ExFormation [BiLambda "Func", BiDelta "00-"]],+ Program (ExFormation [BiLambda "Func", BiDelta (BtOne "00")]),+ [ExFormation [BiLambda "Func", BiDelta (BtOne "00")]], [ExGlobal], Just (Program ExGlobal) ),
test/RewriterSpec.hs view
@@ -21,6 +21,7 @@ import Yaml (normalizationRules) import Yaml qualified as Y import Rewriter (rewrite', RewriteContext (RewriteContext))+import Functions (buildTermFromFunction) data Rules = Rules { basic :: Maybe [String],@@ -91,7 +92,7 @@ if normalize' then pure normalizationRules else pure []- rewritten <- rewrite' program rules' (RewriteContext program repeat')+ rewritten <- rewrite' program rules' (RewriteContext program repeat' buildTermFromFunction) result' <- parseProgramThrows (output pack) unless (rewritten == result') $ expectationFailure