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.18 +version: 0.0.0.19 license: MIT synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions description: Please see the README on GitHub at @@ -38,6 +38,7 @@ Term, Misc, Logger, + Regexp, Pretty, XMIR hs-source-dirs: src @@ -66,7 +67,7 @@ xml-conduit ^>=1.10, time ^>=1.12, transformers, - regex-tdfa, + regex-pcre-builtin, array default-language: Haskell2010 diff --git a/src/Condition.hs b/src/Condition.hs --- a/src/Condition.hs +++ b/src/Condition.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT @@ -6,11 +8,15 @@ import Ast import Builder (buildAttribute, buildBinding) import Data.Aeson (FromJSON) +import qualified Data.ByteString.Char8 as B import qualified Data.Map.Strict as M +import Functions (buildTermFromFunction) import GHC.IO (unsafePerformIO) import Matcher -import Misc (allPathsIn) +import Misc (allPathsIn, btsToUnescapedStr) import Pretty (prettyExpression, prettySubsts) +import Regexp (match) +import Term (Term (TeBytes)) import Yaml (normalizationRules) import qualified Yaml as Y @@ -50,13 +56,15 @@ numToInt _ _ = Nothing -- Returns True if given expression matches with any of given normalization rules +-- Here we use unsafePerformIO because we're sure that conditions which are used +-- in normalization rules doesn't throw an exception. matchesAnyNormalizationRule :: Expression -> Bool matchesAnyNormalizationRule expr = matchesAnyNormalizationRule' expr normalizationRules where matchesAnyNormalizationRule' :: Expression -> [Y.Rule] -> Bool matchesAnyNormalizationRule' _ [] = False matchesAnyNormalizationRule' expr (rule : rules) = - case matchProgramWithCondition (Y.pattern rule) (Y.when rule) (Program expr) of + case unsafePerformIO (matchProgramWithCondition (Y.pattern rule) (Y.when rule) (Program expr)) of Just matched -> not (null matched) || matchesAnyNormalizationRule' expr rules Nothing -> matchesAnyNormalizationRule' expr rules @@ -84,78 +92,85 @@ _ -> False isNF expr = not (matchesAnyNormalizationRule expr) -meetCondition' :: Y.Condition -> Subst -> [Subst] -meetCondition' (Y.Or []) subst = [subst] -meetCondition' (Y.Or (cond : rest)) subst = - let met = meetCondition' cond subst - in if null met - then meetCondition' (Y.Or rest) subst - else met -meetCondition' (Y.And []) subst = [subst] -meetCondition' (Y.And (cond : rest)) subst = - let met = meetCondition' cond subst - in if null met - then [] - else meetCondition' (Y.And rest) subst -meetCondition' (Y.Not cond) subst = - let met = meetCondition' cond subst - in [subst | null met] +meetCondition' :: Y.Condition -> Subst -> IO [Subst] +meetCondition' (Y.Or []) subst = pure [subst] +meetCondition' (Y.Or (cond : rest)) subst = do + met <- meetCondition' cond subst + if null met + then meetCondition' (Y.Or rest) subst + else pure met +meetCondition' (Y.And []) subst = pure [subst] +meetCondition' (Y.And (cond : rest)) subst = do + met <- meetCondition' cond subst + if null met + then pure [] + else meetCondition' (Y.And rest) subst +meetCondition' (Y.Not cond) subst = do + met <- meetCondition' cond subst + pure [subst | null met] meetCondition' (Y.In attr binding) subst = case (buildAttribute attr subst, buildBinding binding subst) of - (Just attr, Just bds) -> [subst | attrInBindings attr bds] -- if attrInBindings attr bd then [subst] else [] - (_, _) -> [] -meetCondition' (Y.Alpha (AtAlpha _)) subst = [subst] + (Just attr, Just bds) -> pure [subst | attrInBindings attr bds] -- if attrInBindings attr bd then [subst] else [] + (_, _) -> pure [] +meetCondition' (Y.Alpha (AtAlpha _)) subst = pure [subst] meetCondition' (Y.Alpha (AtMeta name)) (Subst mp) = case M.lookup name mp of - Just (MvAttribute (AtAlpha _)) -> [Subst mp] - _ -> [] -meetCondition' (Y.Alpha _) _ = [] + Just (MvAttribute (AtAlpha _)) -> pure [Subst mp] + _ -> pure [] +meetCondition' (Y.Alpha _) _ = pure [] meetCondition' (Y.Eq (Y.CmpNum left) (Y.CmpNum right)) subst = case (numToInt left subst, numToInt right subst) of - (Just left_, Just right_) -> [subst | left_ == right_] - (_, _) -> [] -meetCondition' (Y.Eq (Y.CmpAttr left) (Y.CmpAttr right)) subst = [subst | compareAttrs left right subst] -meetCondition' (Y.Eq _ _) _ = [] + (Just left_, Just right_) -> pure [subst | left_ == right_] + (_, _) -> pure [] +meetCondition' (Y.Eq (Y.CmpAttr left) (Y.CmpAttr right)) subst = pure [subst | compareAttrs left right subst] +meetCondition' (Y.Eq _ _) _ = pure [] meetCondition' (Y.NF (ExMeta meta)) (Subst mp) = case M.lookup meta mp of - Just (MvExpression expr _) -> [Subst mp | isNF expr] - _ -> [] -meetCondition' (Y.NF expr) (Subst mp) = [Subst mp | isNF expr] + Just (MvExpression expr _) -> pure [Subst mp | isNF expr] + _ -> pure [] +meetCondition' (Y.NF expr) (Subst mp) = pure [Subst mp | isNF expr] meetCondition' (Y.XI (ExMeta meta)) (Subst mp) = case M.lookup meta mp of Just (MvExpression expr _) -> meetCondition' (Y.XI expr) (Subst mp) - _ -> [] -meetCondition' (Y.XI (ExFormation _)) subst = [subst] -meetCondition' (Y.XI ExThis) subst = [] -meetCondition' (Y.XI ExGlobal) subst = [subst] -meetCondition' (Y.XI (ExApplication expr (BiTau attr texpr))) subst = - let onExpr = meetCondition' (Y.XI expr) subst - onTau = meetCondition' (Y.XI texpr) subst - in [subst | not (null onExpr) && not (null onTau)] + _ -> pure [] +meetCondition' (Y.XI (ExFormation _)) subst = pure [subst] +meetCondition' (Y.XI ExThis) subst = pure [] +meetCondition' (Y.XI ExGlobal) subst = pure [subst] +meetCondition' (Y.XI (ExApplication expr (BiTau attr texpr))) subst = do + onExpr <- meetCondition' (Y.XI expr) subst + onTau <- meetCondition' (Y.XI texpr) subst + pure [subst | not (null onExpr) && not (null onTau)] meetCondition' (Y.XI (ExDispatch expr _)) subst = meetCondition' (Y.XI expr) subst +meetCondition' (Y.Match pat (ExMeta meta)) (Subst mp) = case M.lookup meta mp of + Just (MvExpression expr _) -> meetCondition' (Y.Match pat expr) (Subst mp) + _ -> pure [] +meetCondition' (Y.Match pat expr) subst = do + (TeBytes tgt) <- buildTermFromFunction "dataize" [Y.ArgExpression expr] subst (Program expr) + matched <- match (B.pack pat) (B.pack (btsToUnescapedStr tgt)) + pure [subst | matched] -- For each substitution check if it meetCondition to given condition -- If substitution does not meet the condition - it's thrown out -- and is not used in replacement -meetCondition :: Y.Condition -> [Subst] -> [Subst] -meetCondition _ [] = [] -meetCondition cond (subst : rest) = - let first = meetCondition' cond subst - next = meetCondition cond rest - in if null first - then next - else head first : next +meetCondition :: Y.Condition -> [Subst] -> IO [Subst] +meetCondition _ [] = pure [] +meetCondition cond (subst : rest) = do + first <- meetCondition' cond subst + next <- meetCondition cond rest + if null first + then pure next + else pure (head first : next) -- Returns Just [...] if -- 1. program matches pattern and -- 2.1. condition is not present, or -- 2.2. condition is present and met -- Otherwise returns Nothing -matchProgramWithCondition :: Expression -> Maybe Y.Condition -> Program -> Maybe [Subst] +matchProgramWithCondition :: Expression -> Maybe Y.Condition -> Program -> IO (Maybe [Subst]) matchProgramWithCondition ptn condition program = let matched = matchProgram ptn program in if null matched - then Nothing + then pure Nothing else case condition of - Nothing -> Just matched - Just cond -> - let met = meetCondition cond matched - in if null met - then Nothing - else Just met + Nothing -> pure (Just matched) + Just cond -> do + met <- meetCondition cond matched + if null met + then pure Nothing + else pure (Just met) diff --git a/src/Functions.hs b/src/Functions.hs --- a/src/Functions.hs +++ b/src/Functions.hs @@ -8,16 +8,13 @@ import Ast import Builder import Control.Exception (throwIO) -import Data.Array ((!)) -import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B -import Data.Maybe (catMaybes, mapMaybe) import Matcher import Misc import Pretty +import Regexp import Term import Text.Printf (printf) -import Text.Regex.TDFA import Yaml argToStrBytes :: ExtraArgument -> Subst -> Program -> IO String @@ -29,25 +26,6 @@ pure (btsToUnescapedStr bts) argToStrBytes arg _ _ = throwIO (userError (printf "Can't extract bytes from given argument: %s" (prettyExtraArg arg))) --- Translate perl-like shorthand characters to posix equivalent. --- >>> perlToPosix "\\s+\\W" --- "[[:space:]]+[^[:alnum:]_]" -perlToPosix :: B.ByteString -> B.ByteString -perlToPosix bs = go bs B.empty - where - go input acc - | B.null input = acc - | B.isPrefixOf "\\s" input = go (B.drop 2 input) (acc `B.append` "[[:space:]]") - | B.isPrefixOf "\\S" input = go (B.drop 2 input) (acc `B.append` "[^[:space:]]") - | B.isPrefixOf "\\d" input = go (B.drop 2 input) (acc `B.append` "[[:digit:]]") - | B.isPrefixOf "\\D" input = go (B.drop 2 input) (acc `B.append` "[^[:digit:]]") - | B.isPrefixOf "\\w" input = go (B.drop 2 input) (acc `B.append` "[[:alnum:]_]") - | B.isPrefixOf "\\W" input = go (B.drop 2 input) (acc `B.append` "[^[:alnum:]_]") - | B.head input == '\\' && B.length input >= 2 = - let escapedChar = B.take 2 input - in go (B.drop 2 input) (acc `B.append` escapedChar) - | otherwise = go (B.tail input) (acc `B.snoc` B.head input) - buildTermFromFunction :: String -> [ExtraArgument] -> Subst -> Program -> IO Term buildTermFromFunction "contextualize" [ArgExpression expr, ArgExpression context] subst prog = do (expr', _) <- buildExpressionThrows expr subst @@ -101,11 +79,11 @@ buildTermFromFunction "sed" [tgt, ptn] subst prog = do [tgt', ptn'] <- traverse (\arg -> argToStrBytes arg subst prog) [tgt, ptn] (pat, rep, global) <- parse (B.pack ptn') - let pat' = perlToPosix pat - res = - if global - then replaceAll pat' rep (B.pack tgt') - else replaceFirst pat' rep (B.pack tgt') + regex <- compile pat + res <- + if global + then replaceAll regex rep (B.pack tgt') + else replaceFirst regex rep (B.pack tgt') pure (TeExpression (DataObject "string" (strToBts (B.unpack res)))) where parse :: B.ByteString -> IO (B.ByteString, B.ByteString, Bool) @@ -117,26 +95,7 @@ [pat, rep, "g"] -> pure (pat, rep, True) [pat, rep, ""] -> pure (pat, rep, False) [pat, rep] -> pure (pat, rep, False) - _ -> - throwIO - (userError "The 'sed' 2nd argument must consist of three parts separated by '/', the last part must be either empty or 'g'") - _ -> throwIO (userError "The 'sed' 2nd argument must start with 's/'") - replaceFirst :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString - replaceFirst pat rep input = - let result :: MatchResult B.ByteString - result = input =~ pat - in if mrMatch result == "" - then input - else BS.concat [mrBefore result, rep, mrAfter result] - replaceAll :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString - replaceAll pat rep input = - let matches = getAllMatches (input =~ pat :: AllMatches [] (Int, Int)) - in go 0 matches - where - go offset [] = BS.drop offset input - go offset ((start, len) : rest) = - let prefix = BS.take (start - offset) (BS.drop offset input) - newOffset = start + len - in BS.concat [prefix, rep, go newOffset rest] + _ -> throwIO (userError "sed pattern must be in format s/pat/rep/[g]") + _ -> throwIO (userError "sed pattern must start with s/") buildTermFromFunction "sed" _ _ _ = throwIO (userError "Function sed() requires exactly 2 dataizable arguments") buildTermFromFunction func _ _ _ = throwIO (userError (printf "Function %s() is not supported or does not exist" func)) diff --git a/src/Logger.hs b/src/Logger.hs --- a/src/Logger.hs +++ b/src/Logger.hs @@ -23,7 +23,7 @@ logger :: IORef Logger {-# NOINLINE logger #-} -logger = unsafePerformIO (newIORef (Logger DEBUG)) +logger = unsafePerformIO (newIORef (Logger INFO)) setLogLevel :: LogLevel -> IO () setLogLevel lvl = writeIORef logger (Logger lvl) diff --git a/src/Regexp.hs b/src/Regexp.hs new file mode 100644 --- /dev/null +++ b/src/Regexp.hs @@ -0,0 +1,89 @@ +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module Regexp where + +import Control.Exception +import Data.Array (bounds, (!)) +import qualified Data.ByteString.Char8 as B +import Data.Char (isDigit) +import Data.Maybe (fromMaybe) +import qualified Text.Regex.PCRE.ByteString as R + +compile :: B.ByteString -> IO R.Regex +compile pat = do + compiled <- R.compile R.compBlank R.execBlank pat + case compiled of + Left (_, err) -> throwIO (userError ("Regex compilation failed: " ++ err)) + Right regex -> pure regex + +match :: B.ByteString -> B.ByteString -> IO Bool +match pattern input = do + regex <- compile pattern + res <- R.execute regex input + case res of + Left _ -> pure False + Right Nothing -> pure False + Right (Just _) -> pure True + +extractGroups :: R.Regex -> B.ByteString -> IO [B.ByteString] +extractGroups regex input = do + result <- R.execute regex input + case result of + Left _ -> pure [] + Right Nothing -> pure [] + Right (Just arr) -> + let (start, end) = bounds arr + groups = + [ let (off, len) = arr ! i + in if off == -1 then B.empty else B.take len (B.drop off input) + | i <- [start .. end] + ] + in pure groups + +substituteGroups :: B.ByteString -> [B.ByteString] -> B.ByteString +substituteGroups rep groups = B.concat (go (B.unpack rep)) + where + go [] = [] + go ('$' : rest) = + let (digits, afterDigits) = span isDigit rest + in if null digits + then B.singleton '$' : go rest + else + let idx = read digits + val = fromMaybe (B.pack ('$' : digits)) (safeIndex idx groups) + in val : go afterDigits + go (c : rest) = B.singleton c : go rest + safeIndex i xs + | i >= 0 && i < length xs = Just (xs !! i) + | otherwise = Nothing + +replaceFirst :: R.Regex -> B.ByteString -> B.ByteString -> IO B.ByteString +replaceFirst regex rep input = do + result <- R.execute regex input + case result of + Left _ -> return input + Right Nothing -> return input + Right (Just arr) -> do + groups <- extractGroups regex input + let (off, len) = arr ! 0 + (before, rest) = B.splitAt off input + (_, after) = B.splitAt len rest + replacement = substituteGroups rep groups + return $ B.concat [before, replacement, after] + +replaceAll :: R.Regex -> B.ByteString -> B.ByteString -> IO B.ByteString +replaceAll regex rep input = go input B.empty + where + go bs acc = do + result <- R.execute regex bs + case result of + Left _ -> return $ B.append acc bs + Right Nothing -> return $ B.append acc bs + Right (Just arr) -> do + let (off, len) = arr ! 0 + (before, rest1) = B.splitAt off bs + (_, rest2) = B.splitAt len rest1 + groups <- extractGroups regex bs + let replacement = substituteGroups rep groups + go rest2 (B.concat [acc, before, replacement]) diff --git a/src/Rewriter.hs b/src/Rewriter.hs --- a/src/Rewriter.hs +++ b/src/Rewriter.hs @@ -83,7 +83,8 @@ let ptn = Y.pattern rule res = Y.result rule condition = Y.when rule - prog <- case C.matchProgramWithCondition ptn condition program of + maybeMatched <- C.matchProgramWithCondition ptn condition program + prog <- case maybeMatched of Nothing -> pure program Just matched -> do let ruleName = fromMaybe "unknown" (Y.name rule) diff --git a/src/Yaml.hs b/src/Yaml.hs --- a/src/Yaml.hs +++ b/src/Yaml.hs @@ -84,7 +84,7 @@ vals <- v .: "eq" case vals of [left_, right_] -> Eq <$> parseJSON left_ <*> parseJSON right_ - _ -> fail "'eq' must contain exactly two elements", + _ -> fail "'eq' expects exactly two arguments", do vals <- v .: "in" case vals of @@ -92,7 +92,12 @@ attr <- parseJSON attr_ bd <- parseJSON binding_ pure (In attr bd) - _ -> fail "'in' must contain exactly two elements" + _ -> fail "'in' expects exactly two arguments", + do + vals <- v .: "match" + case vals of + [pat, exp] -> Match <$> parseJSON pat <*> parseJSON exp + _ -> fail "'match' expects exactly two arguments" ] ) @@ -137,6 +142,7 @@ | Eq Comparable Comparable | NF Expression | XI Expression + | Match String Expression deriving (Generic, Show) data ExtraArgument diff --git a/test/ConditionSpec.hs b/test/ConditionSpec.hs --- a/test/ConditionSpec.hs +++ b/test/ConditionSpec.hs @@ -36,7 +36,7 @@ pack <- Y.decodeFileThrow pth :: IO ConditionPack let matched = matchProgram (pattern pack) (Program (expression pack)) unless (matched /= []) (expectationFailure "List of matched substitutions is empty which is not expected") - let met = meetCondition (condition pack) matched + met <- meetCondition (condition pack) matched when (null met) ( expectationFailure $ diff --git a/test/RewriterSpec.hs b/test/RewriterSpec.hs --- a/test/RewriterSpec.hs +++ b/test/RewriterSpec.hs @@ -15,7 +15,7 @@ import GHC.Generics import Misc (allPathsIn, ensuredFile) import Parser (parseProgramThrows) -import Pretty (prettyProgram) +import Pretty (prettyProgram', PrintMode (SWEET)) import System.FilePath (makeRelative, replaceExtension, ()) import Test.Hspec (Spec, describe, expectationFailure, it, pending, runIO) import Yaml (normalizationRules) @@ -97,8 +97,8 @@ unless (rewritten == result') $ expectationFailure ( "Wrong rewritten program. Expected:\n" - ++ prettyProgram result' + ++ prettyProgram' result' SWEET ++ "\nGot:\n" - ++ prettyProgram rewritten + ++ prettyProgram' rewritten SWEET ) )