diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -29,7 +29,7 @@ ```bash cabal update -cabal install --overwrite-policy=always phino-0.0.0.55 +cabal install --overwrite-policy=always phino-0.0.0.56 phino --version ``` @@ -45,7 +45,8 @@ Download paths are: * Ubuntu: -* MacOS: +* MacOS (ARM): +* MacOS (Intel): ## Build diff --git a/phino.cabal b/phino.cabal --- a/phino.cabal +++ b/phino.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: phino -version: 0.0.0.56 +version: 0.0.0.57 license: MIT synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions description: Please see the README on GitHub at @@ -47,6 +47,7 @@ Functions LaTeX Lining + Locator Logger Matcher Merge @@ -124,6 +125,7 @@ FunctionsSpec LaTeXSpec LiningSpec + LocatorSpec MatcherSpec MergeSpec MiscSpec diff --git a/src/AST.hs b/src/AST.hs --- a/src/AST.hs +++ b/src/AST.hs @@ -9,46 +9,46 @@ import GHC.Generics (Generic) -newtype Program = Program Expression -- Q -> expr +newtype Program = Program Expression deriving (Eq, Ord, Show) data Expression - = ExFormation [Binding] -- [[ bindings ]] + = ExFormation [Binding] | ExThis - | ExGlobal -- Q - | ExTermination -- T - | ExApplication Expression Binding -- expr(attr -> expr) - | ExDispatch Expression Attribute -- expr.attr - | ExMeta String -- !e - | ExMetaTail Expression String -- expr * !t + | ExGlobal + | ExTermination + | ExApplication Expression Binding + | ExDispatch Expression Attribute + | ExMeta String + | ExMetaTail Expression String | ExPhiMeet (Maybe String) Int Expression | ExPhiAgain (Maybe String) Int Expression deriving (Eq, Ord, Show, Generic) data Binding - = BiTau Attribute Expression -- attr -> expr - | BiDelta Bytes -- Δ ⤍ 1F-2A - | BiVoid Attribute -- attr ↦ ? - | BiLambda String -- λ ⤍ Function - | BiMeta String -- !B - | BiMetaLambda String -- λ ⤍ !F + = BiTau Attribute Expression + | BiDelta Bytes + | BiVoid Attribute + | BiLambda String + | BiMeta String + | BiMetaLambda String deriving (Eq, Ord, Show, Generic) data Bytes - = BtEmpty -- -- - | BtOne String -- 1F- - | BtMany [String] -- 00-01-02-...04 - | BtMeta String -- !b + = BtEmpty + | BtOne String + | BtMany [String] + | BtMeta String deriving (Eq, Ord, Show, Generic) data Attribute - = AtLabel String -- attr - | AtAlpha Int -- α1 - | AtPhi -- φ - | AtRho -- ρ - | AtLambda -- λ, used only in yaml conditions - | AtDelta -- Δ, used only in yaml conditions - | AtMeta String -- !a + = AtLabel String + | AtAlpha Int + | AtPhi + | AtRho + | AtLambda + | AtDelta + | AtMeta String deriving (Eq, Generic, Ord) instance Show Attribute where @@ -60,14 +60,11 @@ show AtLambda = "λ" show (AtMeta meta) = '!' : meta -countNodes :: Program -> Int -countNodes (Program expr) = countNodes' expr - where - countNodes' :: Expression -> Int - countNodes' ExGlobal = 1 - countNodes' ExTermination = 1 - countNodes' ExThis = 1 - countNodes' (ExApplication expr' (BiTau _ bexpr')) = 2 + countNodes' expr' + countNodes' bexpr' - countNodes' (ExDispatch expr' _) = 2 + countNodes' expr' - countNodes' (ExFormation bds) = 1 + sum (map (\case BiTau _ expr' -> countNodes' expr'; _ -> 1) bds) - countNodes' _ = 0 +countNodes :: Expression -> Int +countNodes ExGlobal = 1 +countNodes ExTermination = 1 +countNodes ExThis = 1 +countNodes (ExApplication expr' (BiTau _ bexpr')) = 2 + countNodes expr' + countNodes bexpr' +countNodes (ExDispatch expr' _) = 2 + countNodes expr' +countNodes (ExFormation bds) = 1 + sum (map (\case BiTau _ expr' -> countNodes expr'; _ -> 1) bds) +countNodes _ = 0 diff --git a/src/Builder.hs b/src/Builder.hs --- a/src/Builder.hs +++ b/src/Builder.hs @@ -43,26 +43,10 @@ type Built a = Either String a instance Show BuildException where - show CouldNotBuildExpression{..} = - printf - "Couldn't build expression, %s\n--Expression: %s" - _msg - (printExpression _expr) - show CouldNotBuildAttribute{..} = - printf - "Couldn't build attribute '%s', %s" - (printAttribute _attr) - _msg - show CouldNotBuildBinding{..} = - printf - "Couldn't build binding, %s\n--Binding: %s" - _msg - (printBinding _bd) - show CouldNotBuildBytes{..} = - printf - "Couldn't build bytes '%s', %s" - (printBytes _bts) - _msg + show CouldNotBuildExpression{..} = printf "Couldn't build expression, %s\n--Expression: %s" _msg (printExpression _expr) + show CouldNotBuildAttribute{..} = printf "Couldn't build attribute '%s', %s" (printAttribute _attr) _msg + show CouldNotBuildBinding{..} = printf "Couldn't build binding, %s\n--Binding: %s" _msg (printBinding _bd) + show CouldNotBuildBytes{..} = printf "Couldn't build bytes '%s', %s" (printBytes _bts) _msg contextualize :: Expression -> Expression -> Expression contextualize ExGlobal _ = ExGlobal @@ -71,9 +55,7 @@ contextualize (ExFormation bds) _ = ExFormation bds contextualize (ExDispatch ex at) context = ExDispatch (contextualize ex context) at contextualize (ExApplication ex (BiTau at bexpr)) context = - let ex' = contextualize ex context - bexpr' = contextualize bexpr context - in ExApplication ex' (BiTau at bexpr') + ExApplication (contextualize ex context) (BiTau at (contextualize bexpr context)) contextualize ex _ = ex buildAttribute :: Attribute -> Subst -> Built Attribute diff --git a/src/CLI.hs b/src/CLI.hs --- a/src/CLI.hs +++ b/src/CLI.hs @@ -37,7 +37,7 @@ import Parser (parseExpressionThrows, parseProgramThrows) import Paths_phino (version) import qualified Printer as P -import Rewriter (RewriteContext (RewriteContext), Rewritten, rewrite') +import Rewriter (RewriteContext (RewriteContext), Rewritten, rewrite) import Rule (RuleContext (RuleContext), matchProgramWithRule) import Sugar import System.Exit (ExitCode (..), exitFailure) @@ -144,6 +144,7 @@ , rules :: [FilePath] , hide :: [String] , show' :: [String] + , locator :: String , expression :: Maybe String , label :: Maybe String , meetPrefix :: Maybe String @@ -278,6 +279,9 @@ ) ) +optLocator :: Parser String +optLocator = strOption (long "locator" <> metavar "FQN" <> help "Location of object to dataize. Must be a valid dispatch expression; e.g. Q.foo.bar" <> value "Q" <> showDefault) + optNormalize :: Parser Bool optNormalize = switch (long "normalize" <> help "Use built-in normalization rules") @@ -348,7 +352,7 @@ <*> optMaxCycles <*> optHide <*> optShow - <*> strOption (long "locator" <> metavar "FQN" <> help "Location of object to dataize. Must be a valid dispatch expression; e.g. Q.foo.bar" <> value "Q" <> showDefault) + <*> optLocator <*> optExpression <*> optLabel <*> optMeetPrefix @@ -389,6 +393,7 @@ <*> optRule <*> optHide <*> optShow + <*> optLocator <*> optExpression <*> optLabel <*> optMeetPrefix @@ -471,6 +476,7 @@ validateOpts excluded <- validatedDispatches "hide" hide included <- validatedDispatches "show" show' + [loc] <- validatedDispatches "locator" [locator] logDebug (printf "Amount of rewriting cycles across all the rules: %d, per rule: %d" maxCycles maxDepth) input <- readInput inputFile rules' <- getRules normalize shuffle rules @@ -481,7 +487,7 @@ _canonize = if canonize then C.canonize else id _hide = (`F.exclude` excluded) _show = (`F.include` included) - rewrittens <- rewrite' program rules' (context printCtx) <&> _canonize . _hide . _show + rewrittens <- rewrite program rules' (context loc printCtx) <&> _canonize . _hide . _show let rewrittens' = if sequence then rewrittens else [last rewrittens] logDebug (printf "Printing rewritten 𝜑-program as %s" (show outputFormat)) progs <- printRewrittens printCtx rewrittens' @@ -519,9 +525,10 @@ (False, Nothing, _) -> do logDebug "The option '--target' is not specified, printing to console..." putStrLn prog - context :: PrintProgramContext -> RewriteContext - context ctx = + context :: Expression -> PrintProgramContext -> RewriteContext + context loc ctx = RewriteContext + loc maxDepth maxCycles depthSensitive @@ -539,7 +546,7 @@ _canonize = if canonize then C.canonize else id _hide = (`F.exclude` excluded) _show = (`F.include` included) - (maybeBytes, seq) <- dataize loc (context prog printCtx) + (maybeBytes, seq) <- dataize (context loc prog printCtx) when sequence (printRewrittens printCtx (_canonize $ _hide $ _show seq) >>= putStrLn) unless quiet (putStrLn (maybe (P.printExpression ExTermination) P.printBytes maybeBytes)) where @@ -553,10 +560,11 @@ outputFormat [(omitListing, "omit-listing"), (omitComments, "omit-comments")] when (length show' > 1) (invalidCLIArguments "The option --show can be used only once") - context :: Program -> PrintProgramContext -> DataizeContext - context program ctx = + context :: Expression -> Program -> PrintProgramContext -> DataizeContext + context loc prog ctx = DataizeContext - program + loc + prog maxDepth maxCycles depthSensitive diff --git a/src/Dataize.hs b/src/Dataize.hs --- a/src/Dataize.hs +++ b/src/Dataize.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} @@ -12,16 +11,17 @@ import AST import Builder (contextualize) -import Control.Exception (Exception, throwIO) +import Control.Exception (throwIO) import Data.List (partition) -import Deps (BuildTermFunc, SaveStepFunc) +import Deps (BuildTermFunc, SaveStepFunc, Term (TeAttribute)) +import Locator (locatedExpression, withLocatedExpression) +import Matcher (substEmpty) import Misc import Must (Must (..)) -import Printer (printExpression) -import Rewriter (RewriteContext (RewriteContext), Rewritten, rewrite') +import Rewriter (RewriteContext (RewriteContext), Rewritten, rewrite) import Rule (RuleContext (RuleContext), isNF) import Text.Printf (printf) -import Yaml (normalizationRules) +import Yaml (ExtraArgument (ArgAttribute), normalizationRules) type Dataized = (Maybe Bytes, [Rewritten]) @@ -29,21 +29,9 @@ type Morphed = Dataizable -data LocatorException - = CanNotFindObjectByLocator {fqn :: Expression} - | InvalidLocatorProvided {fqn :: Expression} - deriving Exception - -instance Show LocatorException where - show CanNotFindObjectByLocator{..} = printf "Can't find object by locator: '%s'" (printExpression fqn) - show InvalidLocatorProvided{..} = - printf - "Can't dataize object by invalid locator. \ - \'Q' or dispatch started with 'Q' expected, but got: '%s'" - (printExpression fqn) - data DataizeContext = DataizeContext - { _program :: Program + { _locator :: Expression + , _program :: Program , _maxDepth :: Int , _maxCycles :: Int , _depthSensitive :: Bool @@ -54,6 +42,7 @@ switchContext :: DataizeContext -> RewriteContext switchContext DataizeContext{..} = RewriteContext + _locator _maxDepth _maxCycles _depthSensitive @@ -114,7 +103,7 @@ withTail (ExApplication expr tau) ctx = do tailed <- withTail expr ctx case tailed of - Just (exp, rule) -> pure (Just (ExApplication exp tau, rule)) + Just (expr', rule) -> pure (Just (ExApplication expr' tau, rule)) _ -> pure Nothing withTail (ExDispatch (ExFormation bds) attr) ctx = do tailed <- formation bds ctx @@ -122,10 +111,11 @@ Just (obj, rule) -> pure (Just (ExDispatch obj attr, rule)) _ -> pure Nothing withTail (ExFormation bds) ctx = formation bds ctx -withTail (ExDispatch (ExDispatch ExGlobal (AtLabel label)) attr) (DataizeContext{_program = Program expr}) = case phiDispatch label expr of - Just (obj, rule) -> pure (Just (ExDispatch obj attr, rule)) - _ -> pure Nothing -withTail (ExDispatch ExGlobal (AtLabel label)) (DataizeContext{_program = Program expr}) = pure (phiDispatch label expr) +withTail (ExDispatch (ExDispatch ExGlobal (AtLabel label)) attr) DataizeContext{_program = Program expr} = + case phiDispatch label expr of + Just (obj, rule) -> pure (Just (ExDispatch obj attr, rule)) + _ -> pure Nothing +withTail (ExDispatch ExGlobal (AtLabel label)) DataizeContext{_program = Program expr} = pure (phiDispatch label expr) withTail (ExDispatch expr attr) ctx = do tailed <- withTail expr ctx case tailed of @@ -146,49 +136,39 @@ -- PHI: M(Q.tau * t) -> M(e * t) if Q -> [B1, tau -> e, B2], t is tail started with dispatch -- M(e) -> ⊥ otherwise morph :: Morphed -> DataizeContext -> IO Morphed -morph (ExTermination, seq) _ = pure (ExTermination, leadsTo seq "Mprim" ExTermination) -- PRIM +morph (expr@ExTermination, seq) ctx = do + seq' <- leadsTo seq "Mprim" expr ctx -- PRIM + pure (expr, seq') morph (form@(ExFormation _), seq) ctx = do resolved <- withTail form ctx case resolved of - Just (expr, rule) -> morph (expr, leadsTo seq rule expr) ctx -- LAMBDA or PHI - _ -> pure (form, leadsTo seq "Mprim" form) -- PRIM -morph (expr, seq) ctx = do + Just (expr, rule) -> do + seq' <- leadsTo seq rule expr ctx -- LAMBDA or PHI + morph (expr, seq') ctx + _ -> do + seq' <- leadsTo seq "Mprim" form ctx -- PRIM + pure (form, seq') +morph (expr, seq) ctx@DataizeContext{..} = do resolved <- withTail expr ctx case resolved of - Just (expr', rule) -> morph (expr', leadsTo seq rule expr') ctx + Just (expr', rule) -> do + seq' <- leadsTo seq rule expr' ctx + morph (expr', seq') ctx _ -> - if isNF expr (RuleContext (_buildTerm ctx)) + if isNF expr (RuleContext _buildTerm) then morph (ExTermination, seq) ctx -- PRIM else do - rewrittens' <- rewrite' (Program expr) normalizationRules (switchContext ctx) -- NMZ - let _seq = reverse rewrittens' <> tail seq - (Program expr') = fst (head _seq) - morph (expr', _seq) ctx + prog' <- withLocatedExpression _locator expr _program + rewrittens' <- rewrite prog' normalizationRules (switchContext ctx) -- NMZ todo + let seq' = reverse rewrittens' <> tail seq + expr' <- locatedExpression _locator (fst (head seq')) + morph (expr', seq') ctx -dataize :: Expression -> DataizeContext -> IO Dataized -dataize locator ctx@DataizeContext{_program = Program expr} = do - fqn <- case fqnToAttrs locator of - Just attrs -> pure attrs - _ -> throwIO (InvalidLocatorProvided locator) - exp <- located expr fqn - (maybeBytes, seq) <- dataize' (exp, [(Program exp, Nothing)]) ctx +dataize :: DataizeContext -> IO Dataized +dataize ctx@DataizeContext{..} = do + expr <- locatedExpression _locator _program + (maybeBytes, seq) <- dataize' (expr, [(_program, Nothing)]) ctx pure (maybeBytes, reverse seq) - where - located :: Expression -> [Attribute] -> IO Expression - located expr [] = pure expr - located (ExFormation bds) [attr] = case locatedInBindings attr bds of - Just expr -> pure expr - _ -> throwIO (CanNotFindObjectByLocator locator) - located (ExFormation bds) (attr : rest) = case locatedInBindings attr bds of - Just expr -> located expr rest - _ -> throwIO (CanNotFindObjectByLocator locator) - located _ _ = throwIO (CanNotFindObjectByLocator locator) - locatedInBindings :: Attribute -> [Binding] -> Maybe Expression - locatedInBindings _ [] = Nothing - locatedInBindings attr (BiTau attr' expr : rest) - | attr == attr' = Just expr - | otherwise = locatedInBindings attr rest - locatedInBindings attr (_ : rest) = locatedInBindings attr rest -- The goal of 'dataize' function is retrieve bytes from given expression. -- @@ -198,31 +178,45 @@ -- nothing otherwise dataize' :: Dataizable -> DataizeContext -> IO Dataized dataize' (ExTermination, seq) _ = pure (Nothing, seq) -dataize' (ExFormation bds, seq) ctx = case maybeDelta bds of +dataize' (form@(ExFormation bds), seq) ctx@DataizeContext{..} = case maybeDelta bds of (Just (BiDelta bytes), _) -> pure (Just bytes, seq) (Just _, _) -> pure (Nothing, seq) (Nothing, _) -> case maybePhi bds of (Just (BiTau AtPhi expr), bds') -> case maybeLambda bds' of (Just (BiLambda _), _) -> throwIO (userError "The 𝜑 and λ can't be present in formation at the same time") (Just _, _) -> pure (Nothing, seq) - (Nothing, _) -> - let expr' = contextualize expr (ExFormation bds) - in dataize' (expr', leadsTo seq "contextualize" expr') ctx + (Nothing, _) -> do + let expr' = contextualize expr form + seq' <- leadsTo seq "contextualize" expr' ctx + dataize' (expr', seq') ctx (Just _, _) -> pure (Nothing, seq) (Nothing, _) -> case maybeLambda bds of - (Just (BiLambda _), _) -> morph (ExFormation bds, seq) ctx >>= (`dataize'` ctx) + (Just (BiLambda _), _) -> morph (form, seq) ctx >>= (`dataize'` ctx) (Just _, _) -> pure (Nothing, seq) (Nothing, _) -> pure (Nothing, seq) dataize' dataizable ctx = morph dataizable ctx >>= (`dataize'` ctx) -leadsTo :: [Rewritten] -> String -> Expression -> [Rewritten] -leadsTo [] rule expr = [(Program expr, Just rule)] -leadsTo ((prog, _) : rest) rule expr = (Program expr, Nothing) : (prog, Just rule) : rest +leadsTo :: [Rewritten] -> String -> Expression -> DataizeContext -> IO [Rewritten] +leadsTo [] _ _ _ = throwIO (userError "Empty rewritten sequence should never met during dataization process") +leadsTo ((prog, _) : rest) rule expr DataizeContext{..} = do + prog' <- withLocatedExpression _locator expr prog + pure ((prog', Nothing) : (prog, Just rule) : rest) +-- Synthetic dataize function for internal usage inside atoms +-- Here we modify original program from context by adding new binding +-- which refers to expression we want to dataize. +_dataize :: Expression -> DataizeContext -> IO (Maybe Bytes) +_dataize expr ctx@DataizeContext{_buildTerm = buildTerm, _program = Program (ExFormation bds)} = do + (TeAttribute attr) <- buildTerm "random-tau" (map ArgAttribute (attributesFromBindings bds)) substEmpty + let prog = Program (ExFormation (BiTau attr expr : bds)) + (bts, _) <- dataize' (expr, [(prog, Nothing)]) ctx{_program = prog} + pure bts +_dataize _ _ = throwIO (userError "Can't call _dataize from atoms with non-formation program") + atom :: String -> Expression -> DataizeContext -> IO Expression atom "L_org_eolang_number_plus" self ctx = do - (left, _) <- dataize' (ExDispatch self (AtLabel "x"), []) ctx - (right, _) <- dataize' (ExDispatch self AtRho, []) ctx + left <- _dataize (ExDispatch self (AtLabel "x")) ctx + right <- _dataize (ExDispatch self AtRho) ctx case (left, right) of (Just left', Just right') -> do let first = either toDouble id (btsToNum left') @@ -231,8 +225,8 @@ pure (DataNumber (numToBts sum)) _ -> pure ExTermination atom "L_org_eolang_number_times" self ctx = do - (left, _) <- dataize' (ExDispatch self (AtLabel "x"), []) ctx - (right, _) <- dataize' (ExDispatch self AtRho, []) ctx + left <- _dataize (ExDispatch self (AtLabel "x")) ctx + right <- _dataize (ExDispatch self AtRho) ctx case (left, right) of (Just left', Just right') -> do let first = either toDouble id (btsToNum left') @@ -241,8 +235,8 @@ pure (DataNumber (numToBts sum)) _ -> pure ExTermination atom "L_org_eolang_number_eq" self ctx = do - (x, _) <- dataize' (ExDispatch self (AtLabel "x"), []) ctx - (rho, _) <- dataize' (ExDispatch self AtRho, []) ctx + x <- _dataize (ExDispatch self (AtLabel "x")) ctx + rho <- _dataize (ExDispatch self AtRho) ctx case (x, rho) of (Just x', Just rho') -> do let self' = either toDouble id (btsToNum rho') diff --git a/src/Locator.hs b/src/Locator.hs new file mode 100644 --- /dev/null +++ b/src/Locator.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE RecordWildCards #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module Locator (locatedExpression, withLocatedExpression) where + +import AST +import Control.Exception (Exception, throwIO) +import Data.Functor ((<&>)) +import Misc +import Printer (printExpression) +import Text.Printf (printf) + +data LocatorException + = InvalidLocatorProvided {fqn :: Expression} + | CanNotFindObjectByLocator {fqn :: Expression} + deriving (Exception) + +instance Show LocatorException where + show InvalidLocatorProvided{..} = + printf + "Invalid locator is provided. 'Q' or dispatch started with 'Q' expected, but got: '%s'" + (printExpression fqn) + show CanNotFindObjectByLocator{..} = printf "Can't find object by locator: '%s'" (printExpression fqn) + +locatedExpression :: Expression -> Program -> IO Expression +locatedExpression ExGlobal (Program expr) = pure expr +locatedExpression locator (Program expr) = case fqnToAttrs locator of + Just attrs -> locatedExpression' expr attrs + _ -> invalidLocator locator + where + locatedExpression' :: Expression -> [Attribute] -> IO Expression + locatedExpression' expr' [] = pure expr' + locatedExpression' (ExFormation bds) [attr] = case locatedInBindings attr bds of + Just expr' -> pure expr' + _ -> cantFindBy locator + locatedExpression' (ExFormation bds) (attr : rest) = case locatedInBindings attr bds of + Just expr' -> locatedExpression' expr' rest + _ -> cantFindBy locator + locatedExpression' _ _ = cantFindBy locator + +withLocatedExpression :: Expression -> Expression -> Program -> IO Program +withLocatedExpression ExGlobal tgt _ = pure (Program tgt) +withLocatedExpression locator target (Program expr) = case fqnToAttrs locator of + Just attrs -> Program <$> withLocatedExpression' expr attrs + _ -> invalidLocator locator + where + withLocatedExpression' :: Expression -> [Attribute] -> IO Expression + withLocatedExpression' (ExFormation bds) [attr] = case locatedInBindings attr bds of + Just _ -> pure (ExFormation (withReplacedExpression bds)) + _ -> cantFindBy locator + where + withReplacedExpression :: [Binding] -> [Binding] + withReplacedExpression [] = [] + withReplacedExpression (bd@(BiTau at _) : bds') + | at == attr = BiTau at target : bds' + | otherwise = bd : withReplacedExpression bds' + withReplacedExpression (bd@(BiVoid at) : bds') + | at == attr = BiTau at target : bds' + | otherwise = bd : withReplacedExpression bds' + withReplacedExpression (bd : bds') = bd : withReplacedExpression bds' + withLocatedExpression' (ExFormation bds) attrs = ExFormation <$> withLocatedBindings bds attrs + where + withLocatedBindings :: [Binding] -> [Attribute] -> IO [Binding] + withLocatedBindings (bd@(BiTau at expr') : rbds) attrs'@(at' : rattrs) + | at == at' = withLocatedExpression' expr' rattrs <&> (: rbds) . BiTau at + | otherwise = withLocatedBindings rbds attrs' <&> (:) bd + withLocatedBindings (bd : rbds) attrs' = (:) bd <$> withLocatedBindings rbds attrs' + withLocatedBindings [] _ = cantFindBy locator + withLocatedExpression' _ _ = cantFindBy locator + +locatedInBindings :: Attribute -> [Binding] -> Maybe Expression +locatedInBindings _ [] = Nothing +locatedInBindings attr (BiTau attr' expr' : rest) + | attr == attr' = Just expr' + | otherwise = locatedInBindings attr rest +locatedInBindings attr (_ : rest) = locatedInBindings attr rest + +invalidLocator :: Expression -> IO a +invalidLocator = throwIO <$> InvalidLocatorProvided + +cantFindBy :: Expression -> IO a +cantFindBy = throwIO <$> CanNotFindObjectByLocator diff --git a/src/Matcher.hs b/src/Matcher.hs --- a/src/Matcher.hs +++ b/src/Matcher.hs @@ -84,7 +84,7 @@ | pFunc == tFunc = [substEmpty] | otherwise = [] matchBinding (BiMetaLambda meta) (BiLambda tFunc) _ = [substSingle meta (MvFunction tFunc)] -matchBinding (BiTau pattr pexp) (BiTau tattr texp) scope = combineMany (matchAttribute pattr tattr) (matchExpression pexp texp scope) +matchBinding (BiTau pattr pexp) (BiTau tattr texp) scope = combineMany (matchAttribute pattr tattr) (matchExpression' pexp texp scope) matchBinding _ _ _ = [] -- Match bindings with ordering @@ -111,7 +111,7 @@ _ -> ([], []) where tailExpressionsReversed :: Expression -> Expression -> Maybe ([Subst], [Tail]) - tailExpressionsReversed ptn' tgt' = case matchExpression ptn' tgt' scope of + tailExpressionsReversed ptn' tgt' = case matchExpression' ptn' tgt' scope of [] -> case tgt' of ExDispatch expr attr -> do (substs, tails) <- tailExpressionsReversed ptn' expr @@ -129,24 +129,24 @@ _ -> Just ([], []) substs -> Just (substs, []) -matchExpression :: Expression -> Expression -> Expression -> [Subst] -matchExpression (ExMeta meta) tgt scope = [substSingle meta (MvExpression tgt scope)] -matchExpression ExThis ExThis _ = [substEmpty] -matchExpression ExGlobal ExGlobal _ = [substEmpty] -matchExpression ExTermination ExTermination _ = [substEmpty] -matchExpression (ExFormation pbs) (ExFormation tbs) _ = matchBindings pbs tbs (ExFormation tbs) -matchExpression (ExDispatch pexp pattr) (ExDispatch texp tattr) scope = combineMany (matchAttribute pattr tattr) (matchExpression pexp texp scope) -matchExpression (ExApplication pexp pbd) (ExApplication texp tbd) scope = combineMany (matchExpression pexp texp scope) (matchBinding pbd tbd scope) -matchExpression (ExMetaTail expr meta) tgt scope = case tailExpressions expr tgt scope of +matchExpression' :: Expression -> Expression -> Expression -> [Subst] +matchExpression' (ExMeta meta) tgt scope = [substSingle meta (MvExpression tgt scope)] +matchExpression' ExThis ExThis _ = [substEmpty] +matchExpression' ExGlobal ExGlobal _ = [substEmpty] +matchExpression' ExTermination ExTermination _ = [substEmpty] +matchExpression' (ExFormation pbs) (ExFormation tbs) _ = matchBindings pbs tbs (ExFormation tbs) +matchExpression' (ExDispatch pexp pattr) (ExDispatch texp tattr) scope = combineMany (matchAttribute pattr tattr) (matchExpression' pexp texp scope) +matchExpression' (ExApplication pexp pbd) (ExApplication texp tbd) scope = combineMany (matchExpression' pexp texp scope) (matchBinding pbd tbd scope) +matchExpression' (ExMetaTail expr meta) tgt scope = case tailExpressions expr tgt scope of ([], _) -> [] (substs, tails) -> combineMany substs [substSingle meta (MvTail tails)] -matchExpression (ExPhiAgain prefix idx expr) (ExPhiAgain prefix' idx' expr') scope - | prefix == prefix' && idx == idx' = matchExpression expr expr' scope +matchExpression' (ExPhiAgain prefix idx expr) (ExPhiAgain prefix' idx' expr') scope + | prefix == prefix' && idx == idx' = matchExpression' expr expr' scope | otherwise = [] -matchExpression (ExPhiMeet prefix idx expr) (ExPhiMeet prefix' idx' expr') scope - | prefix == prefix' && idx == idx' = matchExpression expr expr' scope +matchExpression' (ExPhiMeet prefix idx expr) (ExPhiMeet prefix' idx' expr') scope + | prefix == prefix' && idx == idx' = matchExpression' expr expr' scope | otherwise = [] -matchExpression _ _ _ = [] +matchExpression' _ _ _ = [] -- Deep match pattern to expression inside binding matchBindingExpression :: Binding -> Expression -> Expression -> [Subst] @@ -156,7 +156,7 @@ -- Match expression with deep nested expression(s) matching matchExpressionDeep :: Expression -> Expression -> Expression -> [Subst] matchExpressionDeep ptn tgt scope = - let matched = matchExpression ptn tgt scope + let matched = matchExpression' ptn tgt scope deep = case tgt of ExFormation bds -> concatMap (\bd -> matchBindingExpression bd ptn tgt) bds ExDispatch expr _ -> matchExpressionDeep ptn expr scope @@ -164,5 +164,8 @@ _ -> [] in matched ++ deep +matchExpression :: Expression -> Expression -> [Subst] +matchExpression ptn tgt = matchExpressionDeep ptn tgt defaultScope + matchProgram :: Expression -> Program -> [Subst] -matchProgram ptn (Program expr) = matchExpressionDeep ptn expr defaultScope +matchProgram ptn (Program expr) = matchExpression ptn expr diff --git a/src/Replacer.hs b/src/Replacer.hs --- a/src/Replacer.hs +++ b/src/Replacer.hs @@ -9,8 +9,11 @@ module Replacer ( replaceProgram , replaceProgramFast + , replaceExpression + , replaceExpressionFast , ReplaceContext (..) , ReplaceProgramFunc + , ReplaceExpressionFunc ) where @@ -19,13 +22,15 @@ type ReplaceState a = (a, [Expression], [Expression -> Expression]) -type ReplaceExpressionFunc = ReplaceState Expression -> ReplaceContext -> ReplaceState Expression +type ReplaceExpressionFunc' = ReplaceState Expression -> ReplaceContext -> ReplaceState Expression type ReplaceProgramFunc = ReplaceState Program -> Program +type ReplaceExpressionFunc = ReplaceState Expression -> Expression + newtype ReplaceContext = ReplaceCtx {_maxDepth :: Int} -replaceBindings :: ReplaceState [Binding] -> ReplaceContext -> ReplaceExpressionFunc -> ReplaceState [Binding] +replaceBindings :: ReplaceState [Binding] -> ReplaceContext -> ReplaceExpressionFunc' -> ReplaceState [Binding] replaceBindings state@(_, [], _) _ _ = state replaceBindings state@(_, _, []) _ _ = state replaceBindings state@([], _, _) _ _ = state @@ -37,24 +42,24 @@ let (bds', ptns', repls') = replaceBindings (bds, ptns, repls) ctx func in (bd : bds', ptns', repls') -replaceExpression :: ReplaceExpressionFunc -replaceExpression state@(expr, ptns@(ptn : _ptns), repls@(repl : _repls)) ctx = +replaceExpression' :: ReplaceExpressionFunc' +replaceExpression' state@(expr, ptns@(ptn : _ptns), repls@(repl : _repls)) ctx = if expr == ptn - then replaceExpression (repl expr, _ptns, _repls) ctx + then replaceExpression' (repl expr, _ptns, _repls) ctx else case expr of ExDispatch inner attr -> - let (expr', ptns', repls') = replaceExpression (inner, ptns, repls) ctx + let (expr', ptns', repls') = replaceExpression' (inner, ptns, repls) ctx in (ExDispatch expr' attr, ptns', repls') ExApplication inner tau -> - let (expr', ptns', repls') = replaceExpression (inner, ptns, repls) ctx - in case replaceBindings ([tau], ptns', repls') ctx replaceExpression of + let (expr', ptns', repls') = replaceExpression' (inner, ptns, repls) ctx + in case replaceBindings ([tau], ptns', repls') ctx replaceExpression' of ([tau'], ptns'', repls'') -> (ExApplication expr' tau', ptns'', repls'') (bds', _, _) -> error $ "Expected single binding, got " ++ show (length bds') ExFormation bds -> - let (bds', ptns', repls') = replaceBindings (bds, ptns, repls) ctx replaceExpression + let (bds', ptns', repls') = replaceBindings (bds, ptns, repls) ctx replaceExpression' in (ExFormation bds', ptns', repls') _ -> state -replaceExpression state _ = state +replaceExpression' state _ = state replaceBindingsFast :: [Binding] -> [Expression] -> [Expression] -> [Binding] replaceBindingsFast bds ((ExFormation pbds) : _ptns) ((ExFormation rbds) : _repls) = @@ -69,35 +74,41 @@ | otherwise = x : findAndReplace xs' ptn repl replaceBindingsFast bds _ _ = bds -replaceExpressionFast :: ReplaceExpressionFunc -replaceExpressionFast = replaceExpressionFast' 0 +replaceExpressionFast' :: ReplaceExpressionFunc' +replaceExpressionFast' = _replaceExpressionFast 0 where - replaceExpressionFast' :: Int -> ReplaceExpressionFunc - replaceExpressionFast' _ state@(_, [], _) _ = state - replaceExpressionFast' _ state@(_, _, []) _ = state - replaceExpressionFast' depth state@(expr, ptns, repls) ctx@ReplaceCtx{..} = + _replaceExpressionFast :: Int -> ReplaceExpressionFunc' + _replaceExpressionFast _ state@(_, [], _) _ = state + _replaceExpressionFast _ state@(_, _, []) _ = state + _replaceExpressionFast depth state@(expr, ptns, repls) ctx@ReplaceCtx{..} = if depth == _maxDepth then (expr, [], []) else case expr of ExFormation bds -> let replaced = replaceBindingsFast bds ptns (map (\rep -> rep expr) repls) - (bds', ptns', repls') = replaceBindings (replaced, ptns, repls) ctx (replaceExpressionFast' (depth + 1)) + (bds', ptns', repls') = replaceBindings (replaced, ptns, repls) ctx (_replaceExpressionFast (depth + 1)) in (ExFormation bds', ptns', repls') ExDispatch inner attr -> - let (expr', ptns', repls') = replaceExpressionFast (inner, ptns, repls) ctx + let (expr', ptns', repls') = replaceExpressionFast' (inner, ptns, repls) ctx in (ExDispatch expr' attr, ptns', repls') ExApplication inner (BiTau attr arg) -> - let (expr', ptns', repls') = replaceExpressionFast (inner, ptns, repls) ctx - (expr'', ptns'', repls'') = replaceExpressionFast (arg, ptns', repls') ctx + let (expr', ptns', repls') = replaceExpressionFast' (inner, ptns, repls) ctx + (expr'', ptns'', repls'') = replaceExpressionFast' (arg, ptns', repls') ctx in (ExApplication expr' (BiTau attr expr''), ptns'', repls'') _ -> state +replaceExpression :: ReplaceExpressionFunc +replaceExpression state = + let (expr, _, _) = replaceExpression' state (ReplaceCtx 0) + in expr + +replaceExpressionFast :: ReplaceContext -> ReplaceExpressionFunc +replaceExpressionFast ctx state = + let (expr, _, _) = replaceExpressionFast' state ctx + in expr + replaceProgram :: ReplaceProgramFunc -replaceProgram (Program expr, ptns, repls) = - let (expr', _, _) = replaceExpression (expr, ptns, repls) (ReplaceCtx 0) - in Program expr' +replaceProgram (Program expr, ptns, repls) = Program (replaceExpression (expr, ptns, repls)) replaceProgramFast :: ReplaceContext -> ReplaceProgramFunc -replaceProgramFast ctx (Program expr, ptns, repls) = - let (expr', _, _) = replaceExpressionFast (expr, ptns, repls) ctx - in Program expr' +replaceProgramFast ctx (Program expr, ptns, repls) = Program (replaceExpressionFast ctx (expr, ptns, repls)) diff --git a/src/Rewriter.hs b/src/Rewriter.hs --- a/src/Rewriter.hs +++ b/src/Rewriter.hs @@ -8,7 +8,7 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module Rewriter (rewrite, rewrite', RewriteContext (..), Rewritten) where +module Rewriter (rewrite, RewriteContext (..), Rewritten) where import AST import Builder @@ -18,24 +18,26 @@ import Data.Maybe (fromMaybe) import qualified Data.Set as Set import Deps +import Locator (locatedExpression, withLocatedExpression) import Logger (logDebug) import Matcher (Subst) import Must (Must (..), exceedsUpperBound, inRange) -import Printer (printProgram) -import Replacer (ReplaceContext (ReplaceCtx), ReplaceProgramFunc, replaceProgram, replaceProgramFast) +import Printer (printExpression) +import Replacer (ReplaceContext (ReplaceCtx), ReplaceExpressionFunc, replaceExpression, replaceExpressionFast) import Rule (RuleContext (RuleContext)) import qualified Rule as R import Text.Printf (printf) import qualified Yaml as Y -type RewriteState = ([Rewritten], Set.Set Program) +type RewriteState = ([Rewritten], Set.Set Expression) type Rewritten = (Program, Maybe String) -type ToReplace = (Program, Expression, Expression, [Subst]) +type ToReplace = (Expression, Expression, Expression, [Subst]) data RewriteContext = RewriteContext - { _maxDepth :: Int + { _locator :: Expression + , _maxDepth :: Int , _maxCycles :: Int , _depthSensitive :: Bool , _buildTerm :: BuildTermFunc @@ -68,21 +70,21 @@ "With option --depth-sensitive it's expected rewriting iterations amount does not reach the limit: --%s=%d" flg lim - show (LoopingRewriting prg rul stp) = + show (LoopingRewriting expr rul stp) = printf - "On rewriting step '%d' of rule '%s' we got the same program as we got at one of the previous step, it seems rewriting is looping\nProgram: %s" + "On rewriting step '%d' of rule '%s' we got the same expression as we got at one of the previous step, it seems rewriting is looping\nExpression: %s" stp rul - prg + expr --- Build pattern and result expression and replace patterns to results in given program -buildAndReplace' :: ToReplace -> ReplaceProgramFunc -> IO Program -buildAndReplace' (prog, ptn, res, substs) func = do +-- Build pattern and result expression and replace patterns to results in given expression +buildAndReplace' :: ToReplace -> ReplaceExpressionFunc -> IO Expression +buildAndReplace' (expr, ptn, res, substs) func = do ptns <- buildExpressionsThrows ptn substs repls <- buildExpressionsThrows res substs let ptns' = map fst ptns repls' = map (\ex _ -> fst ex) repls - pure (func (prog, ptns', repls')) + pure (func (expr, ptns', repls')) -- If pattern and replacement are appropriate for fast replacing - does it. -- Pattern and replacement expressions can be used in fast replacing only if @@ -92,8 +94,8 @@ -- In such case we can just replace bindings one by one without building whole expression. -- You can find more details in this ticket: https://github.com/objectionary/phino/issues/321 -- If we don't meet the conditions above - just do a regular replacing -tryBuildAndReplaceFast :: ToReplace -> ReplaceContext -> IO Program -tryBuildAndReplaceFast state@(prog, ExFormation pbds, ExFormation rbds, substs) ctx = +tryBuildAndReplaceFast :: ToReplace -> ReplaceContext -> IO Expression +tryBuildAndReplaceFast state@(expr, ExFormation pbds, ExFormation rbds, substs) ctx = let pbds' = init (tail pbds) rbds' = init (tail rbds) in if startsAndEndsWithMeta pbds @@ -104,10 +106,10 @@ && not (hasMetaBindings rbds') then do logDebug "Applying fast replacing since 'pattern' and 'result' are suitable for this..." - buildAndReplace' (prog, ExFormation pbds', ExFormation rbds', substs) (replaceProgramFast ctx) + buildAndReplace' (expr, ExFormation pbds', ExFormation rbds', substs) (replaceExpressionFast ctx) else do logDebug "Applying regular replacing..." - buildAndReplace' state replaceProgram + buildAndReplace' state replaceExpression where startsAndEndsWithMeta :: [Binding] -> Bool startsAndEndsWithMeta bds = @@ -120,17 +122,17 @@ BiMeta _ -> True _ -> False hasMetaBindings = foldl (\acc bd -> acc || isMetaBinding bd) False -tryBuildAndReplaceFast state _ = buildAndReplace' state replaceProgram +tryBuildAndReplaceFast state _ = buildAndReplace' state replaceExpression -- The function returns tuple (X, Y) where -- - X is sequence of programs; -- - Y is Set of unique programs after each rule application. It allows to stop the rewriting if we're getting -- into loop and get back to program which we've already got before -rewrite :: RewriteState -> [Y.Rule] -> Int -> RewriteContext -> IO RewriteState -rewrite state [] _ _ = pure state -rewrite state (rule : rest) iteration ctx@RewriteContext{..} = do +rewrite' :: RewriteState -> [Y.Rule] -> Int -> RewriteContext -> IO RewriteState +rewrite' state [] _ _ = pure state +rewrite' state (rule : rest) iteration ctx@RewriteContext{..} = do state' <- _rewrite state 1 - rewrite state' rest iteration ctx + rewrite' state' rest iteration ctx where _rewrite :: RewriteState -> Int -> IO RewriteState _rewrite (_rewrittens, _unique) _count = @@ -146,65 +148,61 @@ else pure (_rewrittens, _unique) else do logDebug (printf "Starting rewriting cycle for rule '%s': %d out of %d" ruleName _count _maxDepth) - matched <- R.matchProgramWithRule program rule (RuleContext _buildTerm) + expression <- locatedExpression _locator program + matched <- R.matchExpressionWithRule expression rule (RuleContext _buildTerm) if null matched then do logDebug (printf "Rule '%s' does not match, rewriting is stopped" ruleName) pure (_rewrittens, _unique) else do logDebug (printf "Rule '%s' has been matched, applying..." ruleName) - prog <- tryBuildAndReplaceFast (program, ptn, res, matched) (ReplaceCtx _maxDepth) - if program == prog + expr <- tryBuildAndReplaceFast (expression, ptn, res, matched) (ReplaceCtx _maxDepth) + if expression == expr then do logDebug (printf "Applied '%s', no changes made" ruleName) pure (_rewrittens, _unique) else - if Set.member prog _unique - then throwIO (LoopingRewriting (printProgram prog) ruleName _count) + if Set.member expr _unique + then throwIO (LoopingRewriting (printExpression expr) ruleName _count) else do logDebug ( printf "Applied '%s' (%d nodes -> %d nodes)\n%s" ruleName - (countNodes program) - (countNodes prog) - (printProgram prog) + (countNodes expression) + (countNodes expr) + (printExpression expr) ) + prog <- withLocatedExpression _locator expr program _saveStep prog (((iteration - 1) * _maxDepth) + _count) - _rewrite (leadsTo prog, Set.insert prog _unique) (_count + 1) + _rewrite (leadsTo prog, Set.insert expr _unique) (_count + 1) where leadsTo :: Program -> [Rewritten] leadsTo _prog = case _rewrittens of (program, _) : rest -> (_prog, Nothing) : (program, Just (map toLower (fromMaybe "unknown" (Y.name rule)))) : rest [] -> [(_prog, Nothing)] --- The function accepts single program but returns sequence of programs -rewrite' :: Program -> [Y.Rule] -> RewriteContext -> IO [Rewritten] -rewrite' prog rules ctx = _rewrite ([(prog, Nothing)], Set.empty) 1 ctx <&> reverse +-- Rewrite program by provided locator from RewriteContext +rewrite :: Program -> [Y.Rule] -> RewriteContext -> IO [Rewritten] +rewrite prog rules ctx@RewriteContext{..} = _rewrite ([(prog, Nothing)], Set.empty) 0 <&> reverse where - _rewrite :: RewriteState -> Int -> RewriteContext -> IO [Rewritten] - _rewrite state@(rewrittens, _) count ctx@RewriteContext{..} = do - let cycles = _maxCycles - must = _must - current = count - 1 - if not (inRange must current) && current > 0 && exceedsUpperBound must current - then throwIO (MustStopBefore must current) - else - if current == cycles + _rewrite :: RewriteState -> Int -> IO [Rewritten] + _rewrite state@(rewrittens, _) count + | not (inRange _must count) && count > 0 && exceedsUpperBound _must count = throwIO (MustStopBefore _must count) + | count == _maxCycles = do + logDebug (printf "Max amount of rewriting cycles for all rules (%d) has been reached, rewriting is stopped" _maxCycles) + if _depthSensitive + then throwIO (StoppedOnLimit "max-cycles" _maxCycles) + else pure rewrittens + | otherwise = do + logDebug (printf "Starting rewriting cycle for all rules: %d out of %d" count _maxCycles) + state'@(rewrittens', _) <- rewrite' state rules count ctx + let (program', _) = head rewrittens' + (program, _) = head rewrittens + if program' == program then do - logDebug (printf "Max amount of rewriting cycles for all rules (%d) has been reached, rewriting is stopped" cycles) - if _depthSensitive - then throwIO (StoppedOnLimit "max-cycles" cycles) - else pure rewrittens - else do - logDebug (printf "Starting rewriting cycle for all rules: %d out of %d" count cycles) - state'@(rewrittens', _) <- rewrite state rules count ctx - let (program', _) = head rewrittens' - (program, _) = head rewrittens - if program' == program - then do - logDebug "Rewriting is stopped since it has no effect" - if not (inRange must current) - then throwIO (MustBeGoing must current) - else pure rewrittens' - else _rewrite state' (count + 1) ctx + logDebug "Rewriting is stopped since it has no effect" + if not (inRange _must count) + then throwIO (MustBeGoing _must count) + else pure rewrittens' + else _rewrite state' (count + 1) diff --git a/src/Rule.hs b/src/Rule.hs --- a/src/Rule.hs +++ b/src/Rule.hs @@ -5,7 +5,7 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module Rule (RuleContext (..), isNF, matchProgramWithRule, meetCondition) where +module Rule (RuleContext (..), isNF, matchProgramWithRule, matchExpressionWithRule, meetCondition) where import AST import Builder @@ -44,7 +44,7 @@ matchesAnyNormalizationRule' :: Expression -> [Y.Rule] -> RuleContext -> Bool matchesAnyNormalizationRule' _ [] _ = False matchesAnyNormalizationRule' expr (rule : rules) ctx = - let matched = unsafePerformIO (matchProgramWithRule (Program expr) rule ctx) + let matched = unsafePerformIO (matchExpressionWithRule expr rule ctx) in not (null matched) || matchesAnyNormalizationRule' expr rules ctx -- Returns True if given expression is in the normal form @@ -278,10 +278,10 @@ logDebug "Extra substitutions have been built" pure (catMaybes res) -matchProgramWithRule :: Program -> Y.Rule -> RuleContext -> IO [Subst] -matchProgramWithRule program rule ctx = +matchExpressionWithRule :: Expression -> Y.Rule -> RuleContext -> IO [Subst] +matchExpressionWithRule expr rule ctx = let ptn = Y.pattern rule - matched = matchProgram ptn program + matched = matchExpression ptn expr name = fromMaybe "unknown" (Y.name rule) in if null matched then do @@ -304,3 +304,6 @@ met <- meetMaybeCondition (Y.having rule) extended ctx when (null met) (logDebug "The 'having' condition wan't met") pure met + +matchProgramWithRule :: Program -> Y.Rule -> RuleContext -> IO [Subst] +matchProgramWithRule (Program expr) = matchExpressionWithRule expr diff --git a/test/ASTSpec.hs b/test/ASTSpec.hs --- a/test/ASTSpec.hs +++ b/test/ASTSpec.hs @@ -214,56 +214,25 @@ let hasProgram str = "Program" `elem` words str in show (Program ExGlobal) `shouldSatisfy` hasProgram - describe "countNodes counts ExGlobal" $ - it "returns one for global" $ - countNodes (Program ExGlobal) `shouldBe` 1 - - describe "countNodes counts ExTermination" $ - it "returns one for termination" $ - countNodes (Program ExTermination) `shouldBe` 1 - - describe "countNodes counts ExThis" $ - it "returns one for this" $ - countNodes (Program ExThis) `shouldBe` 1 - - describe "countNodes counts ExDispatch" $ - it "returns three for dispatch on global" $ - countNodes (Program (ExDispatch ExGlobal (AtLabel "x"))) `shouldBe` 3 - - describe "countNodes counts ExApplication" $ - it "returns four for application with globals" $ - countNodes (Program (ExApplication ExGlobal (BiTau AtRho ExGlobal))) `shouldBe` 4 - - describe "countNodes counts ExFormation with tau bindings" $ - it "returns count including nested expressions" $ - countNodes (Program (ExFormation [BiTau AtRho ExGlobal, BiTau AtPhi ExGlobal])) `shouldBe` 3 - describe "countNodes counts ExFormation with non-tau bindings" $ forM_ - [ ("empty formation", ExFormation [], 1) + [ ("Q", ExGlobal, 1) + , ("T", ExTermination, 1) + , ("$", ExThis, 1) + , ("dispatch on global", ExDispatch ExGlobal (AtLabel "x"), 3) + , ("application with globals", ExApplication ExGlobal (BiTau AtRho ExGlobal), 4) + , ("nested expressions", ExFormation [BiTau AtRho ExGlobal, BiTau AtPhi ExGlobal], 3) + , ("empty formation", ExFormation [], 1) , ("void binding", ExFormation [BiVoid AtRho], 2) , ("delta binding", ExFormation [BiDelta BtEmpty], 2) , ("lambda binding", ExFormation [BiLambda "Func"], 2) , ("meta binding", ExFormation [BiMeta "B"], 2) , ("metalambda binding", ExFormation [BiMetaLambda "F"], 2) - ] - ( \(desc, expr, expected) -> - it desc $ countNodes (Program expr) `shouldBe` expected - ) - - describe "countNodes returns zero for meta expressions" $ - forM_ - [ ("meta expression", ExMeta "e", 0) + , ("meta expression", ExMeta "e", 0) , ("metatail expression", ExMetaTail ExGlobal "t", 0) + , ("deeply nested dispatch", ExDispatch (ExDispatch ExGlobal (AtLabel "a")) (AtLabel "b"), 5) + , ("formation with dispatch inside", ExFormation [BiTau AtRho (ExDispatch ExGlobal (AtLabel "x"))], 4) ] ( \(desc, expr, expected) -> - it desc $ countNodes (Program expr) `shouldBe` expected + it desc $ countNodes expr `shouldBe` expected ) - - describe "countNodes counts nested structures" $ - it "counts deeply nested dispatch" $ - countNodes (Program (ExDispatch (ExDispatch ExGlobal (AtLabel "a")) (AtLabel "b"))) `shouldBe` 5 - - describe "countNodes counts complex formation" $ - it "counts formation with dispatch inside" $ - countNodes (Program (ExFormation [BiTau AtRho (ExDispatch ExGlobal (AtLabel "x"))])) `shouldBe` 4 diff --git a/test/CLISpec.hs b/test/CLISpec.hs --- a/test/CLISpec.hs +++ b/test/CLISpec.hs @@ -609,7 +609,7 @@ [ intercalate "\n" [ "[DEBUG]: Applied 'COPY' (28 nodes -> 25 nodes)" - , "{⟦" + , "⟦" , " x ↦ ⟦" , " y ↦ 5" , "---| log is limited by --log-lines=4 option |---" @@ -621,6 +621,12 @@ testCLISucceeded ["rewrite", "--canonize", "--sweet", "--flat"] ["{⟦ x ↦ ⟦ y ↦ ⟦ λ ⤍ F1 ⟧.q, z ↦ Φ.x( a ↦ ⟦ w ↦ ⟦ λ ⤍ F2 ⟧, λ ⤍ F3 ⟧ ) ⟧, λ ⤍ F4 ⟧}"] + + it "rewrites by locator" $ + withStdin "{[[ ex -> [[ x -> [[ y -> 5 ]].y ]], abc -> [[ x -> ? ]](x -> 5) ]]}" $ + testCLISucceeded + ["rewrite", "--sweet", "--flat", "--locator=Q.ex", "--normalize"] + ["{⟦ ex ↦ ⟦ x ↦ 5 ⟧, abc ↦ ⟦ x ↦ ∅ ⟧( x ↦ 5 ) ⟧}"] describe "dataize" $ do it "prints help" $ diff --git a/test/DataizeSpec.hs b/test/DataizeSpec.hs --- a/test/DataizeSpec.hs +++ b/test/DataizeSpec.hs @@ -9,25 +9,26 @@ import Deps (dontSaveStep) import Functions (buildTerm) import Parser (parseExpressionThrows, parseProgramThrows) -import Printer (printProgram) import Rewriter (Rewritten) import Test.Hspec -defaultDataizeContext :: Program -> DataizeContext -defaultDataizeContext prog = DataizeContext prog 25 25 False buildTerm dontSaveStep +defaultDataizeContext :: Expression -> Program -> DataizeContext +defaultDataizeContext loc prog = DataizeContext loc prog 25 25 False buildTerm dontSaveStep test :: (Eq a, Show a) => ((Expression, [Rewritten]) -> DataizeContext -> IO (Maybe a, [Rewritten])) -> [(String, Expression, Expression, Maybe a)] -> Spec test func useCases = - forM_ useCases $ \(desc, input, prog, output) -> + forM_ useCases $ \(desc, input, expr, output) -> it desc $ do - (res, _) <- func (input, []) (defaultDataizeContext (Program prog)) + let prog = Program expr + (res, _) <- func (input, [(prog, Nothing)]) (defaultDataizeContext ExGlobal prog) res `shouldBe` output test' :: (Eq a, Show a) => ((Expression, [Rewritten]) -> DataizeContext -> IO (a, [Rewritten])) -> [(String, Expression, Expression, a)] -> Spec test' func useCases = - forM_ useCases $ \(desc, input, prog, output) -> + forM_ useCases $ \(desc, input, expr, output) -> it desc $ do - (res, _) <- func (input, [(Program prog, Nothing)]) (defaultDataizeContext (Program prog)) + let prog = Program expr + (res, _) <- func (input, [(prog, Nothing)]) (defaultDataizeContext ExGlobal prog) res `shouldBe` output testDataize :: [(String, String, String, Bytes)] -> Spec @@ -36,8 +37,7 @@ it name $ do prog' <- parseProgramThrows prog loc' <- parseExpressionThrows loc - putStrLn (printProgram prog') - (value, _) <- dataize loc' (defaultDataizeContext prog') + (value, _) <- dataize (defaultDataizeContext loc' prog') value `shouldBe` Just res spec :: Spec @@ -104,7 +104,7 @@ testDataize [ - ( "5.plus(5)" + ( "5.plus(6)" , "Q" , unlines [ "Q -> [[" @@ -121,10 +121,10 @@ , " ]]" , " ]]" , " ]]," - , " @ -> 5.plus(5)" + , " @ -> 5.plus(6)" , "]]" ] - , BtMany ["40", "24", "00", "00", "00", "00", "00", "00"] + , BtMany ["40", "26", "00", "00", "00", "00", "00", "00"] ) , ( "Fahrenheit" @@ -197,5 +197,21 @@ , "]]" ] , BtOne "42" + ) + , + ( "Five" + , "Q.x" + , unlines + [ "Q -> [[" + , " org -> [[" + , " eolang -> [[" + , " number(as-bytes) -> [[ @ -> as-bytes ]]," + , " bytes(data) -> [[ @ -> data ]]" + , " ]]" + , " ]]," + , " x -> 5" + , "]]" + ] + , BtMany ["40", "14", "00", "00", "00", "00", "00", "00"] ) ] diff --git a/test/LocatorSpec.hs b/test/LocatorSpec.hs new file mode 100644 --- /dev/null +++ b/test/LocatorSpec.hs @@ -0,0 +1,41 @@ +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module LocatorSpec where + +import Control.Monad (forM_) +import Data.List (intercalate) +import Locator (locatedExpression, withLocatedExpression) +import Parser (parseExpressionThrows, parseProgramThrows) +import Test.Hspec (Spec, describe, it, shouldBe) + +spec :: Spec +spec = do + describe "located expression" $ + forM_ + [ ("{[[ x -> [[ y -> [[ z -> ? ]] ]] ]]}", "Q.x.y", "[[ z -> ? ]]") + , ("{[[ x -> ?, y -> [[ z -> ?, w -> [[ a -> $.x ]] ]], z -> ? ]]}", "Q.y.w.a", "$.x") + , ("{[[ x -> ?, y -> ? ]]}", "Q", "[[ x -> ?, y -> ? ]]") + ] + ( \(prog, locator, res) -> it (intercalate " => " [prog, locator, res]) $ do + prog' <- parseProgramThrows prog + locator' <- parseExpressionThrows locator + res' <- parseExpressionThrows res + located <- locatedExpression locator' prog' + located `shouldBe` res' + ) + + describe "with located expression" $ + forM_ + [ ("{[[ x -> $ ]]}", "Q.x", "[[ y -> ? ]]", "{[[ x -> [[ y -> ? ]] ]]}") + , ("{[[ x -> ?, y -> [[ x -> ?, y -> [[ ]] ]] ]]}", "Q.y.y", "Q.x.y", "{[[ x -> ?, y -> [[ x -> ?, y -> Q.x.y ]] ]]}") + , ("{[[ x -> [[ y -> [[ z -> [[ w -> ? ]] ]] ]] ]]}", "Q.x.y", "$.a(x -> [[]])", "{[[ x -> [[ y -> $.a(x -> [[]]) ]] ]]}") + ] + ( \(prog, locator, expr, res) -> it (intercalate " => " [prog, locator, expr, res]) $ do + prog' <- parseProgramThrows prog + locator' <- parseExpressionThrows locator + expr' <- parseExpressionThrows expr + res' <- parseProgramThrows res + loc <- withLocatedExpression locator' expr' prog' + loc `shouldBe` res' + ) diff --git a/test/MatcherSpec.hs b/test/MatcherSpec.hs --- a/test/MatcherSpec.hs +++ b/test/MatcherSpec.hs @@ -407,7 +407,7 @@ describe "matchExpression: expression => pattern => substitution" $ test - matchExpression + matchExpression' [ ("$ => $ => [()]", ExThis, ExThis, defaultScope, [[]]) , ("Q => Q => [()]", ExGlobal, ExGlobal, defaultScope, [[]]) , diff --git a/test/RewriterSpec.hs b/test/RewriterSpec.hs --- a/test/RewriterSpec.hs +++ b/test/RewriterSpec.hs @@ -8,6 +8,7 @@ module RewriterSpec where +import AST (Expression (ExGlobal)) import Control.Monad (forM_, unless) import Data.Aeson import Data.Char (isSpace) @@ -19,7 +20,7 @@ import Must (Must (..)) import Parser (parseProgramThrows) import Printer (printProgram) -import Rewriter (RewriteContext (RewriteContext), rewrite') +import Rewriter (RewriteContext (RewriteContext), rewrite) import System.FilePath (makeRelative, replaceExtension, ()) import Test.Hspec (Spec, describe, expectationFailure, it, pending, runIO) import Yaml (normalizationRules) @@ -99,10 +100,11 @@ then pure normalizationRules else pure [] rewrittens <- - rewrite' + rewrite prog rules' ( RewriteContext + ExGlobal repeat' repeat' False