diff --git a/phino.cabal b/phino.cabal --- a/phino.cabal +++ b/phino.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: phino -version: 0.0.0.14 +version: 0.0.0.15 license: MIT synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions description: Please see the README on GitHub at @@ -33,6 +33,7 @@ Rewriter, Yaml, Condition, + Dataize, Misc, Logger, Pretty, @@ -94,6 +95,7 @@ MiscSpec, XMIRSpec, HLintSpec, + DataizeSpec, Paths_phino autogen-modules: Paths_phino diff --git a/src/Builder.hs b/src/Builder.hs --- a/src/Builder.hs +++ b/src/Builder.hs @@ -10,6 +10,7 @@ buildExpressionFromFunction, buildAttribute, buildBinding, + contextualize ) where @@ -70,6 +71,11 @@ TaApplication taus -> buildExpressionWithTails (ExApplication expr taus) rest subst TaDispatch attr -> buildExpressionWithTails (ExDispatch expr attr) rest subst +-- Build meta expression with given substitution +-- It returns tuple (X, Y) +-- where X is built expression and Y is context of X +-- If meta expression is built from MvExpression, is has +-- context from original Program. It have default context otherwise buildExpression :: Expression -> Subst -> Maybe (Expression, Expression) buildExpression (ExDispatch expr attr) subst = do (dispatched, scope) <- buildExpression expr subst @@ -82,7 +88,7 @@ buildExpression (ExApplication _ _) _ = Nothing buildExpression (ExFormation bds) subst = do bds' <- buildBindings bds subst - Just (ExFormation bds', ExFormation []) + Just (ExFormation bds', defaultScope) buildExpression (ExMeta meta) (Subst mp) = case Map.lookup meta mp of Just (MvExpression expr scope) -> Just (expr, scope) _ -> Nothing @@ -92,7 +98,7 @@ case Map.lookup meta mp of Just (MvTail tails) -> Just (buildExpressionWithTails expression tails subst, scope) _ -> Nothing -buildExpression expr _ = Just (expr, ExFormation []) +buildExpression expr _ = Just (expr, defaultScope) buildExpressionFromFunction :: String -> [Expression] -> Subst -> Program -> Maybe Expression buildExpressionFromFunction "contextualize" [expr, context] subst prog = do diff --git a/src/CLI.hs b/src/CLI.hs --- a/src/CLI.hs +++ b/src/CLI.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -14,6 +16,7 @@ import Data.Char (toLower, toUpper) import Data.List (intercalate) import Data.Version (showVersion) +import Dataize (dataize) import Logger import Misc (ensuredFile) import qualified Misc @@ -21,29 +24,28 @@ import Parser (parseProgramThrows) import Paths_phino (version) import Pretty (PrintMode (SALTY, SWEET), prettyProgram') -import Rewriter (rewrite) +import Rewriter (rewrite') import System.Exit (ExitCode (..), exitFailure) import System.IO (getContents') import Text.Printf (printf) -import XMIR (printXMIR, programToXMIR, parseXMIRThrows, xmirToPhi) +import XMIR (parseXMIRThrows, printXMIR, programToXMIR, xmirToPhi) import Yaml (normalizationRules) import qualified Yaml as Y data CmdException = InvalidRewriteArguments {message :: String} | CouldNotReadFromStdin {message :: String} + | CouldNotDataize deriving (Exception) instance Show CmdException where show InvalidRewriteArguments {..} = printf "Invalid set of arguments for 'rewrite' command: %s" message show CouldNotReadFromStdin {..} = printf "Could not read input from stdin\nReason: %s" message - -data App = App - { logLevel :: LogLevel, - cmd :: Command - } + show CouldNotDataize = "Could not dataize given program" -newtype Command = CmdRewrite OptsRewrite +data Command + = CmdRewrite OptsRewrite + | CmdDataize OptsDataize data IOFormat = XMIR | PHI deriving (Eq) @@ -52,8 +54,14 @@ show XMIR = "xmir" show PHI = "phi" +data OptsDataize = OptsDataize + { logLevel :: LogLevel, + inputFormat :: IOFormat, + inputFile :: Maybe FilePath + } + data OptsRewrite = OptsRewrite - { inputFile :: Maybe FilePath, + { logLevel :: LogLevel, rules :: [FilePath], inputFormat :: IOFormat, outputFormat :: IOFormat, @@ -62,62 +70,81 @@ nothing :: Bool, shuffle :: Bool, omitListing :: Bool, - maxDepth :: Integer + maxDepth :: Integer, + inputFile :: Maybe FilePath } parseIOFormat :: String -> ReadM IOFormat parseIOFormat type' = eitherReader $ \format -> case map toLower format of "xmir" -> Right XMIR "phi" -> Right PHI - _ -> Left (printf "invalid %s format: expected 'xmir' or 'phi'" type') + _ -> Left (printf "invalid %s format: expected '%s' or '%s'" type' (show PHI) (show XMIR)) +argInputFile :: Parser (Maybe FilePath) +argInputFile = optional (argument str (metavar "FILE" <> help "Path to input file")) + +optInputFormat :: Parser IOFormat +optInputFormat = option (parseIOFormat "input") (long "input" <> metavar "FORMAT" <> help "Program input format (phi, xmir)" <> value PHI <> showDefault) + +optLogLevel :: Parser LogLevel +optLogLevel = + option + parseLogLevel + ( long "log-level" + <> metavar "LEVEL" + <> help ("Log level (" <> intercalate ", " (map show [DEBUG, INFO, WARNING, ERROR, NONE]) <> ")") + <> value INFO + <> showDefault + ) + where + parseLogLevel :: ReadM LogLevel + parseLogLevel = eitherReader $ \lvl -> case map toUpper lvl of + "DEBUG" -> Right DEBUG + "INFO" -> Right INFO + "WARNING" -> Right WARNING + "WARN" -> Right WARNING + "ERROR" -> Right ERROR + "ERR" -> Right ERROR + "NONE" -> Right NONE + _ -> Left $ "unknown log-level: " <> lvl + +dataizeParser :: Parser Command +dataizeParser = + CmdDataize + <$> ( OptsDataize + <$> optLogLevel + <*> optInputFormat + <*> argInputFile + ) + rewriteParser :: Parser Command rewriteParser = CmdRewrite <$> ( OptsRewrite - <$> optional (argument str (metavar "FILE" <> help "Path to input file")) + <$> optLogLevel <*> many (strOption (long "rule" <> metavar "FILE" <> help "Path to custom rule")) - <*> option (parseIOFormat "input") (long "input" <> metavar "FORMAT" <> help "Program input format" <> value PHI <> showDefault) - <*> option (parseIOFormat "output") (long "output" <> metavar "FORMAT" <> help "Program output format" <> value PHI <> showDefault) + <*> optInputFormat + <*> option (parseIOFormat "output") (long "output" <> metavar "FORMAT" <> help "Program output format (phi, xmir)" <> value PHI <> showDefault) <*> flag SALTY SWEET (long "sweet" <> help "Print 𝜑-program using syntax sugar") <*> switch (long "normalize" <> help "Use built-in normalization rules") <*> switch (long "nothing" <> help "Just desugar provided 𝜑-program") <*> switch (long "shuffle" <> help "Shuffle rules before applying") <*> switch (long "omit-listing" <> help "Omit full program listing in XMIR output") <*> option auto (long "max-depth" <> metavar "DEPTH" <> help "Max amount of rewritng cycles" <> value 25 <> showDefault) + <*> argInputFile ) commandParser :: Parser Command -commandParser = hsubparser (command "rewrite" (info rewriteParser (progDesc "Rewrite the expression"))) - -parseLogLevel :: ReadM LogLevel -parseLogLevel = eitherReader $ \lvl -> case map toUpper lvl of - "DEBUG" -> Right DEBUG - "INFO" -> Right INFO - "WARNING" -> Right WARNING - "WARN" -> Right WARNING - "ERROR" -> Right ERROR - "ERR" -> Right ERROR - "NONE" -> Right NONE - _ -> Left $ "unknown log-level: " <> lvl - -appParser :: Parser App -appParser = - App - <$> option - parseLogLevel - ( long "log-level" - <> metavar "LEVEL" - <> help ("Log level (" <> intercalate ", " (map show [DEBUG, INFO, WARNING, ERROR, NONE]) <> ")") - <> value INFO - <> showDefault - ) - <*> commandParser +commandParser = + hsubparser + ( command "rewrite" (info (rewriteParser <**> helper) (progDesc "Rewrite the program")) + <> command "dataize" (info (dataizeParser <**> helper) (progDesc "Dataize the program")) + ) -parserInfo :: ParserInfo App +parserInfo :: ParserInfo Command parserInfo = info - (appParser <**> helper <**> simpleVersioner (showVersion version)) + (commandParser <**> helper <**> simpleVersioner (showVersion version)) (fullDesc <> header "Phino - CLI Manipulator of 𝜑-Calculus Expressions") handler :: SomeException -> IO () @@ -127,31 +154,29 @@ logError (displayException e) exitFailure +setLogLevel' :: Command -> IO () +setLogLevel' cmd = + let level = case cmd of + CmdRewrite OptsRewrite {logLevel} -> logLevel + CmdDataize OptsDataize {logLevel} -> logLevel + in setLogLevel level + runCLI :: [String] -> IO () runCLI args = handle handler $ do - App {..} <- handleParseResult (execParserPure defaultPrefs parserInfo args) - setLogLevel logLevel + cmd <- handleParseResult (execParserPure defaultPrefs parserInfo args) + setLogLevel' cmd case cmd of CmdRewrite OptsRewrite {..} -> do when (maxDepth <= 0) $ throwIO (InvalidRewriteArguments "--max-depth must be positive") logDebug (printf "Amount of rewriting cycles: %d" maxDepth) - input <- readInput + input <- readInput inputFile rules' <- getRules program <- parseProgram input inputFormat - rewritten <- rewrite' program rules' 1 + rewritten <- rewrite' program program rules' maxDepth logDebug (printf "Printing rewritten 𝜑-program as %s" (show outputFormat)) out <- printProgram rewritten outputFormat printMode putStrLn out where - readInput :: IO String - readInput = case inputFile of - Just pth -> do - logDebug (printf "Reading from file: '%s'" pth) - readFile =<< ensuredFile pth - Nothing -> do - logDebug "Reading from stdin" - getContents' `catch` (\(e :: SomeException) -> throwIO (CouldNotReadFromStdin (show e))) - getRules :: IO [Y.Rule] getRules = do ordered <- @@ -176,30 +201,27 @@ logDebug "The --shuffle option is provided, rules are used in random order" Misc.shuffle ordered else pure ordered - - parseProgram :: String -> IOFormat -> IO Program - parseProgram phi PHI = parseProgramThrows phi - parseProgram xmir XMIR = do - doc <- parseXMIRThrows xmir - xmirToPhi doc - - rewrite' :: Program -> [Y.Rule] -> Integer -> IO Program - rewrite' prog rules count = do - logDebug (printf "Starting rewriting cycle %d out of %d" count maxDepth) - if count == maxDepth - then do - logDebug (printf "Max amount of rewriting cycles is reached, rewriting is stopped") - pure prog - else do - rewritten <- rewrite prog rules - if rewritten == prog - then do - logDebug "Rewriting is stopped since it does not affect program anymore" - pure rewritten - else rewrite' rewritten rules (count + 1) - printProgram :: Program -> IOFormat -> PrintMode -> IO String printProgram prog PHI mode = pure (prettyProgram' prog mode) printProgram prog XMIR mode = do xmir <- programToXMIR prog mode omitListing pure (printXMIR xmir) + CmdDataize OptsDataize {..} -> do + input <- readInput inputFile + prog <- parseProgram input inputFormat + dataized <- dataize prog + maybe (throwIO CouldNotDataize) putStrLn dataized + where + readInput :: Maybe FilePath -> IO String + readInput inputFile' = case inputFile' of + Just pth -> do + logDebug (printf "Reading from file: '%s'" pth) + readFile =<< ensuredFile pth + Nothing -> do + logDebug "Reading from stdin" + getContents' `catch` (\(e :: SomeException) -> throwIO (CouldNotReadFromStdin (show e))) + parseProgram :: String -> IOFormat -> IO Program + parseProgram phi PHI = parseProgramThrows phi + parseProgram xmir XMIR = do + doc <- parseXMIRThrows xmir + xmirToPhi doc diff --git a/src/Condition.hs b/src/Condition.hs --- a/src/Condition.hs +++ b/src/Condition.hs @@ -49,6 +49,41 @@ numToInt (Y.Literal num) subst = Just num numToInt _ _ = Nothing +-- Returns True if given expression matches with any of given normalization rules +matchesAnyNormalizationRule :: Expression -> Bool +matchesAnyNormalizationRule expr = matchesAnyNormalizationRule' expr normalizationRules + where + matchesAnyNormalizationRule' :: Expression -> [Y.Rule] -> Bool + matchesAnyNormalizationRule' _ [] = False + matchesAnyNormalizationRule' expr (rule : rules) = + case matchProgramWithCondition (Y.pattern rule) (Y.when rule) (Program expr) of + Just matched -> not (null matched) || matchesAnyNormalizationRule' expr rules + Nothing -> matchesAnyNormalizationRule' expr rules + +-- Returns True if given expression is in the normal form +isNF :: Expression -> Bool +isNF ExThis = True +isNF ExGlobal = True +isNF ExTermination = True +isNF (ExDispatch ExThis _) = True +isNF (ExDispatch ExGlobal _) = True +isNF (ExDispatch ExTermination _) = False -- dd rule +isNF (ExApplication ExTermination _) = False -- dc rule +isNF (ExFormation []) = True +isNF (ExFormation bds) = normalBindings bds || not (matchesAnyNormalizationRule (ExFormation bds)) + where + -- Returns True if all given bindings are 100% in normal form + normalBindings :: [Binding] -> Bool + normalBindings [] = True + normalBindings (bd : bds) = + let next = normalBindings bds + in case bd of + BiDelta _ -> next + BiVoid _ -> next + BiLambda _ -> next + _ -> False +isNF expr = not (matchesAnyNormalizationRule expr) + meetCondition' :: Y.Condition -> Subst -> [Subst] meetCondition' (Y.Or []) subst = [subst] meetCondition' (Y.Or (cond : rest)) subst = @@ -80,38 +115,9 @@ meetCondition' (Y.Eq (Y.CmpAttr left) (Y.CmpAttr right)) subst = [subst | compareAttrs left right subst] meetCondition' (Y.Eq _ _) _ = [] meetCondition' (Y.NF (ExMeta meta)) (Subst mp) = case M.lookup meta mp of - Just (MvExpression expr _) -> - let isNf = not (matchesAnyNormalizationRule expr normalizationRules) - in case expr of - ExThis -> [Subst mp] - ExGlobal -> [Subst mp] - ExTermination -> [Subst mp] - ExDispatch ExThis _ -> [Subst mp] - ExDispatch ExGlobal _ -> [Subst mp] - ExDispatch ExTermination _ -> [] -- dd rule - ExApplication ExTermination _ -> [] -- dc rule - ExFormation [] -> [Subst mp] - ExFormation bds -> [Subst mp | normalBindings bds || isNf] - _ -> [Subst mp | isNf] + Just (MvExpression expr _) -> [Subst mp | isNF expr] _ -> [] - where - -- Returns True if given expression matches with any of given normalization rules - matchesAnyNormalizationRule :: Expression -> [Y.Rule] -> Bool - matchesAnyNormalizationRule _ [] = False - matchesAnyNormalizationRule expr (rule : rules) = - case matchProgramWithCondition (Y.pattern rule) (Y.when rule) (Program expr) of - Just matched -> not (null matched) || matchesAnyNormalizationRule expr rules - Nothing -> matchesAnyNormalizationRule expr rules - normalBindings :: [Binding] -> Bool - normalBindings [] = True - normalBindings (bd : bds) = - let next = normalBindings bds - in case bd of - BiDelta _ -> next - BiVoid _ -> next - BiLambda _ -> next - _ -> False -meetCondition' (Y.NF _) _ = [] +meetCondition' (Y.NF expr) (Subst mp) = [Subst mp | isNF expr] meetCondition' (Y.XI (ExMeta meta)) (Subst mp) = case M.lookup meta mp of Just (MvExpression expr _) -> meetCondition' (Y.XI expr) (Subst mp) _ -> [] diff --git a/src/Dataize.hs b/src/Dataize.hs new file mode 100644 --- /dev/null +++ b/src/Dataize.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE LambdaCase #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module Dataize (morph, dataize, dataize') where + +import Ast +import Builder (buildExpressionFromFunction, contextualize) +import Condition (isNF) +import Control.Exception (throwIO) +import Data.List (partition) +import Misc +import Rewriter (rewrite') +import Text.Printf (printf) +import Yaml (normalizationRules) + +maybeBinding :: (Binding -> Bool) -> [Binding] -> (Maybe Binding, [Binding]) +maybeBinding _ [] = (Nothing, []) +maybeBinding func bds = + let (found, rest) = partition func bds + in case found of + [bd] -> (Just bd, rest) + _ -> (Nothing, bds) + +maybeLambda :: [Binding] -> (Maybe Binding, [Binding]) +maybeLambda = maybeBinding (\case BiLambda _ -> True; _ -> False) + +maybeDelta :: [Binding] -> (Maybe Binding, [Binding]) +maybeDelta = maybeBinding (\case BiDelta _ -> True; _ -> False) + +maybePhi :: [Binding] -> (Maybe Binding, [Binding]) +maybePhi = maybeBinding (\case (BiTau AtPhi _) -> True; _ -> False) + +formation :: [Binding] -> Program -> IO (Maybe Expression) +formation bds prog = do + let (lambda, bds') = maybeLambda bds + case lambda of + Just (BiLambda func) -> do + obj' <- atom func (ExFormation bds') prog + case obj' of + Just obj -> pure (Just obj) + _ -> pure Nothing + _ -> pure Nothing + +phiDispatch :: String -> Expression -> Maybe Expression +phiDispatch attr expr = case expr of + ExFormation bds -> boundExpr bds + _ -> Nothing + where + boundExpr :: [Binding] -> Maybe Expression + boundExpr [] = Nothing + boundExpr (bd : bds) = case bd of + BiTau (AtLabel attr') expr' -> if attr' == attr then Just expr' else boundExpr bds + _ -> boundExpr bds + +withTail :: Expression -> Program -> IO (Maybe Expression) +withTail (ExApplication (ExFormation _) _) _ = pure Nothing +withTail (ExApplication (ExDispatch ExGlobal _) _) _ = pure Nothing +withTail (ExApplication expr tau) prog = do + exp' <- withTail expr prog + case exp' of + Just exp -> pure (Just (ExApplication exp tau)) + _ -> pure Nothing +withTail (ExDispatch (ExFormation bds) attr) prog = do + obj' <- formation bds prog + case obj' of + Just obj -> pure (Just (ExDispatch obj attr)) + _ -> pure Nothing +withTail (ExFormation bds) prog = formation bds prog +withTail (ExDispatch (ExDispatch ExGlobal (AtLabel label)) attr) (Program expr) = case phiDispatch label expr of + Just obj -> pure (Just (ExDispatch obj attr)) + _ -> pure Nothing +withTail (ExDispatch ExGlobal (AtLabel label)) (Program expr) = pure (phiDispatch label expr) +withTail (ExDispatch expr attr) prog = do + exp' <- withTail expr prog + case exp' of + Just exp -> pure (Just (ExDispatch exp attr)) + _ -> pure Nothing +withTail _ _ = pure Nothing + +-- The Morphing function M: -> maps objects to +-- primitives, possibly modifying the state of evaluation. +-- Terminology: +-- P(e) - is e Primitive, which is either formation without λ binding or termination ⊥ +-- N(e) - normalize e +-- NF(e) - is e in normal form (can't be normalized anymore) +-- +-- PRIM: M(e) -> e if P(e) +-- NMZ: M(e1) -> M(e2) if e2 := N(e1) and e1 != e2 +-- LAMBDA: M([B1, λ -> F, B2] * t) -> M(e2 * t) if e3 := [B1,B2] and e2 := F(e3) +-- PHI: M(Q.tau * t) -> M(e * t) if Q -> [B1, tau -> e, B2], t is tail started with dispatch +-- M(e) -> nothing otherwise +-- @todo #169:30min Get rid of hard coded amount of normalization cycles. Right now the value 25 is hard coded. +-- We need to pass it though function argument or global environment. +morph :: Expression -> Program -> IO (Maybe Expression) +morph ExTermination _ = pure (Just ExTermination) -- PRIM +morph (ExFormation bds) prog = do + resolved <- withTail (ExFormation bds) prog + case resolved of + Just obj -> morph obj prog -- LAMBDA or PHI + _ -> pure (Just (ExFormation bds)) -- PRIM +morph expr prog = do + resolved <- withTail expr prog + case resolved of + Just obj -> morph obj prog + _ -> + if isNF expr + then pure Nothing + else do + (Program expr') <- rewrite' (Program expr) prog normalizationRules 25 -- NMZ + morph expr' prog + +-- The goal of 'dataize' function is retrieve bytes from given expression. +-- +-- DELTA: D(e) -> data if e = [B1, Δ -> data, B2] +-- BOX: D([B1, 𝜑 -> e, B2]) -> D(С(e)) if [B1,B2] has no delta/lambda, where С(e) - contextualization +-- NORM: D(e1) -> D(e2) if e2 := M(e1) and e1 is not primitive +-- nothing otherwise +dataize :: Program -> IO (Maybe String) +dataize (Program expr) = dataize' expr (Program expr) + +dataize' :: Expression -> Program -> IO (Maybe String) +dataize' ExTermination _ = pure Nothing +dataize' (ExFormation bds) prog = case maybeDelta bds of + (Just (BiDelta bytes), _) -> pure (Just bytes) + (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") + (_, _) -> + let expr' = contextualize expr (ExFormation bds) prog + in dataize' expr' prog + (Nothing, _) -> case maybeLambda bds of + (Just (BiLambda _), _) -> do + morphed' <- morph (ExFormation bds) prog + case morphed' of + Just morphed -> dataize' morphed prog + _ -> pure Nothing + (Nothing, _) -> pure Nothing +dataize' expr prog = do + morphed' <- morph expr prog + case morphed' of + Just morphed -> dataize' morphed prog + _ -> pure Nothing + +atom :: String -> Expression -> Program -> IO (Maybe Expression) +atom "L_org_eolang_number_plus" self prog = do + left <- dataize' (ExDispatch self (AtLabel "x")) prog + right <- dataize' (ExDispatch self AtRho) prog + case (left, right) of + (Just left', Just right') -> do + let first = either toDouble id (hexToNum left') + second = either toDouble id (hexToNum right') + sum = first + second + pure (Just (DataObject "number" (numToHex sum))) + _ -> pure Nothing + where + toDouble :: Integer -> Double + toDouble = fromIntegral +atom func _ _ = throwIO (userError (printf "Atom '%s' does not exist" func)) diff --git a/src/Logger.hs b/src/Logger.hs --- a/src/Logger.hs +++ b/src/Logger.hs @@ -27,7 +27,7 @@ logger :: IORef Logger {-# NOINLINE logger #-} -logger = unsafePerformIO (newIORef (Logger INFO)) +logger = unsafePerformIO (newIORef (Logger DEBUG)) setLogLevel :: LogLevel -> IO () setLogLevel lvl = writeIORef logger (Logger lvl) diff --git a/src/Matcher.hs b/src/Matcher.hs --- a/src/Matcher.hs +++ b/src/Matcher.hs @@ -41,6 +41,9 @@ substSingle :: String -> MetaValue -> Subst substSingle key value = Subst (Map.singleton key value) +defaultScope :: Expression +defaultScope = ExFormation [BiVoid AtRho] + -- Combine two substitutions into a single one -- Fails if values by the same keys are not equal combine :: Subst -> Subst -> Maybe Subst @@ -141,4 +144,4 @@ in matched ++ deep matchProgram :: Expression -> Program -> [Subst] -matchProgram ptn (Program exp) = matchExpressionDeep ptn exp (ExFormation [BiVoid AtRho]) +matchProgram ptn (Program exp) = matchExpressionDeep ptn exp defaultScope diff --git a/src/Misc.hs b/src/Misc.hs --- a/src/Misc.hs +++ b/src/Misc.hs @@ -215,8 +215,8 @@ -- "" -- >>> hexToStr "68-22" -- "h\\\"" --- >>> hexToStr "01-01" --- "\\x01\\x01" +-- >>> hexToStr "01-02" +-- "\\x01\\x02" hexToStr :: String -> String hexToStr "--" = "" hexToStr [] = "" @@ -241,7 +241,7 @@ -- The function is generated by ChatGPT and claimed as -- fastest approach comparing to usage IOArray. -- >>> shuffle [1..20] --- [20,5,6,1,12,10,7,8,9,11,14,15,13,2,4,16,3,19,18,17] +-- [12,15,5,14,1,7,17,10,9,16,13,11,6,4,18,2,19,20,3,8] shuffle :: [a] -> IO [a] shuffle xs = do gen <- newIOGenM =<< newStdGen diff --git a/src/Rewriter.hs b/src/Rewriter.hs --- a/src/Rewriter.hs +++ b/src/Rewriter.hs @@ -6,7 +6,7 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module Rewriter (rewrite) where +module Rewriter (rewrite, rewrite') where import Ast import Builder @@ -15,10 +15,10 @@ import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe, isJust) import Logger (logDebug) -import Matcher (MetaValue (MvAttribute, MvBindings, MvExpression), Subst (Subst), combine, combineMany, matchProgram, substEmpty, substSingle) +import Matcher (MetaValue (MvAttribute, MvBindings, MvExpression), Subst (Subst), combine, combineMany, defaultScope, matchProgram, substEmpty, substSingle) import Misc (ensuredFile) import Parser (parseProgram, parseProgramThrows) -import Pretty (prettyExpression, prettyProgram, prettySubsts) +import Pretty (PrintMode (SWEET), prettyExpression, prettyProgram, prettyProgram', prettySubsts) import Replacer (replaceProgram) import Text.Printf import qualified Yaml as Y @@ -66,7 +66,7 @@ let func = Y.function extra args = Y.args extra expr <- buildExpressionFromFunction func args subst' prog - combine (substSingle name (MvExpression expr (ExFormation []))) subst' + combine (substSingle name (MvExpression expr defaultScope)) subst' _ -> Just subst' ) (Just subst) @@ -74,19 +74,45 @@ | subst <- substs ] -rewrite :: Program -> [Y.Rule] -> IO Program -rewrite program [] = pure program -rewrite program (rule : rest) = do - logDebug (printf "Trying to apply rule: %s" (fromMaybe "unknown" (Y.name rule))) +-- @todo #169:30min Make original program global. There are some many places where we +-- need access to original program like here, in Rewriter. Also it's needed in Builder and Dataize modules. +-- Right now we pass this original program as argument. Maybe it would be better to move it to some global state +-- since it's not changed during whole program processing. +rewrite :: Program -> Program -> [Y.Rule] -> IO Program +rewrite program _ [] = pure program +rewrite program program' (rule : rest) = do let ptn = Y.pattern rule res = Y.result rule condition = Y.when rule prog <- case C.matchProgramWithCondition ptn condition program of - Nothing -> do - logDebug "Rule didn't match" - pure program + Nothing -> pure program Just matched -> do - let substs = extraSubstitutions program (Y.where_ rule) matched - logDebug (printf "Rule has been matched, substitutions are:\n%s" (prettySubsts substs)) - buildAndReplace program ptn res substs - rewrite prog rest + let substs = extraSubstitutions program' (Y.where_ rule) matched + prog' <- buildAndReplace program ptn res substs + logDebug (printf "%s\n%s" (fromMaybe "unknown" (Y.name rule)) (prettyProgram' prog' SWEET)) + pure prog' + rewrite prog program' rest + +-- @todo #169:30min Stop counting amount of rewriting cycles. Right now in order not to +-- get an infinite recursion during rewriting we just count have many times we apply +-- rewriting rules. If we reach given amount - we just stop. It's not idiomatic and may +-- not work on big programs. We need to introduce some mechanism which would memorize +-- all rewritten program on each step and if on some step we get the program that have already +-- been memorized - we fail because we got into infinite recursion. +rewrite' :: Program -> Program -> [Y.Rule] -> Integer -> IO Program +rewrite' prog prog' rules maxDepth = _rewrite prog 0 + where + _rewrite :: Program -> Integer -> IO Program + _rewrite prog count = do + logDebug (printf "Starting rewriting cycle %d out of %d" count maxDepth) + if count == maxDepth + then do + logDebug (printf "Max amount of rewriting cycles is reached, rewriting is stopped") + pure prog + else do + rewritten <- rewrite prog prog' rules + if rewritten == prog + then do + logDebug "Rewriting is stopped since it does not affect program anymore" + pure rewritten + else _rewrite rewritten (count + 1) diff --git a/src/XMIR.hs b/src/XMIR.hs --- a/src/XMIR.hs +++ b/src/XMIR.hs @@ -270,10 +270,17 @@ printRawText (NodeContent t) = TB.fromText t printRawText _ = mempty +-- >>> printNode 0 (NodeComment (T.pack "--hello--")) +-- "\n" printNode :: Int -> Node -> TB.Builder printNode _ (NodeContent t) = TB.fromText t -- print text exactly as-is printNode i (NodeElement e) = printElement i e -- pretty-print elements -printNode i (NodeComment t) = indent i <> TB.fromString "" <> newline +printNode i (NodeComment t) = + indent i + <> TB.fromString "" + <> newline printNode _ _ = mempty printXMIR :: Document -> String diff --git a/test/BuilderSpec.hs b/test/BuilderSpec.hs --- a/test/BuilderSpec.hs +++ b/test/BuilderSpec.hs @@ -23,12 +23,12 @@ [ ( "Q.!a => (!a >> x) => Q.x", ExDispatch ExGlobal (AtMeta "a"), [("a", MvAttribute (AtLabel "x"))], - Just (ExDispatch ExGlobal (AtLabel "x"), ExFormation []) + Just (ExDispatch ExGlobal (AtLabel "x"), defaultScope) ), ( "Q.c(!a -> !e) => (!a >> x, !e >> $.y.z) => Q.c(x -> $.y.z)", ExApplication (ExDispatch ExGlobal (AtLabel "c")) (BiTau (AtMeta "a") (ExMeta "e")), - [("a", MvAttribute (AtLabel "x")), ("e", MvExpression (ExDispatch (ExDispatch ExThis (AtLabel "y")) (AtLabel "z")) (ExFormation []))], - Just (ExApplication (ExDispatch ExGlobal (AtLabel "c")) (BiTau (AtLabel "x") (ExDispatch (ExDispatch ExThis (AtLabel "y")) (AtLabel "z"))), ExFormation []) + [("a", MvAttribute (AtLabel "x")), ("e", MvExpression (ExDispatch (ExDispatch ExThis (AtLabel "y")) (AtLabel "z")) defaultScope)], + Just (ExApplication (ExDispatch ExGlobal (AtLabel "c")) (BiTau (AtLabel "x") (ExDispatch (ExDispatch ExThis (AtLabel "y")) (AtLabel "z"))), defaultScope) ), ( "[[!a -> $.x, !B]] => (!a >> y, !B >> [[b -> ?, L> Func]]) => [[y -> $.x, b -> ?, L> Func]]", ExFormation [BiTau (AtMeta "a") (ExDispatch ExThis (AtLabel "x")), BiMeta "B"], @@ -39,13 +39,13 @@ BiVoid (AtLabel "b"), BiLambda "Func" ], - ExFormation [] + defaultScope ) ), ( "Q * !t => (!t >> [.a, .b, (~1 -> $.x)]) => Q.a.b(~1 -> $.x)", ExMetaTail ExGlobal "t", [("t", MvTail [TaDispatch (AtLabel "a"), TaDispatch (AtLabel "b"), TaApplication (BiTau (AtAlpha 1) (ExDispatch ExThis (AtLabel "x")))])], - Just (ExApplication (ExDispatch (ExDispatch ExGlobal (AtLabel "a")) (AtLabel "b")) (BiTau (AtAlpha 1) (ExDispatch ExThis (AtLabel "x"))), ExFormation []) + Just (ExApplication (ExDispatch (ExDispatch ExGlobal (AtLabel "a")) (AtLabel "b")) (BiTau (AtAlpha 1) (ExDispatch ExThis (AtLabel "x"))), defaultScope) ), ( "Q.!a => () => X", ExDispatch ExGlobal (AtMeta "a"), @@ -54,13 +54,13 @@ ), ( "!e0(!a1 -> !e1, !a2 => !e2) => (!e0 >> [[]], !a1 >> x, !e1 >> Q, !a2 >> y, !e2 >> $) => [[]](x -> Q, y -> $)", ExApplication (ExApplication (ExMeta "e0") (BiTau (AtMeta "a1") (ExMeta "e1"))) (BiTau (AtMeta "a2") (ExMeta "e2")), - [ ("e0", MvExpression (ExFormation []) (ExFormation [])), + [ ("e0", MvExpression (ExFormation []) defaultScope), ("a1", MvAttribute (AtLabel "x")), - ("e1", MvExpression ExGlobal (ExFormation [])), + ("e1", MvExpression ExGlobal defaultScope), ("a2", MvAttribute (AtLabel "y")), - ("e2", MvExpression ExThis (ExFormation [])) + ("e2", MvExpression ExThis defaultScope) ], - Just (ExApplication (ExApplication (ExFormation []) (BiTau (AtLabel "x") ExGlobal)) (BiTau (AtLabel "y") ExThis), ExFormation []) + Just (ExApplication (ExApplication (ExFormation []) (BiTau (AtLabel "x") ExGlobal)) (BiTau (AtLabel "y") ExThis), defaultScope) ), ( "⟦!a ↦ ∅, !B⟧.!a => (!a >> t, !B >> ⟦ x ↦ ξ.t ⟧ ) => ⟦ t ↦ ∅, x ↦ ξ.t ⟧.t", ExDispatch (ExFormation [BiVoid (AtMeta "a"), BiMeta "B"]) (AtMeta "a"), @@ -75,7 +75,7 @@ ] ) (AtLabel "t"), - ExFormation [] + defaultScope ) ) ] @@ -84,12 +84,12 @@ it "!e => [(!e >> Q.x), (!e >> $.y)] => [Q.x, $.y]" $ buildExpressions (ExMeta "e") - [ substSingle "e" (MvExpression (ExDispatch ExGlobal (AtLabel "x")) (ExFormation [])), - substSingle "e" (MvExpression (ExDispatch ExThis (AtLabel "y")) (ExFormation [])) + [ substSingle "e" (MvExpression (ExDispatch ExGlobal (AtLabel "x")) defaultScope), + substSingle "e" (MvExpression (ExDispatch ExThis (AtLabel "y")) defaultScope) ] - `shouldBe` Just [(ExDispatch ExGlobal (AtLabel "x"), ExFormation []), (ExDispatch ExThis (AtLabel "y"), ExFormation [])] + `shouldBe` Just [(ExDispatch ExGlobal (AtLabel "x"), defaultScope), (ExDispatch ExThis (AtLabel "y"), defaultScope)] it "!e => [(!e1 >> Q.x)] => X" $ buildExpressions (ExMeta "e") - [substSingle "e1" (MvExpression (ExDispatch ExGlobal (AtLabel "x")) (ExFormation []))] + [substSingle "e1" (MvExpression (ExDispatch ExGlobal (AtLabel "x")) defaultScope)] `shouldBe` Nothing diff --git a/test/CLISpec.hs b/test/CLISpec.hs --- a/test/CLISpec.hs +++ b/test/CLISpec.hs @@ -75,7 +75,7 @@ ) testCLIFailed :: [String] -> String -> Expectation -testCLIFailed args output = withStdin "" $ do +testCLIFailed args output = do (out, result) <- withStdout (try (runCLI args) :: IO (Either ExitCode ())) out `shouldContain` output result `shouldBe` Left (ExitFailure 1) @@ -125,14 +125,12 @@ ] it "fails with negative --max-depth" $ - testCLIFailed - ["rewrite", "--max-depth=-1"] - "--max-depth must be positive" + withStdin "" $ + testCLIFailed ["rewrite", "--max-depth=-1"] "--max-depth must be positive" it "fails with no rewriting options provided" $ - testCLIFailed - ["rewrite"] - "no --rule, no --normalize, no --nothing are provided" + withStdin "" $ + testCLIFailed ["rewrite"] "no --rule, no --normalize, no --nothing are provided" it "normalizes from stdin" $ withStdin "Φ ↦ ⟦ a ↦ ⟦ b ↦ ∅ ⟧ (b ↦ [[ ]]) ⟧" $ @@ -179,3 +177,12 @@ testCLI ["rewrite", "--nothing", "--output=xmir", "--omit-listing"] ["", "4 lines of phi", " "] + + describe "dataize" $ do + it "dataizes simple program" $ + withStdin "Q -> [[ D> 01- ]]" $ + testCLI ["dataize"] ["01-"] + + it "fails to dataize" $ + withStdin "Q -> [[ ]]" $ + testCLIFailed ["dataize"] "[ERROR]: Could not dataize given program" diff --git a/test/DataizeSpec.hs b/test/DataizeSpec.hs new file mode 100644 --- /dev/null +++ b/test/DataizeSpec.hs @@ -0,0 +1,100 @@ +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module DataizeSpec (spec) where + +import Ast (Attribute (AtLabel, AtPhi, AtRho), Binding (BiDelta, BiTau, BiVoid), Expression (ExApplication, ExDispatch, ExFormation, ExGlobal, ExTermination, ExThis), Program (Program)) +import Control.Monad +import Dataize (dataize, dataize', morph) +import Parser (parseProgramThrows) +import Test.Hspec + +test :: (Eq a, Show a) => (Expression -> Program -> IO (Maybe a)) -> [(String, Expression, Expression, Maybe a)] -> Spec +test func useCases = + forM_ useCases $ \(desc, input, prog, output) -> + it desc $ do + res <- func input (Program prog) + res `shouldBe` output + +spec :: Spec +spec = do + describe "morph" $ + test + morph + [ ("[[ D> 00- ]] => [[ D> 00- ]]", ExFormation [BiDelta "00-"], ExGlobal, Just (ExFormation [BiDelta "00-"])), + ("T => T", ExTermination, ExGlobal, Just ExTermination), + ("$ => X", ExThis, ExGlobal, Nothing), + ("Q => X", ExGlobal, ExGlobal, Nothing), + ( "Q.x (Q -> [[ x -> [[]] ]]) => [[]]", + ExDispatch ExGlobal (AtLabel "x"), + ExFormation [BiTau (AtLabel "x") (ExFormation [])], + Just (ExFormation []) + ) + ] + + describe "dataize" $ + test + dataize' + [ ("[[ D> 00- ]] => 00-", ExFormation [BiDelta "00-"], ExGlobal, Just "00-"), + ("T => X", ExTermination, ExGlobal, Nothing), + ( "[[ @ -> [[ D> 00-]] ]] => 00-", + ExFormation [BiTau AtPhi (ExFormation [BiDelta "00-", BiVoid AtRho]), BiVoid AtRho], + ExGlobal, + Just "00-" + ), + ( "[[ x -> [[ D> 01- ]] ]].x => 01-", + ExDispatch (ExFormation [BiTau (AtLabel "x") (ExFormation [BiDelta "01-", BiVoid AtRho]), BiVoid AtRho]) (AtLabel "x"), + ExGlobal, + Just "01-" + ), + ( "[[ @ -> [[ x -> [[ D> 01-, y -> ? ]](y -> [[ ]]) ]].x ]] => 01-", + ExFormation + [ BiTau + AtPhi + ( ExDispatch + ( ExFormation + [ BiTau + (AtLabel "x") + ( ExApplication + ( ExFormation + [ BiDelta "01-", + BiVoid (AtLabel "y"), + BiVoid AtRho + ] + ) + (BiTau (AtLabel "y") (ExFormation [])) + ) + ] + ) + (AtLabel "x") + ) + ], + ExGlobal, + Just "01-" + ) + ] + + it "dataizes 5.plus(5)" $ do + prog <- + parseProgramThrows + ( unlines + [ "Q -> [[", + " org -> [[", + " eolang -> [[", + " bytes -> [[", + " data -> ?,", + " @ -> $.data", + " ]],", + " number -> [[", + " as-bytes -> ?,", + " @ -> $.as-bytes,", + " plus -> [[ x -> ?, L> L_org_eolang_number_plus ]]", + " ]]", + " ]]", + " ]],", + " @ -> 5.plus(5)", + "]]" + ] + ) + value <- dataize prog + value `shouldBe` Just "40-24-00-00-00-00-00-00" diff --git a/test/MatcherSpec.hs b/test/MatcherSpec.hs --- a/test/MatcherSpec.hs +++ b/test/MatcherSpec.hs @@ -48,23 +48,23 @@ [ BiTau (AtLabel "f") (ExFormation [BiTau (AtLabel "x") (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "x"))]), BiTau (AtLabel "t") (ExFormation [BiTau (AtLabel "y") (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "y"))]) ], - ExFormation [], + defaultScope, [[("a", MvAttribute (AtLabel "x"))], [("a", MvAttribute (AtLabel "y"))]] ), ( "!e => [[x -> Q]] => [(!e >> [[x -> Q]] ), (!e >> Q)]", ExMeta "e", ExFormation [BiTau (AtLabel "x") ExGlobal], - ExFormation [], - [ [("e", MvExpression (ExFormation [BiTau (AtLabel "x") ExGlobal]) (ExFormation []))], + defaultScope, + [ [("e", MvExpression (ExFormation [BiTau (AtLabel "x") ExGlobal]) defaultScope)], [("e", MvExpression ExGlobal (ExFormation [BiTau (AtLabel "x") ExGlobal]))] ] ), ( "!e.!a => Q.org.eolang => [(!e >> Q.org, !a >> eolang), (!e >> Q, !a >> org)]", ExDispatch (ExMeta "e") (AtMeta "a"), ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang"), - ExFormation [], - [ [("e", MvExpression (ExDispatch ExGlobal (AtLabel "org")) (ExFormation [])), ("a", MvAttribute (AtLabel "eolang"))], - [("e", MvExpression ExGlobal (ExFormation [])), ("a", MvAttribute (AtLabel "org"))] + defaultScope, + [ [("e", MvExpression (ExDispatch ExGlobal (AtLabel "org")) defaultScope), ("a", MvAttribute (AtLabel "eolang"))], + [("e", MvExpression ExGlobal defaultScope), ("a", MvAttribute (AtLabel "org"))] ] ), ( "⟦!B1, !a ↦ ∅, !B2⟧.!a => ⟦ x ↦ ξ.t, t ↦ ∅ ⟧.t(ρ ↦ ⟦ x ↦ ξ.t, t ↦ ∅ ⟧) => [(!B1 >> ⟦x ↦ ξ.t⟧, !a >> t, !B2 >> ⟦⟧ )]", @@ -86,7 +86,7 @@ ] ) ), - ExFormation [], + defaultScope, [ [ ("B1", MvBindings [BiTau (AtLabel "x") (ExDispatch ExThis (AtLabel "t"))]), ("a", MvAttribute (AtLabel "t")), ("B2", MvBindings []) @@ -112,85 +112,85 @@ [ ( "[[]] => [[]] => ()", [], [], - ExFormation [], + defaultScope, [[]] ), ( "[[!B]] => T:[[x -> ?, D> 01-, L> Func]] => (!B >> T)", [BiMeta "B"], [BiVoid (AtLabel "x"), BiDelta "01-", BiLambda "Func"], - ExFormation [], + defaultScope, [[("B", MvBindings [BiVoid (AtLabel "x"), BiDelta "01-", BiLambda "Func"])]] ), ( "[[D> 00-]] => [[D> 00-, L> Func]] => []", [BiDelta "00-"], [BiDelta "00-", BiLambda "Func"], - ExFormation [], + defaultScope, [] ), ( "[[y -> ?, !a -> ?]] => [[y -> ?, x -> ?]] => (!a >> x)", [BiVoid (AtLabel "y"), BiVoid (AtMeta "a")], [BiVoid (AtLabel "y"), BiVoid (AtLabel "x")], - ExFormation [], + defaultScope, [[("a", MvAttribute (AtLabel "x"))]] ), ( "[[!B, x -> ?]] => [[x -> ?]] => (!B >> [[]])", [BiMeta "B", BiVoid (AtLabel "x")], [BiVoid (AtLabel "x")], - ExFormation [], + defaultScope, [[("B", MvBindings [])]] ), ( "[[!B1, x -> ?, !B2]] => [[x -> ?, y -> ?]] => (!B1 >> [[]], !B2 >> [[y -> ?]])", [BiMeta "B1", BiVoid (AtLabel "x"), BiMeta "B2"], [BiVoid (AtLabel "x"), BiVoid (AtLabel "y")], - ExFormation [], + defaultScope, [[("B1", MvBindings []), ("B2", MvBindings [BiVoid (AtLabel "y")])]] ), ( "[[!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"], - ExFormation [], + defaultScope, [[("B1", MvBindings []), ("B2", MvBindings [BiDelta "00-", BiLambda "Func"]), ("x", MvAttribute (AtLabel "y"))]] ), ( "[[!x -> ?, !y -> ?]] => [[a -> ?, b -> ?]] => (!x >> a, !y >> b)", [BiVoid (AtMeta "x"), BiVoid (AtMeta "y")], [BiVoid (AtLabel "a"), BiVoid (AtLabel "b")], - ExFormation [], + defaultScope, [[("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], - ExFormation [], + defaultScope, [[("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], - ExFormation [], + defaultScope, [[("B", MvBindings [BiTau (AtLabel "x") ExGlobal, BiTau (AtLabel "y") ExThis])]] ), ( "[[L> Func, D> 00-]] => [[D> 00-, L> Func]] => []", [BiLambda "Func", BiDelta "00-"], [BiDelta "00-", BiLambda "Func"], - ExFormation [], + defaultScope, [] ), ( "[[t -> ?, !B]] => [[x -> ?, t -> ?]] => []", [BiVoid (AtLabel "t"), BiMeta "B"], [BiVoid (AtLabel "x"), BiVoid (AtLabel "t")], - ExFormation [], + defaultScope, [] ), ( "[[!B, !a -> ?]] => [[x -> ?, y -> ?]] => (!a >> y, !B >> [[ x -> ? ]] )", [BiMeta "B", BiVoid (AtMeta "a")], [BiVoid (AtLabel "x"), BiVoid (AtLabel "y")], - ExFormation [], + defaultScope, [[("a", MvAttribute (AtLabel "y")), ("B", MvBindings [BiVoid (AtLabel "x")])]] ), ( "[[!B1, !a -> ?, !B2]] => [[ x -> ?, y -> ?, z -> ? ]] => [(), (), ()]", [BiMeta "B1", BiVoid (AtMeta "a"), BiMeta "B2"], [BiVoid (AtLabel "x"), BiVoid (AtLabel "y"), BiVoid (AtLabel "z")], - ExFormation [], + defaultScope, [ [ ("B1", MvBindings []), ("a", MvAttribute (AtLabel "x")), ("B2", MvBindings [BiVoid (AtLabel "y"), BiVoid (AtLabel "z")]) @@ -213,7 +213,7 @@ BiVoid (AtLabel "y"), BiVoid (AtLabel "z") ], - ExFormation [], + defaultScope, [ [ ("B1", MvBindings []), ("a1", MvAttribute (AtLabel "a")), ("B2", MvBindings []), @@ -281,31 +281,31 @@ describe "matchExpression: expression => pattern => substitution" $ test matchExpression - [ ("$ => $ => [()]", ExThis, ExThis, ExFormation [], [[]]), - ("Q => Q => [()]", ExGlobal, ExGlobal, ExFormation [], [[]]), + [ ("$ => $ => [()]", ExThis, ExThis, defaultScope, [[]]), + ("Q => Q => [()]", ExGlobal, ExGlobal, defaultScope, [[]]), ( "!e => Q => [(!e >> Q)]", ExMeta "e", ExGlobal, - ExFormation [], - [[("e", MvExpression ExGlobal (ExFormation []))]] + defaultScope, + [[("e", MvExpression ExGlobal defaultScope)]] ), ( "!e => Q.org(x -> $) => [(!e >> Q.org(x -> $))]", ExMeta "e", ExApplication (ExDispatch ExGlobal (AtLabel "org")) (BiTau (AtLabel "x") ExThis), - ExFormation [], - [[("e", MvExpression (ExApplication (ExDispatch ExGlobal (AtLabel "org")) (BiTau (AtLabel "x") ExThis)) (ExFormation []))]] + defaultScope, + [[("e", MvExpression (ExApplication (ExDispatch ExGlobal (AtLabel "org")) (BiTau (AtLabel "x") ExThis)) defaultScope)]] ), ( "!e1.x => Q.org.x => [(!e1 >> Q.org)]", ExDispatch (ExMeta "e1") (AtLabel "x"), ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "x"), - ExFormation [], - [[("e1", MvExpression (ExDispatch ExGlobal (AtLabel "org")) (ExFormation []))]] + defaultScope, + [[("e1", MvExpression (ExDispatch ExGlobal (AtLabel "org")) defaultScope)]] ), ( "!e.org.!a => $.org.x => [(!e >> $, !a >> x)]", ExDispatch (ExDispatch (ExMeta "e") (AtLabel "org")) (AtMeta "a"), ExDispatch (ExDispatch ExThis (AtLabel "org")) (AtLabel "x"), - ExFormation [], - [[("e", MvExpression ExThis (ExFormation [])), ("a", MvAttribute (AtLabel "x"))]] + defaultScope, + [[("e", MvExpression ExThis defaultScope), ("a", MvAttribute (AtLabel "x"))]] ), ( "[[!a -> !e, !B]].!a => [[x -> Q, y -> $]].x => [(!a >> x, !e >> Q, !B >> [y -> $])]", ExDispatch (ExFormation [BiTau (AtMeta "a") (ExMeta "e"), BiMeta "B"]) (AtMeta "a"), @@ -316,7 +316,7 @@ ] ) (AtLabel "x"), - ExFormation [], + defaultScope, [ [ ("a", MvAttribute (AtLabel "x")), ( "e", MvExpression @@ -334,25 +334,25 @@ ( "Q * !t => Q.org => [(!t >> [.org])]", ExMetaTail ExGlobal "t", ExDispatch ExGlobal (AtLabel "x"), - ExFormation [], + defaultScope, [[("t", MvTail [TaDispatch (AtLabel "x")])]] ), ( "Q * !t => Q.org(x -> [[]]) => [(!t >> [.org, (x -> [[]])])]", ExMetaTail ExGlobal "t", - ExApplication (ExDispatch ExGlobal (AtLabel "org")) (BiTau (AtLabel "x") (ExFormation [])), - ExFormation [], - [[("t", MvTail [TaDispatch (AtLabel "org"), TaApplication (BiTau (AtLabel "x") (ExFormation []))])]] + ExApplication (ExDispatch ExGlobal (AtLabel "org")) (BiTau (AtLabel "x") defaultScope), + defaultScope, + [[("t", MvTail [TaDispatch (AtLabel "org"), TaApplication (BiTau (AtLabel "x") defaultScope)])]] ), ( "Q.!a * !t => Q.org(x -> [[]]) => [(!a >> org, !t >> [(x -> [[]])])]", ExMetaTail (ExDispatch ExGlobal (AtMeta "a")) "t", - ExApplication (ExDispatch ExGlobal (AtLabel "org")) (BiTau (AtLabel "x") (ExFormation [])), - ExFormation [], - [[("a", MvAttribute (AtLabel "org")), ("t", MvTail [TaApplication (BiTau (AtLabel "x") (ExFormation []))])]] + ExApplication (ExDispatch ExGlobal (AtLabel "org")) (BiTau (AtLabel "x") defaultScope), + defaultScope, + [[("a", MvAttribute (AtLabel "org")), ("t", MvTail [TaApplication (BiTau (AtLabel "x") defaultScope)])]] ), ( "Q.x(y -> $ * !t1) * !t2 => Q.x(y -> $.q).p => [(!t1 >> [.q], !t2 >> [.p])]", ExMetaTail (ExApplication (ExDispatch ExGlobal (AtLabel "x")) (BiTau (AtLabel "y") (ExMetaTail ExThis "t1"))) "t2", ExDispatch (ExApplication (ExDispatch ExGlobal (AtLabel "x")) (BiTau (AtLabel "y") (ExDispatch ExThis (AtLabel "q")))) (AtLabel "p"), - ExFormation [], + defaultScope, [[("t1", MvTail [TaDispatch (AtLabel "q")]), ("t2", MvTail [TaDispatch (AtLabel "p")])]] ), ( "[[!B1, !a ↦ !e1, !B2]](!a ↦ !e2) => ⟦ t ↦ ξ.k, x ↦ ξ.t, k ↦ ∅ ⟧(x ↦ ξ) => [(!B1 >> [[ t -> $.k ]], !a >> x, !B2 >> [[ k -> ? ]], !e1 >> $.t, !e2 >> $)]", @@ -365,7 +365,7 @@ ] ) (BiTau (AtLabel "x") ExThis), - ExFormation [], + defaultScope, [ [ ("B1", MvBindings [BiTau (AtLabel "t") (ExDispatch ExThis (AtLabel "k"))]), ("a", MvAttribute (AtLabel "x")), ("B2", MvBindings [BiVoid (AtLabel "k")]), @@ -379,7 +379,7 @@ ] ) ), - ("e2", MvExpression ExThis (ExFormation [])) + ("e2", MvExpression ExThis defaultScope) ] ] ) diff --git a/test/PrettySpec.hs b/test/PrettySpec.hs --- a/test/PrettySpec.hs +++ b/test/PrettySpec.hs @@ -5,7 +5,7 @@ import Ast import Control.Monad (forM_) -import Matcher (MetaValue (MvAttribute, MvExpression), substEmpty, substSingle) +import Matcher (MetaValue (MvAttribute, MvExpression), substEmpty, substSingle, defaultScope) import Parser (parseProgramThrows) import Pretty import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, describe, it, runIO, shouldBe) @@ -62,7 +62,7 @@ map (\(desc, output, substs) -> (desc, output, substs, SALTY)) [ ("[()]", "[\n (\n \n )\n]", [substEmpty]), - ("[(!e >> Q.x)]", "[\n (\n !e >> Φ.x\n )\n]", [substSingle "e" (MvExpression (ExDispatch ExGlobal (AtLabel "x")) (ExFormation []))]), + ("[(!e >> Q.x)]", "[\n (\n !e >> Φ.x\n )\n]", [substSingle "e" (MvExpression (ExDispatch ExGlobal (AtLabel "x")) defaultScope)]), ("[(!a >> x)]", "[\n (\n !a >> x\n )\n]", [substSingle "a" (MvAttribute (AtLabel "x"))]) ] test prettySubsts' useCases diff --git a/test/RewriterSpec.hs b/test/RewriterSpec.hs --- a/test/RewriterSpec.hs +++ b/test/RewriterSpec.hs @@ -11,17 +11,16 @@ import Control.Monad (forM_, unless) import Data.Aeson import Data.Char (isSpace) -import Data.Foldable (foldlM) import Data.Yaml qualified as Yaml import GHC.Generics import Misc (allPathsIn, ensuredFile) import Parser (parseProgramThrows) import Pretty (prettyProgram) -import Rewriter (rewrite) import System.FilePath (makeRelative, replaceExtension, ()) import Test.Hspec (Spec, describe, expectationFailure, it, pending, runIO) import Yaml (normalizationRules) import Yaml qualified as Y +import Rewriter (rewrite') data Rules = Rules { basic :: Maybe [String], @@ -92,7 +91,7 @@ if normalize' then pure normalizationRules else pure [] - rewritten <- foldlM (\prog _ -> rewrite prog rules') program [1 .. repeat'] + rewritten <- rewrite' program program rules' repeat' result' <- parseProgramThrows (output pack) unless (rewritten == result') $ expectationFailure