phino 0.0.0.5 → 0.0.0.6
raw patch · 6 files changed
+146/−21 lines, 6 files
Files
- phino.cabal +13/−2
- src/CLI.hs +64/−14
- src/Logger.hs +49/−0
- src/Misc.hs +6/−0
- src/Rewriter.hs +10/−4
- test/CLISpec.hs +4/−1
phino.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 name: phino-version: 0.0.0.5+version: 0.0.0.6 license: MIT synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions description: Please see the README on GitHub at <https://github.com/objectionary/phino#readme>@@ -24,7 +24,18 @@ library exposed-modules:- CLI, Ast, Parser, Matcher, Builder, Replacer, Printer, Rewriter, Yaml, Condition, Misc+ CLI,+ Ast,+ Parser,+ Matcher,+ Builder,+ Replacer,+ Printer,+ Rewriter,+ Yaml,+ Condition,+ Misc,+ Logger hs-source-dirs: src other-modules: Paths_phino
src/CLI.hs view
@@ -11,7 +11,10 @@ import Control.Exception (Exception (displayException), SomeException, handle, throw, throwIO) import Control.Exception.Base import Control.Monad (when)+import Data.Char (toUpper)+import Data.List (intercalate) import Data.Version (showVersion)+import Logger import Misc (ensuredFile) import qualified Misc import Options.Applicative@@ -20,7 +23,7 @@ import Printer (printProgram) import Rewriter (rewrite) import System.Exit (ExitCode (..), exitFailure)-import System.IO (getContents', hPutStrLn, stderr)+import System.IO (getContents') import Text.Printf (printf) import Yaml (normalizationRules) import qualified Yaml as Y@@ -34,6 +37,11 @@ show InvalidRewriteArguments {..} = printf "Invalid set of arguments for 'rewrite' command: %s" message show CouldNotReadFromStdin {..} = printf "Could not read 𝜑-expression from stdin\nReason: %s" message +data App = App+ { logLevel :: LogLevel,+ cmd :: Command+ }+ newtype Command = CmdRewrite OptsRewrite data OptsRewrite = OptsRewrite@@ -60,54 +68,96 @@ commandParser :: Parser Command commandParser = hsubparser (command "rewrite" (info rewriteParser (progDesc "Rewrite the expression"))) -parserInfo :: ParserInfo Command+readLogLevel :: String -> Either String LogLevel+readLogLevel lvl = case map toUpper lvl of+ "DEBUG" -> Right DEBUG+ "INFO" -> Right INFO+ "WARNING" -> Right WARNING+ "WARN" -> Right WARNING+ "ERROR" -> Right ERROR+ "ERR" -> Right ERROR+ "NONE" -> Right NONE+ _ -> Left $ "unknown log-level: " <> lvl++appParser :: Parser App+appParser =+ App+ <$> option+ (eitherReader readLogLevel)+ ( long "log-level"+ <> metavar "LEVEL"+ <> help ("Log level (" <> intercalate ", " (map show [DEBUG, INFO, WARNING, ERROR, NONE]) <> ")")+ <> value INFO+ <> showDefault+ )+ <*> commandParser++parserInfo :: ParserInfo App parserInfo = info- (commandParser <**> helper <**> simpleVersioner (showVersion version))+ (appParser <**> helper <**> simpleVersioner (showVersion version)) (fullDesc <> header "Phino - CLI Manipulator of 𝜑-Calculus Expressions") handler :: SomeException -> IO () handler e = case fromException e of Just ExitSuccess -> pure () -- prevent printing error on --version etc. _ -> do- hPutStrLn stderr ("[error] " ++ displayException e)+ logError (displayException e) exitFailure runCLI :: [String] -> IO () runCLI args = handle handler $ do- cmd <- handleParseResult (execParserPure defaultPrefs parserInfo args)+ App {..} <- handleParseResult (execParserPure defaultPrefs parserInfo args)+ setLogLevel logLevel case cmd of CmdRewrite OptsRewrite {..} -> do- when (maxDepth < 0) $ throwIO (InvalidRewriteArguments "--max-depth must be non-negative")+ when (maxDepth <= 0) $ throwIO (InvalidRewriteArguments "--max-depth must be positive")+ logDebug (printf "Amount of rewriting cycles: %d" maxDepth) prog <- case phiInput of- Just pth -> readFile =<< ensuredFile pth- Nothing -> getContents' `catch` (\(e :: SomeException) -> throwIO (CouldNotReadFromStdin (show e)))+ Just pth -> do+ logDebug (printf "Reading 𝜑-program from file: '%s'" pth)+ readFile =<< ensuredFile pth+ Nothing -> do+ logDebug "Reading 𝜑-program from stdin"+ getContents' `catch` (\(e :: SomeException) -> throwIO (CouldNotReadFromStdin (show e))) rules' <- do ordered <- if nothing- then pure []+ then do+ logDebug "The --nothing option is provided, no rules are used"+ pure [] else if normalize- then pure normalizationRules+ then do+ logDebug "The --normalize option is provided, built-it normalization rules are used"+ pure normalizationRules else if null rules then throwIO (InvalidRewriteArguments "no --rule, no --normalize, no --nothing are provided") else do+ logDebug (printf "Using rules from files: [%s]" (intercalate ", " rules)) yamls <- mapM ensuredFile rules mapM Y.yamlRule yamls if shuffle- then Misc.shuffle ordered+ then do+ logDebug "The --shuffle option is provided, rules are used in random order"+ Misc.shuffle ordered else pure ordered program <- parseProgramThrows prog- rewritten <- rewrite' program rules' 0+ rewritten <- rewrite' program rules' 1 putStrLn (printProgram rewritten) where rewrite' :: Program -> [Y.Rule] -> Integer -> IO Program rewrite' prog rules count = do+ logDebug (printf "Starting rewriting cycle %d out of %d" count maxDepth) if count == maxDepth- then pure prog+ then do+ logDebug (printf "Max amount of rewriting cycles is reached, rewriting is stopped")+ pure prog else do rewritten <- rewrite prog rules if rewritten == prog- then pure rewritten+ then do+ logDebug "Rewriting is stopped since it does not affect program anymore"+ pure rewritten else rewrite' rewritten rules (count + 1)
+ src/Logger.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE LambdaCase #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module Logger+ ( logDebug,+ logInfo,+ logWarning,+ logError,+ setLogLevel,+ LogLevel(DEBUG, INFO, WARNING, ERROR, NONE),+ )+where++import Control.Monad (when)+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)++newtype Logger = Logger {level :: LogLevel}++logger :: IORef Logger+{-# NOINLINE logger #-}+logger = unsafePerformIO (newIORef (Logger DEBUG))++setLogLevel :: LogLevel -> IO ()+setLogLevel lvl = writeIORef logger (Logger lvl)++handle :: LogLevel -> Handle+handle = \case+ ERROR -> stderr+ _ -> stdout++logMessage :: LogLevel -> String -> IO ()+logMessage lvl message = do+ log <- readIORef logger+ when (lvl >= level log) $ hPutStrLn (handle lvl) ("[" ++ show lvl ++ "]: " ++ message)++logDebug, logInfo, logWarning, logError :: String -> IO ()+logDebug = logMessage DEBUG+logInfo = logMessage INFO+logWarning = logMessage WARNING+logError = logMessage ERROR
src/Misc.hs view
@@ -88,7 +88,13 @@ -- "68-65-6C-6C-6F" -- >>> strToHex "world" -- "77-6F-72-6C-64"+-- >>> strToHex ""+-- "--"+-- >>> strToHex "h"+-- "68-" strToHex :: String -> String+strToHex "" = "--"+strToHex [ch] = btsToHex (unpack (U.fromString [ch])) ++ "-" strToHex str = btsToHex (unpack (U.fromString str)) -- Fast Fisher-Yates with mutable vectors.
src/Rewriter.hs view
@@ -13,8 +13,8 @@ import qualified Condition as C import Control.Exception import qualified Data.Map.Strict as M-import Data.Maybe (catMaybes, isJust)-import Data.Text (intercalate)+import Data.Maybe (catMaybes, fromMaybe, isJust)+import Logger (logDebug) import Matcher (MetaValue (MvAttribute, MvBindings, MvExpression), Subst (Subst), combine, combineMany, matchProgram, substEmpty, substSingle) import Misc (ensuredFile) import Parser (parseProgram, parseProgramThrows)@@ -71,12 +71,18 @@ rewrite :: Program -> [Y.Rule] -> IO Program rewrite program [] = pure program rewrite program (rule : rest) = do+ logDebug (printf "Trying to apply rule: %s" (fromMaybe "unknown" (Y.name rule))) let ptn = Y.pattern rule res = Y.result rule condition = Y.when rule replaced = buildAndReplace program ptn res extended = extraSubstitutions program (Y.where_ rule) prog <- case C.matchProgramWithCondition ptn condition program of- Nothing -> pure program- Just matched -> replaced (extended matched)+ Nothing -> do+ logDebug "Rule didn't match"+ pure program+ Just matched -> do+ let substs = extended matched+ logDebug (printf "Rule has been matched, substitutions are:\n%s" (printSubstitutions substs))+ replaced substs rewrite prog rest
test/CLISpec.hs view
@@ -86,6 +86,9 @@ output `shouldContain` "Phino - CLI Manipulator of 𝜑-Calculus Expressions" output `shouldContain` "Usage:" + it "prints debug info with --log-level=DEBUG" $ do+ withStdin "Q -> [[]]" $ testCLI ["rewrite", "--nothing", "--log-level=DEBUG"] "[DEBUG]:"+ describe "rewrites" $ do it "desugares with --nothing flag from file" $ testCLI@@ -119,7 +122,7 @@ it "fails with negative --max-depth" $ testCLIFailed ["rewrite", "--max-depth=-1"]- "--max-depth must be non-negative"+ "--max-depth must be positive" it "fails with no rewriting options provided" $ testCLIFailed