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.49 +version: 0.0.0.50 license: MIT synopsis: Command-Line Manipulator of šœ‘-Calculus Expressions description: Please see the README on GitHub at @@ -35,6 +35,7 @@ AST Builder CLI + Condition CST Dataize Deps @@ -112,6 +113,7 @@ other-modules: BuilderSpec CLISpec + ConditionSpec CSTSpec DataizeSpec FunctionsSpec diff --git a/src/Builder.hs b/src/Builder.hs --- a/src/Builder.hs +++ b/src/Builder.hs @@ -43,10 +43,6 @@ type Built a = Either String a --- @todo #277:30min Error messages are too verbose. Now, if we can't build expression or binding, we --- throw an exception and just print whole expression or binding to console. --- If this elements are big, it's just a mess and error message became unreadable. It would be nice to --- print expression or binding in some reduce way, removing some parts or printing only first N lines instance Show BuildException where show CouldNotBuildExpression {..} = printf diff --git a/src/CLI.hs b/src/CLI.hs --- a/src/CLI.hs +++ b/src/CLI.hs @@ -10,16 +10,19 @@ module CLI (runCLI) where import AST +import Condition (parseConditionThrows) import Control.Exception (Exception (displayException), SomeException, handle, throw, throwIO) import Control.Exception.Base import Control.Monad (when, (>=>)) import Data.Char (toLower, toUpper) +import Data.Foldable (for_) +import qualified Data.Foldable import Data.Functor ((<&>)) import Data.List (intercalate) -import Data.Maybe (isJust, isNothing) +import Data.Maybe (fromJust, isJust, isNothing) import Data.Version (showVersion) import Dataize (DataizeContext (DataizeContext), dataize) -import Deps (saveStep) +import Deps (SaveStepFunc, saveStep) import Encoding (Encoding (ASCII, UNICODE)) import Functions (buildTerm) import qualified Functions @@ -30,13 +33,13 @@ import Merge (merge) import Misc (ensuredFile) import qualified Misc -import Must (Must (..)) +import Must (Must (..), validateMust) import Options.Applicative import Parser (parseExpressionThrows, parseProgramThrows) import Paths_phino (version) -import Printer (printExpression') import qualified Printer as P import Rewriter (RewriteContext (RewriteContext), Rewritten (..), rewrite') +import Rule (RuleContext (RuleContext), matchProgramWithRule) import Sugar import System.Exit (ExitCode (..), exitFailure) import System.IO (getContents') @@ -51,7 +54,8 @@ xmirCtx :: XmirContext, nonumber :: Bool, expression :: Maybe String, - label :: Maybe String + label :: Maybe String, + outputFormat :: IOFormat } data CmdException @@ -70,6 +74,7 @@ | CmdDataize OptsDataize | CmdExplain OptsExplain | CmdMerge OptsMerge + | CmdMatch OptsMatch data IOFormat = XMIR | PHI | LATEX deriving (Eq) @@ -81,18 +86,28 @@ data OptsDataize = OptsDataize { logLevel :: LogLevel, + logLines :: Integer, inputFormat :: IOFormat, + outputFormat :: IOFormat, sugarType :: SugarType, flat :: LineFormat, + omitListing :: Bool, + omitComments :: Bool, + nonumber :: Bool, + sequence :: Bool, + depthSensitive :: Bool, maxDepth :: Integer, maxCycles :: Integer, - depthSensitive :: Bool, + hide :: [String], + expression :: Maybe String, + label :: Maybe String, stepsDir :: Maybe FilePath, inputFile :: Maybe FilePath } data OptsExplain = OptsExplain { logLevel :: LogLevel, + logLines :: Integer, rules :: [FilePath], normalize :: Bool, shuffle :: Bool, @@ -101,25 +116,26 @@ data OptsRewrite = OptsRewrite { logLevel :: LogLevel, - rules :: [FilePath], + logLines :: Integer, inputFormat :: IOFormat, outputFormat :: IOFormat, sugarType :: SugarType, flat :: LineFormat, + must :: Must, normalize :: Bool, shuffle :: Bool, omitListing :: Bool, omitComments :: Bool, depthSensitive :: Bool, nonumber :: Bool, - must :: Must, - maxDepth :: Integer, - maxCycles :: Integer, inPlace :: Bool, sequence :: Bool, + maxDepth :: Integer, + maxCycles :: Integer, + rules :: [FilePath], + hide :: [String], expression :: Maybe String, label :: Maybe String, - hide :: [String], targetFile :: Maybe FilePath, stepsDir :: Maybe FilePath, inputFile :: Maybe FilePath @@ -127,6 +143,7 @@ data OptsMerge = OptsMerge { logLevel :: LogLevel, + logLines :: Integer, inputFormat :: IOFormat, outputFormat :: IOFormat, sugarType :: SugarType, @@ -137,6 +154,21 @@ inputs :: [FilePath] } +data OptsMatch = OptsMatch + { logLevel :: LogLevel, + logLines :: Integer, + sugarType :: SugarType, + flat :: LineFormat, + pattern :: Maybe String, + when' :: Maybe String, + inputFile :: Maybe FilePath + } + +validateIntegerOption :: (Integer -> Bool) -> String -> Integer -> ReadM Integer +validateIntegerOption cmp msg num + | cmp num = return num + | otherwise = readerError msg + optLogLevel :: Parser LogLevel optLogLevel = option @@ -159,6 +191,18 @@ "NONE" -> Right NONE _ -> Left $ "unknown log-level: " <> lvl +optLogLines :: Parser Integer +optLogLines = + option + (auto >>= validateIntegerOption (>= -1) "--log-lines must be >= -1") + (long "log-lines" <> metavar "LINES" <> help "Amount of lines printed to console per each log operation (0 - print nothing, -1 - no limits)" <> value 25 <> showDefault) + +optRule :: Parser [FilePath] +optRule = many (strOption (long "rule" <> metavar "[FILE]" <> help "Path to custom rule")) + +optInputFormat :: Parser IOFormat +optInputFormat = option (parseIOFormat "input") (long "input" <> metavar "FORMAT" <> help "Program input format (phi, xmir)" <> value PHI <> showDefault) + parseIOFormat :: String -> ReadM IOFormat parseIOFormat type' = eitherReader $ \format -> case (map toLower format, type') of ("xmir", _) -> Right XMIR @@ -166,27 +210,45 @@ ("latex", "output") -> Right LATEX _ -> Left (printf "The value '%s' can't be used for '--%s' option, use --help to check possible values" format type') +optOutputFormat :: Parser IOFormat +optOutputFormat = + option + (parseIOFormat "output") + (long "output" <> metavar "FORMAT" <> help (printf "Result and intermediate (see %s option(s)) programs output format (phi, xmir, latex)" _intermediateOptions) <> value PHI <> showDefault) + argInputFile :: Parser (Maybe FilePath) argInputFile = optional (argument str (metavar "FILE" <> help "Path to input file")) optMaxDepth :: Parser Integer -optMaxDepth = option auto (long "max-depth" <> metavar "DEPTH" <> help "Maximum number of rewriting iterations per rule" <> value 25 <> showDefault) +optMaxDepth = + option + (auto >>= validateIntegerOption (> 0) "--max-depth must be positive") + (long "max-depth" <> metavar "DEPTH" <> help "Maximum number of rewriting iterations per rule" <> value 25 <> showDefault) optMaxCycles :: Parser Integer -optMaxCycles = option auto (long "max-cycles" <> metavar "CYCLES" <> help "Maximum number of rewriting cycles across all rules" <> value 25 <> showDefault) - -optInputFormat :: Parser IOFormat -optInputFormat = option (parseIOFormat "input") (long "input" <> metavar "FORMAT" <> help "Program input format (phi, xmir)" <> value PHI <> showDefault) - -optOutputFormat :: Parser IOFormat -optOutputFormat = option (parseIOFormat "output") (long "output" <> metavar "FORMAT" <> help "Program output format (phi, xmir, latex)" <> value PHI <> showDefault) +optMaxCycles = + option + (auto >>= validateIntegerOption (> 0) "--max-cycles must be positive") + (long "max-cycles" <> metavar "CYCLES" <> help "Maximum number of rewriting cycles across all rules" <> value 25 <> showDefault) optDepthSensitive :: Parser Bool optDepthSensitive = switch (long "depth-sensitive" <> help "Fail if rewriting is not finished after reaching max attempts (see --max-cycles or --max-depth)") -optRule :: Parser [FilePath] -optRule = many (strOption (long "rule" <> metavar "[FILE]" <> help "Path to custom rule")) +optNonumber :: Parser Bool +optNonumber = switch (long "nonumber" <> help "Turn off equation auto numbering in LaTeX rendering (see --output option)") +optSequence :: Parser Bool +optSequence = switch (long "sequence" <> help "Result output contains all intermediate šœ‘-programs concatenated with EOL") + +optExpression :: Parser (Maybe String) +optExpression = optional (strOption (long "expression" <> metavar "NAME" <> help "Name for 'phiExpression' element when rendering to LaTeX (see --output option)")) + +optLabel :: Parser (Maybe String) +optLabel = optional (strOption (long "label" <> metavar "NAME" <> help "Name for 'label' element when rendering to LaTeX (see --output option)")) + +optHide :: Parser [String] +optHide = many (strOption (long "hide" <> metavar "FQN" <> help "Location of object to exclude from result and intermediate programs after rewriting. Must be a valid dispatch expression; e.g. Q.org.eolang")) + optNormalize :: Parser Bool optNormalize = switch (long "normalize" <> help "Use built-in normalization rules") @@ -199,14 +261,14 @@ optShuffle :: Parser Bool optShuffle = switch (long "shuffle" <> help "Shuffle rules before applying") -optSugar :: [String] -> Parser SugarType -optSugar opts = flag SALTY SWEET (long "sweet" <> help (printf "Print result and intermediate (see %s option(s)) šœ‘-programs using syntax sugar" (intercalate ", " opts))) +optSugar :: Parser SugarType +optSugar = flag SALTY SWEET (long "sweet" <> help (printf "Print result and intermediate (see %s option(s)) šœ‘-programs using syntax sugar" _intermediateOptions)) optSugar' :: Parser SugarType optSugar' = flag SALTY SWEET (long "sweet" <> help "Print result šœ‘-program using syntax sugar") -optLineFormat :: [String] -> Parser LineFormat -optLineFormat opts = flag MULTILINE SINGLELINE (long "flat" <> help (printf "Print result and intermediate (see %s option(s)) šœ‘-programs in one line" (intercalate ", " opts))) +optLineFormat :: Parser LineFormat +optLineFormat = flag MULTILINE SINGLELINE (long "flat" <> help (printf "Print result and intermediate (see %s option(s)) šœ‘-programs in one line" _intermediateOptions)) optLineFormat' :: Parser LineFormat optLineFormat' = flag MULTILINE SINGLELINE (long "flat" <> help "Print result šœ‘-program in one line") @@ -217,11 +279,15 @@ optOmitComments :: Parser Bool optOmitComments = switch (long "omit-comments" <> help "Omit comments in XMIR output") +_intermediateOptions :: String +_intermediateOptions = intercalate ", " ["--sequence", "--steps-dir"] + explainParser :: Parser Command explainParser = CmdExplain <$> ( OptsExplain <$> optLogLevel + <*> optLogLines <*> optRule <*> optNormalize <*> optShuffle @@ -230,64 +296,73 @@ dataizeParser :: Parser Command dataizeParser = - let steps = ["--steps-dir"] - in CmdDataize - <$> ( OptsDataize - <$> optLogLevel - <*> optInputFormat - <*> optSugar steps - <*> optLineFormat steps - <*> optMaxDepth - <*> optMaxCycles - <*> optDepthSensitive - <*> optStepsDir - <*> argInputFile - ) + CmdDataize + <$> ( OptsDataize + <$> optLogLevel + <*> optLogLines + <*> optInputFormat + <*> optOutputFormat + <*> optSugar + <*> optLineFormat + <*> optOmitListing + <*> optOmitComments + <*> optNonumber + <*> optSequence + <*> optDepthSensitive + <*> optMaxDepth + <*> optMaxCycles + <*> optHide + <*> optExpression + <*> optLabel + <*> optStepsDir + <*> argInputFile + ) rewriteParser :: Parser Command rewriteParser = - let opts = ["--sequence", "--steps-dir"] - in CmdRewrite - <$> ( OptsRewrite - <$> optLogLevel - <*> optRule - <*> optInputFormat - <*> optOutputFormat - <*> optSugar opts - <*> optLineFormat opts - <*> optNormalize - <*> optShuffle - <*> optOmitListing - <*> optOmitComments - <*> optDepthSensitive - <*> switch (long "nonumber" <> help "Turn off equation auto numbering in LaTeX rendering") - <*> option - auto - ( long "must" - <> metavar "RANGE" - <> help "Must-rewrite range (e.g., '3', '..5', '3..', '3..5'). Stops execution if number of rules applied is not in range. Use 0 to disable." - <> value MtDisabled - <> showDefaultWith show - ) - <*> optMaxDepth - <*> optMaxCycles - <*> switch (long "in-place" <> help "Edit file in-place instead of printing to output") - <*> switch (long "sequence" <> help "Result output contains all intermediate šœ‘-programs concatenated with EOL") - <*> optional (strOption (long "expression" <> metavar "NAME" <> help "Name for 'phiExpression' element when rendering to LaTeX")) - <*> optional (strOption (long "label" <> metavar "NAME" <> help "Name for 'label' element when rendering to LaTeX")) - <*> many (strOption (long "hide" <> metavar "FQN" <> help "Location of object to exclude from result program after rewriting, must be a valid dispatch expression; e.g. Q.org.eolang")) - <*> optTarget - <*> optStepsDir - <*> argInputFile - ) + CmdRewrite + <$> ( OptsRewrite + <$> optLogLevel + <*> optLogLines + <*> optInputFormat + <*> optOutputFormat + <*> optSugar + <*> optLineFormat + <*> option + auto + ( long "must" + <> metavar "RANGE" + <> help "Must-rewrite range (e.g., '3', '..5', '3..', '3..5'). Stops execution if number of rules applied is not in range. Use 0 to disable." + <> value MtDisabled + <> showDefaultWith show + ) + <*> optNormalize + <*> optShuffle + <*> optOmitListing + <*> optOmitComments + <*> optDepthSensitive + <*> optNonumber + <*> switch (long "in-place" <> help "Edit file in-place instead of printing to output") + <*> optSequence + <*> optMaxDepth + <*> optMaxCycles + <*> optRule + <*> optHide + <*> optExpression + <*> optLabel + <*> optTarget + <*> optStepsDir + <*> argInputFile + ) mergeParser :: Parser Command mergeParser = CmdMerge <$> ( OptsMerge <$> optLogLevel + <*> optLogLines <*> optInputFormat - <*> optOutputFormat + <*> option (parseIOFormat "output") (long "output" <> metavar "FORMAT" <> help (printf "Result program output format (phi, xmir, latex)") <> value PHI <> showDefault) <*> optSugar' <*> optLineFormat' <*> optOmitListing @@ -296,6 +371,19 @@ <*> many (argument str (metavar "[FILE]" <> help "Paths to input files")) ) +matchParser :: Parser Command +matchParser = + CmdMatch + <$> ( OptsMatch + <$> optLogLevel + <*> optLogLines + <*> optSugar + <*> optLineFormat + <*> optional (strOption (long "pattern" <> metavar "EXPRESSION" <> help "Pattern expression to match against")) + <*> optional (strOption (long "when" <> metavar "CONDITION" <> help "Predicate for matched substitutions")) + <*> argInputFile + ) + commandParser :: Parser Command commandParser = hsubparser @@ -303,6 +391,7 @@ <> command "dataize" (info dataizeParser (progDesc "Dataize the šœ‘-program")) <> command "explain" (info explainParser (progDesc "Explain rules in LaTeX format")) <> command "merge" (info mergeParser (progDesc "Merge šœ‘-programs into single one by merging their top level formations")) + <> command "match" (info matchParser (progDesc "Match šœ‘-program against provided pattern and build matched substitutions")) ) parserInfo :: ParserInfo Command @@ -318,14 +407,15 @@ logError (displayException e) exitFailure -setLogLevel' :: Command -> IO () -setLogLevel' cmd = - let level = case cmd of - CmdRewrite OptsRewrite {logLevel} -> logLevel - CmdDataize OptsDataize {logLevel} -> logLevel - CmdExplain OptsExplain {logLevel} -> logLevel - CmdMerge OptsMerge {logLevel} -> logLevel - in setLogLevel level +setLogger :: Command -> IO () +setLogger cmd = + let (level, lines) = case cmd of + CmdRewrite OptsRewrite {logLevel, logLines} -> (logLevel, logLines) + CmdDataize OptsDataize {logLevel, logLines} -> (logLevel, logLines) + CmdExplain OptsExplain {logLevel, logLines} -> (logLevel, logLines) + CmdMerge OptsMerge {logLevel, logLines} -> (logLevel, logLines) + CmdMatch OptsMatch {logLevel, logLines} -> (logLevel, logLines) + in setLogConfig level lines invalidCLIArguments :: String -> IO a invalidCLIArguments msg = throwIO (InvalidCLIArguments msg) @@ -333,21 +423,22 @@ runCLI :: [String] -> IO () runCLI args = handle handler $ do cmd <- handleParseResult (execParserPure defaultPrefs parserInfo args) - setLogLevel' cmd + setLogger cmd case cmd of CmdRewrite OptsRewrite {..} -> do validateOpts - exclude <- traverse (parseExpressionThrows >=> canBeHidden) hide + exclude <- expressionsToHide hide logDebug (printf "Amount of rewriting cycles across all the rules: %d, per rule: %d" maxCycles maxDepth) input <- readInput inputFile rules' <- getRules normalize shuffle rules program <- parseProgram input inputFormat let listing = if null rules' then const input else (\prog -> P.printProgram' prog (sugarType, UNICODE, flat)) xmirCtx = XmirContext omitListing omitComments listing - printProgCtx = PrintProgCtx sugarType flat xmirCtx nonumber expression label - rewrittens <- rewrite' program rules' (context printProgCtx) <&> (`H.hide` exclude) + printCtx = PrintProgCtx sugarType flat xmirCtx nonumber expression label outputFormat + rewrittens <- rewrite' program rules' (context printCtx) <&> (`H.hide` exclude) + let rewrittens' = if sequence then rewrittens else [last rewrittens] logDebug (printf "Printing rewritten šœ‘-program as %s" (show outputFormat)) - progs <- printRewrittens printProgCtx rewrittens + progs <- printRewrittens printCtx rewrittens' output targetFile progs where validateOpts :: IO () @@ -358,18 +449,8 @@ when (inPlace && isJust targetFile) (invalidCLIArguments "--in-place and --target cannot be used together") - when - (nonumber && outputFormat /= LATEX) - (invalidCLIArguments "The --nonumber option can stay together with --output=latex only") - when - (isJust expression && outputFormat /= LATEX) - (invalidCLIArguments "The --expression option can stay together with --output=latex only") - when - (isJust label && outputFormat /= LATEX) - (invalidCLIArguments "The --label option can stay together with --output=latex only") - validateMaxDepth maxDepth - validateMaxCycles maxCycles - validateMust must + validateLatexOptions outputFormat nonumber expression label + validateMust' must validateXmirOptions outputFormat omitListing omitComments output :: Maybe FilePath -> String -> IO () output target prog = case (inPlace, target, inputFile) of @@ -390,46 +471,32 @@ maxDepth maxCycles depthSensitive - sequence buildTerm must - (saveStep stepsDir (ioToExtension outputFormat) (printProgram outputFormat ctx)) - printRewrittens :: PrintProgramContext -> [Rewritten] -> IO String - printRewrittens ctx rewrittens - | outputFormat == LATEX = pure (rewrittensToLatex rewrittens (LatexContext sugarType flat nonumber expression label)) - | otherwise = mapM (printProgram outputFormat ctx . program) rewrittens <&> intercalate "\n" - canBeHidden :: Expression -> IO Expression - canBeHidden expr = canBeHidden' expr expr - where - canBeHidden' :: Expression -> Expression -> IO Expression - canBeHidden' exp@(ExDispatch ExGlobal _) _ = pure exp - canBeHidden' exp@(ExDispatch expr attr) full = canBeHidden' expr full >> pure exp - canBeHidden' _ full = - invalidCLIArguments - ( printf - "Only dispatch expression started with Ī¦ (or Q) can be used in --hide, but given: %s" - (printExpression' full P.logPrintConfig) - ) + (saveStepFunc stepsDir ctx) CmdDataize OptsDataize {..} -> do validateOpts + exclude <- expressionsToHide hide input <- readInput inputFile prog <- parseProgram input inputFormat - dataized <- dataize prog (context prog) - maybe (throwIO CouldNotDataize) (putStrLn . P.printBytes) dataized + let printCtx = PrintProgCtx sugarType flat defaultXmirContext nonumber expression label outputFormat + (maybeBytes, seq) <- dataize prog (context prog printCtx) + when sequence (putStrLn =<< printRewrittens printCtx (H.hide seq exclude)) + putStrLn (maybe (P.printExpression ExTermination) P.printBytes maybeBytes) where validateOpts :: IO () validateOpts = do - validateMaxDepth maxDepth - validateMaxCycles maxCycles - context :: Program -> DataizeContext - context program = + validateLatexOptions outputFormat nonumber expression label + validateXmirOptions outputFormat omitListing omitComments + context :: Program -> PrintProgramContext -> DataizeContext + context program ctx = DataizeContext program maxDepth maxCycles depthSensitive buildTerm - (saveStep stepsDir (ioToExtension PHI) (printProgram PHI (PrintProgCtx sugarType flat defaultXmirContext False Nothing Nothing))) + (saveStepFunc stepsDir ctx) CmdExplain OptsExplain {..} -> do validateOpts rules' <- getRules normalize shuffle rules @@ -448,8 +515,8 @@ prog <- merge progs let listing = const (P.printProgram' prog (sugarType, UNICODE, flat)) xmirCtx = XmirContext omitListing omitComments listing - printProgCtx = PrintProgCtx sugarType flat xmirCtx False Nothing Nothing - prog' <- printProgram outputFormat printProgCtx prog + printProgCtx = PrintProgCtx sugarType flat xmirCtx False Nothing Nothing outputFormat + prog' <- printProgram printProgCtx prog output targetFile prog' where validateOpts :: IO () @@ -458,84 +525,134 @@ (null inputs) (throwIO (InvalidCLIArguments "At least one input file must be specified for 'merge' command")) validateXmirOptions outputFormat omitListing omitComments + CmdMatch OptsMatch {..} -> do + input <- readInput inputFile + prog <- parseProgram input PHI + if isNothing pattern + then logInfo "The --pattern is not provided, no substitutions are built" + else do + ptn <- parseExpressionThrows (fromJust pattern) + condition <- traverse parseConditionThrows when' + substs <- matchProgramWithRule prog (rule ptn condition) (RuleContext buildTerm) + if null substs + then logInfo "Provided pattern was not matched, no substitutions are built" + else putStrLn (P.printSubsts' substs (sugarType, UNICODE, flat)) + where + rule :: Expression -> Maybe Y.Condition -> Y.Rule + rule ptn cnd = Y.Rule Nothing Nothing ptn ExGlobal cnd Nothing Nothing + +-- Prepare saveStepFunc +saveStepFunc :: Maybe FilePath -> PrintProgramContext -> SaveStepFunc +saveStepFunc stepsDir ctx@PrintProgCtx {..} = saveStep stepsDir ioToExt (printProgram ctx) where - validateXmirOptions :: IOFormat -> Bool -> Bool -> IO () - validateXmirOptions outputFormat omitListing omitComments = do - when - (outputFormat /= XMIR && omitListing) - (invalidCLIArguments "--omit-listing can be used only with --output-format=xmir") - when - (outputFormat /= XMIR && omitComments) - (invalidCLIArguments "--omit-comments can be used only with --output-format=xmir") - validateIntArgument :: Integer -> (Integer -> Bool) -> String -> IO () - validateIntArgument num cmp msg = - when - (cmp num) - (invalidCLIArguments msg) - validateMaxDepth :: Integer -> IO () - validateMaxDepth depth = validateIntArgument depth (<= 0) "--max-depth must be positive" - validateMaxCycles :: Integer -> IO () - validateMaxCycles cycles = validateIntArgument cycles (<= 0) "--max-cycles must be positive" - validateMust :: Must -> IO () - validateMust MtDisabled = pure () - validateMust (MtExact n) = validateIntArgument n (<= 0) "--must exact value must be positive" - validateMust (MtRange minVal maxVal) = do - maybe (pure ()) (\n -> validateIntArgument n (< 0) "--must minimum must be non-negative") minVal - maybe (pure ()) (\n -> validateIntArgument n (< 0) "--must maximum must be non-negative") maxVal - case (minVal, maxVal) of - (Just min, Just max) - | min > max -> - invalidCLIArguments - (printf "--must range invalid: minimum (%d) is greater than maximum (%d)" min max) - _ -> pure () - 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 - printProgram :: IOFormat -> PrintProgramContext -> Program -> IO String - printProgram PHI PrintProgCtx {..} prog = pure (P.printProgram' prog (sugar, UNICODE, line)) - printProgram XMIR PrintProgCtx {..} prog = programToXMIR prog xmirCtx <&> printXMIR - printProgram LATEX PrintProgCtx {..} prog = pure (programToLaTeX prog (LatexContext sugar line nonumber expression label)) - getRules :: Bool -> Bool -> [FilePath] -> IO [Y.Rule] - getRules normalize shuffle rules = do - ordered <- - if normalize + ioToExt :: String + ioToExt + | outputFormat == LATEX = "tex" + | otherwise = show outputFormat + +-- Get list of expressions which must be hidden in printed programs +expressionsToHide :: [String] -> IO [Expression] +expressionsToHide = traverse (parseExpressionThrows >=> canBeHidden) + where + canBeHidden :: Expression -> IO Expression + canBeHidden expr = canBeHidden' expr expr + canBeHidden' :: Expression -> Expression -> IO Expression + canBeHidden' exp@(ExDispatch ExGlobal _) _ = pure exp + canBeHidden' exp@(ExDispatch expr attr) full = canBeHidden' expr full >> pure exp + canBeHidden' _ full = + invalidCLIArguments + ( printf + "Only dispatch expression started with Ī¦ (or Q) can be used in --hide, but given: %s" + (P.printExpression' full P.logPrintConfig) + ) + +-- Validate LaTeX options +validateLatexOptions :: IOFormat -> Bool -> Maybe String -> Maybe String -> IO () +validateLatexOptions outputFormat nonumber expression label = do + when + (nonumber && outputFormat /= LATEX) + (invalidCLIArguments "The --nonumber option can stay together with --output=latex only") + when + (isJust expression && outputFormat /= LATEX) + (invalidCLIArguments "The --expression option can stay together with --output=latex only") + when + (isJust label && outputFormat /= LATEX) + (invalidCLIArguments "The --label option can stay together with --output=latex only") + +-- Validate 'must' option +validateMust' :: Must -> IO () +validateMust' must = for_ (validateMust must) invalidCLIArguments + +-- Validate options for output to XMIR +validateXmirOptions :: IOFormat -> Bool -> Bool -> IO () +validateXmirOptions outputFormat omitListing omitComments = do + when + (outputFormat /= XMIR && omitListing) + (invalidCLIArguments "--omit-listing can be used only with --output=xmir") + when + (outputFormat /= XMIR && omitComments) + (invalidCLIArguments "--omit-comments can be used only with --output=xmir") + +-- Read input from file or stdin +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))) + +-- Parse program from String input depending on input IO format +parseProgram :: String -> IOFormat -> IO Program +parseProgram phi PHI = parseProgramThrows phi +parseProgram xmir XMIR = do + doc <- parseXMIRThrows xmir + xmirToPhi doc + +printRewrittens :: PrintProgramContext -> [Rewritten] -> IO String +printRewrittens ctx@PrintProgCtx {..} rewrittens + | outputFormat == LATEX = pure (rewrittensToLatex rewrittens (LatexContext sugar line nonumber expression label)) + | otherwise = mapM (printProgram ctx . fst) rewrittens <&> intercalate "\n" + +-- Convert program to corresponding String format +printProgram :: PrintProgramContext -> Program -> IO String +printProgram PrintProgCtx {..} prog = case outputFormat of + PHI -> pure (P.printProgram' prog (sugar, UNICODE, line)) + XMIR -> programToXMIR prog xmirCtx <&> printXMIR + LATEX -> pure (programToLaTeX prog (LatexContext sugar line nonumber expression label)) + +-- Get rules for rewriting depending on provided flags +getRules :: Bool -> Bool -> [FilePath] -> IO [Y.Rule] +getRules normalize shuffle rules = do + ordered <- + if normalize + then do + let rules' = normalizationRules + logDebug (printf "The --normalize option is provided, %d built-it normalization rules are used" (length rules')) + pure rules' + else + if null rules then do - let rules' = normalizationRules - logDebug (printf "The --normalize option is provided, %d built-it normalization rules are used" (length rules')) - pure rules' - else - if null rules - then do - logDebug "No --rule and no --normalize options are provided, no rules are used" - pure [] - else do - logDebug (printf "Using rules from files: [%s]" (intercalate ", " rules)) - yamls <- mapM ensuredFile rules - mapM Y.yamlRule yamls - if shuffle - then do - logDebug "The --shuffle option is provided, rules are used in random order" - Misc.shuffle ordered - else pure ordered - output :: Maybe FilePath -> String -> IO () - output target content = case target of - Nothing -> do - logDebug "The option '--target' is not specified, printing to console..." - putStrLn content - Just file -> do - logDebug (printf "The option '--target' is specified, printing to '%s'..." file) - writeFile file content - logInfo (printf "The command result was saved in '%s'" file) - ioToExtension :: IOFormat -> String - ioToExtension LATEX = "tex" - ioToExtension format = show format + logDebug "No --rule and no --normalize options are provided, no rules are used" + pure [] + else do + logDebug (printf "Using rules from files: [%s]" (intercalate ", " rules)) + yamls <- mapM ensuredFile rules + mapM Y.yamlRule yamls + if shuffle + then do + logDebug "The --shuffle option is provided, rules are used in random order" + Misc.shuffle ordered + else pure ordered + +-- Output content +output :: Maybe FilePath -> String -> IO () +output target content = case target of + Nothing -> do + logDebug "The option '--target' is not specified, printing to console..." + putStrLn content + Just file -> do + logDebug (printf "The option '--target' is specified, printing to '%s'..." file) + writeFile file content + logInfo (printf "The command result was saved in '%s'" file) diff --git a/src/CST.hs b/src/CST.hs --- a/src/CST.hs +++ b/src/CST.hs @@ -2,8 +2,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT @@ -12,6 +10,7 @@ import AST import Data.List (intercalate) +import Data.Maybe (isJust) import Misc data LCB = LCB | BIG_LCB @@ -104,6 +103,7 @@ data PAIR = PA_TAU {attr :: ATTRIBUTE, arrow :: ARROW, expr :: EXPRESSION} + | PA_FORMATION {attr :: ATTRIBUTE, voids :: [ATTRIBUTE], arrow :: ARROW, expr :: EXPRESSION} | PA_VOID {attr :: ATTRIBUTE, arrow :: ARROW, void :: VOID} | PA_LAMBDA {func :: String} | PA_LAMBDA' {func :: String} -- ASCII version of PA_LAMBDA @@ -115,6 +115,9 @@ | PA_META_DELTA' {meta :: META} -- ASCII version of PA_META_DELTA deriving (Eq, Show) +newtype APP_BINDING = APP_BINDING {pair :: PAIR} + deriving (Eq, Show) + data BINDING = BI_PAIR {pair :: PAIR, bindings :: BINDINGS, tab :: TAB} | BI_EMPTY {tab :: TAB} @@ -139,16 +142,17 @@ data EXPRESSION = EX_GLOBAL {global :: GLOBAL} - | EX_DEF_PACKAGE {pckg :: DEF_PACKAGE} + | EX_DEF_PACKAGE {pckg :: DEF_PACKAGE} -- sugar for Q.org.eolang | EX_XI {xi :: XI} | EX_ATTR {attr :: ATTRIBUTE} -- sugar for $.x -> just x | EX_TERMINATION {termination :: TERMINATION} | EX_FORMATION {lsb :: LSB, eol :: EOL, tab :: TAB, binding :: BINDING, eol' :: EOL, tab' :: TAB, rsb :: RSB} | EX_DISPATCH {expr :: EXPRESSION, attr :: ATTRIBUTE} - | EX_APPLICATION {expr :: EXPRESSION, eol :: EOL, tab :: TAB, bindings :: BINDING, eol' :: EOL, tab' :: TAB} - | EX_APPLICATION' {expr :: EXPRESSION, eol :: EOL, tab :: TAB, args :: APP_ARG, eol' :: EOL, tab' :: TAB} - | EX_STRING {str :: String, tab :: TAB} - | EX_NUMBER {num :: Either Integer Double, tab :: TAB} + | EX_APPLICATION {expr :: EXPRESSION, eol :: EOL, tab :: TAB, tau :: APP_BINDING, eol' :: EOL, tab' :: TAB, indent :: Integer} -- e(a1 -> e1) + | EX_APPLICATION_TAUS {expr :: EXPRESSION, eol :: EOL, tab :: TAB, taus :: BINDING, eol' :: EOL, tab' :: TAB, indent :: Integer} -- e(a1 -> e1)(a2 -> e2)(...) + | EX_APPLICATION_EXPRS {expr :: EXPRESSION, eol :: EOL, tab :: TAB, args :: APP_ARG, eol' :: EOL, tab' :: TAB, indent :: Integer} -- e(e1, e2, ...) + | EX_STRING {str :: String, tab :: TAB, rhos :: [Binding]} + | EX_NUMBER {num :: Either Integer Double, tab :: TAB, rhos :: [Binding]} | EX_META {meta :: META} | EX_META_TAIL {expr :: EXPRESSION, meta :: META} deriving (Eq, Show) @@ -164,31 +168,31 @@ deriving (Eq, Show) programToCST :: Program -> PROGRAM -programToCST prog = toCST prog 0 +programToCST prog = toCST prog 0 EOL expressionToCST :: Expression -> EXPRESSION -expressionToCST expr = toCST expr 0 +expressionToCST expr = toCST expr 0 EOL -- This class is used to convert AST to CST -- CST is created with sugar and unicode -- All further transformations much consider that class ToCST a b where - toCST :: a -> Integer -> b + toCST :: a -> Integer -> EOL -> b instance ToCST Program PROGRAM where - toCST (Program expr) tabs = PR_SWEET LCB (toCST expr tabs) RCB + toCST (Program expr) tabs eol = PR_SWEET LCB (toCST expr tabs eol) RCB instance ToCST Expression EXPRESSION where - toCST ExGlobal _ = EX_GLOBAL Ī¦ - toCST ExThis _ = EX_XI XI - toCST (ExMeta mt) _ = EX_META (MT_EXPRESSION (tail mt)) - toCST (ExMetaTail expr mt) tabs = EX_META_TAIL (toCST expr tabs) (MT_TAIL (tail mt)) - toCST ExTermination _ = EX_TERMINATION DEAD - toCST (ExFormation [BiVoid AtRho]) _ = toCST (ExFormation []) 0 - toCST (ExFormation []) _ = EX_FORMATION LSB NO_EOL NO_TAB (BI_EMPTY NO_TAB) NO_EOL NO_TAB RSB - toCST (ExFormation bds) tabs = + toCST ExGlobal _ _ = EX_GLOBAL Ī¦ + toCST ExThis _ _ = EX_XI XI + toCST (ExMeta mt) _ _ = EX_META (MT_EXPRESSION (tail mt)) + toCST (ExMetaTail expr mt) tabs eol = EX_META_TAIL (toCST expr tabs eol) (MT_TAIL (tail mt)) + toCST ExTermination _ _ = EX_TERMINATION DEAD + toCST (ExFormation [BiVoid AtRho]) _ eol = toCST (ExFormation []) 0 eol + toCST (ExFormation []) _ _ = EX_FORMATION LSB NO_EOL NO_TAB (BI_EMPTY NO_TAB) NO_EOL NO_TAB RSB + toCST (ExFormation bds) tabs eol = let next = tabs + 1 - bds' = toCST (withoutLastVoidRho bds) next :: BINDING + bds' = toCST (withoutLastVoidRho bds) next eol :: BINDING in EX_FORMATION LSB EOL @@ -203,33 +207,70 @@ withoutLastVoidRho [BiVoid AtRho] = [] withoutLastVoidRho (bd : [BiVoid AtRho]) = [bd] withoutLastVoidRho (bd : bds') = bd : withoutLastVoidRho bds' - toCST (DataString bts) tabs = EX_STRING (btsToStr bts) (TAB tabs) - toCST (DataNumber bts) tabs = EX_NUMBER (btsToNum bts) (TAB tabs) - toCST (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) _ = EX_DEF_PACKAGE Ī¦Ģ‡ - toCST (ExDispatch ExThis attr) tabs = EX_ATTR (toCST attr tabs) - toCST (ExDispatch expr attr) tabs = EX_DISPATCH (toCST expr tabs) (toCST attr tabs) - toCST app@(ExApplication _ _) tabs = + toCST (DataString bts) tabs _ = EX_STRING (btsToStr bts) (TAB tabs) [] + toCST (DataNumber bts) tabs _ = EX_NUMBER (btsToNum bts) (TAB tabs) [] + toCST (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) _ _ = EX_DEF_PACKAGE Ī¦Ģ‡ + toCST (ExDispatch ExThis attr) tabs eol = EX_ATTR (toCST attr tabs eol) + toCST (ExDispatch expr attr) tabs eol = EX_DISPATCH (toCST expr tabs eol) (toCST attr tabs eol) + -- Since we convert AST to CST in sweet notation, here we're trying to get rid of unnecessary rho bindings + -- in primitives (more details here: https://github.com/objectionary/phino/issues/451) + -- If we find something similar to: + -- `QQ.number(~0 -> QQ.bytes(...), ^ -> ..., ^ -> ...)` + -- We remove unnecessary rho bindings and save them to EX_STRING or EX_NUMBER so they can be successfully + -- converted to salty notation without losing information. + -- In the end we just get CST with data primitive which is printed correctly. + -- If given application is not such primitive - we just convert it to one of the applications: + -- 1. either with pure expression with arguments, which means there are incremented only alpha bindings + -- 2. or with just bindings + toCST app@(ExApplication exp tau) tabs eol = let (expr, taus, exprs) = complexApplication app + expr' = toCST expr tabs eol :: EXPRESSION next = tabs + 1 - expr'' = toCST expr tabs :: EXPRESSION - in if null exprs - then - EX_APPLICATION - (toCST expr tabs) - EOL - (TAB next) - (toCST (reverse taus) next) - EOL - (TAB tabs) + (taus', rhos) = withoutRhosInPrimitives expr taus + obj = ExApplication expr (head taus') + in if length taus' == 1 && isJust (matchDataObject obj) + then applicationToPrimitive obj tabs rhos else - EX_APPLICATION' - (toCST expr tabs) - EOL - (TAB next) - (toCST (reverse exprs) next) - EOL - (TAB tabs) + if null exprs + then + let eol' = inlinedEOL (not (hasEOL taus)) + in EX_APPLICATION_TAUS + expr' + eol' + (tabOfEOL eol' next) + (toCST taus next eol' :: BINDING) + eol' + (tabOfEOL eol' tabs) + next + else + let eol' = inlinedEOL (not (hasEOL exprs)) + in EX_APPLICATION_EXPRS + expr' + eol' + (tabOfEOL eol' next) + (toCST exprs next eol') + eol' + (tabOfEOL eol' tabs) + next where + primitives :: [String] + primitives = ["number", "string"] + withoutRhosInPrimitives :: Expression -> [Binding] -> ([Binding], [Binding]) + withoutRhosInPrimitives _ [] = ([], []) + withoutRhosInPrimitives obj@(BaseObject label) bds@(rho@(BiTau AtRho _) : rest) + | label `elem` primitives = + let (bds', rhos) = withoutRhosInPrimitives obj rest + in (bds', rho : rhos) + | otherwise = (bds, []) + withoutRhosInPrimitives obj@(BaseObject label) bds@(bd : rest) + | label `elem` primitives = + let (bds', rhos) = withoutRhosInPrimitives obj rest + in (bd : bds', rhos) + | otherwise = (bds, []) + withoutRhosInPrimitives _ bds = (bds, []) + applicationToPrimitive :: Expression -> Integer -> [Binding] -> EXPRESSION + applicationToPrimitive (DataNumber bts) tabs = EX_NUMBER (btsToNum bts) (TAB tabs) + applicationToPrimitive (DataString bts) tabs = EX_STRING (btsToStr bts) (TAB tabs) -- Here we unroll nested application sequence into flat structure -- The returned tuple consists of: -- 1. deepest start expression @@ -237,89 +278,114 @@ -- 3. list of expressions which are applied to start expression with default -- alpha attributes (~0 -> e1, ~1 -> e2, ...) complexApplication :: Expression -> (Expression, [Binding], [Expression]) - complexApplication (ExApplication (ExApplication expr tau) tau') = - let (before, taus, exprs) = complexApplication (ExApplication expr tau) - taus' = tau' : taus - in if null exprs - then (before, taus', []) - else case tau' of - BiTau (AtAlpha idx) expr' -> - if idx == fromIntegral (length exprs) - then (before, taus', expr' : exprs) - else (before, taus', []) - _ -> (before, taus', []) - complexApplication (ExApplication expr (BiTau (AtAlpha 0) expr')) = (expr, [BiTau (AtAlpha 0) expr'], [expr']) - complexApplication (ExApplication expr tau) = (expr, [tau], []) + complexApplication expr = + let (expr', taus', exprs') = complexApplication' expr + in (expr', reverse taus', reverse exprs') + where + complexApplication' :: Expression -> (Expression, [Binding], [Expression]) + complexApplication' (ExApplication (ExApplication expr tau) tau') = + let (before, taus, exprs) = complexApplication' (ExApplication expr tau) + taus' = tau' : taus + in if null exprs + then (before, taus', []) + else case tau' of + BiTau (AtAlpha idx) expr' -> + if idx == fromIntegral (length exprs) + then (before, taus', expr' : exprs) + else (before, taus', []) + _ -> (before, taus', []) + complexApplication' (ExApplication expr (BiTau (AtAlpha 0) expr')) = (expr, [BiTau (AtAlpha 0) expr'], [expr']) + complexApplication' (ExApplication expr tau) = (expr, [tau], []) instance ToCST [Expression] APP_ARG where - toCST (expr : exprs) tabs = APP_ARG (toCST expr tabs) (toCST exprs tabs) + toCST (expr : exprs) tabs eol = APP_ARG (toCST expr tabs eol) (toCST exprs tabs eol) instance ToCST [Expression] APP_ARGS where - toCST [] _ = AAS_EMPTY - toCST (expr : exprs) tabs = AAS_EXPR EOL (TAB tabs) (toCST expr tabs) (toCST exprs tabs) + toCST [] _ _ = AAS_EMPTY + toCST (expr : exprs) tabs eol = AAS_EXPR eol (tabOfEOL eol tabs) (toCST expr tabs eol) (toCST exprs tabs eol) instance ToCST [Binding] BINDING where - toCST [] tabs = BI_EMPTY (TAB tabs) - toCST (BiMeta mt : bds) tabs = BI_META (MT_BINDING (tail mt)) (toCST bds tabs) (TAB tabs) - toCST (bd : bds) tabs = BI_PAIR (toCST bd tabs) (toCST bds tabs) (TAB tabs) + toCST [] tabs _ = BI_EMPTY (TAB tabs) + toCST (BiMeta mt : bds) tabs eol = BI_META (MT_BINDING (tail mt)) (toCST bds tabs eol) (tabOfEOL eol tabs) + toCST (bd : bds) tabs eol = BI_PAIR (toCST bd tabs eol) (toCST bds tabs eol) (tabOfEOL eol tabs) instance ToCST [Binding] BINDINGS where - toCST [] tabs = BDS_EMPTY (TAB tabs) - toCST (BiMeta mt : bds) tabs = BDS_META EOL (TAB tabs) (MT_BINDING (tail mt)) (toCST bds tabs) - toCST (bd : bds) tabs = BDS_PAIR EOL (TAB tabs) (toCST bd tabs) (toCST bds tabs) + toCST [] tabs _ = BDS_EMPTY (TAB tabs) + toCST (BiMeta mt : bds) tabs eol = BDS_META eol (tabOfEOL eol tabs) (MT_BINDING (tail mt)) (toCST bds tabs eol) + toCST (bd : bds) tabs eol = BDS_PAIR eol (tabOfEOL eol tabs) (toCST bd tabs eol) (toCST bds tabs eol) instance ToCST Binding PAIR where - toCST (BiTau attr exp) tabs = PA_TAU (toCST attr tabs) ARROW (toCST exp tabs) - toCST (BiVoid attr) tabs = PA_VOID (toCST attr tabs) ARROW EMPTY - toCST (BiDelta bts) tabs = PA_DELTA (toCST bts tabs) - toCST (BiLambda func) _ = PA_LAMBDA func - toCST (BiMetaLambda mt) _ = PA_META_LAMBDA (MT_FUNCTION (tail mt)) + toCST (BiTau attr exp@(ExFormation bds)) tabs eol = + let voids' = voids bds + attr' = toCST attr tabs eol + in if null voids' + then PA_TAU attr' ARROW (toCST exp tabs eol) + else + let (_voids, _bds) = if length voids' == length bds && last voids' == AtRho then (init voids', []) else (voids', drop (length voids') bds) + in PA_FORMATION + attr' + (map (\at -> toCST at tabs eol) _voids) + ARROW + (toCST (ExFormation _bds) tabs eol) + where + voids :: [Binding] -> [Attribute] + voids [] = [] + voids (bd : bds) = case bd of + BiVoid attr -> attr : voids bds + _ -> [] + toCST (BiTau attr exp) tabs eol = PA_TAU (toCST attr tabs eol) ARROW (toCST exp tabs eol) + toCST (BiVoid attr) tabs eol = PA_VOID (toCST attr tabs eol) ARROW EMPTY + toCST (BiDelta bts) tabs eol = PA_DELTA (toCST bts tabs eol) + toCST (BiLambda func) _ _ = PA_LAMBDA func + toCST (BiMetaLambda mt) _ _ = PA_META_LAMBDA (MT_FUNCTION (tail mt)) +instance ToCST Binding APP_BINDING where + toCST bd@(BiTau _ _) tabs eol = APP_BINDING (toCST bd tabs eol :: PAIR) + instance ToCST Bytes BYTES where - toCST BtEmpty _ = BT_EMPTY - toCST (BtOne byte) _ = BT_ONE byte - toCST (BtMany bts) _ = BT_MANY bts - toCST (BtMeta mt) _ = BT_META (MT_BYTES (tail mt)) + toCST BtEmpty _ _ = BT_EMPTY + toCST (BtOne byte) _ _ = BT_ONE byte + toCST (BtMany bts) _ _ = BT_MANY bts + toCST (BtMeta mt) _ _ = BT_META (MT_BYTES (tail mt)) instance ToCST Attribute ATTRIBUTE where - toCST (AtLabel label) _ = AT_LABEL label - toCST (AtAlpha idx) _ = AT_ALPHA ALPHA idx - toCST AtPhi _ = AT_PHI PHI - toCST AtRho _ = AT_RHO RHO - toCST AtDelta _ = AT_DELTA DELTA - toCST AtLambda _ = AT_LAMBDA LAMBDA - toCST (AtMeta mt) _ = AT_META (MT_ATTRIBUTE (tail mt)) + toCST (AtLabel label) _ _ = AT_LABEL label + toCST (AtAlpha idx) _ _ = AT_ALPHA ALPHA idx + toCST AtPhi _ _ = AT_PHI PHI + toCST AtRho _ _ = AT_RHO RHO + toCST AtDelta _ _ = AT_DELTA DELTA + toCST AtLambda _ _ = AT_LAMBDA LAMBDA + toCST (AtMeta mt) _ _ = AT_META (MT_ATTRIBUTE (tail mt)) -class HasEOL a where - hasEOL :: a -> Bool +inlinedEOL :: Bool -> EOL +inlinedEOL True = NO_EOL +inlinedEOL False = EOL -instance HasEOL EXPRESSION where - hasEOL EX_FORMATION {eol = NO_EOL, binding, eol' = NO_EOL} = hasEOL binding - hasEOL EX_FORMATION {..} = True - hasEOL EX_DISPATCH {..} = hasEOL expr - hasEOL EX_APPLICATION {eol = NO_EOL, expr, bindings, eol' = NO_EOL} = hasEOL expr || hasEOL bindings - hasEOL EX_APPLICATION {..} = True - hasEOL EX_APPLICATION' {eol = NO_EOL, expr, args, eol' = NO_EOL} = hasEOL expr || hasEOL args - hasEOL EX_APPLICATION' {..} = True - hasEOL _ = False +tabOfEOL :: EOL -> Integer -> TAB +tabOfEOL EOL indent = TAB indent +tabOfEOL NO_EOL _ = TAB' -instance HasEOL BINDING where - hasEOL BI_EMPTY {..} = False - hasEOL BI_PAIR {..} = hasEOL pair || hasEOL bindings +class HasEOL a where + hasEOL :: a -> Bool -instance HasEOL BINDINGS where - hasEOL BDS_PAIR {eol = NO_EOL, pair, bindings} = hasEOL pair || hasEOL bindings - hasEOL BDS_PAIR {..} = True - hasEOL BDS_EMPTY {..} = False +instance HasEOL [Binding] where + hasEOL [] = False + hasEOL (bd : rest) = hasEOL bd || hasEOL rest -instance HasEOL PAIR where - hasEOL PA_TAU {..} = hasEOL expr - hasEOL _ = False +instance HasEOL Binding where + hasEOL (BiTau _ expr) = hasEOL expr + hasEOL bd = False -instance HasEOL APP_ARG where - hasEOL APP_ARG {..} = hasEOL expr || hasEOL args +instance HasEOL [Expression] where + hasEOL [] = False + hasEOL (expr : rest) = hasEOL expr || hasEOL rest -instance HasEOL APP_ARGS where - hasEOL AAS_EMPTY = False - hasEOL AAS_EXPR {eol = NO_EOL, expr, args} = hasEOL expr || hasEOL args - hasEOL AAS_EXPR {..} = True +instance HasEOL Expression where + hasEOL (ExFormation []) = False + hasEOL (ExFormation _) = True + hasEOL (DataNumber _) = False + hasEOL (DataString _) = False + hasEOL (BaseObject _) = False + hasEOL (ExDispatch expr _) = hasEOL expr + hasEOL (ExApplication expr tau) = hasEOL expr || hasEOL tau + hasEOL expr = False diff --git a/src/Condition.hs b/src/Condition.hs new file mode 100644 --- /dev/null +++ b/src/Condition.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE RecordWildCards #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module Condition (parseCondition, parseConditionThrows) where + +import Control.Exception (Exception) +import Control.Exception.Base (throwIO) +import Data.Void (Void) +import Parser (PhiParser (..), phiParser) +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L +import qualified Yaml as Y +import Text.Printf (printf) + +newtype ConditionException = CouldNotParseCondition {message :: String} + deriving (Exception) + +instance Show ConditionException where + show CouldNotParseCondition {..} = printf "Couldn't parse given condition, cause: %s" message + +type Parser = Parsec Void String + +-- White space consumer +whiteSpace :: Parser () +whiteSpace = L.space hspace1 empty empty + +-- Lexeme that ignores white spaces after +lexeme :: Parser a -> Parser a +lexeme = L.lexeme whiteSpace + +-- Strict symbol (or sequence of symbols) with ignored white spaces after +symbol :: String -> Parser String +symbol = L.symbol whiteSpace + +lparen :: Parser String +lparen = symbol "(" + +rparen :: Parser String +rparen = symbol ")" + +comma :: Parser String +comma = symbol "," + +number :: Parser Y.Number +number = + choice + [ do + _ <- symbol "ordinal" >> lparen + attr <- _attribute phiParser + _ <- rparen + return (Y.Ordinal attr), + do + _ <- symbol "length" >> lparen + bd <- _binding phiParser + _ <- rparen + return (Y.Length bd), + do + sign <- optional (choice [char '-', char '+']) + unsigned <- lexeme L.decimal + return + ( Y.Literal + ( case sign of + Just '-' -> negate unsigned + _ -> unsigned + ) + ) + ] + +comparable :: Parser Y.Comparable +comparable = + choice + [ try $ Y.CmpNum <$> number, + try $ Y.CmpAttr <$> _attribute phiParser, + Y.CmpExpr <$> _expression phiParser + ] + +condition :: Parser Y.Condition +condition = + choice + [ do + _ <- symbol "and" >> lparen + args <- condition `sepBy1` comma + _ <- rparen + return (Y.And args), + do + _ <- symbol "or" >> lparen + args <- condition `sepBy1` comma + _ <- rparen + return (Y.Or args), + do + _ <- symbol "in" >> lparen + attr <- _attribute phiParser + _ <- comma + bd <- _binding phiParser + _ <- rparen + return (Y.In attr bd), + do + _ <- symbol "not" >> lparen + cond <- condition + _ <- rparen + return (Y.Not cond), + do + _ <- symbol "alpha" >> lparen + attr <- _attribute phiParser + _ <- rparen + return (Y.Alpha attr), + do + _ <- symbol "eq" >> lparen + left <- comparable + _ <- comma + right <- comparable + _ <- rparen + return (Y.Eq left right), + do + _ <- symbol "nf" >> lparen + expr <- _expression phiParser + _ <- rparen + return (Y.NF expr), + do + _ <- symbol "xi" >> lparen + expr <- _expression phiParser + _ <- rparen + return (Y.XI expr), + do + _ <- symbol "matches" >> lparen + ptn <- _string phiParser + _ <- comma + expr <- _expression phiParser + _ <- rparen + return (Y.Matches ptn expr), + do + _ <- symbol "part-of" >> lparen + expr <- _expression phiParser + _ <- comma + bd <- _binding phiParser + _ <- rparen + return (Y.PartOf expr bd) + ] + +parseCondition :: String -> Either String Y.Condition +parseCondition input = do + let parsed = + runParser + ( do + _ <- whiteSpace + p <- condition + _ <- eof + return p + ) + "condition" + input + case parsed of + Right parsed' -> Right parsed' + Left err -> Left (errorBundlePretty err) + +parseConditionThrows :: String -> IO Y.Condition +parseConditionThrows cnd = case parseCondition cnd of + Right condition -> pure condition + Left err -> throwIO (CouldNotParseCondition err) diff --git a/src/Dataize.hs b/src/Dataize.hs --- a/src/Dataize.hs +++ b/src/Dataize.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} @@ -9,16 +10,23 @@ import AST import Builder (contextualize) import Control.Exception (throwIO) +import Data.IntMap (restrictKeys) import Data.List (partition) import Deps (BuildTermFunc, SaveStepFunc) import Misc import Must (Must (..)) -import Rewriter (RewriteContext (RewriteContext), Rewritten (Rewritten, program), rewrite') +import Rewriter (RewriteContext (RewriteContext), Rewritten, rewrite') import Rule (RuleContext (RuleContext), isNF) import Text.Printf (printf) import XMIR (XmirContext (XmirContext)) import Yaml (normalizationRules) +type Dataized = (Maybe Bytes, [Rewritten]) + +type Dataizable = (Expression, [Rewritten]) + +type Morphed = Dataizable + data DataizeContext = DataizeContext { _program :: Program, _maxDepth :: Integer, @@ -34,7 +42,6 @@ _maxDepth _maxCycles _depthSensitive - False _buildTerm MtDisabled _saveStep @@ -56,50 +63,58 @@ maybePhi :: [Binding] -> (Maybe Binding, [Binding]) maybePhi = maybeBinding (\case (BiTau AtPhi _) -> True; _ -> False) -formation :: [Binding] -> DataizeContext -> IO (Maybe Expression) +-- Resolve formation for LAMBDA Morphing rule. +-- If formation contains Ī» binding, the called atom +-- result is returned. +formation :: [Binding] -> DataizeContext -> IO (Maybe (Expression, String)) formation bds ctx = do let (lambda, bds') = maybeLambda bds case lambda of Just (BiLambda func) -> do - obj' <- atom func (ExFormation bds') ctx - case obj' of - Just obj -> pure (Just obj) - _ -> pure Nothing + obj <- atom func (ExFormation bds') ctx + pure (Just (obj, "M(lambda)")) _ -> pure Nothing -phiDispatch :: String -> Expression -> Maybe Expression -phiDispatch attr expr = case expr of +-- Resolve dispatch from global object (Q.tau) for PHI Morphing rule. +-- Here tau is the name of the attribute which is taken from Q +-- and expr is expression which program refers to. +-- If Q refers to formation which contains binding with attribute == tau - +-- the expression from this binding is returned. +phiDispatch :: String -> Expression -> Maybe (Expression, String) +phiDispatch tau expr = case expr of ExFormation bds -> boundExpr bds _ -> Nothing where - boundExpr :: [Binding] -> Maybe Expression + boundExpr :: [Binding] -> Maybe (Expression, String) boundExpr [] = Nothing boundExpr (bd : bds) = case bd of - BiTau (AtLabel attr') expr' -> if attr' == attr then Just expr' else boundExpr bds + BiTau (AtLabel attr) expr' -> if attr == tau then Just (expr', "M(phi)") else boundExpr bds _ -> boundExpr bds -withTail :: Expression -> DataizeContext -> IO (Maybe Expression) +-- Resolve tail PHI and LAMBDA Morphing rules. +-- Tail MUST start with dispatch, that's why most of the applications return Nothing +withTail :: Expression -> DataizeContext -> IO (Maybe (Expression, String)) withTail (ExApplication (ExFormation _) _) _ = pure Nothing withTail (ExApplication (ExDispatch ExGlobal _) _) _ = pure Nothing withTail (ExApplication expr tau) ctx = do - exp' <- withTail expr ctx - case exp' of - Just exp -> pure (Just (ExApplication exp tau)) + tailed <- withTail expr ctx + case tailed of + Just (exp, rule) -> pure (Just (ExApplication exp tau, rule)) _ -> pure Nothing withTail (ExDispatch (ExFormation bds) attr) ctx = do - obj' <- formation bds ctx - case obj' of - Just obj -> pure (Just (ExDispatch obj attr)) + tailed <- formation bds ctx + case tailed of + 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 -> pure (Just (ExDispatch obj attr)) + 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 - exp' <- withTail expr ctx - case exp' of - Just exp -> pure (Just (ExDispatch exp attr)) + tailed <- withTail expr ctx + case tailed of + Just (exp, rule) -> pure (Just (ExDispatch exp attr, rule)) _ -> pure Nothing withTail _ _ = pure Nothing @@ -114,24 +129,26 @@ -- 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 -morph :: Expression -> DataizeContext -> IO (Maybe Expression) -morph ExTermination _ = pure (Just ExTermination) -- PRIM -morph (ExFormation bds) ctx = do - resolved <- withTail (ExFormation bds) ctx +-- M(e) -> āŠ„ otherwise +morph :: Morphed -> DataizeContext -> IO Morphed +morph (ExTermination, seq) _ = pure (ExTermination, leadsTo seq "M(prim)" ExTermination) -- PRIM +morph (form@(ExFormation bds), seq) ctx = do + resolved <- withTail form ctx case resolved of - Just obj -> morph obj ctx -- LAMBDA or PHI - _ -> pure (Just (ExFormation bds)) -- PRIM -morph expr ctx = do + Just (expr, rule) -> morph (expr, leadsTo seq rule expr) ctx -- LAMBDA or PHI + _ -> pure (form, leadsTo seq "M(prim)" form) -- PRIM +morph (expr, seq) ctx = do resolved <- withTail expr ctx case resolved of - Just obj -> morph obj ctx + Just (expr', rule) -> morph (expr', leadsTo seq rule expr') ctx _ -> if isNF expr (RuleContext (_buildTerm ctx)) - then pure Nothing + then morph (ExTermination, seq) ctx -- PRIM else do - [Rewritten {program = Program expr'}] <- rewrite' (Program expr) normalizationRules (switchContext ctx) -- NMZ - morph expr' ctx + rewrittens' <- rewrite' (Program expr) normalizationRules (switchContext ctx) -- NMZ + let _seq = reverse rewrittens' <> tail seq + (Program expr') = fst (head _seq) + morph (expr', _seq) ctx -- The goal of 'dataize' function is retrieve bytes from given expression. -- @@ -139,62 +156,61 @@ -- 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 -> DataizeContext -> IO (Maybe Bytes) -dataize (Program expr) = dataize' expr +dataize :: Program -> DataizeContext -> IO Dataized +dataize (Program expr) ctx = do + (maybeBytes, seq) <- dataize' (expr, [(Program expr, Nothing)]) ctx + pure (maybeBytes, reverse seq) -dataize' :: Expression -> DataizeContext -> IO (Maybe Bytes) -dataize' ExTermination _ = pure Nothing -dataize' (ExFormation bds) ctx = case maybeDelta bds of - (Just (BiDelta bytes), _) -> pure (Just bytes) +dataize' :: Dataizable -> DataizeContext -> IO Dataized +dataize' (ExTermination, seq) _ = pure (Nothing, seq) +dataize' (ExFormation bds, seq) ctx = case maybeDelta bds of + (Just (BiDelta bytes), _) -> pure (Just bytes, 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") (_, _) -> let expr' = contextualize expr (ExFormation bds) - in dataize' expr' ctx + in dataize' (expr', leadsTo seq "contextualize" expr') ctx (Nothing, _) -> case maybeLambda bds of - (Just (BiLambda _), _) -> do - morphed' <- morph (ExFormation bds) ctx - case morphed' of - Just morphed -> dataize' morphed ctx - _ -> pure Nothing - (Nothing, _) -> pure Nothing -dataize' expr prog = do - morphed' <- morph expr prog - case morphed' of - Just morphed -> dataize' morphed prog - _ -> pure Nothing + (Just (BiLambda _), _) -> morph (ExFormation bds, seq) ctx >>= (`dataize'` ctx) + (Nothing, _) -> pure (Nothing, seq) +dataize' dataizable ctx = morph dataizable ctx >>= (`dataize'` ctx) -atom :: String -> Expression -> DataizeContext -> IO (Maybe Expression) +leadsTo :: [Rewritten] -> String -> Expression -> [Rewritten] +leadsTo seq rule expr = + let (prog, _) : rest = seq + in (Program expr, Nothing) : (prog, Just rule) : rest + +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 (Program (ExDispatch self (AtLabel "x"))) ctx + (right, _) <- dataize (Program (ExDispatch self AtRho)) ctx case (left, right) of (Just left', Just right') -> do let first = either toDouble id (btsToNum left') second = either toDouble id (btsToNum right') sum = first + second - pure (Just (DataNumber (numToBts sum))) - _ -> pure Nothing + 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 (Program (ExDispatch self (AtLabel "x"))) ctx + (right, _) <- dataize (Program (ExDispatch self AtRho)) ctx case (left, right) of (Just left', Just right') -> do let first = either toDouble id (btsToNum left') second = either toDouble id (btsToNum right') sum = first * second - pure (Just (DataNumber (numToBts sum))) - _ -> pure Nothing + 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 (Program (ExDispatch self (AtLabel "x"))) ctx + (rho, _) <- dataize (Program (ExDispatch self AtRho)) ctx case (x, rho) of (Just x', Just rho') -> do let self' = either toDouble id (btsToNum rho') first = either toDouble id (btsToNum x') if self' == first - then pure (Just (DataNumber (numToBts first))) - else pure (Just (ExDispatch self (AtLabel "y"))) - _ -> pure Nothing + then pure (DataNumber (numToBts first)) + else pure (ExDispatch self (AtLabel "y")) + _ -> pure ExTermination atom func _ _ = throwIO (userError (printf "Atom '%s' does not exist" func)) diff --git a/src/Encoding.hs b/src/Encoding.hs --- a/src/Encoding.hs +++ b/src/Encoding.hs @@ -29,12 +29,16 @@ toASCII EX_TERMINATION {..} = EX_TERMINATION T toASCII EX_FORMATION {..} = EX_FORMATION LSB' eol tab (toASCII binding) eol' tab' RSB' toASCII EX_DISPATCH {..} = EX_DISPATCH (toASCII expr) (toASCII attr) - toASCII EX_APPLICATION {..} = EX_APPLICATION (toASCII expr) eol tab (toASCII bindings) eol' tab' - toASCII EX_APPLICATION' {..} = EX_APPLICATION' (toASCII expr) eol tab (toASCII args) eol' tab' + toASCII EX_APPLICATION {..} = EX_APPLICATION (toASCII expr) eol tab (toASCII tau) eol' tab' indent + toASCII EX_APPLICATION_TAUS {..} = EX_APPLICATION_TAUS (toASCII expr) eol tab (toASCII taus) eol' tab' indent + toASCII EX_APPLICATION_EXPRS {..} = EX_APPLICATION_EXPRS (toASCII expr) eol tab (toASCII args) eol' tab' indent toASCII EX_META {..} = EX_META (MT_EXPRESSION' (rest meta)) toASCII EX_META_TAIL {..} = EX_META_TAIL (toASCII expr) (MT_TAIL (rest meta)) toASCII expr = expr +instance ToASCII APP_BINDING where + toASCII APP_BINDING {..} = APP_BINDING (toASCII pair) + instance ToASCII BINDING where toASCII BI_PAIR {..} = BI_PAIR (toASCII pair) (toASCII bindings) tab toASCII BI_META {..} = BI_META (MT_BINDING' (rest meta)) (toASCII bindings) tab @@ -54,6 +58,7 @@ instance ToASCII PAIR where toASCII PA_TAU {..} = PA_TAU (toASCII attr) ARROW' (toASCII expr) + toASCII PA_FORMATION{..} = PA_FORMATION (toASCII attr) (map toASCII voids) ARROW' (toASCII expr) toASCII PA_VOID {..} = PA_VOID (toASCII attr) ARROW' QUESTION toASCII PA_LAMBDA {..} = PA_LAMBDA' func toASCII PA_DELTA {..} = PA_DELTA' bytes diff --git a/src/Functions.hs b/src/Functions.hs --- a/src/Functions.hs +++ b/src/Functions.hs @@ -108,7 +108,7 @@ _concat :: BuildTermMethod _concat args subst = do - args' <- traverse (\arg -> argToString arg subst) args + args' <- traverse (`argToString` subst) args pure (TeExpression (DataString (strToBts (concat args')))) _sed :: BuildTermMethod diff --git a/src/Hide.hs b/src/Hide.hs --- a/src/Hide.hs +++ b/src/Hide.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} - -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT @@ -35,10 +33,10 @@ hiddenBindings (bd@(BiTau attr form@(ExFormation _)) : bds) attrs@(attr' : rest) | attr == attr' = BiTau attr (hiddenFormation form rest) : bds | otherwise = bd : hiddenBindings bds attrs - hiddenBindings bds _ = bds + hiddenBindings (bd : bds) attrs = bd : hiddenBindings bds attrs hiddenFormation expr attr = expr hide' prog (fqn : rest) = prog hide :: [Rewritten] -> [Expression] -> [Rewritten] hide [] _ = [] -hide (Rewritten {..} : rest) exprs = Rewritten (hide' program exprs) maybeRule : hide rest exprs +hide ((program, maybeRule) : rest) exprs = (hide' program exprs, maybeRule) : hide rest exprs diff --git a/src/LaTeX.hs b/src/LaTeX.hs --- a/src/LaTeX.hs +++ b/src/LaTeX.hs @@ -40,28 +40,18 @@ let equation = phiquation ctx in concat [ printf "\\begin{%s}\n" equation, - case label of - Just lbl -> printf "\\label{%s}\n" lbl - _ -> "", - case expression of - Just expr -> printf "\\phiExpression{%s} " expr - _ -> "", + maybe "" (printf "\\label{%s}\n") label, + maybe "" (printf "\\phiExpression{%s} ") expression, intercalate "\n \\leadsto " ( map - ( \Rewritten {..} -> + ( \(program, maybeName) -> let prog = renderToLatex program ctx - unknown = "unknown" - maybeTo = case maybeRule of - Just (Y.Rule {..}) -> Just (map toLower (fromMaybe unknown name)) - _ -> Nothing - in case maybeTo of - Just name -> printf "%s \\leadsto_{\\nameref{r:%s}}" prog name - _ -> prog + in maybe prog (printf "%s \\leadsto_{\\nameref{r:%s}}" prog) maybeName ) rewrittens ), - printf "\n\\end{%s}" equation + printf ".\n\\end{%s}" equation ] programToLaTeX :: Program -> LatexContext -> String @@ -90,8 +80,9 @@ instance ToLaTeX EXPRESSION where toLaTeX EX_ATTR {..} = EX_ATTR (toLaTeX attr) toLaTeX EX_FORMATION {..} = EX_FORMATION lsb eol tab (toLaTeX binding) eol' tab' rsb - toLaTeX EX_APPLICATION {..} = EX_APPLICATION (toLaTeX expr) eol tab (toLaTeX bindings) eol' tab' - toLaTeX EX_APPLICATION' {..} = EX_APPLICATION' (toLaTeX expr) eol tab (toLaTeX args) eol' tab' + toLaTeX EX_APPLICATION {..} = EX_APPLICATION (toLaTeX expr) eol tab (toLaTeX tau) eol' tab' indent + toLaTeX EX_APPLICATION_TAUS {..} = EX_APPLICATION_TAUS (toLaTeX expr) eol tab (toLaTeX taus) eol' tab' indent + toLaTeX EX_APPLICATION_EXPRS {..} = EX_APPLICATION_EXPRS (toLaTeX expr) eol tab (toLaTeX args) eol' tab' indent toLaTeX EX_DISPATCH {..} = EX_DISPATCH (toLaTeX expr) (toLaTeX attr) toLaTeX expr = expr @@ -99,6 +90,9 @@ toLaTeX AT_LABEL {..} = AT_LABEL (piped (toLaTeX label)) toLaTeX attr = attr +instance ToLaTeX APP_BINDING where + toLaTeX APP_BINDING {..} = APP_BINDING (toLaTeX pair) + instance ToLaTeX BINDING where toLaTeX BI_PAIR {..} = BI_PAIR (toLaTeX pair) (toLaTeX bindings) tab toLaTeX bd = bd @@ -113,6 +107,7 @@ toLaTeX PA_LAMBDA' {..} = PA_LAMBDA' (piped (toLaTeX func)) toLaTeX PA_VOID {..} = PA_VOID (toLaTeX attr) arrow void toLaTeX PA_TAU {..} = PA_TAU (toLaTeX attr) arrow (toLaTeX expr) + toLaTeX PA_FORMATION {..} = PA_FORMATION (toLaTeX attr) (map toLaTeX voids) arrow (toLaTeX expr) toLaTeX pair = pair instance ToLaTeX APP_ARG where diff --git a/src/Lining.hs b/src/Lining.hs --- a/src/Lining.hs +++ b/src/Lining.hs @@ -26,10 +26,14 @@ toSingleLine EX_FORMATION {lsb, binding = bd@BI_EMPTY {..}, rsb} = EX_FORMATION lsb NO_EOL NO_TAB bd NO_EOL NO_TAB rsb toSingleLine EX_FORMATION {..} = EX_FORMATION lsb NO_EOL TAB' (toSingleLine binding) NO_EOL TAB' rsb toSingleLine EX_DISPATCH {..} = EX_DISPATCH (toSingleLine expr) attr - toSingleLine EX_APPLICATION {..} = EX_APPLICATION (toSingleLine expr) NO_EOL TAB' (toSingleLine bindings) NO_EOL TAB' - toSingleLine EX_APPLICATION' {..} = EX_APPLICATION' (toSingleLine expr) NO_EOL TAB' (toSingleLine args) NO_EOL TAB' + toSingleLine EX_APPLICATION {..} = EX_APPLICATION (toSingleLine expr) NO_EOL TAB' (toSingleLine tau) NO_EOL TAB' indent + toSingleLine EX_APPLICATION_TAUS {..} = EX_APPLICATION_TAUS (toSingleLine expr) NO_EOL TAB' (toSingleLine taus) NO_EOL TAB' indent + toSingleLine EX_APPLICATION_EXPRS {..} = EX_APPLICATION_EXPRS (toSingleLine expr) NO_EOL TAB' (toSingleLine args) NO_EOL TAB' indent toSingleLine expr = expr +instance ToSingleLine APP_BINDING where + toSingleLine APP_BINDING {..} = APP_BINDING (toSingleLine pair) + instance ToSingleLine BINDING where toSingleLine BI_PAIR {..} = BI_PAIR (toSingleLine pair) (toSingleLine bindings) TAB' toSingleLine BI_META {..} = BI_META meta (toSingleLine bindings) TAB' @@ -42,6 +46,7 @@ instance ToSingleLine PAIR where toSingleLine PA_TAU {..} = PA_TAU attr arrow (toSingleLine expr) + toSingleLine PA_FORMATION {..} = PA_FORMATION attr voids arrow (toSingleLine expr) toSingleLine pair = pair instance ToSingleLine APP_ARG where diff --git a/src/Logger.hs b/src/Logger.hs --- a/src/Logger.hs +++ b/src/Logger.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT @@ -6,32 +8,42 @@ logInfo, logWarning, logError, - setLogLevel, + setLogConfig, LogLevel (DEBUG, INFO, WARNING, ERROR, NONE), ) where import Control.Monad (when) import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import qualified Data.List as DL import GHC.IO (unsafePerformIO) import System.IO data LogLevel = DEBUG | INFO | WARNING | ERROR | NONE deriving (Show, Ord, Eq, Bounded, Enum, Read) -newtype Logger = Logger {level :: LogLevel} +data Logger = Logger {level :: LogLevel, lines :: Int} logger :: IORef Logger {-# NOINLINE logger #-} -logger = unsafePerformIO (newIORef (Logger INFO)) +logger = unsafePerformIO (newIORef (Logger INFO 25)) -setLogLevel :: LogLevel -> IO () -setLogLevel lvl = writeIORef logger (Logger lvl) +setLogConfig :: LogLevel -> Integer -> IO () +setLogConfig lvl lines = writeIORef logger (Logger lvl (fromIntegral lines)) logMessage :: LogLevel -> String -> IO () logMessage lvl message = do - log <- readIORef logger - when (lvl >= level log) $ hPutStrLn stderr ("[" ++ show lvl ++ "]: " ++ message) + Logger {..} <- readIORef logger + when + (lvl >= level && lines /= 0) + ( let lines' = DL.lines message + toPrint = take lines lines' + msg + | lines == -1 = [message] + | length lines' > lines = toPrint ++ ["---| log is limited by --log-lines=" ++ show lines ++ " option |---"] + | otherwise = toPrint + in hPutStrLn stderr ("[" ++ show lvl ++ "]: " ++ DL.intercalate "\n" msg) + ) logDebug, logInfo, logWarning, logError :: String -> IO () logDebug = logMessage DEBUG diff --git a/src/Misc.hs b/src/Misc.hs --- a/src/Misc.hs +++ b/src/Misc.hs @@ -26,9 +26,11 @@ uniqueBindings, uniqueBindings', validateYamlObject, + matchDataObject, pattern DataObject, pattern DataString, pattern DataNumber, + pattern BaseObject, ) where @@ -69,15 +71,24 @@ show FileDoesNotExist {..} = printf "File '%s' does not exist" file show DirectoryDoesNotExist {..} = printf "Directory '%s' does not exist" dir +matchBaseObject :: Expression -> Maybe String +matchBaseObject (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel label)) = Just label +matchBaseObject _ = Nothing + +pattern BaseObject :: String -> Expression +pattern BaseObject label <- (matchBaseObject -> Just label) + where + BaseObject label = ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel label) + -- Minimal matcher function (required for view pattern) matchDataObject :: Expression -> Maybe (String, Bytes) matchDataObject ( ExApplication - (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel label)) + (BaseObject label) ( BiTau (AtAlpha 0) ( ExApplication - (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "bytes")) + (BaseObject "bytes") ( BiTau (AtAlpha 0) (ExFormation [BiDelta bts, BiVoid AtRho]) @@ -98,11 +109,11 @@ where DataObject label bts = ExApplication - (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel label)) + (BaseObject label) ( BiTau (AtAlpha 0) ( ExApplication - (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "bytes")) + (BaseObject "bytes") ( BiTau (AtAlpha 0) (ExFormation [BiDelta bts, BiVoid AtRho]) diff --git a/src/Must.hs b/src/Must.hs --- a/src/Must.hs +++ b/src/Must.hs @@ -1,10 +1,11 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module Must (Must (..), inRange, exceedsUpperBound) where +module Must (Must (..), inRange, exceedsUpperBound, validateMust) where import Data.List (isInfixOf) import Text.Read (readMaybe) +import Text.Printf (printf) data Must = MtDisabled @@ -63,3 +64,15 @@ exceedsUpperBound (MtExact n) current = current > n exceedsUpperBound (MtRange _ (Just max)) current = current > max exceedsUpperBound (MtRange _ Nothing) _ = False + +validateMust :: Must -> Maybe String +validateMust MtDisabled = Nothing +validateMust (MtExact n) | n <= 0 = Just "--must exact value must be positive" +validateMust (MtRange (Just minVal) _) | minVal < 0 = Just "--must minimum must be non-negative" +validateMust (MtRange _ (Just maxVal)) | maxVal < 0 = Just "--must maximum must be non-negative" +validateMust (MtRange Nothing _) = Nothing +validateMust (MtRange _ Nothing) = Nothing +validateMust (MtRange (Just min) (Just max)) + | min > max = Just (printf "--must range invalid: minimum (%d) is greater than maximum (%d)" min max) + | otherwise = Nothing +validateMust _ = Nothing diff --git a/src/Parser.hs b/src/Parser.hs --- a/src/Parser.hs +++ b/src/Parser.hs @@ -16,6 +16,8 @@ parseNumberThrows, parseBinding, parseBytes, + PhiParser (..), + phiParser, ) where @@ -42,6 +44,16 @@ | CouldNotParseNumber {message :: String} deriving (Exception) +data PhiParser = PhiParser + { _attribute :: Parser Attribute, + _binding :: Parser Binding, + _expression :: Parser Expression, + _string :: Parser String + } + +phiParser :: PhiParser +phiParser = PhiParser fullAttribute binding expression quotedStr + instance Show ParserException where show CouldNotParseProgram {..} = printf "Couldn't parse given phi program, cause: %s" message show CouldNotParseExpression {..} = printf "Couldn't parse given phi expression, cause: %s" message @@ -66,55 +78,6 @@ rest <- many (satisfy (`notElem` " \r\n\t,.|':;!?][}{)(āŸ§āŸ¦") "allowed character") return (first : rest) -escapedChar :: Parser Char -escapedChar = do - _ <- char '\\' - c <- oneOf ['\\', '"', 'n', 'r', 't', 'b', 'f', 'u', 'x'] - case c of - '\\' -> return '\\' - '"' -> return '"' - 'n' -> return '\n' - 'r' -> return '\r' - 't' -> return '\t' - 'b' -> return '\b' - 'f' -> return '\f' - 'u' -> unicodeEscape - 'x' -> hexEscape - _ -> fail ("Unknown escape: \\" ++ [c]) - where - unicodeEscape :: Parser Char - unicodeEscape = do - hexDigits <- count 4 hexDigitChar - case readHex hexDigits of - [(n, "")] -> - if n >= 0xD800 && n <= 0xDBFF - then -- High surrogate, look for low surrogate - do - _ <- string "\\u" - lowHexDigits <- count 4 hexDigitChar - case readHex lowHexDigits of - [(low, "")] -> - if low >= 0xDC00 && low <= 0xDFFF - then do - -- Valid surrogate pair, combine them - let codePoint = 0x10000 + ((n - 0xD800) * 0x400) + (low - 0xDC00) - return (chr codePoint) - else fail ("Invalid low surrogate: \\u" ++ lowHexDigits) - _ -> fail ("Invalid low surrogate hex: \\u" ++ lowHexDigits) - else - if n >= 0xDC00 && n <= 0xDFFF - then fail ("Unexpected low surrogate: \\u" ++ hexDigits) - else - if n >= 0 && n <= 0x10FFFF - then return (chr n) - else fail ("Invalid Unicode code point: \\u" ++ hexDigits) - hexEscape :: Parser Char - hexEscape = do - digits <- count 2 hexDigitChar - case readHex digits of - [(n, "")] -> return (chr n) - _ -> fail ("Invalid hex escape: \\x" ++ digits) - function :: Parser String function = lexeme $ do first <- oneOf ['A' .. 'Z'] @@ -220,6 +183,57 @@ ) ) +quotedStr :: Parser String +quotedStr = char '"' >> manyTill (choice [escapedChar, noneOf ['\\', '"']]) (char '"') + where + escapedChar :: Parser Char + escapedChar = do + _ <- char '\\' + c <- oneOf ['\\', '"', 'n', 'r', 't', 'b', 'f', 'u', 'x'] + case c of + '\\' -> return '\\' + '"' -> return '"' + 'n' -> return '\n' + 'r' -> return '\r' + 't' -> return '\t' + 'b' -> return '\b' + 'f' -> return '\f' + 'u' -> unicodeEscape + 'x' -> hexEscape + _ -> fail ("Unknown escape: \\" ++ [c]) + unicodeEscape :: Parser Char + unicodeEscape = do + hexDigits <- count 4 hexDigitChar + case readHex hexDigits of + [(n, "")] -> + if n >= 0xD800 && n <= 0xDBFF + then -- High surrogate, look for low surrogate + do + _ <- string "\\u" + lowHexDigits <- count 4 hexDigitChar + case readHex lowHexDigits of + [(low, "")] -> + if low >= 0xDC00 && low <= 0xDFFF + then do + -- Valid surrogate pair, combine them + let codePoint = 0x10000 + ((n - 0xD800) * 0x400) + (low - 0xDC00) + return (chr codePoint) + else fail ("Invalid low surrogate: \\u" ++ lowHexDigits) + _ -> fail ("Invalid low surrogate hex: \\u" ++ lowHexDigits) + else + if n >= 0xDC00 && n <= 0xDFFF + then fail ("Unexpected low surrogate: \\u" ++ hexDigits) + else + if n >= 0 && n <= 0x10FFFF + then return (chr n) + else fail ("Invalid Unicode code point: \\u" ++ hexDigits) + hexEscape :: Parser Char + hexEscape = do + digits <- count 2 hexDigitChar + case readHex digits of + [(n, "")] -> return (chr n) + _ -> fail ("Invalid hex escape: \\x" ++ digits) + tauBinding :: Parser Attribute -> Parser Binding tauBinding attr = do attr' <- attr @@ -368,10 +382,7 @@ _ <- choice [symbol "T", symbol "āŠ„"] return ExTermination, number, - lexeme $ do - _ <- char '"' - str <- manyTill (choice [escapedChar, noneOf ['\\', '"']]) (char '"') - return (DataString (strToBts str)), + lexeme (DataString . strToBts <$> quotedStr), try (ExMeta <$> meta' 'e' "š‘’"), ExDispatch ExThis <$> attribute ] diff --git a/src/Printer.hs b/src/Printer.hs --- a/src/Printer.hs +++ b/src/Printer.hs @@ -14,6 +14,7 @@ printBytes, printExtraArg, printSubsts, + printSubsts', PrintConfig (..), logPrintConfig, ) @@ -52,7 +53,7 @@ printExpression expr = printExpression' expr defaultPrintConfig printAttribute' :: Attribute -> Encoding -> String -printAttribute' attr encoding = render (withEncoding encoding (toCST attr 0 :: ATTRIBUTE)) +printAttribute' attr encoding = render (withEncoding encoding (toCST attr 0 NO_EOL :: ATTRIBUTE)) printAttribute :: Attribute -> String printAttribute attr = @@ -66,7 +67,7 @@ printBinding bd = printBinding' bd defaultPrintConfig printBytes :: Bytes -> String -printBytes bts = render (toCST bts 0 :: BYTES) +printBytes bts = render (toCST bts 0 NO_EOL :: BYTES) printExtraArg' :: ExtraArgument -> PrintConfig -> String printExtraArg' (ArgAttribute attr) (_, encoding, _) = printAttribute' attr encoding @@ -91,13 +92,13 @@ printSubst :: Subst -> PrintConfig -> String printSubst (Subst mp) config = - " " - <> intercalate - "\n " - (map (\(key, value) -> key <> " >> " <> printMetaValue value config) (Map.toList mp)) + intercalate + "\n" + (map (\(key, value) -> key <> " >> " <> printMetaValue value config) (Map.toList mp)) printSubsts' :: [Subst] -> PrintConfig -> String -printSubsts' substs config = intercalate "\n---\n" (map (`printSubst` config) substs) +printSubsts' [] _ = "------" +printSubsts' substs config = intercalate "\n------\n" (map (`printSubst` config) substs) printSubsts :: [Subst] -> String printSubsts substs = printSubsts' substs defaultPrintConfig diff --git a/src/Render.hs b/src/Render.hs --- a/src/Render.hs +++ b/src/Render.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com @@ -125,6 +126,8 @@ instance Render PAIR where render PA_TAU {..} = render attr <> render SPACE <> render arrow <> render SPACE <> render expr + render PA_FORMATION {voids = [], attr, arrow, expr} = render (PA_TAU attr arrow expr) + render PA_FORMATION {..} = render attr <> "(" <> intercalate ", " (map render voids) <> ")" <> render SPACE <> render arrow <> render SPACE <> render expr render PA_LAMBDA {..} = render LAMBDA <> render SPACE <> render DASHED_ARROW <> render SPACE <> render func render PA_LAMBDA' {..} = "L> " <> func render PA_VOID {..} = render attr <> render SPACE <> render arrow <> render SPACE <> render void @@ -140,6 +143,9 @@ render BDS_PAIR {..} = render COMMA <> render eol <> render tab <> render pair <> render bindings render BDS_META {..} = render COMMA <> render eol <> render tab <> render meta <> render bindings +instance Render APP_BINDING where + render APP_BINDING {..} = render pair + instance Render BINDING where render BI_EMPTY {..} = "" render BI_PAIR {..} = render pair <> render bindings @@ -152,10 +158,6 @@ render AAS_EMPTY = "" render AAS_EXPR {..} = render COMMA <> render eol <> render tab <> render expr <> render args --- @todo #163:30min Introduce node for formation with inlined voids. --- We need to be able to print formation with inlined void attributes: --- x(a, b) -> [[ y -> 1 ]] => x -> [[ a -> ?, b -> ?, y -> 1 ]] --- Don't forget to extend toSalty instance so such sugar. instance Render EXPRESSION where render EX_GLOBAL {..} = render global render EX_DEF_PACKAGE {..} = render pckg @@ -164,8 +166,9 @@ render EX_TERMINATION {..} = render termination render EX_FORMATION {..} = render lsb <> render eol <> render tab <> render binding <> render eol' <> render tab' <> render rsb render EX_DISPATCH {..} = render expr <> "." <> render attr - render EX_APPLICATION {..} = render expr <> "(" <> render eol <> render tab <> render bindings <> render eol' <> render tab' <> ")" - render EX_APPLICATION' {..} = render expr <> "(" <> render eol <> render tab <> render args <> render eol' <> render tab' <> ")" + render EX_APPLICATION {..} = render expr <> "(" <> render eol <> render tab <> render tau <> render eol' <> render tab' <> ")" + render EX_APPLICATION_TAUS {..} = render expr <> "(" <> render eol <> render tab <> render taus <> render eol' <> render tab' <> ")" + render EX_APPLICATION_EXPRS {..} = render expr <> "(" <> render eol <> render tab <> render args <> render eol' <> render tab' <> ")" render EX_STRING {..} = '"' : render str <> "\"" render EX_NUMBER {..} = either show show num render EX_META {..} = render meta diff --git a/src/Rewriter.hs b/src/Rewriter.hs --- a/src/Rewriter.hs +++ b/src/Rewriter.hs @@ -7,11 +7,12 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module Rewriter (rewrite, rewrite', RewriteContext (..), Rewritten (..)) where +module Rewriter (rewrite, rewrite', RewriteContext (..), Rewritten) where import AST import Builder import Control.Exception (Exception, throwIO) +import Data.Char (toLower) import Data.Foldable (foldlM) import Data.Functor ((<&>)) import qualified Data.Map.Strict as M @@ -33,19 +34,12 @@ type RewriteState = ([Rewritten], Set.Set Program) -data Rewritten = Rewritten - { program :: Program, - maybeRule :: Maybe Y.Rule - } - -instance Eq Rewritten where - left == right = program left == program right +type Rewritten = (Program, Maybe String) data RewriteContext = RewriteContext { _maxDepth :: Integer, _maxCycles :: Integer, _depthSensitive :: Bool, - _sequence :: Bool, _buildTerm :: BuildTermFunc, _must :: Must, _saveStep :: SaveStepFunc @@ -131,7 +125,7 @@ tryBuildAndReplaceFast ptn res substs ctx = buildAndReplace' ptn res substs replaceProgramThrows ctx -- The function returns tuple (X, Y) where --- - X is sequence of programs; for more details about this sequence see description of rewrite' function +-- - 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] -> Integer -> RewriteContext -> IO RewriteState @@ -145,7 +139,7 @@ let ruleName = fromMaybe "unknown" (Y.name rule) ptn = Y.pattern rule res = Y.result rule - Rewritten {..} = head _rewrittens + (program, _) = head _rewrittens in if _count - 1 == _maxDepth then do logDebug (printf "Max amount of rewriting cycles (%d) for rule '%s' has been reached, rewriting is stopped" _maxDepth ruleName) @@ -179,24 +173,19 @@ (printProgram prog) ) _saveStep prog (((iteration - 1) * _maxDepth) + _count) - _rewrite (rewriteSequence prog, Set.insert prog _unique) (_count + 1) + _rewrite (leadsTo prog, Set.insert prog _unique) (_count + 1) where - rewriteSequence :: Program -> [Rewritten] - rewriteSequence _prog - | _sequence = - let Rewritten {..} : rest = _rewrittens - in Rewritten _prog Nothing : Rewritten program (Just rule) : rest - | otherwise = [Rewritten _prog Nothing] + leadsTo :: Program -> [Rewritten] + leadsTo _prog = + let (program, _) : rest = _rewrittens + in (_prog, Nothing) : (program, Just (map toLower (fromMaybe "unknown" (Y.name rule)))) : rest -- The function accepts single program but returns sequence of programs --- If RewriteContext has _sequence == True - all the intermediate --- programs after each rule application are included into sequence --- Otherwise sequence contains only one program rewrite' :: Program -> [Y.Rule] -> RewriteContext -> IO [Rewritten] -rewrite' prog rules ctx = _rewrite ([Rewritten prog Nothing], Set.empty) 1 ctx <&> reverse +rewrite' prog rules ctx = _rewrite ([(prog, Nothing)], Set.empty) 1 ctx <&> reverse where _rewrite :: RewriteState -> Integer -> RewriteContext -> IO [Rewritten] - _rewrite state@(rewrittens, unique) count ctx@RewriteContext{..} = do + _rewrite state@(rewrittens, unique) count ctx@RewriteContext {..} = do let cycles = _maxCycles must = _must current = count - 1 @@ -212,7 +201,9 @@ else do logDebug (printf "Starting rewriting cycle for all rules: %d out of %d" count cycles) state'@(rewrittens', unique') <- rewrite state rules count ctx - if head rewrittens' == head rewrittens + 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) diff --git a/src/Sugar.hs b/src/Sugar.hs --- a/src/Sugar.hs +++ b/src/Sugar.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} @@ -60,9 +61,23 @@ toSalty EX_DISPATCH {..} = EX_DISPATCH (toSalty expr) attr toSalty EX_FORMATION {lsb, binding = bd@BI_EMPTY {..}, rsb} = EX_FORMATION lsb NO_EOL TAB' (toSalty (bdWithVoidRho bd)) NO_EOL TAB' rsb toSalty EX_FORMATION {..} = EX_FORMATION lsb eol tab (toSalty (bdWithVoidRho binding)) eol' tab' rsb - toSalty EX_APPLICATION {..} = EX_APPLICATION (toSalty expr) eol tab (toSalty bindings) eol' tab' - toSalty EX_APPLICATION' {..} = EX_APPLICATION (toSalty expr) eol tab (toSalty (argToBinding args tab)) eol' tab' + toSalty EX_APPLICATION {..} = EX_APPLICATION (toSalty expr) EOL (TAB indent) (toSalty tau) EOL (TAB (indent - 1)) indent + toSalty EX_APPLICATION_TAUS {..} = + foldl + toApplication + expr + (tauToPairs taus) where + toApplication :: EXPRESSION -> PAIR -> EXPRESSION + toApplication exp pair = + EX_APPLICATION (toSalty exp) EOL (TAB indent) (APP_BINDING (toSalty pair)) EOL (TAB (indent - 1)) indent + tauToPairs :: BINDING -> [PAIR] + tauToPairs BI_PAIR {..} = pair : tausToPairs bindings + tausToPairs :: BINDINGS -> [PAIR] + tausToPairs BDS_EMPTY {..} = [] + tausToPairs BDS_PAIR {..} = pair : tausToPairs bindings + toSalty EX_APPLICATION_EXPRS {..} = toSalty (EX_APPLICATION_TAUS expr EOL (TAB indent) (argToBinding args tab) EOL (TAB (indent - 1)) indent) + where argToBinding :: APP_ARG -> TAB -> BINDING argToBinding APP_ARG {..} = BI_PAIR @@ -71,66 +86,73 @@ argsToBindings :: APP_ARGS -> Integer -> TAB -> BINDINGS argsToBindings AAS_EMPTY _ tab = BDS_EMPTY tab argsToBindings AAS_EXPR {..} idx tb = BDS_PAIR eol tb (PA_TAU (AT_ALPHA ALPHA idx) ARROW expr) (argsToBindings args (idx + 1) tb) - toSalty EX_NUMBER {num, tab = tb@TAB {..}} = - let number = ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "number") - bytes = ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "bytes") - number' = toCST number (indent + 1) :: EXPRESSION - bytes' = toCST bytes (indent + 2) :: EXPRESSION - data' = toCST (ExFormation [BiDelta (numToBts (either toDouble id num))]) (indent + 2) :: EXPRESSION - in toSalty - ( EX_APPLICATION' - number' - EOL - (TAB (indent + 1)) - ( APP_ARG - ( EX_APPLICATION' - bytes' - EOL - (TAB (indent + 2)) - (APP_ARG data' AAS_EMPTY) - EOL - (TAB (indent + 1)) - ) - AAS_EMPTY - ) - EOL - tb - ) - toSalty EX_STRING {str, tab = tb@TAB {..}} = - let string = ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "string") - bytes = ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "bytes") - string' = toCST string (indent + 1) :: EXPRESSION - bytes' = toCST bytes (indent + 2) :: EXPRESSION - data' = toCST (ExFormation [BiDelta (strToBts str)]) (indent + 2) :: EXPRESSION - in toSalty - ( EX_APPLICATION' - string' - EOL - (TAB (indent + 1)) - ( APP_ARG - ( EX_APPLICATION' - bytes' - EOL - (TAB (indent + 2)) - (APP_ARG data' AAS_EMPTY) - EOL - (TAB (indent + 1)) - ) - AAS_EMPTY - ) - EOL - tb - ) + toSalty EX_NUMBER {num, tab = tab@TAB {..}, rhos} = + saltifyPrimitive + (toCST (BaseObject "number") (indent + 1) EOL) + (toCST (BaseObject "bytes") (indent + 2) EOL) + (toCST (ExFormation [BiDelta (numToBts (either toDouble id num))]) (indent + 2) EOL) + tab + rhos + toSalty EX_STRING {str, tab = tab@TAB {..}, rhos} = + saltifyPrimitive + (toCST (BaseObject "string") (indent + 1) EOL) + (toCST (BaseObject "bytes") (indent + 2) EOL) + (toCST (ExFormation [BiDelta (strToBts str)]) (indent + 2) EOL) + tab + rhos toSalty expr = expr +saltifyPrimitive :: EXPRESSION -> EXPRESSION -> EXPRESSION -> TAB -> [Binding] -> EXPRESSION +saltifyPrimitive base bytes data' tb@TAB {..} rhos = + let next = TAB (indent + 1) + in toSalty + ( EX_APPLICATION_TAUS + base + EOL + next + ( BI_PAIR + ( PA_TAU + (AT_ALPHA ALPHA 0) + ARROW + ( EX_APPLICATION_EXPRS + bytes + EOL + (TAB (indent + 2)) + (APP_ARG data' AAS_EMPTY) + EOL + next + (indent + 2) + ) + ) + (toCST rhos (indent + 1) EOL) + next + ) + EOL + tb + (indent + 1) + ) + instance ToSalty BINDING where toSalty BI_PAIR {..} = BI_PAIR (toSalty pair) (toSalty bindings) tab toSalty bd = bd +instance ToSalty APP_BINDING where + toSalty APP_BINDING {..} = APP_BINDING (toSalty pair) + instance ToSalty BINDINGS where toSalty BDS_PAIR {..} = BDS_PAIR eol tab (toSalty pair) (toSalty bindings) toSalty bds = bds instance ToSalty PAIR where toSalty PA_TAU {..} = PA_TAU attr arrow (toSalty expr) + toSalty PA_FORMATION {voids, attr, arrow, expr = expr@EX_FORMATION {..}} = + PA_TAU attr arrow (toSalty (EX_FORMATION lsb eol tab (joinToBinding voids binding) eol' tab' rsb)) + where + joinToBinding :: [ATTRIBUTE] -> BINDING -> BINDING + joinToBinding [] bd = bd + joinToBinding (attr : rest) bd = BI_PAIR (PA_VOID attr arrow EMPTY) (joinToBindings rest bd) tab + joinToBindings :: [ATTRIBUTE] -> BINDING -> BINDINGS + joinToBindings [] BI_EMPTY {..} = BDS_EMPTY tab + joinToBindings [] BI_PAIR {..} = BDS_PAIR eol tab pair bindings + joinToBindings (attr : rest) bd = BDS_PAIR eol tab (PA_VOID attr arrow EMPTY) (joinToBindings rest bd) toSalty pair = pair diff --git a/src/Yaml.hs b/src/Yaml.hs --- a/src/Yaml.hs +++ b/src/Yaml.hs @@ -134,13 +134,13 @@ = Ordinal Attribute | Length Binding | Literal Integer - deriving (Generic, Show) + deriving (Eq, Generic, Show) data Comparable = CmpAttr Attribute | CmpNum Number | CmpExpr Expression - deriving (Generic, Show) + deriving (Eq, Generic, Show) data Condition = And [Condition] @@ -153,7 +153,7 @@ | XI Expression | Matches String Expression | PartOf Expression Binding - deriving (Generic, Show) + deriving (Eq, Generic, Show) data ExtraArgument = ArgAttribute Attribute diff --git a/test/CLISpec.hs b/test/CLISpec.hs --- a/test/CLISpec.hs +++ b/test/CLISpec.hs @@ -10,7 +10,7 @@ import CLI (runCLI) import Control.Exception import Control.Monad (forM_, unless, when) -import Data.List (isInfixOf) +import Data.List (intercalate, isInfixOf) import Data.Version (showVersion) import GHC.IO.Handle import Paths_phino (version) @@ -116,6 +116,12 @@ ["rewrite", "--input=latex"] ["The value 'latex' can't be used for '--input' option"] + it "with negative --log-lines" $ + withStdin "" $ + testCLIFailed + ["rewrite", "--log-lines=-2"] + ["--log-lines must be >= -1"] + it "with negative --max-depth" $ withStdin "" $ testCLIFailed @@ -276,9 +282,7 @@ ["rewrite", "--output=latex", "--sweet"] [ "\\begin{phiquation}", "\\Big\\{[[\n", - " |x\\char95{}o| -> QQ.|z|(\n", - " |y| -> 5\n", - " ),\n", + " |x\\char95{}o| -> QQ.|z|( |y| -> 5 ),\n", " |q\\char36{}| -> T,\n", " |w| -> $,\n", " ^ -> Q,\n", @@ -303,7 +307,7 @@ testCLISucceeded ["rewrite", "--output=latex", "--sweet", "--flat", "--expression=foo"] [ "\\begin{phiquation}", - "\\phiExpression{foo} \\Big\\{[[ |x| -> 5 ]]\\Big\\}", + "\\phiExpression{foo} \\Big\\{[[ |x| -> 5 ]]\\Big\\}.\n", "\\end{phiquation}" ] @@ -312,7 +316,7 @@ testCLISucceeded ["rewrite", "--output=latex", "--sweet", "--flat", "--label=foo"] [ "\\begin{phiquation}\n\\label{foo}\n", - "\\Big\\{[[ |x| -> 5 ]]\\Big\\}\n", + "\\Big\\{[[ |x| -> 5 ]]\\Big\\}.\n", "\\end{phiquation}" ] @@ -377,7 +381,7 @@ [ "\\begin{phiquation}", "\\Big\\{[[ |x| -> \"foo\" ]]\\Big\\} \\leadsto_{\\nameref{r:first}}", " \\leadsto \\Big\\{Q.|x|( |y| -> \"foo\" )\\Big\\} \\leadsto_{\\nameref{r:second}}", - " \\leadsto \\Big\\{[[ |x| -> \"foo\" ]]\\Big\\}", + " \\leadsto \\Big\\{[[ |x| -> \"foo\" ]]\\Big\\}.", "\\end{phiquation}" ] ] @@ -499,15 +503,98 @@ ["rewrite", "--sweet", "--flat"] ["{āŸ¦ x ā†¦ 5, y ā†¦ \"hey\", z ā†¦ āŸ¦ w ā†¦ āŸ¦āŸ§ āŸ§ āŸ§}"] + it "removes unnecessary rho bindings in primitive applications" $ + withStdin + ( unlines + [ "{[[", + " z -> [[ x -> [[ t -> 42 ]].t ]].x,", + " org -> [[ eolang -> [[ bytes -> [[ data -> ? ]], number -> [[ as-bytes -> ? ]] ]] ]]", + "]]}" + ] + ) + ( testCLISucceeded + ["rewrite", "--sweet", "--normalize", "--flat"] + ["{āŸ¦ z ā†¦ 42, org ā†¦ āŸ¦ eolang ā†¦ āŸ¦ bytes(data) ā†¦ āŸ¦āŸ§, number(as-bytes) ā†¦ āŸ¦āŸ§ āŸ§ āŸ§ āŸ§}"] + ) + + it "reduces log message" $ + withStdin "{[[ x -> [[ y -> ? ]](y -> 5) ]]}" $ + testCLISucceeded + ["rewrite", "--log-level=debug", "--log-lines=4", "--normalize"] + [ intercalate + "\n" + [ "[DEBUG]: Applied 'COPY' (28 nodes -> 25 nodes)", + "{āŸ¦", + " x ā†¦ āŸ¦", + " y ā†¦ 5", + "---| log is limited by --log-lines=4 option |---" + ] + ] + describe "dataize" $ do it "dataizes simple program" $ withStdin "Q -> [[ D> 01- ]]" $ testCLISucceeded ["dataize"] ["01-"] - it "fails to dataize" $ + it "dataizes to dead" $ withStdin "Q -> [[ ]]" $ - testCLIFailed ["dataize"] ["[ERROR]: Could not dataize given program"] + testCLISucceeded ["dataize"] ["āŠ„"] + it "dataizes with --sequence" $ + withStdin "{[[ @ -> [[ x -> [[ D> 01-, y -> ? ]](y -> [[ ]]) ]].x ]]}" $ + testCLISucceeded + ["dataize", "--sequence", "--output=latex", "--flat", "--sweet"] + [ intercalate + "\n" + [ "\\begin{phiquation}", + "\\Big\\{[[ @ -> [[ |x| -> [[ D> 01-, |y| -> ? ]]( |y| -> [[]] ) ]].|x| ]]\\Big\\} \\leadsto_{\\nameref{r:contextualize}}", + " \\leadsto \\Big\\{[[ |x| -> [[ D> 01-, |y| -> ? ]]( |y| -> [[]] ) ]].|x|\\Big\\} \\leadsto_{\\nameref{r:copy}}", + " \\leadsto \\Big\\{[[ |x| -> [[ D> 01-, |y| -> [[]] ]] ]].|x|\\Big\\} \\leadsto_{\\nameref{r:dot}}", + " \\leadsto \\Big\\{[[ D> 01-, |y| -> [[]] ]]( ^ -> [[ |x| -> [[ D> 01-, |y| -> [[]] ]] ]] )\\Big\\} \\leadsto_{\\nameref{r:copy}}", + " \\leadsto \\Big\\{[[ D> 01-, |y| -> [[]], ^ -> [[ |x| -> [[ D> 01-, |y| -> [[]] ]] ]] ]]\\Big\\} \\leadsto_{\\nameref{r:M(prim)}}", + " \\leadsto \\Big\\{[[ D> 01-, |y| -> [[]], ^ -> [[ |x| -> [[ D> 01-, |y| -> [[]] ]] ]] ]]\\Big\\}.", + "\\end{phiquation}", + "01-" + ] + ] + + describe "fails" $ do + it "with --output != latex and --nonumber" $ + withStdin "{[[]]}" $ + testCLIFailed + ["dataize", "--nonumber", "--output=xmir"] + ["The --nonumber option can stay together with --output=latex only"] + + it "with --omit-listing and --output != xmir" $ + withStdin "{[[]]}" $ + testCLIFailed + ["dataize", "--omit-listing", "--output=phi"] + ["--omit-listing"] + + it "with --omit-comments and --output != xmir" $ + withStdin "{[[]]}" $ + testCLIFailed + ["dataize", "--omit-comments", "--output=phi"] + ["--omit-comments"] + + it "with --expression and --output != latex" $ + withStdin "{[[]]}" $ + testCLIFailed + ["dataize", "--expression=foo", "--output=phi"] + ["--expression option can stay together with --output=latex only"] + + it "with --label and --output != latex" $ + withStdin "{[[]]}" $ + testCLIFailed + ["dataize", "--label=foo", "--output=phi"] + ["--label option can stay together with --output=latex only"] + + it "with wrong --hide option" $ + withStdin "{[[]]}" $ + testCLIFailed + ["dataize", "--hide=Q.x(Q.y)"] + ["[ERROR]: Invalid set of arguments: Only dispatch expression", "but given: Ī¦.x( Ī¦.y )"] + describe "explain" $ do it "explains single rule" $ testCLISucceeded @@ -556,15 +643,9 @@ [ "{āŸ¦", " org ā†¦ āŸ¦", " eolang ā†¦ āŸ¦", - " number ā†¦ āŸ¦", - " Ļ† ā†¦ āˆ…", - " āŸ§,", - " bytes ā†¦ āŸ¦", - " data ā†¦ āˆ…", - " āŸ§,", - " string ā†¦ āŸ¦", - " Ļ† ā†¦ āˆ…", - " āŸ§,", + " number(Ļ†) ā†¦ āŸ¦āŸ§,", + " bytes(data) ā†¦ āŸ¦āŸ§,", + " string(Ļ†) ā†¦ āŸ¦āŸ§,", " Ī» ā¤ Package", " āŸ§,", " Ī» ā¤ Package", @@ -587,3 +668,40 @@ testCLIFailed ["merge"] ["At least one input file must be specified for 'merge' command"] + + describe "match" $ do + it "takes from stdin" $ + withStdin "{[[]]}" $ + testCLISucceeded ["match"] ["[INFO]"] + + it "takes from file" $ + testCLISucceeded ["match", "test-resources/cli/foo.phi"] ["[INFO]"] + + it "does not print substitutions without pattern" $ + withStdin "{[[]]}" $ + testCLISucceeded ["match"] ["[INFO]: The --pattern is not provided, no substitutions are built"] + + it "prints one substitution" $ + withStdin "{[[ x -> Q.x ]]}" $ + testCLISucceeded ["match", "--pattern=Q.!a"] ["a >> x"] + + it "prints many substitutions" $ + withStdin "{[[ x -> Q.x, y -> Q.y ]]}" $ + testCLISucceeded ["match", "--pattern=Q.!a"] ["a >> x\n------\na >> y"] + + it "builds substitutions with conditions" $ + withStdin "{[[ x -> Q.y ]].x}" $ + testCLISucceeded + ["match", "--pattern=[[ !a -> Q.y, !B ]].!a", "--when=and(not(alpha(!a)),eq(length(!B),1))"] + ["B >> āŸ¦ Ļ ā†¦ āˆ… āŸ§\na >> x"] + + it "builds with condition from file" $ + testCLISucceeded + ["match", "--pattern=[[ !B ]]", "--when=eq(length(!B),2)", "test-resources/cli/foo.phi"] + ["B >> āŸ¦\n foo ā†¦ Ī¦.org.eolang.x,\n Ļ ā†¦ āˆ…\nāŸ§"] + + it "fails on parsing --when condition" $ + withStdin "{[[]]}" $ + testCLIFailed + ["match", "--pattern=[[!B]]", "--when=hello"] + ["[ERROR]: Couldn't parse given condition"] diff --git a/test/ConditionSpec.hs b/test/ConditionSpec.hs new file mode 100644 --- /dev/null +++ b/test/ConditionSpec.hs @@ -0,0 +1,51 @@ +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module ConditionSpec where + +import AST (Attribute (AtLabel, AtMeta), Binding (BiMeta), Expression (ExDispatch, ExGlobal, ExMeta)) +import Condition +import Control.Monad (forM_) +import Data.Either (isLeft, isRight) +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) +import Yaml qualified as Y + +spec :: Spec +spec = do + describe "just parses" $ + forM_ + [ "in (!a, !B)", + " not (in (!a1, !B)) ", + "alpha(x)", + "eq(1, 1)", + "or(eq(ordinal(a),1),eq(length(!B),-2),eq(!e1,!e2),eq(!a1,x),eq(Q.org.eolang,[[ x -> 2 ]]))", + "and(alpha(q),eq(-5,21))", + "nf([[ x -> !e ]].x)", + "xi(!e1)", + "matches(\"hello(\\\"\\u0000)\", !e)", + "part-of ( [[ x -> 1 ]] , !B ) ", + "and(not(alpha(!a)),eq(!a,x))" + ] + (\expr -> it expr (parseCondition expr `shouldSatisfy` isRight)) + + describe "parses correctly" $ + forM_ + [ ("in(!a, !B)", Y.In (AtMeta "a") (BiMeta "B")), + ("not(in(!a,!B))", Y.Not (Y.In (AtMeta "a") (BiMeta "B"))), + ("alpha(y)", Y.Alpha (AtLabel "y")), + ("eq(1,-2)", Y.Eq (Y.CmpNum (Y.Literal 1)) (Y.CmpNum (Y.Literal (-2)))), + ("eq(ordinal(z),length(!B1))", Y.Eq (Y.CmpNum (Y.Ordinal (AtLabel "z"))) (Y.CmpNum (Y.Length (BiMeta "B1")))), + ("eq(!a1, !e2)", Y.Eq (Y.CmpAttr (AtMeta "a1")) (Y.CmpExpr (ExMeta "e2"))), + ("or(xi(!e1), nf(Q.x))", Y.Or [Y.XI (ExMeta "e1"), Y.NF (ExDispatch ExGlobal (AtLabel "x"))]), + ("and(matches(\"hi\", !e),part-of(!e, !B))", Y.And [Y.Matches "hi" (ExMeta "e"), Y.PartOf (ExMeta "e") (BiMeta "B")]) + ] + (\(expr, res) -> it expr (parseCondition expr `shouldBe` Right res)) + + describe "does not parse" $ + forM_ + [ "some()", + "in(!a, !a)", + "alpha(!B)", + "or(or(), or())" + ] + (\expr -> it expr (parseCondition expr `shouldSatisfy` isLeft)) diff --git a/test/DataizeSpec.hs b/test/DataizeSpec.hs --- a/test/DataizeSpec.hs +++ b/test/DataizeSpec.hs @@ -9,39 +9,49 @@ import Deps (dontSaveStep) import Functions (buildTerm) import Parser (parseProgramThrows) +import Printer (printProgram) +import Rewriter (Rewritten) import Test.Hspec defaultDataizeContext :: Program -> DataizeContext defaultDataizeContext prog = DataizeContext prog 25 25 False buildTerm dontSaveStep -test :: (Eq a, Show a) => (Expression -> DataizeContext -> IO (Maybe a)) -> [(String, Expression, Expression, Maybe a)] -> Spec +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) -> it desc $ do - res <- func input (defaultDataizeContext (Program prog)) + (res, _) <- func (input, []) (defaultDataizeContext (Program 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) -> + it desc $ do + (res, _) <- func (input, [(Program prog, Nothing)]) (defaultDataizeContext (Program prog)) + res `shouldBe` output + testDataize :: [(String, String, Bytes)] -> Spec testDataize useCases = forM_ useCases $ \(name, prog, res) -> it name $ do prog' <- parseProgramThrows prog - value <- dataize prog' (defaultDataizeContext prog') + putStrLn (printProgram prog') + (value, _) <- dataize prog' (defaultDataizeContext prog') value `shouldBe` Just res spec :: Spec spec = do describe "morph" $ - test + test' morph - [ ("[[ D> 00- ]] => [[ D> 00- ]]", ExFormation [BiDelta (BtOne "00")], ExGlobal, Just (ExFormation [BiDelta (BtOne "00")])), - ("T => T", ExTermination, ExGlobal, Just ExTermination), - ("$ => X", ExThis, ExGlobal, Nothing), - ("Q => X", ExGlobal, ExGlobal, Nothing), + [ ("[[ D> 00- ]] => [[ D> 00- ]]", ExFormation [BiDelta (BtOne "00")], ExGlobal, ExFormation [BiDelta (BtOne "00")]), + ("T => T", ExTermination, ExGlobal, ExTermination), + ("$ => X", ExThis, ExGlobal, ExTermination), + ("Q => X", ExGlobal, ExGlobal, ExTermination), ( "Q.x (Q -> [[ x -> [[]] ]]) => [[]]", ExDispatch ExGlobal (AtLabel "x"), ExFormation [BiTau (AtLabel "x") (ExFormation [])], - Just (ExFormation []) + ExFormation [] ) ] diff --git a/test/HideSpec.hs b/test/HideSpec.hs --- a/test/HideSpec.hs +++ b/test/HideSpec.hs @@ -15,10 +15,8 @@ import Hide (hide) import Misc import Parser (parseExpressionThrows, parseProgramThrows) -import Rewriter import System.FilePath import Test.Hspec -import Yaml (normalizationRules) data YamlPack = YamlPack { program :: String, @@ -34,9 +32,7 @@ spec = describe "hide packs" $ do let resources = "test-resources/hide-packs" - rule = head normalizationRules packs <- runIO (allPathsIn resources) - forM_ packs ( \pth -> it (makeRelative resources pth) $ do @@ -44,6 +40,6 @@ prog <- parseProgramThrows program expr <- parseExpressionThrows hidden res <- parseProgramThrows result - let [Rewritten {program = prog'}] = hide [Rewritten prog (Just rule)] [expr] + let [(prog', _)] = hide [(prog, Nothing)] [expr] prog' `shouldBe` res ) diff --git a/test/ParserSpec.hs b/test/ParserSpec.hs --- a/test/ParserSpec.hs +++ b/test/ParserSpec.hs @@ -9,7 +9,7 @@ import AST import Control.Monad (forM_) import Data.Either (isLeft, isRight) -import Misc (allPathsIn) +import Misc import Parser import System.FilePath (takeBaseName) import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, describe, it, runIO, shouldBe, shouldSatisfy) @@ -147,56 +147,20 @@ Just ( ExApplication ( ExDispatch - ( ExApplication - (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "number")) - ( BiTau - (AtAlpha 0) - ( ExApplication - (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "bytes")) - ( BiTau - (AtAlpha 0) - (ExFormation [BiDelta (BtMany ["40", "14", "00", "00", "00", "00", "00", "00"]), BiVoid AtRho]) - ) - ) - ) - ) + (DataNumber (BtMany ["40", "14", "00", "00", "00", "00", "00", "00"])) (AtLabel "plus") ) ( BiTau (AtAlpha 0) ( ExApplication ( ExDispatch - ( ExApplication - (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "number")) - ( BiTau - (AtAlpha 0) - ( ExApplication - (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "bytes")) - ( BiTau - (AtAlpha 0) - (ExFormation [BiDelta (BtMany ["40", "14", "00", "00", "00", "00", "00", "00"]), BiVoid AtRho]) - ) - ) - ) - ) + (DataNumber (BtMany ["40", "14", "00", "00", "00", "00", "00", "00"])) (AtLabel "q") ) ( BiTau (AtAlpha 0) ( ExDispatch - ( ExApplication - (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "string")) - ( BiTau - (AtAlpha 0) - ( ExApplication - (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "bytes")) - ( BiTau - (AtAlpha 0) - (ExFormation [BiDelta (BtMany ["68", "65", "6C", "6C", "6F"]), BiVoid AtRho]) - ) - ) - ) - ) + (DataString (BtMany ["68", "65", "6C", "6C", "6F"])) (AtLabel "length") ) ) diff --git a/test/RewriterSpec.hs b/test/RewriterSpec.hs --- a/test/RewriterSpec.hs +++ b/test/RewriterSpec.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-orphans #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com @@ -20,7 +19,7 @@ import Must (Must (..)) import Parser (parseProgramThrows) import Printer (printProgram) -import Rewriter (RewriteContext (RewriteContext), Rewritten (..), rewrite') +import Rewriter (RewriteContext (RewriteContext), rewrite') import System.FilePath (makeRelative, replaceExtension, ()) import Test.Hspec (Spec, describe, expectationFailure, it, pending, runIO) import Yaml (normalizationRules) @@ -99,7 +98,7 @@ if normalize' then pure normalizationRules else pure [] - [Rewritten {..}] <- + rewrittens <- rewrite' prog rules' @@ -107,11 +106,11 @@ repeat' repeat' False - False buildTerm must' dontSaveStep ) + let (program, _) = last rewrittens result' <- parseProgramThrows (output pack) unless (program == result') $ expectationFailure