phino 0.0.0.18 → 0.0.0.19

raw patch · 9 files changed

+185/−114 lines, 9 filesdep +regex-pcre-builtindep −regex-tdfaPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: regex-pcre-builtin

Dependencies removed: regex-tdfa

API changes (from Hackage documentation)

Files

• phino.cabal +3/−2
• src/Condition.hs +70/−55
• src/Functions.hs +8/−49
• src/Logger.hs +1/−1
• src/Regexp.hs +89/−0
• src/Rewriter.hs +2/−1
• src/Yaml.hs +8/−2
• test/ConditionSpec.hs +1/−1
• test/RewriterSpec.hs +3/−3

@@ -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 <https://github.com/objectionary/phino#readme>@@ -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 

@@ -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)

@@ -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))

@@ -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)

@@ -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])

@@ -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)

@@ -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

@@ -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 $

@@ -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                   )       )