diff --git a/phino.cabal b/phino.cabal --- a/phino.cabal +++ b/phino.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: phino -version: 0.0.0.43 +version: 0.0.0.44 license: MIT synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions description: Please see the README on GitHub at @@ -35,7 +35,7 @@ Rule, Dataize, Functions, - Term, + Deps, Misc, Must, Logger, diff --git a/src/CLI.hs b/src/CLI.hs --- a/src/CLI.hs +++ b/src/CLI.hs @@ -18,6 +18,7 @@ import Data.Maybe (isJust, isNothing) import Data.Version (showVersion) import Dataize (DataizeContext (DataizeContext), dataize) +import Deps (saveStep) import Functions (buildTerm) import qualified Functions import LaTeX (explainRules, programToLaTeX) @@ -28,12 +29,12 @@ import Options.Applicative import Parser (parseProgramThrows) import Paths_phino (version) -import Pretty (PrintMode (SALTY, SWEET), prettyBytes, prettyProgram', Encoding (UNICODE)) +import Pretty (Encoding (UNICODE), PrintMode (SALTY, SWEET), prettyBytes, prettyProgram') import Rewriter (RewriteContext (RewriteContext), rewrite') import System.Exit (ExitCode (..), exitFailure) import System.IO (getContents') import Text.Printf (printf) -import XMIR (XmirContext (XmirContext), parseXMIRThrows, printXMIR, programToXMIR, xmirToPhi) +import XMIR (XmirContext (XmirContext), defaultXmirContext, parseXMIRThrows, printXMIR, programToXMIR, xmirToPhi) import Yaml (normalizationRules) import qualified Yaml as Y @@ -67,6 +68,7 @@ maxDepth :: Integer, maxCycles :: Integer, depthSensitive :: Bool, + stepsDir :: Maybe FilePath, inputFile :: Maybe FilePath } @@ -94,6 +96,7 @@ maxCycles :: Integer, inPlace :: Bool, targetFile :: Maybe FilePath, + stepsDir :: Maybe FilePath, inputFile :: Maybe FilePath } @@ -150,6 +153,9 @@ optTarget :: Parser (Maybe FilePath) optTarget = optional (strOption (long "target" <> short 't' <> metavar "FILE" <> help "File to save output to")) +optStepsDir :: Parser (Maybe FilePath) +optStepsDir = optional (strOption (long "steps-dir" <> metavar "FILE" <> help "Directory to save intermediate steps during rewriting/dataizing")) + optShuffle :: Parser Bool optShuffle = switch (long "shuffle" <> help "Shuffle rules before applying") @@ -173,6 +179,7 @@ <*> optMaxDepth <*> optMaxCycles <*> optDepthSensitive + <*> optStepsDir <*> argInputFile ) @@ -202,6 +209,7 @@ <*> optMaxCycles <*> switch (long "in-place" <> help "Edit file in-place instead of printing to output") <*> optTarget + <*> optStepsDir <*> argInputFile ) @@ -243,11 +251,12 @@ validateOpts logDebug (printf "Amount of rewriting cycles across all the rules: %d, per rule: %d" maxCycles maxDepth) input <- readInput inputFile + let xmirCtx = Just (XmirContext omitListing omitComments input) rules' <- getRules normalize shuffle rules program <- parseProgram input inputFormat - rewritten <- rewrite' program rules' (RewriteContext program maxDepth maxCycles depthSensitive buildTerm must) + rewritten <- rewrite' program rules' (context program xmirCtx) logDebug (printf "Printing rewritten 𝜑-program as %s" (show outputFormat)) - prog <- printProgram rewritten outputFormat printMode input + prog <- printProgram outputFormat printMode xmirCtx rewritten output targetFile prog where validateOpts :: IO () @@ -264,12 +273,6 @@ validateMaxDepth maxDepth validateMaxCycles maxCycles validateMust must - printProgram :: Program -> IOFormat -> PrintMode -> String -> IO String - printProgram prog PHI mode _ = pure (prettyProgram' prog mode UNICODE) - printProgram prog XMIR _ listing = do - xmir <- programToXMIR prog (XmirContext omitListing omitComments listing) - pure (printXMIR xmir) - printProgram prog LATEX mode _ = pure (programToLaTeX prog mode) output :: Maybe FilePath -> String -> IO () output target prog = case (inPlace, target, inputFile) of (True, _, Just file) -> do @@ -283,17 +286,36 @@ (False, Nothing, _) -> do logDebug "The option '--target' is not specified, printing to console..." putStrLn prog + context :: Program -> Maybe XmirContext -> RewriteContext + context program ctx = + RewriteContext + program + maxDepth + maxCycles + depthSensitive + buildTerm + must + (saveStep stepsDir (ioToExtension outputFormat) (printProgram outputFormat printMode ctx)) CmdDataize opts@OptsDataize {..} -> do validateOpts input <- readInput inputFile prog <- parseProgram input inputFormat - dataized <- dataize prog (DataizeContext prog maxDepth maxCycles depthSensitive buildTerm) + dataized <- dataize prog (context prog) maybe (throwIO CouldNotDataize) (putStrLn . prettyBytes) dataized where validateOpts :: IO () validateOpts = do validateMaxDepth maxDepth validateMaxCycles maxCycles + context :: Program -> DataizeContext + context program = + DataizeContext + program + maxDepth + maxCycles + depthSensitive + buildTerm + (saveStep stepsDir (ioToExtension PHI) (printProgram PHI SWEET Nothing)) CmdExplain opts@OptsExplain {..} -> do validateOpts rules' <- getRules normalize shuffle rules @@ -342,6 +364,13 @@ parseProgram xmir XMIR = do doc <- parseXMIRThrows xmir xmirToPhi doc + printProgram :: IOFormat -> PrintMode -> Maybe XmirContext -> Program -> IO String + printProgram PHI mode _ prog = pure (prettyProgram' prog mode UNICODE) + printProgram XMIR mode Nothing prog = printProgram XMIR mode (Just defaultXmirContext) prog + printProgram XMIR _ (Just ctx) prog = do + xmir <- programToXMIR prog ctx + pure (printXMIR xmir) + printProgram LATEX mode _ prog = pure (programToLaTeX prog mode) getRules :: Bool -> Bool -> [FilePath] -> IO [Y.Rule] getRules normalize shuffle rules = do ordered <- @@ -373,3 +402,6 @@ logDebug (printf "The option '--target' is specified, printing to '%s'..." file) writeFile file content logInfo (printf "The command result was saved in '%s'" file) + ioToExtension :: IOFormat -> String + ioToExtension LATEX = "tex" + ioToExtension format = show format diff --git a/src/Dataize.hs b/src/Dataize.hs --- a/src/Dataize.hs +++ b/src/Dataize.hs @@ -10,11 +10,11 @@ import Builder (contextualize) import Control.Exception (throwIO) import Data.List (partition) +import Deps (BuildTermFunc, SaveStepFunc) import Misc import Must (Must (..)) import Rewriter (RewriteContext (RewriteContext), rewrite') import Rule (RuleContext (RuleContext), isNF) -import Term (BuildTermFunc) import Text.Printf (printf) import XMIR (XmirContext (XmirContext)) import Yaml (normalizationRules) @@ -24,11 +24,20 @@ _maxDepth :: Integer, _maxCycles :: Integer, _depthSensitive :: Bool, - _buildTerm :: BuildTermFunc + _buildTerm :: BuildTermFunc, + _saveStep :: SaveStepFunc } switchContext :: DataizeContext -> RewriteContext -switchContext DataizeContext {..} = RewriteContext _program _maxDepth _maxCycles _depthSensitive _buildTerm MtDisabled +switchContext DataizeContext {..} = + RewriteContext + _program + _maxDepth + _maxCycles + _depthSensitive + _buildTerm + MtDisabled + _saveStep maybeBinding :: (Binding -> Bool) -> [Binding] -> (Maybe Binding, [Binding]) maybeBinding _ [] = (Nothing, []) diff --git a/src/Deps.hs b/src/Deps.hs new file mode 100644 --- /dev/null +++ b/src/Deps.hs @@ -0,0 +1,42 @@ +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +-- The main goal of this module is breaking 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 Deps where + +import Ast +import Logger (logDebug) +import Matcher +import System.Directory (createDirectoryIfMissing) +import System.FilePath +import Text.Printf (printf) +import Yaml + +data Term + = TeExpression Expression + | TeAttribute Attribute + | TeBytes Bytes + | TeBindings [Binding] + +type BuildTermMethod = [ExtraArgument] -> Subst -> Program -> IO Term + +type BuildTermFunc = String -> BuildTermMethod + +type SaveStepFunc = Program -> Integer -> IO () + +saveStep :: Maybe FilePath -> String -> (Program -> IO String) -> SaveStepFunc +saveStep Nothing _ _ _ _ = pure () +saveStep (Just dir) ext print' prog step = do + createDirectoryIfMissing True dir + let path = dir printf "%05d.%s" step ext + content <- print' prog + writeFile path content + logDebug (printf "Saved step '%d' to '%s'" step path) + +dontSaveStep :: SaveStepFunc +dontSaveStep = saveStep Nothing "" (\_ -> pure "") diff --git a/src/Functions.hs b/src/Functions.hs --- a/src/Functions.hs +++ b/src/Functions.hs @@ -24,7 +24,7 @@ import Random (randomString) import Regexp import System.Random (randomRIO) -import Term +import Deps import Text.Printf (printf) import qualified Yaml as Y diff --git a/src/Misc.hs b/src/Misc.hs --- a/src/Misc.hs +++ b/src/Misc.hs @@ -67,8 +67,8 @@ show DirectoryDoesNotExist {..} = printf "Directory '%s' does not exist" dir -- Minimal matcher function (required for view pattern) -matchDataoObject :: Expression -> Maybe (String, Bytes) -matchDataoObject +matchDataObject :: Expression -> Maybe (String, Bytes) +matchDataObject ( ExApplication (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel label)) ( BiTau @@ -82,7 +82,7 @@ ) ) ) = Just (label, bts) -matchDataoObject _ = Nothing +matchDataObject _ = Nothing pattern DataString :: Bytes -> Expression pattern DataString bts = DataObject "string" bts @@ -91,7 +91,7 @@ pattern DataNumber bts = DataObject "number" bts pattern DataObject :: String -> Bytes -> Expression -pattern DataObject label bts <- (matchDataoObject -> Just (label, bts)) +pattern DataObject label bts <- (matchDataObject -> Just (label, bts)) where DataObject label bts = ExApplication diff --git a/src/Rewriter.hs b/src/Rewriter.hs --- a/src/Rewriter.hs +++ b/src/Rewriter.hs @@ -15,6 +15,7 @@ import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe, isJust) import qualified Data.Set as Set +import Deps import Logger (logDebug) import Matcher (MetaValue (MvAttribute, MvBindings, MvBytes, MvExpression), Subst (Subst), combine, combineMany, defaultScope, matchProgram, substEmpty, substSingle) import Misc (ensuredFile) @@ -24,7 +25,6 @@ import Replacer (ReplaceProgramContext (ReplaceProgramContext), ReplaceProgramThrowsFunc, replaceProgramFastThrows, replaceProgramThrows) import Rule (RuleContext (RuleContext), matchProgramWithRule) import qualified Rule as R -import Term import Text.Printf import Yaml (ExtraArgument (..)) import qualified Yaml as Y @@ -35,7 +35,8 @@ _maxCycles :: Integer, _depthSensitive :: Bool, _buildTerm :: BuildTermFunc, - _must :: Must + _must :: Must, + _saveStep :: SaveStepFunc } data RewriteException @@ -117,34 +118,33 @@ hasMetaBindings = foldl (\acc bd -> acc || isMetaBinding bd) False tryBuildAndReplaceFast ptn res substs ctx = buildAndReplace' ptn res substs replaceProgramThrows ctx -rewrite :: Program -> [Y.Rule] -> Set.Set Program -> RewriteContext -> IO (Program, Set.Set Program) -rewrite program [] progs _ = pure (program, progs) -rewrite program (rule : rest) progs ctx = do +rewrite :: Program -> [Y.Rule] -> Set.Set Program -> Integer -> RewriteContext -> IO (Program, Set.Set Program) +rewrite program [] progs _ _ = pure (program, progs) +rewrite program (rule : rest) progs iteration ctx@RewriteContext {..} = do (prog, _progs) <- _rewrite program 1 progs - rewrite prog rest _progs ctx + rewrite prog rest _progs iteration ctx where _rewrite :: Program -> Integer -> Set.Set Program -> IO (Program, Set.Set Program) _rewrite prog count progs' = let ruleName = fromMaybe "unknown" (Y.name rule) ptn = Y.pattern rule res = Y.result rule - depth = _maxDepth ctx - in if count - 1 == depth + in if count - 1 == _maxDepth then do - logDebug (printf "Max amount of rewriting cycles (%d) for rule '%s' has been reached, rewriting is stopped" depth ruleName) - if _depthSensitive ctx - then throwIO (StoppedOnLimit "max-depth" depth) + logDebug (printf "Max amount of rewriting cycles (%d) for rule '%s' has been reached, rewriting is stopped" _maxDepth ruleName) + if _depthSensitive + then throwIO (StoppedOnLimit "max-depth" _maxDepth) else pure (prog, progs') else do - logDebug (printf "Starting rewriting cycle for rule '%s': %d out of %d" ruleName count depth) - matched <- R.matchProgramWithRule prog rule (RuleContext (_program ctx) (_buildTerm ctx)) + logDebug (printf "Starting rewriting cycle for rule '%s': %d out of %d" ruleName count _maxDepth) + matched <- R.matchProgramWithRule prog rule (RuleContext _program _buildTerm) if null matched then do logDebug (printf "Rule '%s' does not match, rewriting is stopped" ruleName) pure (prog, progs') else do logDebug (printf "Rule '%s' has been matched, applying..." ruleName) - prog' <- tryBuildAndReplaceFast ptn res matched (ReplaceProgramContext prog depth) + prog' <- tryBuildAndReplaceFast ptn res matched (ReplaceProgramContext prog _maxDepth) if prog == prog' then do logDebug (printf "Applied '%s', no changes made" ruleName) @@ -160,6 +160,7 @@ (countNodes prog) (countNodes prog') ) + _saveStep prog' (((iteration - 1) * _maxDepth) + count) _rewrite prog' (count + 1) (Set.insert prog' progs) rewrite' :: Program -> [Y.Rule] -> RewriteContext -> IO Program @@ -181,7 +182,7 @@ else pure prog else do logDebug (printf "Starting rewriting cycle for all rules: %d out of %d" count cycles) - (rewritten, progs') <- rewrite prog rules progs ctx + (rewritten, progs') <- rewrite prog rules progs count ctx if rewritten == prog then do logDebug "Rewriting is stopped since it has no effect" diff --git a/src/Rule.hs b/src/Rule.hs --- a/src/Rule.hs +++ b/src/Rule.hs @@ -21,7 +21,7 @@ import Misc (allPathsIn, btsToUnescapedStr) import Pretty (prettyAttribute, prettyBytes, prettyExpression, prettyExpression', prettySubsts, prettyBinding) import Regexp (match) -import Term (BuildTermFunc, Term (..)) +import Deps (BuildTermFunc, Term (..)) import Text.Printf (printf) import Yaml (normalizationRules) import qualified Yaml as Y diff --git a/src/Term.hs b/src/Term.hs deleted file mode 100644 --- a/src/Term.hs +++ /dev/null @@ -1,24 +0,0 @@ --- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com --- SPDX-License-Identifier: MIT - --- The main goal of this module is breaking 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 - | TeBindings [Binding] - -type BuildTermMethod = [ExtraArgument] -> Subst -> Program -> IO Term - -type BuildTermFunc = String -> BuildTermMethod diff --git a/test/CLISpec.hs b/test/CLISpec.hs --- a/test/CLISpec.hs +++ b/test/CLISpec.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unused-do-bind #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT @@ -8,12 +9,12 @@ import CLI (runCLI) import Control.Exception -import Control.Monad (forM_, unless) +import Control.Monad (forM_, unless, when) import Data.List (isInfixOf) import Data.Version (showVersion) import GHC.IO.Handle import Paths_phino (version) -import System.Directory (removeFile) +import System.Directory (doesDirectoryExist, doesFileExist, listDirectory, removeDirectoryRecursive, removeFile) import System.Exit (ExitCode (ExitFailure)) import System.IO import Test.Hspec @@ -153,14 +154,29 @@ ["rewrite", "--rule=test-resources/cli/first.yaml", "--rule=test-resources/cli/second.yaml", "--max-depth=1", "--max-cycles=3"] ["it seems rewriting is looping"] - it "with wrong attribute and valid error message" $ - testCLIFailed - ["rewrite", "test-resources/cli/with-$this-attribute.phi"] - [ "[ERROR]: Couldn't parse given phi program, cause: program:10:13:", - "10 | $this ↦ ⟦⟧", - " | ^^", - "unexpected \"$t\"" - ] + it "with wrong attribute and valid error message" $ + testCLIFailed + ["rewrite", "test-resources/cli/with-$this-attribute.phi"] + [ "[ERROR]: Couldn't parse given phi program, cause: program:10:13:", + "10 | $this ↦ ⟦⟧", + " | ^^", + "unexpected \"$t\"" + ] + + it "saves steps to dir with --steps-dir" $ do + let dir = "test-steps-temp" + dirExists <- doesDirectoryExist dir + when dirExists (removeDirectoryRecursive dir) + withStdin "Q -> [[ x -> \"hello\"]]" $ do + testCLISucceeded + ["rewrite", "--rule=test-resources/cli/infinite.yaml", "--max-cycles=2", "--max-depth=2", "--steps-dir=" ++ dir, "--sweet"] + ["hello_hi_hi"] + (`shouldBe` True) <$> doesDirectoryExist dir + files <- listDirectory dir + length files `shouldBe` 4 + (`shouldBe` True) <$> doesFileExist (dir ++ "/00001.phi") + (`shouldBe` True) <$> doesFileExist (dir ++ "/00003.phi") + removeDirectoryRecursive dir it "desugares without any rules flag from file" $ testCLISucceeded diff --git a/test/DataizeSpec.hs b/test/DataizeSpec.hs --- a/test/DataizeSpec.hs +++ b/test/DataizeSpec.hs @@ -5,13 +5,14 @@ import Ast import Control.Monad -import Dataize (dataize, dataize', morph, DataizeContext (DataizeContext)) +import Dataize (DataizeContext (DataizeContext), dataize, dataize', morph) +import Deps (dontSaveStep) +import Functions (buildTerm) import Parser (parseProgramThrows) import Test.Hspec -import Functions (buildTerm) defaultDataizeContext :: Program -> DataizeContext -defaultDataizeContext prog = DataizeContext prog 25 1 False buildTerm +defaultDataizeContext prog = DataizeContext prog 25 1 False buildTerm dontSaveStep test :: (Eq a, Show a) => (Expression -> DataizeContext -> IO (Maybe a)) -> [(String, Expression, Expression, Maybe a)] -> Spec test func useCases = diff --git a/test/FunctionsSpec.hs b/test/FunctionsSpec.hs --- a/test/FunctionsSpec.hs +++ b/test/FunctionsSpec.hs @@ -10,7 +10,7 @@ import Matcher (MetaValue (MvBindings), Subst (Subst)) import Misc (uniqueBindings') import Pretty (prettyExpression') -import Term (Term (TeBindings)) +import Deps (Term (TeBindings)) import Test.Hspec (Spec, describe, it, shouldBe) import Text.Printf (printf) import Yaml (ExtraArgument (ArgBinding)) diff --git a/test/RewriterSpec.hs b/test/RewriterSpec.hs --- a/test/RewriterSpec.hs +++ b/test/RewriterSpec.hs @@ -12,12 +12,13 @@ import Data.Aeson import Data.Char (isSpace) import Data.Yaml qualified as Yaml +import Deps (dontSaveStep) import Functions (buildTerm) import GHC.Generics import Misc (allPathsIn, ensuredFile) -import Must (Must(..)) +import Must (Must (..)) import Parser (parseProgramThrows) -import Pretty (PrintMode (SWEET), prettyProgram', Encoding (UNICODE)) +import Pretty (Encoding (UNICODE), PrintMode (SWEET), prettyProgram') import Rewriter (RewriteContext (RewriteContext), rewrite') import System.FilePath (makeRelative, replaceExtension, ()) import Test.Hspec (Spec, describe, expectationFailure, it, pending, runIO) @@ -97,7 +98,19 @@ if normalize' then pure normalizationRules else pure [] - rewritten <- rewrite' program rules' (RewriteContext program repeat' repeat' False buildTerm must') + rewritten <- + rewrite' + program + rules' + ( RewriteContext + program + repeat' + repeat' + False + buildTerm + must' + dontSaveStep + ) result' <- parseProgramThrows (output pack) unless (rewritten == result') $ expectationFailure