packages feed

phino 0.0.0.1 → 0.0.0.2

raw patch · 16 files changed

+462/−260 lines, 16 files

Files

phino.cabal view
@@ -1,7 +1,7 @@ cabal-version:      3.0  name:               phino-version:            0.0.0.1+version:            0.0.0.2 license:            MIT synopsis:           Command-Line Manipulator of 𝜑-Calculus Expressions description:        Please see the README on GitHub at <https://github.com/objectionary/phino#readme>@@ -70,7 +70,11 @@     BuilderSpec,     ReplacerSpec,     PrinterSpec,-    RewriterSpec+    RewriterSpec,+    YamlSpec,+    Paths_phino+  autogen-modules:+    Paths_phino   default-extensions:     ImportQualifiedPost   ghc-options: -Wall
src/Ast.hs view
@@ -36,5 +36,7 @@   | AtAlpha Integer                       -- ~1   | AtPhi                                 -- @   | AtRho                                 -- ^+  | AtLambda                              -- λ, used only in yaml conditions+  | AtDelta                               -- Δ, used only in yaml conditions   | AtMeta String                         -- !a   deriving (Eq, Show, Generic)
src/Builder.hs view
@@ -4,13 +4,19 @@ -- 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+module Builder+  ( buildExpressions,+    buildExpression,+    buildAttribute,+    buildBindings,+  )+where  import Ast-import Misc-import Matcher-import qualified Data.Map.Strict as Map import Data.List (findIndex)+import qualified Data.Map.Strict as Map+import Matcher+import Misc  buildAttribute :: Attribute -> Subst -> Maybe Attribute buildAttribute (AtMeta meta) (Subst mp) = case Map.lookup meta mp of@@ -40,27 +46,17 @@   _ -> 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+buildBindings (bd : rest) subst = do+  first <- buildBinding bd subst+  bds <- buildBindings rest subst+  Just (first ++ bds)  buildExpressionWithTails :: Expression -> [Tail] -> Subst -> Expression buildExpressionWithTails expr [] _ = expr-buildExpressionWithTails expr (tail:rest) subst = case tail of+buildExpressionWithTails expr (tail : rest) subst = case tail of   TaApplication taus -> buildExpressionWithTails (ExApplication expr taus) rest subst   TaDispatch attr -> buildExpressionWithTails (ExDispatch expr attr) rest subst @@ -74,9 +70,6 @@   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
src/CLI.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}  -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com@@ -7,33 +7,33 @@  module CLI (runCLI) where +import Control.Exception (Exception (displayException), SomeException, handle, throw, throwIO)+import Control.Exception.Base import Data.Version (showVersion)+import Misc (ensuredFile) 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 System.Exit (exitFailure, ExitCode (..))+import System.IO (getContents', hPutStrLn, stderr) import Text.Printf (printf)+import qualified Yaml as Y  data CmdException   = InvalidRewriteArguments   | NormalizationIsNotSupported-  | CouldNotReadFromStdin { message :: String }+  | 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 InvalidRewriteArguments = "Invalid set of arguments for 'rewrite' command: no --rule, 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+  show CouldNotReadFromStdin {..} = printf "Could not read 𝜑-expression from stdin\nReason: %s" message  newtype Command = CmdRewrite OptsRewrite  data OptsRewrite = OptsRewrite-  { rules :: Maybe FilePath,+  { rules :: [FilePath],     phiInput :: Maybe FilePath,     normalize :: Bool,     nothing :: Bool@@ -43,8 +43,8 @@ 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"))+            <$> many (strOption (long "rule" <> metavar "FILE" <> help "Path to custom rule"))+            <*> optional (strOption (long "phi-input" <> metavar "FILE" <> help "Path .phi file with 𝜑-expression"))             <*> switch (long "normalize" <> help "Use built-in normalization rules")             <*> switch (long "nothing" <> help "Desugar provided 𝜑-expression")         )@@ -59,28 +59,31 @@     (fullDesc <> header "Phino - CLI Manipulator of 𝜑-Calculus Expressions")  handler :: SomeException -> IO ()-handler e = do-  hPutStrLn stderr ("[error] " ++ displayException e)-  exitFailure+handler e = case fromException e of+  Just ExitSuccess -> pure ()  -- prevent printing error on --version etc.+  _ -> 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+    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)+      rules' <-+        if nothing+          then pure []+          else do+            paths <-+              if null rules+                then+                  if normalize+                    then throwIO NormalizationIsNotSupported+                    else throwIO InvalidRewriteArguments+                else mapM ensuredFile rules+            mapM Y.yamlRule paths       rewritten <- rewrite prog rules'       putStrLn rewritten
src/Matcher.hs view
@@ -6,12 +6,12 @@ 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)+import Misc  -- Meta value -- The right part of substitution@@ -44,14 +44,6 @@ 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@@ -87,79 +79,43 @@   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 bindings with ordering+-- Function returns tuple (X, Y), where+-- - X - "before bindings" - list of bindings before each exact binding. It's used to join with+--   meta binding which goes before exact binding, if such is exist. If there's no one,+--   it'll be []+-- - Y - Substitution for bindings+-- +-- How it works:+-- We start process pattern bindings. +-- 1. If we meet meta binding (!B), we skip for now+--    and go the next recursive cycle with next pattern and wait for the result.+--    Result will contain list of "before bindings". This list will be+--    matched to current meta binding+-- 2. If we meet exact binding in pattern, like void, tau, delta, lambda, etc... we try to match it+--    with current target binding. If it matches, we go further and try to match next patterns with next targets.+--    If it does not match, there may be two options:+--    a) we came here from step 1. It means that we should skip this target binding and go the next+--       cycle. When we get the result, we join skipped target binding with returned list of "before" bindings+--       and return to the step one+--    b) we came from somewhere else. Then we just returns Nothing as substitution and don't go further+matchBindingsInOrder :: [Binding] -> [Binding] -> Bool -> ([Binding], Maybe Subst)+matchBindingsInOrder [] [] _ = ([], Just substEmpty)+matchBindingsInOrder [] tbs True = (tbs, Just substEmpty)+matchBindingsInOrder [] tbs False = ([], Nothing)+matchBindingsInOrder [BiMeta name] tbs _ = ([], Just (substSingle name (MvBindings tbs)))+matchBindingsInOrder ((BiMeta name) : pbs) tbs meta = case matchBindingsInOrder pbs tbs True of+  (_, Nothing) -> ([], Nothing)+  (before, Just subst) -> ([], combine (substSingle name  (MvBindings before)) subst)+matchBindingsInOrder (pb : pbs) (tb : tbs) meta = case matchBinding pb tb of+  Nothing -> if meta +    then case matchBindingsInOrder (pb : pbs) tbs meta of+      (_, Nothing) -> ([], Nothing)+      (before, Just subst) -> (tb : before, Just subst)+    else ([], Nothing)+  Just subst -> case matchBindingsInOrder pbs tbs False of+    (_, Nothing) -> ([], Nothing)+    (before, Just subst') -> (before, combine subst subst')  -- Match pattern bindings to target bindings -- !! Pattern bindings list may contain only one BiMeta binding@@ -168,15 +124,9 @@ -- 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+matchBindings pbs tbs = do+  let (_, subst) = matchBindingsInOrder pbs tbs False+  subst  -- Recursively go through given target expression and try to find -- the head expression which matches to given pattern.
src/Parser.hs view
@@ -5,7 +5,15 @@ -- SPDX-License-Identifier: MIT  -- The goal of the module is to parse given phi program to Ast-module Parser (parseProgram, parseProgramThrows, parseExpression, parseExpressionThrows) where+module Parser+  ( parseProgram,+    parseProgramThrows,+    parseExpression,+    parseExpressionThrows,+    parseAttribute,+    parseBinding+  )+where  import Ast import Control.Exception (Exception, throwIO)@@ -154,6 +162,9 @@         return (BiTau attr' (ExFormation (voids ++ bs)))     ] +metaBinding :: Parser Binding+metaBinding = BiMeta <$> meta 'B'+ -- binding -- 1. tau -- 2. void@@ -177,7 +188,7 @@       try $ do         _ <- delta         BiMetaDelta <$> meta 'b',-      try (BiMeta <$> meta 'B'),+      try metaBinding,       try $ do         _ <- lambda         BiLambda <$> function,@@ -305,7 +316,12 @@                 _ <- symbol "("                 bds <-                   choice-                    [ try $ tauBinding fullAttribute `sepBy1` symbol ",",+                    [ try $+                        choice+                          [ try (tauBinding fullAttribute),+                            metaBinding+                          ]+                          `sepBy1` symbol ",",                       do                         exprs <- expression `sepBy1` symbol ","                         return (zipWith (BiTau . AtAlpha) [0 ..] exprs) -- \idx expr -> BiTau (AtAlpha idx) expr@@ -362,6 +378,12 @@   case parsed of     Right parsed' -> Right parsed'     Left err -> Left (errorBundlePretty err)++parseBinding :: String -> Either String Binding+parseBinding = parse' "binding" binding++parseAttribute :: String -> Either String Attribute+parseAttribute = parse' "attribute" fullAttribute  parseExpression :: String -> Either String Expression parseExpression = parse' "expression" expression
src/Printer.hs view
@@ -67,7 +67,7 @@ instance Pretty MetaValue where   pretty (MvAttribute attr) = pretty attr   pretty (MvBytes bytes) = pretty bytes-  pretty (MvBindings bindings) = pretty bindings+  pretty (MvBindings bindings) = vsep [pretty "[", indent 2 (pretty bindings), pretty "]"]   pretty (MvFunction func) = pretty func   pretty (MvExpression expr) = pretty expr   pretty (MvTail tails) = vsep (punctuate comma (map pretty tails))
src/Rewriter.hs view
@@ -9,8 +9,9 @@ module Rewriter (rewrite) where  import Ast-import Builder (buildExpressions)+import Builder import Control.Exception+import Data.Text (intercalate) import Matcher (Subst, matchProgram) import Misc (ensuredFile) import Parser (parseProgram, parseProgramThrows)@@ -18,8 +19,8 @@ import Replacer (replaceProgram) import System.Directory import Text.Printf+import Yaml import qualified Yaml as Y-import Yaml (Rule)  data RewriteException   = CouldNotMatch {pattern :: Expression, program :: Program}@@ -45,27 +46,87 @@       (printExpression ptn)       (printExpression res) +-- Check if given attribute is present in given binding+attrInBinding :: Attribute -> Binding -> Bool+attrInBinding attr (BiTau battr _) = attr == battr+attrInBinding attr (BiVoid battr) = attr == battr+attrInBinding AtLambda (BiLambda _) = True+attrInBinding AtDelta (BiDelta _) = True+attrInBinding _ _ = False++-- Check if all given attributes are present in given bindings+attrsInBindings :: [Attribute] -> [Binding] -> Bool+attrsInBindings [] _ = True+attrsInBindings attrs [] = False+attrsInBindings [attr] (bd : rest) = attrInBinding attr bd || attrsInBindings [attr] rest+attrsInBindings (attr : rest) bds = attrsInBindings [attr] bds && attrsInBindings rest bds++-- For each substitution check if it meets to given condition+-- If substitution does not meet the condition - it's thrown out+-- and is not used in replacement+meets :: Condition -> [Subst] -> [Subst]+meets _ [] = []+-- OR+meets (Or []) substs = substs+meets (Or (cond : rest)) [subst] = case meets cond [subst] of+  [] -> meets (Or rest) [subst]+  substs -> substs+-- AND+meets (And []) substs = substs+meets (And (cond : rest)) [subst] = case meets cond [subst] of+  [] -> []+  _ -> meets (And rest) [subst]+-- NOT+meets (Not cond) [subst] = case meets cond [subst] of+  [] -> [subst]+  _ -> []+-- IN+meets (In attrs bindings) [subst] =+  case (traverse (`buildAttribute` subst) attrs, buildBindings bindings subst) of+    (Just attrs', Just bds) -> [subst | attrsInBindings attrs' bds] -- if attrsInBindings attrs' bds then [subst] else []+    (_, _) -> []+meets (In attrs bindings) (subst : rest) = do+  let cond = In attrs bindings+      substs = meets cond [subst]+  head substs : meets cond rest+-- Any condition with many substitutions+meets cond (subst : rest) = do+  let first = meets cond [subst]+      next = meets cond rest+  if null first+    then next+    else head first : next++-- Build pattern and result expression and replace patterns to results in given program+buildAndReplace :: Program -> Expression -> Expression -> [Subst] -> IO Program+buildAndReplace program ptn res 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 -> [Y.Rule] -> IO Program applyRules program [] = pure program applyRules program [rule] = do   let ptn = Y.pattern rule-  let res = Y.result rule+      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)+    substs -> do+      let replaced = buildAndReplace program ptn res+      case Y.when rule of+        Just cond -> case meets cond substs of+          [] -> pure program+          substs' -> replaced substs'+        Nothing -> replaced substs applyRules program (rule : rest) = do   prog <- applyRules program [rule]   applyRules prog rest -rewrite :: String -> Maybe Y.RuleSet -> IO String-rewrite prog rulesSet = do+rewrite :: String -> [Y.Rule] -> IO String+rewrite prog rules = do   program <- parseProgramThrows prog-  rewritten <- case rulesSet of-    Just set -> applyRules program (Y.rules set)-    Nothing -> pure program+  rewritten <- applyRules program rules   pure (printProgram rewritten)
src/Yaml.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}  -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT@@ -7,34 +8,78 @@ module Yaml where  import Ast+import Control.Applicative (asum) import Data.Aeson+import Data.Aeson.KeyMap (keys) import Data.String (IsString (..)) import Data.Text (unpack)+import Data.Yaml (Parser) import qualified Data.Yaml as Yaml+import Debug.Trace+import GHC.Base import GHC.Generics import Parser +parseJSON' :: String -> (String -> Either String a) -> Value -> Parser a+parseJSON' name func =+  withText+    name+    ( \txt -> case func (unpack txt) of+        Left err -> fail err+        Right parsed -> pure parsed+    )+ instance FromJSON Expression where+  parseJSON = parseJSON' "Expression" parseExpression++instance FromJSON Attribute where   parseJSON =     withText-      "Expression"-      ( \txt -> case parseExpression (unpack txt) of-          Left err -> fail err-          Right expr -> pure expr+      "Attribute"+      ( \txt -> case unpack txt of+          "λ" -> pure AtLambda+          "Δ" -> pure AtDelta+          other -> case parseAttribute other of+            Left err -> fail err+            Right attr -> pure attr       )+instance FromJSON Binding where+  parseJSON = parseJSON' "Binding" parseBinding -data RuleSet = RuleSet-  { title :: String,-    rules :: [Rule]-  }-  deriving (Generic, FromJSON, Show)+instance FromJSON Condition where+  parseJSON =+    withObject+      "Condition"+      ( \v ->+          asum+            [ And <$> v .: "and",+              Or <$> v .: "or",+              Not <$> v .: "not",+              do+                vals <- v .: "in"+                case vals of+                  [attrs_, bindings_] -> do+                    attrs' <- parseJSON attrs_+                    bds <- parseJSON bindings_+                    pure (In attrs' bds)+                  _ -> fail "'in' must contain exactly two elements"+            ]+      ) +data Condition+  = And [Condition]+  | Or [Condition]+  | In [Attribute] [Binding]+  | Not Condition+  deriving (Generic, Show)+ data Rule = Rule-  { name :: String,+  { name :: Maybe String,     pattern :: Expression,-    result :: Expression+    result :: Expression,+    when :: Maybe Condition   }   deriving (Generic, FromJSON, Show) -yamlRuleSet :: FilePath -> IO RuleSet-yamlRuleSet = Yaml.decodeFileThrow+yamlRule :: FilePath -> IO Rule+yamlRule = Yaml.decodeFileThrow
test/BuilderSpec.hs view
@@ -60,6 +60,21 @@             ("e2", MvExpression ExThis)           ],           Just (ExApplication (ExFormation []) [BiTau (AtLabel "x") ExGlobal, BiTau (AtLabel "y") ExThis])+        ),+        ( "⟦!a ↦ ∅, !B⟧.!a => (!a >> t, !B >> ⟦ x ↦ ξ.t ⟧ ) => ⟦ t ↦ ∅, x ↦ ξ.t ⟧.t",+          ExDispatch (ExFormation [BiVoid (AtMeta "a"), BiMeta "B"]) (AtMeta "a"),+          [ ("a", MvAttribute (AtLabel "t")),+            ("B", MvBindings [BiTau (AtLabel "x") (ExDispatch ExThis (AtLabel "t"))])+          ],+          Just+            ( ExDispatch+                ( ExFormation+                    [ BiVoid (AtLabel "t"),+                      BiTau (AtLabel "x") (ExDispatch ExThis (AtLabel "t"))+                    ]+                )+                (AtLabel "t")+            )         )       ]
test/CLISpec.hs view
@@ -13,6 +13,8 @@ import System.IO import Control.Exception import GHC.IO.Handle+import Paths_phino (version)+import Data.Version (showVersion)  withRedirectedStdin :: String -> IO a -> IO a withRedirectedStdin input action = do@@ -34,13 +36,29 @@  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 "prints version" $ do+    output <- capture_ (runCLI ["--version"])+    output `shouldContain` showVersion version -  it "desugares with --nothing flag from stdin" $ do-    withRedirectedStdin "{[[foo ↦ QQ]]}" $ do-      let args = ["rewrite", "--nothing"]+  it "prints help" $ do+    output <- capture_ (runCLI ["--help"])+    output `shouldContain` "Phino - CLI Manipulator of 𝜑-Calculus Expressions"+    output `shouldContain` "Usage:"++  describe "rewrites" $ 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⟧"+    +    it "rewrites with single rule" $ do+      withRedirectedStdin "{T(x -> Q.y)}" $ do+        let args = ["rewrite", "--rule=resources/dc.yaml"]+        output <- capture_ (runCLI args)+        output `shouldContain` "Φ ↦ ⊥"
test/MatcherSpec.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}  -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com@@ -69,6 +69,31 @@           [ [("e", MvExpression (ExDispatch ExGlobal (AtLabel "org"))), ("a", MvAttribute (AtLabel "eolang"))],             [("e", MvExpression ExGlobal), ("a", MvAttribute (AtLabel "org"))]           ]+        ),+        ( "⟦!B1, !a ↦ ∅, !B2⟧.!a => ⟦ x ↦ ξ.t, t ↦ ∅ ⟧.t(ρ ↦ ⟦ x ↦ ξ.t, t ↦ ∅ ⟧) => [(!B1 >> ⟦x ↦ ξ.t⟧, !a >> t, !B2 >> ⟦⟧ )]",+          ExDispatch (ExFormation [BiMeta "B1", BiVoid (AtMeta "a"), BiMeta "B2"]) (AtMeta "a"),+          ExApplication+            ( ExDispatch+                ( ExFormation+                    [ BiTau (AtLabel "x") (ExDispatch ExThis (AtLabel "t")),+                      BiVoid (AtLabel "t")+                    ]+                )+                (AtLabel "t")+            )+            [ BiTau+                AtRho+                ( ExFormation+                    [ BiTau (AtLabel "x") (ExDispatch ExThis (AtLabel "t")),+                      BiVoid (AtLabel "t")+                    ]+                )+            ],+          [ [ ("B1", MvBindings [BiTau (AtLabel "x") (ExDispatch ExThis (AtLabel "t"))]),+              ("a", MvAttribute (AtLabel "t")),+              ("B2", MvBindings [])+            ]+          ]         )       ] @@ -81,68 +106,68 @@         ("~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)",+        ( "[[!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",+        ( "[[D> 00-]] => [[D> 00-, L> Func]] => X",           [BiDelta "00-"],           [BiDelta "00-", BiLambda "Func"],           Nothing         ),-        ( "[y -> ?, !a -> ?] => [x -> ?, y -> ?] => (!a >> x)",+        ( "[[y -> ?, !a -> ?]] => [[y -> ?, x -> ?]] => (!a >> x)",           [BiVoid (AtLabel "y"), BiVoid (AtMeta "a")],-          [BiVoid (AtLabel "x"), BiVoid (AtLabel "y")],+          [BiVoid (AtLabel "y"), BiVoid (AtLabel "x")],           Just [("a", MvAttribute (AtLabel "x"))]         ),-        ( "[!B, x -> ?] => [x -> ?] => (!B >> [])",+        ( "[[!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")],+        ( "[[!B1, x -> ?, !B2]] => [[x -> ?, y -> ?]] => (!B1 >> [[]], !B2 >> [[y -> ?]])",+          [BiMeta "B1", BiVoid (AtLabel "x"), BiMeta "B2"],           [BiVoid (AtLabel "x"), BiVoid (AtLabel "y")],-          Just [("B", MvBindings [BiVoid (AtLabel "y")])]+          Just [("B1", MvBindings []), ("B2", MvBindings [BiVoid (AtLabel "y")])]         ),-        ( "[!B, !x -> ?] => [y -> ?, D> -> 00-, L> Func] => (!x >> y, !B >> [D> -> 00-, L> Func])",-          [BiMeta "B", BiVoid (AtMeta "x")],+        ( "[[!B1, !x -> ?, !B2]] => [[y -> ?, D> -> 00-, L> Func]] => (!x >> y, !B1 >> [[]], !B2 >> [[D> -> 00-, L> Func]])",+          [BiMeta "B1", BiVoid (AtMeta "x"), BiMeta "B2"],           [BiVoid (AtLabel "y"), BiDelta "00-", BiLambda "Func"],-          Just [("B", MvBindings [BiDelta "00-", BiLambda "Func"]), ("x", MvAttribute (AtLabel "y"))]+          Just [("B1", MvBindings []), ("B2", MvBindings [BiDelta "00-", BiLambda "Func"]), ("x", MvAttribute (AtLabel "y"))]         ),-        ( "[!x -> ?, !y -> ?] => [a -> ?, b -> ?] => (!x >> a, !y >> b)",+        ( "[[!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"))]+        ),+        ( "[[t -> ?, !B]] => [[t -> ?, x -> Q, y -> $]] => (!B >> [[x -> Q, y -> $]])",+          [BiVoid (AtLabel "t"), BiMeta "B"],+          [BiVoid (AtLabel "t"), BiTau (AtLabel "x") ExGlobal, BiTau (AtLabel "y") ExThis],+          Just [("B", MvBindings [BiTau (AtLabel "x") ExGlobal, BiTau (AtLabel "y") ExThis])]+        ),+        ( "[[!B, z -> Q]] => [[x -> Q, y -> $, z -> Q]] => (!B >> [[x -> Q, y -> $]])",+          [BiMeta "B", BiTau (AtLabel "z") ExGlobal],+          [BiTau (AtLabel "x") ExGlobal, BiTau (AtLabel "y") ExThis, BiTau (AtLabel "z") ExGlobal],+          Just [("B", MvBindings [BiTau (AtLabel "x") ExGlobal, BiTau (AtLabel "y") ExThis])]+        ),+        ( "[[L> Func, D> 00-]] => [[D> 00-, L> Func]] => X",+          [BiLambda "Func", BiDelta "00-"],+          [BiDelta "00-", BiLambda "Func"],+          Nothing+        ),+        ( "[[t -> ?, !B]] => [[x -> ?, t -> ?]] => X",+          [BiVoid (AtLabel "t"), BiMeta "B"],+          [BiVoid (AtLabel "x"), BiVoid (AtLabel "t")],+          Nothing         )       ] @@ -208,31 +233,6 @@         )       ] -  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@@ -272,9 +272,3 @@               )           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
@@ -200,7 +200,8 @@                     )                 ]             )-        )+        ),+        ("Q.x(!B)", Just (ExApplication (ExDispatch ExGlobal (AtLabel "x")) [BiMeta "B"]))       ]    describe "just parses" $@@ -222,7 +223,9 @@         "[[\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]]"+        "[[x -> 1.00e+3, y -> 2.32e-4]]",+        "Q.x(!B)",+        "Q.x(~1 -> Q.y, x -> 5, !B1)"       ]       (\expr -> it expr (parseExpression expr `shouldSatisfy` isRight)) @@ -238,7 +241,6 @@             "Q.x(x -> ?)",             "Q.x(L> Func)",             "Q.x(D> --)",-            "Q.x(!B)",             "Q.x(~1 -> ?)",             "Q.x(L> !F)",             "Q.x(D> !b)",@@ -246,12 +248,13 @@             "[[x(~1) -> [[]] ]]",             "[[y(!e) -> [[]] ]]",             "[[z(w) -> Q.x]]",-            "Q.x(y(~1) -> [[]])"+            "Q.x(y(~1) -> [[]])",+            "Q.x(1, 2, !B)"           ]       )    describe "parse packs" $ do-    packs <- runIO (allPathsIn "test/resources/parser-packs")+    packs <- runIO (allPathsIn "test-resources/parser-packs")     forM_       packs       ( \pack -> do
test/ReplacerSpec.hs view
@@ -51,5 +51,55 @@           [ExFormation [BiLambda "Func", BiDelta "00-"]],           [ExGlobal],           Just (Program ExGlobal)+        ),+        ( "Q -> Q.org.eolang => ([Q.org.eolang, Q.org], [$, $]) => $",+          Program (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")),+          [ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang"), ExDispatch ExGlobal (AtLabel "org")],+          [ExThis, ExThis],+          Just (Program ExThis)+        ),+        ( "",+          Program+            ( ExApplication+                ( ExDispatch+                    ( ExFormation+                        [ BiTau (AtLabel "x") (ExDispatch ExThis (AtLabel "t")),+                          BiVoid (AtLabel "t")+                        ]+                    )+                    (AtLabel "t")+                )+                [ BiTau+                    AtRho+                    ( ExFormation+                        [ BiTau (AtLabel "x") (ExDispatch ExThis (AtLabel "t")),+                          BiVoid (AtLabel "t")+                        ]+                    )+                ]+            ),+          [ ExDispatch+              ( ExFormation+                  [ BiTau (AtLabel "x") (ExDispatch ExThis (AtLabel "t")),+                    BiVoid (AtLabel "t")+                  ]+              )+              (AtLabel "t")+          ],+          [ExTermination],+          Just+            ( Program+                ( ExApplication+                    ExTermination+                    [ BiTau+                        AtRho+                        ( ExFormation+                            [ BiTau (AtLabel "x") (ExDispatch ExThis (AtLabel "t")),+                              BiVoid (AtLabel "t")+                            ]+                        )+                    ]+                )+            )         )       ]
test/RewriterSpec.hs view
@@ -11,16 +11,22 @@ import Data.Aeson import Data.Yaml qualified as Yaml import GHC.Generics-import Misc (allPathsIn)+import Misc (allPathsIn, ensuredFile) import Rewriter (rewrite)-import Test.Hspec (Spec, describe, runIO, shouldBe, it)-import qualified Yaml-import System.FilePath (takeBaseName)+import System.FilePath (makeRelative, replaceExtension, (</>))+import Test.Hspec (Spec, describe, it, runIO, shouldBe)+import Yaml qualified as Y +data Rules = Rules+  { basic :: Maybe [String],+    custom :: Maybe [Y.Rule]+  }+  deriving (Generic, FromJSON, Show)+ data YamlPack = YamlPack   { input :: String,     output :: String,-    ruleSet :: Maybe Yaml.RuleSet+    rules :: Maybe Rules   }   deriving (Generic, FromJSON, Show) @@ -30,14 +36,28 @@ spec :: Spec spec = do   describe "rewrite packs" $ do-    packs <- runIO (allPathsIn "test/resources/rewriter-packs")+    let resources = "test-resources/rewriter-packs"+    packs <- runIO (allPathsIn resources)     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')+          rules' <- case rules pack of+            Just _rules -> case custom _rules of+              Just custom' -> pure custom'+              _ -> case basic _rules of+                Just basic' ->+                  runIO $+                    mapM+                      ( \name -> do+                          yaml <- ensuredFile ("resources" </> replaceExtension name ".yaml")+                          Y.yamlRule yaml+                      )+                      basic'+                _ -> pure []+            Nothing -> pure []+          rewritten <- runIO $ rewrite input' rules'+          it (makeRelative resources pth) (rewritten `shouldBe` output')       )
+ test/YamlSpec.hs view
@@ -0,0 +1,22 @@+-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module YamlSpec where++import Control.Monad+import Misc+import System.FilePath+import Test.Hspec (Spec, describe, it, runIO, shouldReturn)+import Yaml (yamlRule)++spec :: Spec+spec = do+  describe "parses yaml rule" $ do+    let resources = "test-resources/yaml-packs"+    packs <- runIO (allPathsIn resources)+    forM_+      packs+      ( \pth -> it (makeRelative resources pth) $ do+          _ <- yamlRule pth+          pure () `shouldReturn` ()+      )