phino (empty) → 0.0.0.1
raw patch · 22 files changed
+2137/−0 lines, 22 filesdep +aesondep +basedep +binary-ieee754
Dependencies added: aeson, base, binary-ieee754, bytestring, containers, directory, filepath, hspec, hspec-core, megaparsec, optparse-applicative, phino, prettyprinter, scientific, silently, text, utf8-string, yaml
Files
- LICENSES/MIT.txt +19/−0
- app/Main.hs +10/−0
- phino.cabal +94/−0
- src/Ast.hs +40/−0
- src/Builder.hs +93/−0
- src/CLI.hs +86/−0
- src/Matcher.hs +240/−0
- src/Misc.hs +82/−0
- src/Parser.hs +380/−0
- src/Printer.hs +108/−0
- src/Replacer.hs +47/−0
- src/Rewriter.hs +71/−0
- src/Yaml.hs +40/−0
- test/BuilderSpec.hs +80/−0
- test/CLISpec.hs +46/−0
- test/Main.hs +10/−0
- test/MatcherSpec.hs +280/−0
- test/ParserSpec.hs +260/−0
- test/PrinterSpec.hs +46/−0
- test/ReplacerSpec.hs +55/−0
- test/RewriterSpec.hs +43/−0
- test/Spec.hs +7/−0
+ LICENSES/MIT.txt view
@@ -0,0 +1,19 @@+Copyright (c) 2025 Objectionary.com++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NON-INFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ app/Main.hs view
@@ -0,0 +1,10 @@+-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module Main where++import CLI (runCLI)+import System.Environment (getArgs)++main :: IO ()+main = getArgs >>= runCLI
+ phino.cabal view
@@ -0,0 +1,94 @@+cabal-version: 3.0++name: phino+version: 0.0.0.1+license: MIT+synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions+description: Please see the README on GitHub at <https://github.com/objectionary/phino#readme>+homepage: https://github.com/objectionary/phino#readme+bug-reports: https://github.com/objectionary/phino/issues+license-file: LICENSES/MIT.txt+author: maxonfjvipon+maintainer: mtrunnikov@gmail.com+copyright: 2025 Objectionary.com+category: Language, Code Analysis+build-type: Simple++source-repository head+ type: git+ location: https://github.com/objectionary/phino++common warnings+ ghc-options: -Wall++library+ exposed-modules:+ CLI, Ast, Parser, Matcher, Builder, Replacer, Printer, Rewriter, Yaml, Misc+ hs-source-dirs: src+ other-modules:+ Paths_phino+ autogen-modules:+ Paths_phino+ build-depends:+ base ^>=4.18.3.0,+ containers,+ megaparsec >= 9.0,+ text,+ aeson,+ yaml,+ directory,+ filepath,+ scientific,+ binary-ieee754,+ bytestring,+ utf8-string,+ prettyprinter,+ optparse-applicative+ default-language: Haskell2010++-- Executable using the library+executable phino+ import: warnings+ main-is: Main.hs+ hs-source-dirs: app+ build-depends:+ phino,+ base+ default-language: Haskell2010++-- Test suite for Matcher+test-suite spec+ import: warnings+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: test+ other-modules:+ Spec,+ CLISpec,+ ParserSpec,+ MatcherSpec,+ BuilderSpec,+ ReplacerSpec,+ PrinterSpec,+ RewriterSpec+ default-extensions:+ ImportQualifiedPost+ ghc-options: -Wall+ build-depends:+ optparse-applicative,+ base,+ megaparsec,+ phino,+ containers,+ hspec,+ hspec-core,+ filepath,+ prettyprinter,+ aeson,+ yaml,+ text,+ silently,+ directory+ build-tool-depends:+ hspec-discover:hspec-discover+ default-language: Haskell2010
+ src/Ast.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE DeriveGeneric #-}++-- 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+ 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+ 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+ deriving (Eq, Show, Generic)++data Attribute+ = AtLabel String -- attr+ | AtAlpha Integer -- ~1+ | AtPhi -- @+ | AtRho -- ^+ | AtMeta String -- !a+ deriving (Eq, Show, Generic)
+ src/Builder.hs view
@@ -0,0 +1,93 @@+-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++-- The goal of the module is to build phi expression based on+-- pattern expression and set of substitutions by replacing+-- meta variables with appropriate meta values+module Builder where++import Ast+import Misc+import Matcher+import qualified Data.Map.Strict as Map+import Data.List (findIndex)++buildAttribute :: Attribute -> Subst -> Maybe Attribute+buildAttribute (AtMeta meta) (Subst mp) = case Map.lookup meta mp of+ Just (MvAttribute attr) -> Just attr+ _ -> Nothing+buildAttribute attr _ = Just attr++-- Build binding+-- The function returns [Binding] because the BiMeta is always attached+-- to the list of bindings+buildBinding :: Binding -> Subst -> Maybe [Binding]+buildBinding (BiTau attr expr) subst = do+ attribute <- buildAttribute attr subst+ expression <- buildExpression expr subst+ Just [BiTau attribute expression]+buildBinding (BiVoid attr) subst = do+ attribute <- buildAttribute attr subst+ Just [BiVoid attribute]+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 (BiMetaLambda meta) (Subst mp) = case Map.lookup meta mp of+ Just (MvFunction func) -> Just [BiLambda func]+ _ -> Nothing+buildBinding binding _ = Just [binding]++-- Build bindings which don't contain meta binding (BiMeta)+buildExactBindings :: [Binding] -> Subst -> Maybe [Binding]+buildExactBindings [] _ = Just []+buildExactBindings (bd:rest) subst = do+ first <- buildBinding bd subst+ bds <- buildExactBindings rest subst+ Just (head first : bds)++-- Build bindings that may contain meta binding (BiMeta)+buildBindings :: [Binding] -> Subst -> Maybe [Binding]+buildBindings [] _ = Just []+buildBindings bindings subst = case findIndex isMetaBinding bindings of+ Just idx -> do+ exact <- buildExactBindings (withoutAt idx bindings) subst+ meta <- buildBinding (bindings !! idx) subst+ Just (exact ++ meta)+ _ -> buildExactBindings bindings subst++buildExpressionWithTails :: Expression -> [Tail] -> Subst -> Expression+buildExpressionWithTails expr [] _ = expr+buildExpressionWithTails expr (tail:rest) subst = case tail of+ TaApplication taus -> buildExpressionWithTails (ExApplication expr taus) rest subst+ TaDispatch attr -> buildExpressionWithTails (ExDispatch expr attr) rest subst++buildExpression :: Expression -> Subst -> Maybe Expression+buildExpression (ExDispatch expr attr) subst = do+ dispatched <- buildExpression expr subst+ attr <- buildAttribute attr subst+ return (ExDispatch dispatched attr)+buildExpression (ExApplication expr taus) subst = do+ applied <- buildExpression expr subst+ bindings <- buildBindings taus subst+ Just (ExApplication applied bindings)+buildExpression (ExFormation bds) subst = buildBindings bds subst >>= (Just . ExFormation)+-- buildExpression (ExFormation bds) subst = do+-- bindings <- buildBindings bds subst+-- Just (ExFormation bindings)+buildExpression (ExMeta meta) (Subst mp) = case Map.lookup meta mp of+ Just (MvExpression expr) -> Just expr+ _ -> Nothing+buildExpression (ExMetaTail expr meta) subst = do+ let (Subst mp) = subst+ expression <- buildExpression expr subst+ case Map.lookup meta mp of+ Just (MvTail tails) -> Just (buildExpressionWithTails expression tails subst)+ _ -> Nothing+buildExpression expr _ = Just expr++-- Build a several expression from one expression and several substitutions+buildExpressions :: Expression -> [Subst] -> Maybe [Expression]+buildExpressions expr = traverse (buildExpression expr)
+ src/CLI.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module CLI (runCLI) where++import Data.Version (showVersion)+import Options.Applicative+import Paths_phino (version)+import Rewriter (rewrite)+import Misc (ensuredFile)+import qualified Yaml as Y+import System.IO (hPutStrLn, stderr, getContents')+import System.Exit (exitFailure)+import Control.Exception (handle, SomeException, Exception (displayException), throwIO)+import Control.Exception.Base+import Text.Printf (printf)++data CmdException+ = InvalidRewriteArguments+ | NormalizationIsNotSupported+ | CouldNotReadFromStdin { message :: String }+ deriving (Exception)++instance Show CmdException where+ show InvalidRewriteArguments = "Invalid set of arguments for 'rewrite' command: no --rules, no --normalize, no --nothing are provided"+ show NormalizationIsNotSupported = "Normalization is not supported yet..."+ show CouldNotReadFromStdin{..} = printf "Could not read 𝜑-expression from stdin\nReason: %s" message++newtype Command = CmdRewrite OptsRewrite++data OptsRewrite = OptsRewrite+ { rules :: Maybe FilePath,+ phiInput :: Maybe FilePath,+ normalize :: Bool,+ nothing :: Bool+ }++rewriteParser :: Parser Command+rewriteParser =+ CmdRewrite+ <$> ( OptsRewrite+ <$> optional (strOption (long "rules" <> metavar "FILENAME" <> help "Path to custom rules"))+ <*> optional (strOption (long "phi-input" <> metavar "FILENAME" <> help "Path .phi file with 𝜑-expression"))+ <*> switch (long "normalize" <> help "Use built-in normalization rules")+ <*> switch (long "nothing" <> help "Desugar provided 𝜑-expression")+ )++commandParser :: Parser Command+commandParser = hsubparser (command "rewrite" (info rewriteParser (progDesc "Rewrite the expression")))++parserInfo :: ParserInfo Command+parserInfo =+ info+ (commandParser <**> helper <**> simpleVersioner (showVersion version))+ (fullDesc <> header "Phino - CLI Manipulator of 𝜑-Calculus Expressions")++handler :: SomeException -> IO ()+handler e = do+ hPutStrLn stderr ("[error] " ++ displayException e)+ exitFailure++runCLI :: [String] -> IO ()+runCLI args = handle handler $ do+ cmd <- handleParseResult (execParserPure defaultPrefs parserInfo args)+ case cmd of+ CmdRewrite OptsRewrite{..} -> do+ prog <- case phiInput of+ Just pth -> readFile =<< ensuredFile pth+ Nothing -> getContents' `catch` (\(e :: SomeException) -> throwIO (CouldNotReadFromStdin (show e)))+ rules' <- if nothing+ then pure Nothing+ else do+ path <- case rules of+ Nothing ->+ if normalize+ then throwIO NormalizationIsNotSupported+ else throwIO InvalidRewriteArguments+ Just pth -> ensuredFile pth+ ruleSet <- Y.yamlRuleSet path+ pure (Just ruleSet)+ rewritten <- rewrite prog rules'+ putStrLn rewritten
+ src/Matcher.hs view
@@ -0,0 +1,240 @@+-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++-- The goal of the module is to traverse given Ast and build substitutions+-- from meta variables to appropriate meta values+module Matcher where++import Ast+import Misc+import Data.List (findIndex, partition)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe, isJust, maybeToList)+import Data.Sequence (foldlWithIndex)++-- Meta value+-- The right part of substitution+data MetaValue+ = MvAttribute Attribute -- !a+ | MvBytes String -- !b+ | MvBindings [Binding] -- !B+ | MvFunction String -- !F+ | MvExpression Expression -- !e+ | MvTail [Tail] -- !t+ deriving (Eq, Show)++-- Tail operation after expression+-- Dispatch or application+data Tail+ = TaApplication [Binding] -- BiTau only+ | TaDispatch Attribute+ deriving (Eq, Show)++-- Substitution+-- Shows the match of meta name to meta value+newtype Subst = Subst (Map String MetaValue)+ deriving (Eq, Show)++-- Empty substitution+substEmpty :: Subst+substEmpty = Subst Map.empty++-- Singleton substitution with one (key -> value) pair+substSingle :: String -> MetaValue -> Subst+substSingle key value = Subst (Map.singleton key value)++-- Returns True if given binding contains meta attribute on the left:+-- !a -> ...+-- !a -> ?+isBindingWithMetaAttr :: Binding -> Bool+isBindingWithMetaAttr (BiTau (AtMeta _) _) = True+isBindingWithMetaAttr (BiVoid (AtMeta _)) = True+isBindingWithMetaAttr _ = False++-- Combine two substitutions into a single one+-- Fails if values by the same keys are not equal+combine :: Subst -> Subst -> Maybe Subst+combine (Subst a) (Subst b) = combine' (Map.toList b) a+ where+ combine' :: [(String, MetaValue)] -> Map String MetaValue -> Maybe Subst+ combine' [] acc = Just (Subst acc)+ combine' ((key, value) : rest) acc = case Map.lookup key acc of+ Just found+ | found == value -> combine' rest acc+ | otherwise -> Nothing+ Nothing -> combine' rest (Map.insert key value acc)++matchAttribute :: Attribute -> Attribute -> Maybe Subst+matchAttribute (AtMeta meta) tgt = Just (substSingle meta (MvAttribute tgt))+matchAttribute ptn tgt+ | ptn == tgt = Just substEmpty+ | otherwise = Nothing++matchBinding :: Binding -> Binding -> Maybe Subst+matchBinding (BiVoid pattr) (BiVoid tattr) = matchAttribute pattr tattr+matchBinding (BiDelta pbts) (BiDelta tbts)+ | pbts == tbts = Just substEmpty+ | otherwise = Nothing+matchBinding (BiMetaDelta meta) (BiDelta tBts) = Just (substSingle meta (MvBytes tBts))+matchBinding (BiLambda pFunc) (BiLambda tFunc)+ | pFunc == tFunc = Just substEmpty+ | otherwise = Nothing+matchBinding (BiMetaLambda meta) (BiLambda tFunc) = Just (substSingle meta (MvFunction tFunc))+matchBinding (BiTau pattr pexp) (BiTau tattr texp) = do+ mattr <- matchAttribute pattr tattr+ mexp <- matchExpression pexp texp+ combine mattr mexp+matchBinding _ _ = Nothing++-- Returns a tuple (X, Y) if given binding B is matched to any of bindings L+-- X is an index of matched B in L+-- Y is substiturion for matched B+-- (-1, Nothing) is returned in case of no binding is matched in L+matchAnyBinding :: Binding -> [Binding] -> (Int, Maybe Subst)+matchAnyBinding pb [] = (-1, Nothing)+matchAnyBinding pb tbs = matchAnyBindingWithIndex 0 tbs+ where+ matchAnyBindingWithIndex :: Integer -> [Binding] -> (Int, Maybe Subst)+ matchAnyBindingWithIndex idx [] = (-1, Nothing)+ matchAnyBindingWithIndex idx (tb : rest) = case matchBinding pb tb of+ Nothing -> matchAnyBindingWithIndex (idx + 1) rest+ subst -> (fromInteger idx, subst)++-- Match bindings with filtering target bindings+-- !! Bindings may be placed in random order+--+-- Returns a tuple (B, S) where:+-- B is a list of rest target bindings excluding matched ones+-- S is a substitution for matched bindings+-- In case of not matching - S as Nothing is returned+matchBindingsWithFiltering :: [Binding] -> [Binding] -> ([Binding], Maybe Subst)+matchBindingsWithFiltering [] [] = ([], Just substEmpty)+matchBindingsWithFiltering [] tbs = (tbs, Just substEmpty)+matchBindingsWithFiltering (pb : rest) tbs = case matchAnyBinding pb tbs of+ (-1, Nothing) -> (tbs, Nothing)+ (idx, Just subst) -> case matchBindingsWithFiltering rest (withoutAt idx tbs) of+ (bs, Just next) -> (bs, combine subst next)+ _ -> (tbs, Nothing)++-- Match non meta bindings+-- !! Pattern bindings don't contain BiMeta+-- !! Target and pattern bindings may be placed in random order+-- !! Lengths of pattern and target bindings must be the same+--+-- First it filters pattern bindings, only bindings without meta attributes are left (B)+-- If B are not empty, it means we have bindings B with exact attributes, like "attr", "foo", etc.+-- Since all the attributes in phi calculus are unique in the scope of formation or application+-- we try to match these exact bindings first. While matching them we drop target bindings which+-- we found a match for. When we're done with exact bindings, we have a list of target+-- unmatched bindings (L). Now we're entering a new circle and trying to match rest "not exact"+-- pattern bindings with left unmatched bindings L. If matching is succeeded - we just merge+-- result substitutions.+matchNonMetaExactBindings :: [Binding] -> [Binding] -> Maybe Subst+matchNonMetaExactBindings [] [] = Just substEmpty+matchNonMetaExactBindings pbs tbs+ | length tbs /= length pbs = Nothing+ | otherwise = case partition isBindingWithMetaAttr pbs of+ (with, []) -> case matchBindingsWithFiltering with tbs of+ ([], Just subst) -> Just subst+ (_, _) -> Nothing+ (with, without) -> case matchBindingsWithFiltering without tbs of+ (rest, Just subst) -> case matchNonMetaExactBindings with rest of+ Just next -> combine subst next+ Nothing -> Nothing+ (_, Nothing) -> Nothing++-- The same as `matchNonMetaExactBindings` but without the "same length" requirement+matchNonMetaBindingsWithFiltering :: [Binding] -> [Binding] -> ([Binding], Maybe Subst)+matchNonMetaBindingsWithFiltering [] [] = ([], Just substEmpty)+matchNonMetaBindingsWithFiltering [] tbs = (tbs, Just substEmpty)+matchNonMetaBindingsWithFiltering pbs [] = ([], Nothing)+matchNonMetaBindingsWithFiltering pbs tbs+ | length pbs > length tbs = ([], Nothing)+ | otherwise = case partition isBindingWithMetaAttr pbs of+ (with, []) -> case matchBindingsWithFiltering with tbs of+ (rest, Just subst) -> (rest, Just subst)+ (_, Nothing) -> ([], Nothing)+ (with, without) -> case matchBindingsWithFiltering without tbs of+ (rest, Just subst) -> case matchNonMetaBindingsWithFiltering with rest of+ (rest', Just next) -> (rest', combine subst next)+ (_, Nothing) -> ([], Nothing)+ (_, Nothing) -> ([], Nothing)++-- Match pattern bindings to target bindings+-- !! Pattern bindings list may contain only one BiMeta binding+-- !! Pattern and target bindings may be placed in random order+--+-- If pattern bindings contains only BiMeta binding - all the target bindings are matched+matchBindings :: [Binding] -> [Binding] -> Maybe Subst+matchBindings [] [] = Just substEmpty+matchBindings pbs tbs = case findIndex isMetaBinding pbs of+ Just idx -> do+ let (BiMeta name) = pbs !! idx+ if length pbs == 1+ then Just (substSingle name (MvBindings tbs))+ else case matchNonMetaBindingsWithFiltering (withoutAt idx pbs) tbs of+ (rest, Just subst) -> combine subst (substSingle name (MvBindings rest))+ (_, Nothing) -> Nothing+ _ -> matchNonMetaExactBindings pbs tbs++-- Recursively go through given target expression and try to find+-- the head expression which matches to given pattern.+-- If there's one - build the list of all the tail operations after head expression.+-- The tail operations may be only dispatches or applications+tailExpressions :: Expression -> Expression -> Maybe (Subst, [Tail])+tailExpressions ptn tgt = do+ (subst, tails) <- tailExpressionsReversed ptn tgt+ return (subst, reverse tails)+ where+ tailExpressionsReversed :: Expression -> Expression -> Maybe (Subst, [Tail])+ tailExpressionsReversed ptn' tgt' = case matchExpression ptn' tgt' of+ Just subst -> Just (subst, [])+ Nothing -> case tgt' of+ ExDispatch expr attr -> do+ (subst, tails) <- tailExpressionsReversed ptn' expr+ return (subst, TaDispatch attr : tails)+ ExApplication expr bds -> do+ (subst, tails) <- tailExpressionsReversed ptn' expr+ return (subst, TaApplication bds : tails)+ _ -> Nothing++matchExpression :: Expression -> Expression -> Maybe Subst+matchExpression (ExMeta meta) tgt = Just (substSingle meta (MvExpression tgt))+matchExpression ExThis ExThis = Just substEmpty+matchExpression ExGlobal ExGlobal = Just substEmpty+matchExpression ExTermination ExTermination = Just substEmpty+matchExpression (ExFormation pbs) (ExFormation tbs) = matchBindings pbs tbs+matchExpression (ExDispatch pexp pattr) (ExDispatch texp tattr) = do+ mexp <- matchExpression pexp texp+ mattr <- matchAttribute pattr tattr+ combine mexp mattr+matchExpression (ExApplication pexp pbs) (ExApplication texp tbs) = do+ mexp <- matchExpression pexp texp+ mbs <- matchBindings pbs tbs+ combine mexp mbs+matchExpression (ExMetaTail exp meta) tgt = do+ (subst, tails) <- tailExpressions exp tgt+ combine subst (substSingle meta (MvTail tails))+matchExpression _ _ = Nothing++-- Match expression with deep nested expression(s) matching+matchExpressionDeep :: Expression -> Expression -> [Subst]+matchExpressionDeep ptn tgt = do+ let here = maybeToList (matchExpression ptn tgt)+ deep = case tgt of+ ExFormation bds -> concatMap matchBindingExpression bds+ ExDispatch dexp _ -> matchExpressionDeep ptn dexp+ ExApplication aexp taus -> matchExpressionDeep ptn aexp ++ concatMap matchBindingExpression taus+ _ -> []+ where+ -- Deep match pattern to expression inside binding+ matchBindingExpression :: Binding -> [Subst]+ matchBindingExpression (BiTau _ texp) = matchExpressionDeep ptn texp+ matchBindingExpression _ = []+ case here of+ [] -> deep+ found : _ -> found : deep++matchProgram :: Expression -> Program -> [Subst]+matchProgram ptn (Program exp) = matchExpressionDeep ptn exp
+ src/Misc.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE RecordWildCards #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++-- This module provides commonly used helper functions for other modules+module Misc where++import Ast+import Control.Exception+import Control.Monad+import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)+import System.FilePath ((</>))+import Text.Printf (printf)+import Data.Binary.IEEE754 +import Data.ByteString.Builder (word64BE, toLazyByteString)+import Data.List (intercalate)+import Data.ByteString.Lazy (unpack)+import qualified Data.ByteString.Lazy.UTF8 as U+import Data.Word (Word8)++data FsException+ = FileDoesNotExist {file :: FilePath}+ | DirectoryDoesNotExist {dir :: FilePath}+ deriving (Exception)++instance Show FsException where+ show FileDoesNotExist {..} = printf "File '%s' does not exist" file+ show DirectoryDoesNotExist {..} = printf "Directory '%s' does not exist" dir++-- List without element by given index+withoutAt :: Int -> [a] -> [a]+withoutAt i xs = take i xs ++ drop (i + 1) xs++-- Returns True if given binding is BiMeta (!B)+isMetaBinding :: Binding -> Bool+isMetaBinding (BiMeta _) = True+isMetaBinding _ = False++ensuredFile :: FilePath -> IO FilePath+ensuredFile pth = do+ exists <- doesFileExist pth+ if exists then pure pth else throwIO (FileDoesNotExist pth)++-- Recursively collect all file paths in provided directory+allPathsIn :: FilePath -> IO [FilePath]+allPathsIn dir = do+ exists <- doesDirectoryExist dir+ names <- if exists then listDirectory dir else throwIO (DirectoryDoesNotExist dir)+ let nested = map (dir </>) names+ paths <-+ forM+ nested+ ( \path -> do+ isDir <- doesDirectoryExist path+ if isDir+ then allPathsIn path+ else return [path]+ )+ return (concat paths)++btsToHex :: [Word8] -> String+btsToHex bts = intercalate "-" (map (printf "%02X") bts)++-- >>> 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))))++-- >>> strToHex "hello"+-- "68-65-6C-6C-6F"+-- >>> strToHex "world"+-- "77-6F-72-6C-64"+strToHex :: String -> String+strToHex str = btsToHex (unpack (U.fromString str))
+ src/Parser.hs view
@@ -0,0 +1,380 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE RecordWildCards #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++-- The goal of the module is to parse given phi program to Ast+module Parser (parseProgram, parseProgramThrows, parseExpression, parseExpressionThrows) where++import Ast+import Control.Exception (Exception, throwIO)+import Control.Monad (guard)+import Data.Char (isDigit, isLower)+import Data.Scientific (toRealFloat)+import Data.Sequence (mapWithIndex)+import Data.Text.Internal.Fusion.Size (lowerBound)+import Data.Void+import Misc (numToHex, strToHex)+import Text.Megaparsec+import Text.Megaparsec.Char (alphaNumChar, char, digitChar, hexDigitChar, letterChar, lowerChar, space1, string, upperChar)+import qualified Text.Megaparsec.Char.Lexer as L+import Text.Printf (printf)++type Parser = Parsec Void String++data ParserException+ = CouldNotParseProgram {message :: String}+ | CouldNotParseExpression {message :: String}+ deriving (Exception)++instance Show ParserException where+ 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])+ ]+ )+ ]++-- White space consumer+whiteSpace :: Parser ()+whiteSpace = L.space space1 empty empty++-- Lexeme that ignores white spaces after+lexeme :: Parser a -> Parser a+lexeme = L.lexeme whiteSpace++-- Strict symbol (or sequence of symbols) with ignored white spaces after+symbol :: String -> Parser String+symbol = L.symbol whiteSpace++label' :: Parser String+label' = lexeme $ do+ first <- lowerChar+ rest <- many (satisfy (`notElem` " \r\n\t,.|':;!?][}{)(⟧⟦") <?> "allowed character")+ return (first : rest)++function :: Parser String+function = lexeme $ do+ first <- upperChar+ rest <-+ many+ ( satisfy+ (\ch -> isDigit ch || isLower ch || ch == '_' || ch == 'φ')+ <?> "allowed character in function name"+ )+ return (first : rest)++delta :: Parser String+delta =+ choice+ [ symbol "D>",+ symbol "Δ" >> dashedArrow+ ]++lambda :: Parser String+lambda =+ choice+ [ symbol "L>",+ symbol "λ" >> dashedArrow+ ]++dashedArrow :: Parser String+dashedArrow = symbol "⤍"++arrow :: Parser String+arrow = choice [symbol "->", symbol "↦"]++global :: Parser String+global = choice [symbol "Q", symbol "Φ"]++meta :: Char -> Parser String+meta ch = do+ _ <- char '!'+ c <- char ch+ ds <- lexeme (many digitChar)+ return (c : ds)++byte :: Parser String+byte = do+ f <- hexDigitChar >>= upperHex+ s <- hexDigitChar >>= upperHex+ return [f, s]+ where+ upperHex ch+ | isDigit ch || ('A' <= ch && ch <= 'F') = return ch+ | otherwise = fail ("expected 0-9 or A-F, got " ++ show ch)++-- bytes+-- 1. empty: --+-- 2. one byte: 01-+-- 3. many bytes: 01-02-...-FF+bytes :: Parser String+bytes = lexeme $ do+ choice+ [ symbol "--",+ try $ do+ first <- byte+ rest <- some $ do+ dash <- char '-'+ bte <- byte+ return (dash : bte)+ return (first ++ concat rest),+ do+ bte <- byte+ dash <- char '-'+ return (bte ++ [dash])+ ]+ <?> "bytes"++tauBinding :: Parser Attribute -> Parser Binding+tauBinding attr = do+ attr' <- attr+ choice+ [ try $ do+ _ <- arrow+ BiTau attr' <$> expression,+ do+ _ <- symbol "("+ voids <- map BiVoid <$> void' `sepBy` symbol ","+ _ <- symbol ")"+ _ <- arrow+ ExFormation bs <- formation+ return (BiTau attr' (ExFormation (voids ++ bs)))+ ]++-- binding+-- 1. tau+-- 2. void+-- 3. delta+-- 4. meta delta+-- 5. meta+-- 6. lambda+-- 7. meta lambda+binding :: Parser Binding+binding =+ choice+ [ try (tauBinding attribute),+ try $ do+ attr <- attribute+ _ <- arrow+ _ <- choice [symbol "?", symbol "∅"]+ return (BiVoid attr),+ try $ do+ _ <- delta+ BiDelta <$> bytes,+ try $ do+ _ <- delta+ BiMetaDelta <$> meta 'b',+ try (BiMeta <$> meta 'B'),+ try $ do+ _ <- lambda+ BiLambda <$> function,+ do+ _ <- lambda+ BiMetaLambda <$> meta 'F'+ ]+ <?> "binding"++-- inlined void attribute+-- 1. label+-- 2. rho+-- 3. phi+void' :: Parser Attribute+void' =+ choice+ [ AtLabel <$> label',+ do+ _ <- choice [symbol "^", symbol "ρ"]+ return AtRho,+ do+ _ <- choice [symbol "@", symbol "φ"]+ return AtPhi+ ]++-- attribute+-- 1. label+-- 2. meta+-- 3. rho+-- 4. phi+attribute :: Parser Attribute+attribute =+ choice+ [ void',+ AtMeta <$> meta 'a'+ ]+ <?> "attribute"++-- full attribute+-- 1. label+-- 2. meta+-- 3. rho+-- 4. phi+-- 5. alpha+fullAttribute :: Parser Attribute+fullAttribute =+ choice+ [ attribute,+ do+ _ <- choice [symbol "~", symbol "α"]+ AtAlpha <$> lexeme L.decimal+ ]+ <?> "full attribute"++-- formation+formation :: Parser Expression+formation = do+ _ <- choice [symbol "[[", symbol "⟦"]+ bs <- binding `sepBy` symbol ","+ _ <- choice [symbol "]]", symbol "⟧"]+ return (ExFormation bs)++-- head part of expression+-- 1. formation+-- 2. this+-- 3. global+-- 4. termination+-- 5. meta expression+-- 6. full attribute -> sugar for $.attr+exHead :: Parser Expression+exHead =+ choice+ [ formation,+ do+ _ <- choice [symbol "$", symbol "ξ"]+ return ExThis,+ try $ do+ _ <- choice [symbol "QQ", symbol "Φ̇"]+ return (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")),+ do+ _ <- global+ return ExGlobal,+ do+ _ <- choice [symbol "T", symbol "⊥"]+ return ExTermination,+ do+ sign <- optional (choice [char '-', char '+'])+ unsigned <- lexeme L.scientific+ let num =+ toRealFloat+ ( case sign of+ Just '-' -> negate unsigned+ _ -> unsigned+ )+ return (dataExpression "number" (numToHex num)),+ lexeme $ do+ _ <- char '"'+ str <- manyTill L.charLiteral (char '"')+ return (dataExpression "string" (strToHex str)),+ try (ExMeta <$> meta 'e'),+ ExDispatch ExThis <$> fullAttribute+ ]+ <?> "expression head"++-- tail optional part of application+-- 1. any head + dispatch+-- 2. any head except $ and Q + application+-- 3. any head except meta tail + meta tail+exTail :: Expression -> Parser Expression+exTail expr =+ choice+ [ do+ next <-+ choice+ [ do+ _ <- symbol "."+ ExDispatch expr <$> fullAttribute,+ do+ guard+ ( case expr of+ ExThis -> False+ ExGlobal -> False+ _ -> True+ )+ _ <- symbol "("+ bds <-+ choice+ [ try $ tauBinding fullAttribute `sepBy1` symbol ",",+ do+ exprs <- expression `sepBy1` symbol ","+ return (zipWith (BiTau . AtAlpha) [0 ..] exprs) -- \idx expr -> BiTau (AtAlpha idx) expr+ ]+ _ <- symbol ")"+ return (ExApplication expr bds),+ do+ guard+ ( case expr of+ ExMetaTail _ _ -> False+ _ -> True+ )+ _ <- symbol "*"+ ExMetaTail expr <$> meta 't'+ ]+ <?> "dispatch or application"+ exTail next,+ return expr+ ]++expression :: Parser Expression+expression = do+ expr <- exHead+ exTail expr++program :: Parser Program+program =+ choice+ [ do+ _ <- symbol "{"+ prog <- Program <$> expression+ _ <- symbol "}"+ return prog,+ do+ _ <- global+ _ <- arrow+ Program <$> expression+ ]+ <?> "program"++-- Entry point+parse' :: String -> Parser a -> String -> Either String a+parse' name parser input = do+ let parsed =+ runParser+ ( do+ _ <- whiteSpace+ p <- parser+ _ <- eof+ return p+ )+ name+ input+ case parsed of+ Right parsed' -> Right parsed'+ Left err -> Left (errorBundlePretty err)++parseExpression :: String -> Either String Expression+parseExpression = parse' "expression" expression++parseExpressionThrows :: String -> IO Expression+parseExpressionThrows expression = case parseExpression expression of+ Right expr -> pure expr+ Left err -> throwIO (CouldNotParseExpression err)++parseProgram :: String -> Either String Program+parseProgram = parse' "program" program++parseProgramThrows :: String -> IO Program+parseProgramThrows program = case parseProgram program of+ Right prog -> pure prog+ Left err -> throwIO (CouldNotParseProgram err)
+ src/Printer.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module Printer (printExpression, printProgram, printSubstitutions) where++import Ast+import qualified Data.Map.Strict as Map+import Matcher+import Prettyprinter+import Prettyprinter.Render.String (renderString)+import Text.Printf (vFmt)++prettyMeta :: String -> Doc ann+prettyMeta meta = pretty "!" <> pretty meta++prettyArrow :: Doc ann+prettyArrow = pretty "↦"++prettyDashedArrow :: Doc ann+prettyDashedArrow = pretty "⤍"++instance Pretty Attribute where+ pretty (AtLabel name) = pretty name+ pretty (AtAlpha index) = pretty "α" <> pretty index+ pretty AtRho = pretty "ρ"+ pretty AtPhi = pretty "φ"+ pretty (AtMeta meta) = prettyMeta meta++instance Pretty Binding where+ pretty (BiTau attr expr) = pretty attr <+> prettyArrow <+> pretty expr+ pretty (BiMeta meta) = prettyMeta meta+ pretty (BiDelta bytes) = pretty "Δ" <+> prettyDashedArrow <+> pretty bytes+ pretty (BiMetaDelta meta) = pretty "Δ" <+> prettyDashedArrow <+> prettyMeta meta+ pretty (BiVoid attr) = pretty attr <+> prettyArrow <+> pretty "∅"+ pretty (BiLambda func) = pretty "λ" <+> prettyDashedArrow <+> pretty func+ pretty (BiMetaLambda meta) = pretty "λ" <+> prettyDashedArrow <+> prettyMeta meta++instance {-# OVERLAPPING #-} Pretty [Binding] where+ pretty bindings = vsep (punctuate comma (map pretty bindings))++instance Pretty Expression where+ pretty (ExFormation []) = pretty "⟦⟧"+ pretty (ExFormation [binding]) = case binding of+ BiTau _ _ -> vsep [pretty "⟦", indent 2 (pretty binding), pretty "⟧"]+ _ -> pretty "⟦" <+> pretty binding <+> pretty "⟧"+ pretty (ExFormation bindings) = vsep [pretty "⟦", indent 2 (pretty bindings), pretty "⟧"]+ pretty ExThis = pretty "ξ"+ pretty ExGlobal = pretty "Φ"+ pretty ExTermination = pretty "⊥"+ pretty (ExMeta meta) = prettyMeta meta+ pretty (ExApplication expr []) = pretty expr <> pretty "()"+ pretty (ExApplication expr taus) = pretty expr <> vsep [lparen, indent 2 (pretty taus), rparen]+ pretty (ExDispatch expr attr) = pretty expr <> pretty "." <> pretty attr+ pretty (ExMetaTail expr meta) = pretty expr <+> pretty "*" <+> prettyMeta meta++instance Pretty Program where+ pretty (Program expr) = pretty "Φ" <+> prettyArrow <+> pretty expr++instance Pretty Tail where+ pretty (TaApplication []) = pretty "()"+ pretty (TaApplication taus) = vsep [lparen, indent 2 (pretty taus), rparen]+ pretty (TaDispatch attr) = pretty "." <> pretty attr++instance Pretty MetaValue where+ pretty (MvAttribute attr) = pretty attr+ pretty (MvBytes bytes) = pretty bytes+ pretty (MvBindings bindings) = pretty bindings+ pretty (MvFunction func) = pretty func+ pretty (MvExpression expr) = pretty expr+ pretty (MvTail tails) = vsep (punctuate comma (map pretty tails))++instance Pretty Subst where+ pretty (Subst mp) =+ vsep+ [ lparen,+ indent+ 2+ ( vsep+ ( punctuate+ comma+ ( map+ (\(key, value) -> prettyMeta key <+> pretty ">>" <+> pretty value)+ (Map.toList mp)+ )+ )+ ),+ rparen+ ]++instance {-# OVERLAPPING #-} Pretty [Subst] where+ pretty :: [Subst] -> Doc ann+ pretty [] = pretty "[]"+ pretty substs = vsep [pretty "[", indent 2 (vsep (punctuate comma (map pretty substs))), pretty "]"]++prettyPrint :: (Pretty a) => a -> String+prettyPrint printable = renderString (layoutPretty defaultLayoutOptions (pretty printable))++printSubstitutions :: [Subst] -> String+printSubstitutions = prettyPrint++printExpression :: Expression -> String+printExpression = prettyPrint++printProgram :: Program -> String+printProgram = prettyPrint
+ src/Replacer.hs view
@@ -0,0 +1,47 @@+-- 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++import Ast+import Matcher (Tail (TaApplication, TaDispatch))++replaceBindings :: [Binding] -> [Expression] -> [Expression] -> ([Binding], [Expression], [Expression])+replaceBindings bds [] [] = (bds, [], [])+replaceBindings [] ptns repls = ([], ptns, repls)+replaceBindings (BiTau attr expr : bds) ptns repls = do+ let (expr', ptns', repls') = replaceExpression expr ptns repls+ let (bds', ptns'', repls'') = replaceBindings bds ptns' repls'+ (BiTau attr expr' : bds', ptns'', repls'')+replaceBindings (bd : bds) ptns repls = do+ let (bds', ptns', repls') = replaceBindings bds ptns repls+ (bd : bds', ptns', repls')++replaceExpression :: Expression -> [Expression] -> [Expression] -> (Expression, [Expression], [Expression])+replaceExpression expr [] [] = (expr, [], [])+replaceExpression expr ptns repls = do+ let (ptn : ptnsRest) = ptns+ let (repl : replsRest) = repls+ if expr == ptn+ then (repl, ptnsRest, replsRest)+ else case expr of+ ExDispatch inner attr -> do+ let (expr', ptns', repls') = replaceExpression inner ptns repls+ (ExDispatch expr' attr, ptns', repls')+ ExApplication inner taus -> do+ let (expr', ptns', repls') = replaceExpression inner ptns repls+ let (taus', ptns'', repls'') = replaceBindings taus ptns' repls'+ (ExApplication expr' taus', ptns'', repls'')+ ExFormation bds -> do+ let (bds', ptns', repls') = replaceBindings bds ptns repls+ (ExFormation bds', ptns', repls')+ _ -> (expr, ptns, repls)++replaceProgram :: Program -> [Expression] -> [Expression] -> Maybe Program+replaceProgram (Program expr) ptns repls+ | length ptns == length repls = do+ let (expr', _, _) = replaceExpression expr ptns repls+ Just (Program expr')+ | otherwise = Nothing
+ src/Rewriter.hs view
@@ -0,0 +1,71 @@+{-# 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) where++import Ast+import Builder (buildExpressions)+import Control.Exception+import Matcher (Subst, matchProgram)+import Misc (ensuredFile)+import Parser (parseProgram, parseProgramThrows)+import Printer (printExpression, printProgram, printSubstitutions)+import Replacer (replaceProgram)+import System.Directory+import Text.Printf+import qualified Yaml as Y+import Yaml (Rule)++data RewriteException+ = CouldNotMatch {pattern :: Expression, program :: Program}+ | CouldNotBuild {expr :: Expression, substs :: [Subst]}+ | CouldNotReplace {prog :: Program, ptn :: Expression, res :: Expression}+ deriving (Exception)++instance Show RewriteException where+ show CouldNotMatch {..} =+ printf+ "Couldn't find given pattern in provided program\n--Pattern: %s\n--Program: %s"+ (printExpression pattern)+ (printProgram program)+ show CouldNotBuild {..} =+ printf+ "Couldn't build given expression with provided substitutions\n--Expression: %s\n--Substitutions: %s"+ (printExpression expr)+ (printSubstitutions substs)+ show CouldNotReplace {..} =+ printf+ "Couldn't replace expression in program by pattern\nProgram: %s\n--Pattern: %s\n--Result: %s"+ (printProgram prog)+ (printExpression ptn)+ (printExpression res)++applyRules :: Program -> [Y.Rule] -> IO Program+applyRules program [] = pure program+applyRules program [rule] = do+ let ptn = Y.pattern rule+ let res = Y.result rule+ case matchProgram ptn program of+ [] -> throwIO (CouldNotMatch ptn program)+ substs -> case (buildExpressions ptn substs, buildExpressions res substs) of+ (Just ptns, Just repls) -> 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)+applyRules program (rule : rest) = do+ prog <- applyRules program [rule]+ applyRules prog rest++rewrite :: String -> Maybe Y.RuleSet -> IO String+rewrite prog rulesSet = do+ program <- parseProgramThrows prog+ rewritten <- case rulesSet of+ Just set -> applyRules program (Y.rules set)+ Nothing -> pure program+ pure (printProgram rewritten)
+ src/Yaml.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module Yaml where++import Ast+import Data.Aeson+import Data.String (IsString (..))+import Data.Text (unpack)+import qualified Data.Yaml as Yaml+import GHC.Generics+import Parser++instance FromJSON Expression where+ parseJSON =+ withText+ "Expression"+ ( \txt -> case parseExpression (unpack txt) of+ Left err -> fail err+ Right expr -> pure expr+ )++data RuleSet = RuleSet+ { title :: String,+ rules :: [Rule]+ }+ deriving (Generic, FromJSON, Show)++data Rule = Rule+ { name :: String,+ pattern :: Expression,+ result :: Expression+ }+ deriving (Generic, FromJSON, Show)++yamlRuleSet :: FilePath -> IO RuleSet+yamlRuleSet = Yaml.decodeFileThrow
+ test/BuilderSpec.hs view
@@ -0,0 +1,80 @@+-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module BuilderSpec where++import Ast+import Builder+import Control.Monad+import Data.Map.Strict qualified as Map+import Matcher+import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, describe, it, shouldBe)++test :: (Show a, Eq a) => (a -> Subst -> Maybe a) -> [(String, a, [(String, MetaValue)], Maybe a)] -> SpecWith (Arg Expectation)+test function useCases =+ forM_ useCases $ \(desc, expr, mp, res) ->+ it desc $ function expr (Subst (Map.fromList mp)) `shouldBe` res++spec :: Spec+spec = do+ describe "buildExpression" $ do+ test+ buildExpression+ [ ( "Q.!a => (!a >> x) => Q.x",+ ExDispatch ExGlobal (AtMeta "a"),+ [("a", MvAttribute (AtLabel "x"))],+ Just (ExDispatch ExGlobal (AtLabel "x"))+ ),+ ( "Q.c(!a -> !e) => (!a >> x, !e >> $.y.z) => Q.c(x -> $.y.z)",+ ExApplication (ExDispatch ExGlobal (AtLabel "c")) [BiTau (AtMeta "a") (ExMeta "e")],+ [("a", MvAttribute (AtLabel "x")), ("e", MvExpression (ExDispatch (ExDispatch ExThis (AtLabel "y")) (AtLabel "z")))],+ Just (ExApplication (ExDispatch ExGlobal (AtLabel "c")) [BiTau (AtLabel "x") (ExDispatch (ExDispatch ExThis (AtLabel "y")) (AtLabel "z"))])+ ),+ ( "[[!a -> $.x, !B]] => (!a >> y, !B >> [[b -> ?, L> Func]]) => [[y -> $.x, b -> ?, L> Func]]",+ ExFormation [BiTau (AtMeta "a") (ExDispatch ExThis (AtLabel "x")), BiMeta "B"],+ [("a", MvAttribute (AtLabel "y")), ("B", MvBindings [BiVoid (AtLabel "b"), BiLambda "Func"])],+ Just+ ( ExFormation+ [ BiTau (AtLabel "y") (ExDispatch ExThis (AtLabel "x")),+ BiVoid (AtLabel "b"),+ BiLambda "Func"+ ]+ )+ ),+ ( "Q * !t => (!t >> [.a, .b, (~1 -> $.x)]) => Q.a.b(~1 -> $.x)",+ ExMetaTail ExGlobal "t",+ [("t", MvTail [TaDispatch (AtLabel "a"), TaDispatch (AtLabel "b"), TaApplication [BiTau (AtAlpha 1) (ExDispatch ExThis (AtLabel "x"))]])],+ Just (ExApplication (ExDispatch (ExDispatch ExGlobal (AtLabel "a")) (AtLabel "b")) [BiTau (AtAlpha 1) (ExDispatch ExThis (AtLabel "x"))])+ ),+ ( "Q.!a => () => X",+ ExDispatch ExGlobal (AtMeta "a"),+ [],+ Nothing+ ),+ ( "!e0(!a1 -> !e1, !a2 => !e2) => (!e0 >> [[]], !a1 >> x, !e1 >> Q, !a2 >> y, !e2 >> $) => [[]](x -> Q, y -> $)",+ ExApplication (ExMeta "e0") [BiTau (AtMeta "a1") (ExMeta "e1"), BiTau (AtMeta "a2") (ExMeta "e2")],+ [ ("e0", MvExpression (ExFormation [])),+ ("a1", MvAttribute (AtLabel "x")),+ ("e1", MvExpression ExGlobal),+ ("a2", MvAttribute (AtLabel "y")),+ ("e2", MvExpression ExThis)+ ],+ Just (ExApplication (ExFormation []) [BiTau (AtLabel "x") ExGlobal, BiTau (AtLabel "y") ExThis])+ )+ ]++ describe "buildExpressions" $ do+ it "!e => [(!e >> Q.x), (!e >> $.y)] => [Q.x, $.y]" $+ do+ buildExpressions+ (ExMeta "e")+ [ substSingle "e" (MvExpression (ExDispatch ExGlobal (AtLabel "x"))),+ substSingle "e" (MvExpression (ExDispatch ExThis (AtLabel "y")))+ ]+ `shouldBe` Just [ExDispatch ExGlobal (AtLabel "x"), ExDispatch ExThis (AtLabel "y")]+ it "!e => [(!e1 >> Q.x)] => X" $+ do+ buildExpressions+ (ExMeta "e")+ [substSingle "e1" (MvExpression (ExDispatch ExGlobal (AtLabel "x")))]+ `shouldBe` Nothing
+ test/CLISpec.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module CLISpec (spec) where++import CLI (runCLI)+import System.IO.Silently (capture_)+import System.Directory (removeFile)+import Test.Hspec+import System.IO+import Control.Exception+import GHC.IO.Handle++withRedirectedStdin :: String -> IO a -> IO a+withRedirectedStdin input action = do+ bracket (openTempFile "." "stdin.tmp") cleanup $ \(filePath, h) -> do+ hSetEncoding h utf8+ hPutStr h input+ hFlush h+ hSeek h AbsoluteSeek 0+ hClose h+ withFile filePath ReadMode $ \hIn -> do+ hSetEncoding hIn utf8+ bracket (hDuplicate stdin) restoreStdin $ \_ -> do+ hDuplicateTo hIn stdin+ hSetEncoding stdin utf8+ action+ where+ restoreStdin orig = hDuplicateTo orig stdin >> hClose orig+ cleanup (fp, _) = removeFile fp++spec :: Spec+spec = do+ it "desugares with --nothing flag from file" $ do+ let args = ["rewrite", "--nothing", "--phi-input=test/resources/cli/desugar.phi"]+ output <- capture_ (runCLI args)+ output `shouldContain` "Φ ↦ ⟦\n foo ↦ Φ.org.eolang\n⟧"++ it "desugares with --nothing flag from stdin" $ do+ withRedirectedStdin "{[[foo ↦ QQ]]}" $ do+ let args = ["rewrite", "--nothing"]+ output <- capture_ (runCLI args)+ output `shouldContain` "Φ ↦ ⟦\n foo ↦ Φ.org.eolang\n⟧"
+ test/Main.hs view
@@ -0,0 +1,10 @@+-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module Main where++import Spec qualified+import Test.Hspec.Runner++main :: IO ()+main = hspecWith defaultConfig Spec.spec
+ test/MatcherSpec.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module MatcherSpec where++import Ast+import Control.Monad (forM_)+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe)+import Matcher+import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, describe, it, shouldBe)++class Expected e where+ type ExpectedResult e+ toExpected :: e -> ExpectedResult e++instance Expected (Maybe [(String, MetaValue)]) where+ type ExpectedResult (Maybe [(String, MetaValue)]) = Maybe Subst+ toExpected = fmap (Subst . Map.fromList)++instance Expected ([Binding], [(String, MetaValue)]) where+ type ExpectedResult ([Binding], [(String, MetaValue)]) = ([Binding], Maybe Subst)+ toExpected (rest, pairs) = (rest, Just (Subst (Map.fromList pairs)))++instance Expected [[(String, MetaValue)]] where+ type ExpectedResult [[(String, MetaValue)]] = [Subst]+ toExpected = map (Subst . Map.fromList)++maybeCombined :: Subst -> Subst -> Subst+maybeCombined first second =+ fromMaybe+ (error "combine returned Nothing")+ (combine first second)++test ::+ (Expected e, ExpectedResult e ~ r, Eq r, Show r) =>+ (a -> a -> r) ->+ [(String, a, a, e)] ->+ SpecWith (Arg Expectation)+test function useCases =+ forM_ useCases $ \(desc, ptn, tgt, mp) ->+ it desc $ function ptn tgt `shouldBe` toExpected mp++spec :: Spec+spec = do+ describe "matchExpressionDeep: expression => expression => [substitution]" $+ test+ matchExpressionDeep+ [ ( "[[!a -> Q.org.!a]] => [[f -> [[x -> Q.org.x]], t -> [[y -> Q.org.y]] => [(!a >> x), (!a >> y)]",+ ExFormation [BiTau (AtMeta "a") (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtMeta "a"))],+ ExFormation+ [ BiTau (AtLabel "f") (ExFormation [BiTau (AtLabel "x") (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "x"))]),+ BiTau (AtLabel "t") (ExFormation [BiTau (AtLabel "y") (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "y"))])+ ],+ [[("a", MvAttribute (AtLabel "x"))], [("a", MvAttribute (AtLabel "y"))]]+ ),+ ( "!e => [[x -> Q]] => [(!e >> [[x -> Q]]), (!e >> Q)]",+ ExMeta "e",+ ExFormation [BiTau (AtLabel "x") ExGlobal],+ [[("e", MvExpression (ExFormation [BiTau (AtLabel "x") ExGlobal]))], [("e", MvExpression ExGlobal)]]+ ),+ ( "!e.!a => Q.org.eolang => [(!e >> Q.org, !a >> eolang), (!e >> Q, !a >> org)]",+ ExDispatch (ExMeta "e") (AtMeta "a"),+ ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang"),+ [ [("e", MvExpression (ExDispatch ExGlobal (AtLabel "org"))), ("a", MvAttribute (AtLabel "eolang"))],+ [("e", MvExpression ExGlobal), ("a", MvAttribute (AtLabel "org"))]+ ]+ )+ ]++ describe "matchAttribute: attribute => attribute => substitution" $+ test+ matchAttribute+ [ ("~1 => ~1 => ()", AtAlpha 1, AtAlpha 1, Just []),+ ("!a => ^ => (!a >> ^)", AtMeta "a", AtRho, Just [("a", MvAttribute AtRho)]),+ ("!a => @ => (!a >> @)", AtMeta "a", AtPhi, Just [("a", MvAttribute AtPhi)]),+ ("~0 => x => X", AtAlpha 0, AtLabel "x", Nothing)+ ]++ describe "matchNonMetaExactBindings" $+ test+ matchNonMetaExactBindings+ [ ( "[^ -> ?, !a -> ?] => [^ -> ?, x -> ?] => (!a >> x)",+ [BiVoid AtRho, BiVoid (AtMeta "a")],+ [BiVoid AtRho, BiVoid (AtLabel "x")],+ Just [("a", MvAttribute (AtLabel "x"))]+ ),+ ( "[^ -> ?, !a -> ?] => [!x -> ?, ^ -> ?] => (!a >> x)",+ [BiVoid AtRho, BiVoid (AtMeta "a")],+ [BiVoid (AtLabel "x"), BiVoid AtRho],+ Just [("a", MvAttribute (AtLabel "x"))]+ ),+ ( "[^ -> ?] => [^ -> ?] => ()",+ [BiVoid AtRho],+ [BiVoid AtRho],+ Just []+ )+ ]++ describe "matchBindings: [binding] => [binding] => substitution" $+ test+ matchBindings+ [ ( "[] => [] => ()",+ [],+ [],+ Just []+ ),+ ( "[!B] => T:[x -> ?, D> 01-, L> Func] => (!B >> T)",+ [BiMeta "B"],+ [BiVoid (AtLabel "x"), BiDelta "01-", BiLambda "Func"],+ Just [("B", MvBindings [BiVoid (AtLabel "x"), BiDelta "01-", BiLambda "Func"])]+ ),+ ( "[D> 00-] => [D> 00-, L> Func] => X",+ [BiDelta "00-"],+ [BiDelta "00-", BiLambda "Func"],+ Nothing+ ),+ ( "[y -> ?, !a -> ?] => [x -> ?, y -> ?] => (!a >> x)",+ [BiVoid (AtLabel "y"), BiVoid (AtMeta "a")],+ [BiVoid (AtLabel "x"), BiVoid (AtLabel "y")],+ Just [("a", MvAttribute (AtLabel "x"))]+ ),+ ( "[!B, x -> ?] => [x -> ?] => (!B >> [])",+ [BiMeta "B", BiVoid (AtLabel "x")],+ [BiVoid (AtLabel "x")],+ Just [("B", MvBindings [])]+ ),+ ( "[!B, x -> ?] => [x -> ?, y -> ?] => (!B >> [y -> ?])",+ [BiMeta "B", BiVoid (AtLabel "x")],+ [BiVoid (AtLabel "x"), BiVoid (AtLabel "y")],+ Just [("B", MvBindings [BiVoid (AtLabel "y")])]+ ),+ ( "[!B, !x -> ?] => [y -> ?, D> -> 00-, L> Func] => (!x >> y, !B >> [D> -> 00-, L> Func])",+ [BiMeta "B", BiVoid (AtMeta "x")],+ [BiVoid (AtLabel "y"), BiDelta "00-", BiLambda "Func"],+ Just [("B", MvBindings [BiDelta "00-", BiLambda "Func"]), ("x", MvAttribute (AtLabel "y"))]+ ),+ ( "[!x -> ?, !y -> ?] => [a -> ?, b -> ?] => (!x >> a, !y >> b)",+ [BiVoid (AtMeta "x"), BiVoid (AtMeta "y")],+ [BiVoid (AtLabel "a"), BiVoid (AtLabel "b")],+ Just [("x", MvAttribute (AtLabel "a")), ("y", MvAttribute (AtLabel "b"))]+ )+ ]++ describe "matchExpression: expression => pattern => substitution" $+ test+ matchExpression+ [ ("$ => $ => ()", ExThis, ExThis, Just []),+ ("Q => Q => ()", ExGlobal, ExGlobal, Just []),+ ( "!e => Q => (!e >> Q)",+ ExMeta "e",+ ExGlobal,+ Just [("e", MvExpression ExGlobal)]+ ),+ ( "!e => Q.org(x -> $) => (!e >> Q.org(x -> $))",+ ExMeta "e",+ ExApplication (ExDispatch ExGlobal (AtLabel "org")) [BiTau (AtLabel "x") ExThis],+ Just [("e", MvExpression (ExApplication (ExDispatch ExGlobal (AtLabel "org")) [BiTau (AtLabel "x") ExThis]))]+ ),+ ( "!e1.x => Q.org.x => (!e1 >> Q.org)",+ ExDispatch (ExMeta "e1") (AtLabel "x"),+ ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "x"),+ Just [("e1", MvExpression (ExDispatch ExGlobal (AtLabel "org")))]+ ),+ ( "!e.org.!a => $.org.x => (!e >> $, !a >> x)",+ ExDispatch (ExDispatch (ExMeta "e") (AtLabel "org")) (AtMeta "a"),+ ExDispatch (ExDispatch ExThis (AtLabel "org")) (AtLabel "x"),+ Just [("e", MvExpression ExThis), ("a", MvAttribute (AtLabel "x"))]+ ),+ ( "[[!a -> !e, !B]].!a => [[x -> Q, y -> $]].x => (!a >> x, !e >> Q, !B >> [y -> $])",+ ExDispatch (ExFormation [BiTau (AtMeta "a") (ExMeta "e"), BiMeta "B"]) (AtMeta "a"),+ ExDispatch+ ( ExFormation+ [ BiTau (AtLabel "x") ExGlobal,+ BiTau (AtLabel "y") ExThis+ ]+ )+ (AtLabel "x"),+ Just+ [ ("a", MvAttribute (AtLabel "x")),+ ("e", MvExpression ExGlobal),+ ("B", MvBindings [BiTau (AtLabel "y") ExThis])+ ]+ ),+ ( "Q * !t => Q.org => (!t >> [.org])",+ ExMetaTail ExGlobal "t",+ ExDispatch ExGlobal (AtLabel "x"),+ Just [("t", MvTail [TaDispatch (AtLabel "x")])]+ ),+ ( "Q * !t => Q.org(x -> [[]]) => (!t >> [.org, (x -> [[]])])",+ ExMetaTail ExGlobal "t",+ ExApplication (ExDispatch ExGlobal (AtLabel "org")) [BiTau (AtLabel "x") (ExFormation [])],+ Just [("t", MvTail [TaDispatch (AtLabel "org"), TaApplication [BiTau (AtLabel "x") (ExFormation [])]])]+ ),+ ( "Q.!a * !t => Q.org(x -> [[]]) => (!a >> org, !t >> [(x -> [[]])])",+ ExMetaTail (ExDispatch ExGlobal (AtMeta "a")) "t",+ ExApplication (ExDispatch ExGlobal (AtLabel "org")) [BiTau (AtLabel "x") (ExFormation [])],+ Just [("a", MvAttribute (AtLabel "org")), ("t", MvTail [TaApplication [BiTau (AtLabel "x") (ExFormation [])]])]+ ),+ ( "Q.x(y -> $ * !t1) * !t2 => Q.x(y -> $.q).p => (!t1 >> [.q], !t2 >> [.p])",+ ExMetaTail (ExApplication (ExDispatch ExGlobal (AtLabel "x")) [BiTau (AtLabel "y") (ExMetaTail ExThis "t1")]) "t2",+ ExDispatch (ExApplication (ExDispatch ExGlobal (AtLabel "x")) [BiTau (AtLabel "y") (ExDispatch ExThis (AtLabel "q"))]) (AtLabel "p"),+ Just [("t1", MvTail [TaDispatch (AtLabel "q")]), ("t2", MvTail [TaDispatch (AtLabel "p")])]+ )+ ]++ describe "matchBindingsWithFiltering: [binding] => [binding] => ([binding], substitution)" $+ test+ matchBindingsWithFiltering+ [ ( "[^ -> ?] => [^ -> ?] => ([], ())",+ [BiVoid AtRho],+ [BiVoid AtRho],+ ([], [])+ ),+ ( "[x -> ?] => [x -> ?] => ([], ())",+ [BiVoid (AtLabel "x")],+ [BiVoid (AtLabel "x")],+ ([], [])+ ),+ ( "[x -> ?] => [x -> ?, ^ -> ?] => ([^ -> ?], ())",+ [BiVoid (AtLabel "x")],+ [BiVoid (AtLabel "x"), BiVoid AtRho],+ ([BiVoid AtRho], [])+ ),+ ( "[!a -> ?] => [x -> ?] => ([], (!a -> x))",+ [BiVoid (AtMeta "a")],+ [BiVoid (AtLabel "x")],+ ([], [("a", MvAttribute (AtLabel "x"))])+ )+ ]++ describe "combine" $ do+ it "combines empty substitutions" $ do+ combine substEmpty substEmpty `shouldBe` Just substEmpty+ it "combines two empty substs from list" $ do+ combine (Subst Map.empty) (Subst Map.empty) `shouldBe` Just substEmpty+ it "combines empty subst with single one" $ do+ let Subst joined = maybeCombined substEmpty (Subst (Map.singleton "at" (MvAttribute AtPhi)))+ Map.lookup "at" joined `shouldBe` Just (MvAttribute AtPhi)+ it "combines two different subst" $ do+ let Subst joined =+ maybeCombined+ (Subst (Map.singleton "first" (MvAttribute AtPhi)))+ (Subst (Map.singleton "second" (MvBytes "00-")))+ Map.lookup "first" joined `shouldBe` Just (MvAttribute AtPhi)+ Map.lookup "second" joined `shouldBe` Just (MvBytes "00-")+ it "leave values in the same substs" $ do+ let rho = MvAttribute AtRho+ first =+ Subst+ ( Map.fromList+ [ ("first", rho),+ ("second", MvAttribute AtPhi)+ ]+ )+ second = Subst (Map.singleton "first" rho)+ Subst joined = maybeCombined first second+ Map.lookup "first" joined `shouldBe` Just (MvAttribute AtRho)+ it "returns Nothing if values are different" $ do+ combine (Subst (Map.singleton "x" (MvAttribute AtPhi))) (Subst (Map.singleton "x" (MvAttribute AtRho))) `shouldBe` Nothing+ it "clears all the values" $ do+ let first =+ Subst+ ( Map.fromList+ [ ("x", MvAttribute AtRho),+ ("y", MvBytes "1F-")+ ]+ )+ second = Subst (Map.singleton "x" (MvAttribute AtPhi))+ combine first second `shouldBe` Nothing++ describe "isBindingWithMetaAttr" $ do+ it "does not touch simple attr" $ do+ isBindingWithMetaAttr (BiVoid (AtLabel "x")) `shouldBe` False+ it "recognizes void meta attr" $ do+ isBindingWithMetaAttr (BiVoid (AtMeta "x")) `shouldBe` True
+ test/ParserSpec.hs view
@@ -0,0 +1,260 @@+-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Use tuple-section" #-}++module ParserSpec where++import Ast+import Control.Monad (forM_)+import Data.Either (isLeft, isRight)+import Misc (allPathsIn)+import Parser+import System.FilePath (takeBaseName)+import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, describe, it, runIO, shouldBe, shouldSatisfy)++test ::+ (Eq a, Show a) =>+ (String -> Either String a) ->+ [(String, Maybe a)] ->+ SpecWith (Arg Expectation)+test function useCases =+ forM_ useCases $ \(ipt, res) ->+ it ipt $ case res of+ Just right -> function ipt `shouldBe` Right right+ _ -> function ipt `shouldSatisfy` isLeft++spec :: Spec+spec = do+ describe "parse program" $+ test+ parseProgram+ [ ("Q -> [[]]", Just (Program (ExFormation []))),+ ("Q -> T(x -> Q)", Just (Program (ExApplication ExTermination [BiTau (AtLabel "x") ExGlobal]))),+ ("Q -> Q.org.eolang", Just (Program (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")))),+ ("Q -> [[x -> $, y -> ?]]", Just (Program (ExFormation [BiTau (AtLabel "x") ExThis, BiVoid (AtLabel "y")]))),+ ("{[[foo ↦ QQ]]}", Just (Program (ExFormation [BiTau (AtLabel "foo") (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang"))])))+ ]++ describe "parse expression" $+ test+ parseExpression+ [ ("Q.!a", Just (ExDispatch ExGlobal (AtMeta "a"))),+ ("[[]](!a1 -> $)", Just (ExApplication (ExFormation []) [BiTau (AtMeta "a1") ExThis])),+ ( "[[]](~0 -> $)(~11 -> Q)",+ Just+ ( ExApplication+ ( ExApplication+ (ExFormation [])+ [BiTau (AtAlpha 0) ExThis]+ )+ [BiTau (AtAlpha 11) ExGlobal]+ )+ ),+ ("[[]](x -> $, y -> Q)", Just (ExApplication (ExFormation []) [BiTau (AtLabel "x") ExThis, BiTau (AtLabel "y") ExGlobal])),+ ("[[!B, !B1]]", Just (ExFormation [BiMeta "B", BiMeta "B1"])),+ ("[[!B2, !a2 -> $]]", Just (ExFormation [BiMeta "B2", BiTau (AtMeta "a2") ExThis])),+ ("!e0", Just (ExMeta "e0")),+ ("[[x -> !e]]", Just (ExFormation [BiTau (AtLabel "x") (ExMeta "e")])),+ ("[[!a -> !e1]]", Just (ExFormation [BiTau (AtMeta "a") (ExMeta "e1")])),+ ("Q * !t", Just (ExMetaTail ExGlobal "t")),+ ("[[]](x -> $) * !t1", Just (ExMetaTail (ExApplication (ExFormation []) [BiTau (AtLabel "x") ExThis]) "t1")),+ ("[[D> --]]", Just (ExFormation [BiDelta "--"])),+ ("[[D> 1F-]]", Just (ExFormation [BiDelta "1F-"])),+ ("[[\n L> Func,\n D> 00-\n]]", Just (ExFormation [BiLambda "Func", BiDelta "00-"])),+ ("[[D> 1F-2A-00]]", Just (ExFormation [BiDelta "1F-2A-00"])),+ ("[[D> !b0]]", Just (ExFormation [BiMetaDelta "b0"])),+ ("[[L> Function]]", Just (ExFormation [BiLambda "Function"])),+ ("[[L> !F3]]", Just (ExFormation [BiMetaLambda "F3"])),+ ("[[x() -> [[]] ]]", Just (ExFormation [BiTau (AtLabel "x") (ExFormation [])])),+ ( "[[y(^,@,z) -> [[q -> Q.a]] ]]",+ Just+ ( ExFormation+ [ BiTau+ (AtLabel "y")+ ( ExFormation+ [ BiVoid AtRho,+ BiVoid AtPhi,+ BiVoid (AtLabel "z"),+ BiTau (AtLabel "q") (ExDispatch ExGlobal (AtLabel "a"))+ ]+ )+ ]+ )+ ),+ ( "!e(x(^,@) -> [[w -> !e1]])",+ Just+ ( ExApplication+ (ExMeta "e")+ [ BiTau+ (AtLabel "x")+ ( ExFormation+ [ BiVoid AtRho,+ BiVoid AtPhi,+ BiTau (AtLabel "w") (ExMeta "e1")+ ]+ )+ ]+ )+ ),+ ( "[[x -> y.z, a -> ~1, w -> ^, u -> @, p -> !a, q -> !e]]",+ Just+ ( ExFormation+ [ BiTau+ (AtLabel "x")+ (ExDispatch (ExDispatch ExThis (AtLabel "y")) (AtLabel "z")),+ BiTau+ (AtLabel "a")+ (ExDispatch ExThis (AtAlpha 1)),+ BiTau+ (AtLabel "w")+ (ExDispatch ExThis AtRho),+ BiTau+ (AtLabel "u")+ (ExDispatch ExThis AtPhi),+ BiTau+ (AtLabel "p")+ (ExDispatch ExThis (AtMeta "a")),+ BiTau+ (AtLabel "q")+ (ExMeta "e")+ ]+ )+ ),+ ( "Q.x(~1, y, [[]].z, Q.y(^,@))",+ Just+ ( ExApplication+ (ExDispatch ExGlobal (AtLabel "x"))+ [ BiTau (AtAlpha 0) (ExDispatch ExThis (AtAlpha 1)),+ BiTau (AtAlpha 1) (ExDispatch ExThis (AtLabel "y")),+ BiTau (AtAlpha 2) (ExDispatch (ExFormation []) (AtLabel "z")),+ BiTau+ (AtAlpha 3)+ ( ExApplication+ (ExDispatch ExGlobal (AtLabel "y"))+ [ BiTau (AtAlpha 0) (ExDispatch ExThis AtRho),+ BiTau (AtAlpha 1) (ExDispatch ExThis AtPhi)+ ]+ )+ ]+ )+ ),+ ( "5.plus(5.q(\"hello\".length))",+ Just+ ( ExApplication+ ( ExDispatch+ ( ExApplication+ (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "number"))+ [ BiTau+ (AtAlpha 0)+ ( ExApplication+ (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "bytes"))+ [ BiTau+ (AtAlpha 0)+ (ExFormation [BiDelta "40-14-00-00-00-00-00-00"])+ ]+ )+ ]+ )+ (AtLabel "plus")+ )+ [ BiTau+ (AtAlpha 0)+ ( ExApplication+ ( ExDispatch+ ( ExApplication+ (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "number"))+ [ BiTau+ (AtAlpha 0)+ ( ExApplication+ (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "bytes"))+ [ BiTau+ (AtAlpha 0)+ (ExFormation [BiDelta "40-14-00-00-00-00-00-00"])+ ]+ )+ ]+ )+ (AtLabel "q")+ )+ [ BiTau+ (AtAlpha 0)+ ( ExDispatch+ ( ExApplication+ (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "string"))+ [ BiTau+ (AtAlpha 0)+ ( ExApplication+ (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "bytes"))+ [ BiTau+ (AtAlpha 0)+ (ExFormation [BiDelta "68-65-6C-6C-6F"])+ ]+ )+ ]+ )+ (AtLabel "length")+ )+ ]+ )+ ]+ )+ )+ ]++ describe "just parses" $+ forM_+ [ "[[x -> $, y -> ?]]",+ "[[x() -> [[]] ]]",+ "[[x(^, @, y) -> [[q -> QQ]] ]]",+ "Q.x(y() -> [[]])",+ "Q.x(y(q) -> [[w -> !e]])",+ "Q.x(~1(^,@) -> [[]])",+ "Q.x.~1.^.@.!a0",+ "[[x -> y.z]]",+ "[[x -> ~1]]",+ "[[x -> ^, y -> @, z -> !a]]",+ "Q.x(a.b.c, Q.a(b), [[]])",+ "Q.x(~1, y, [[]].z, Q.y(^,@))",+ "[[x -> 5.plus(5), y -> \"hello\", z -> 42.5]]",+ "[[w -> x(~1)]]",+ "[[\n x -> \"Hi\",\n y -> 42\n]]",+ "[[x -> -42, y -> +34]]",+ "⟦x ↦ Φ.org.eolang(z ↦ ξ.f, x ↦ α0, φ ↦ ρ, t ↦ φ, first ↦ ⟦ λ ⤍ Function_name, Δ ⤍ 42- ⟧)⟧",+ "[[x -> 1.00e+3, y -> 2.32e-4]]"+ ]+ (\expr -> it expr (parseExpression expr `shouldSatisfy` isRight))++ describe "prohibits" $+ test+ parseExpression+ ( map+ (\input -> (input, Nothing))+ [ "Q.x()",+ "Q * !t1 * !t2",+ "Q(x -> [[]])",+ "$(x -> [[]])",+ "Q.x(x -> ?)",+ "Q.x(L> Func)",+ "Q.x(D> --)",+ "Q.x(!B)",+ "Q.x(~1 -> ?)",+ "Q.x(L> !F)",+ "Q.x(D> !b)",+ "[[~0 -> Q.x]]",+ "[[x(~1) -> [[]] ]]",+ "[[y(!e) -> [[]] ]]",+ "[[z(w) -> Q.x]]",+ "Q.x(y(~1) -> [[]])"+ ]+ )++ describe "parse packs" $ do+ packs <- runIO (allPathsIn "test/resources/parser-packs")+ forM_+ packs+ ( \pack -> do+ content <- runIO (readFile pack)+ it (takeBaseName pack) (parseProgram content `shouldSatisfy` isRight)+ )
+ test/PrinterSpec.hs view
@@ -0,0 +1,46 @@+-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module PrinterSpec where++import Ast+import Control.Monad (forM_)+import Matcher (MetaValue (MvAttribute, MvExpression), substEmpty, substSingle)+import Parser (parseProgramThrows)+import Prettyprinter+import Printer+import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, describe, it, runIO, shouldBe)++test :: (Pretty a) => (a -> String) -> [(String, String, a)] -> SpecWith (Arg Expectation)+test function useCases =+ forM_ useCases $ \(input, output, arg) ->+ it input $ function arg `shouldBe` output++spec :: Spec+spec = do+ describe "print program" $ do+ useCases <-+ runIO $+ mapM+ ( \(input, output) -> do+ prog <- parseProgramThrows input+ return (input, output, prog)+ )+ [ ("Q -> $", "Φ ↦ ξ"),+ ("Q -> Q.org.x", "Φ ↦ Φ.org.x"),+ ("Q -> [[]]", "Φ ↦ ⟦⟧"),+ ("Q -> [[@ -> ?]](~1 -> Q.x)", "Φ ↦ ⟦ φ ↦ ∅ ⟧(\n α1 ↦ Φ.x\n)"),+ ("Q -> !e * !t", "Φ ↦ !e * !t"),+ ( "Q -> [[D> 00-,L> F,^ -> ?,!B,@ -> [[y -> ?]]]]",+ "Φ ↦ ⟦\n Δ ⤍ 00-,\n λ ⤍ F,\n ρ ↦ ∅,\n !B,\n φ ↦ ⟦ y ↦ ∅ ⟧\n⟧"+ )+ ]+ test printProgram useCases++ describe "print substitution" $+ test+ printSubstitutions+ [ ("[()]", "[\n (\n \n )\n]", [substEmpty]),+ ("[(!e >> Q.x)]", "[\n (\n !e >> Φ.x\n )\n]", [substSingle "e" (MvExpression (ExDispatch ExGlobal (AtLabel "x")))]),+ ("[(!a >> x)]", "[\n (\n !a >> x\n )\n]", [substSingle "a" (MvAttribute (AtLabel "x"))])+ ]
+ test/ReplacerSpec.hs view
@@ -0,0 +1,55 @@+-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module ReplacerSpec where++import Ast+import Control.Monad (forM_)+import Replacer+import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, describe, it, shouldBe)++test ::+ (Program -> [Expression] -> [Expression] -> Maybe Program) ->+ [(String, Program, [Expression], [Expression], Maybe Program)] ->+ SpecWith (Arg Expectation)+test function useCases =+ forM_ useCases $ \(desc, prog, ptns, repls, res) ->+ it desc $ function prog ptns repls `shouldBe` res++spec :: Spec+spec = do+ describe "replaceProgram: program => ([expression], [expression]) => program" $ do+ test+ replaceProgram+ [ ( "Q -> Q.y.x() => ([Q.y], [$]) => Q -> $.x()",+ Program (ExApplication (ExDispatch (ExDispatch ExGlobal (AtLabel "y")) (AtLabel "x")) []),+ [ExDispatch ExGlobal (AtLabel "y")],+ [ExThis],+ Just (Program (ExApplication (ExDispatch ExThis (AtLabel "x")) []))+ ),+ ( "Q -> [[x -> [[y -> $]], z -> [[w -> $]] ]] => ([[y -> $], [w -> $]], [Q.y, Q.w]) => Q -> [[x -> Q.y, z -> Q.w]]",+ Program+ ( ExFormation+ [ BiTau (AtLabel "x") (ExFormation [BiTau (AtLabel "y") ExThis]),+ BiTau (AtLabel "z") (ExFormation [BiTau (AtLabel "w") ExThis])+ ]+ ),+ [ExFormation [BiTau (AtLabel "y") ExThis], ExFormation [BiTau (AtLabel "w") ExThis]],+ [ExDispatch ExGlobal (AtLabel "y"), ExDispatch ExGlobal (AtLabel "w")],+ Just+ ( Program+ ( ExFormation+ [ BiTau (AtLabel "x") (ExDispatch ExGlobal (AtLabel "y")),+ BiTau (AtLabel "z") (ExDispatch ExGlobal (AtLabel "w"))+ ]+ )+ )+ ),+ ("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-"]],+ [ExGlobal],+ Just (Program ExGlobal)+ )+ ]
+ test/RewriterSpec.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module RewriterSpec where++import Control.Monad (forM_)+import Data.Aeson+import Data.Yaml qualified as Yaml+import GHC.Generics+import Misc (allPathsIn)+import Rewriter (rewrite)+import Test.Hspec (Spec, describe, runIO, shouldBe, it)+import qualified Yaml+import System.FilePath (takeBaseName)++data YamlPack = YamlPack+ { input :: String,+ output :: String,+ ruleSet :: Maybe Yaml.RuleSet+ }+ deriving (Generic, FromJSON, Show)++yamlPack :: FilePath -> IO YamlPack+yamlPack = Yaml.decodeFileThrow++spec :: Spec+spec = do+ describe "rewrite packs" $ do+ packs <- runIO (allPathsIn "test/resources/rewriter-packs")+ forM_+ packs+ ( \pth -> do+ pack <- runIO $ yamlPack pth+ let output' = output pack+ input' = input pack+ ruleSet' = ruleSet pack+ rewritten <- runIO $ rewrite input' ruleSet'+ it (takeBaseName pth) (rewritten `shouldBe` output')+ )
+ test/Spec.hs view
@@ -0,0 +1,7 @@+-- This pragma runs `hspec-discover` preprocessor at compile time.+-- This preprocessor scans for *Spec.hs modules and gathers them into+-- one big spec :: Spec module which is run by test/Main.hs+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT