phino 0.0.0.46 → 0.0.0.47
raw patch · 8 files changed
+489/−175 lines, 8 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ LaTeX: [nonumber] :: LatexContext -> Bool
+ Merge: instance GHC.Exception.Type.Exception Merge.MergeException
+ Merge: instance GHC.Show.Show Merge.MergeException
+ Merge: merge :: [Program] -> IO Program
+ Misc: attributeFromBinding :: Binding -> Maybe Attribute
+ Misc: attributesFromBindings' :: [Binding] -> [Maybe Attribute]
- LaTeX: LatexContext :: SugarType -> LineFormat -> LatexContext
+ LaTeX: LatexContext :: SugarType -> LineFormat -> Bool -> LatexContext
- XMIR: XmirContext :: Bool -> Bool -> String -> XmirContext
+ XMIR: XmirContext :: Bool -> Bool -> (Program -> String) -> XmirContext
Files
- phino.cabal +3/−1
- src/CLI.hs +174/−90
- src/LaTeX.hs +41/−26
- src/Merge.hs +65/−0
- src/Misc.hs +19/−15
- src/XMIR.hs +18/−13
- test/CLISpec.hs +114/−30
- test/MergeSpec.hs +55/−0
phino.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: phino-version: 0.0.0.46+version: 0.0.0.47 license: MIT synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions description: Please see the README on GitHub at <https://github.com/objectionary/phino#readme>@@ -44,6 +44,7 @@ Lining Logger Matcher+ Merge Misc Must Parser@@ -114,6 +115,7 @@ DataizeSpec FunctionsSpec MatcherSpec+ MergeSpec MiscSpec ParserSpec Paths_phino
src/CLI.hs view
@@ -26,6 +26,7 @@ import LaTeX (LatexContext (LatexContext), explainRules, programToLaTeX, rewrittensToLatex) import Lining (LineFormat (MULTILINE, SINGLELINE)) import Logger+import Merge (merge) import Misc (ensuredFile) import qualified Misc import Must (Must (..))@@ -42,14 +43,21 @@ import Yaml (normalizationRules) import qualified Yaml as Y +data PrintProgramContext = PrintProgCtx+ { sugar :: SugarType,+ line :: LineFormat,+ xmirCtx :: XmirContext,+ nonumber :: Bool+ }+ data CmdException- = InvalidRewriteArguments {message :: String}+ = InvalidCLIArguments {message :: String} | CouldNotReadFromStdin {message :: String} | CouldNotDataize deriving (Exception) instance Show CmdException where- show InvalidRewriteArguments {..} = printf "Invalid set of arguments for 'rewrite' command: %s" message+ show InvalidCLIArguments {..} = printf "Invalid set of arguments: %s" message show CouldNotReadFromStdin {..} = printf "Could not read input from stdin\nReason: %s" message show CouldNotDataize = "Could not dataize given program" @@ -57,6 +65,7 @@ = CmdRewrite OptsRewrite | CmdDataize OptsDataize | CmdExplain OptsExplain+ | CmdMerge OptsMerge data IOFormat = XMIR | PHI | LATEX deriving (Eq)@@ -98,6 +107,7 @@ omitListing :: Bool, omitComments :: Bool, depthSensitive :: Bool,+ nonumber :: Bool, must :: Must, maxDepth :: Integer, maxCycles :: Integer,@@ -108,27 +118,17 @@ inputFile :: Maybe FilePath } -parseIOFormat :: String -> ReadM IOFormat-parseIOFormat type' = eitherReader $ \format -> case (map toLower format, type') of- ("xmir", _) -> Right XMIR- ("phi", _) -> Right PHI- ("latex", "output") -> Right LATEX- _ -> Left (printf "The value '%s' can't be used for '--%s' option, use --help to check possible values" format type')--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)--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, latex)" <> value PHI <> 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)")+data OptsMerge = OptsMerge+ { logLevel :: LogLevel,+ inputFormat :: IOFormat,+ outputFormat :: IOFormat,+ sugarType :: SugarType,+ flat :: LineFormat,+ omitListing :: Bool,+ omitComments :: Bool,+ targetFile :: Maybe FilePath,+ inputs :: [FilePath]+ } optLogLevel :: Parser LogLevel optLogLevel =@@ -152,8 +152,33 @@ "NONE" -> Right NONE _ -> Left $ "unknown log-level: " <> lvl +parseIOFormat :: String -> ReadM IOFormat+parseIOFormat type' = eitherReader $ \format -> case (map toLower format, type') of+ ("xmir", _) -> Right XMIR+ ("phi", _) -> Right PHI+ ("latex", "output") -> Right LATEX+ _ -> Left (printf "The value '%s' can't be used for '--%s' option, use --help to check possible values" format type')++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)++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)++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"))+optRule = many (strOption (long "rule" <> metavar "[FILE]" <> help "Path to custom rule")) optNormalize :: Parser Bool optNormalize = switch (long "normalize" <> help "Use built-in normalization rules")@@ -167,12 +192,24 @@ optShuffle :: Parser Bool optShuffle = switch (long "shuffle" <> help "Shuffle rules before applying") -optSugar :: Parser SugarType-optSugar = flag SALTY SWEET (long "sweet" <> help "Print result and intermediate (see --steps flag) 𝜑-programs using syntax sugar")+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))) -optLineFormat :: Parser LineFormat-optLineFormat = flag MULTILINE SINGLELINE (long "flat" <> help "Print result and intermediate (see --steps flag) 𝜑-programs in one line")+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 "Print result 𝜑-program in one line")++optOmitListing :: Parser Bool+optOmitListing = switch (long "omit-listing" <> help "Omit full program listing in XMIR output")++optOmitComments :: Parser Bool+optOmitComments = switch (long "omit-comments" <> help "Omit comments in XMIR output")+ explainParser :: Parser Command explainParser = CmdExplain@@ -186,49 +223,67 @@ dataizeParser :: Parser Command dataizeParser =- CmdDataize- <$> ( OptsDataize- <$> optLogLevel- <*> optInputFormat- <*> optSugar- <*> optLineFormat- <*> optMaxDepth- <*> optMaxCycles- <*> optDepthSensitive- <*> optStepsDir- <*> argInputFile- )+ let steps = ["--steps-dir"]+ in CmdDataize+ <$> ( OptsDataize+ <$> optLogLevel+ <*> optInputFormat+ <*> optSugar steps+ <*> optLineFormat steps+ <*> optMaxDepth+ <*> optMaxCycles+ <*> optDepthSensitive+ <*> optStepsDir+ <*> argInputFile+ ) rewriteParser :: Parser Command rewriteParser =- CmdRewrite- <$> ( OptsRewrite+ 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")+ <*> optTarget+ <*> optStepsDir+ <*> argInputFile+ )++mergeParser :: Parser Command+mergeParser =+ CmdMerge+ <$> ( OptsMerge <$> optLogLevel- <*> optRule <*> optInputFormat- <*> option (parseIOFormat "output") (long "output" <> metavar "FORMAT" <> help "Program output format (phi, xmir)" <> value PHI <> showDefault)- <*> optSugar- <*> optLineFormat- <*> optNormalize- <*> optShuffle- <*> switch (long "omit-listing" <> help "Omit full program listing in XMIR output")- <*> switch (long "omit-comments" <> help "Omit comments in XMIR output")- <*> optDepthSensitive- <*> 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")+ <*> optOutputFormat+ <*> optSugar'+ <*> optLineFormat'+ <*> optOmitListing+ <*> optOmitComments <*> optTarget- <*> optStepsDir- <*> argInputFile+ <*> many (argument str (metavar "[FILE]" <> help "Paths to input files")) ) commandParser :: Parser Command@@ -237,6 +292,7 @@ ( command "rewrite" (info rewriteParser (progDesc "Rewrite the 𝜑-program")) <> 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")) ) parserInfo :: ParserInfo Command@@ -258,6 +314,7 @@ CmdRewrite OptsRewrite {logLevel} -> logLevel CmdDataize OptsDataize {logLevel} -> logLevel CmdExplain OptsExplain {logLevel} -> logLevel+ CmdMerge OptsMerge {logLevel} -> logLevel in setLogLevel level runCLI :: [String] -> IO ()@@ -265,32 +322,35 @@ cmd <- handleParseResult (execParserPure defaultPrefs parserInfo args) setLogLevel' cmd case cmd of- CmdRewrite opts@OptsRewrite {..} -> do+ CmdRewrite OptsRewrite {..} -> do validateOpts logDebug (printf "Amount of rewriting cycles across all the rules: %d, per rule: %d" maxCycles maxDepth) input <- readInput inputFile- let xmirCtx = Just (XmirContext omitListing omitComments input) rules' <- getRules normalize shuffle rules program <- parseProgram input inputFormat- rewrittens <- rewrite' program rules' (context program xmirCtx)+ 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+ rewrittens <- rewrite' program rules' (context program printProgCtx) logDebug (printf "Printing rewritten 𝜑-program as %s" (show outputFormat))- progs <- printRewrittens xmirCtx rewrittens+ progs <- printRewrittens printProgCtx rewrittens output targetFile progs where validateOpts :: IO () validateOpts = do when- (sugarType == SWEET && outputFormat == XMIR)- (throwIO (InvalidRewriteArguments "The --sweet and --output=xmir can't stay together"))- when (inPlace && isNothing inputFile)- (throwIO (InvalidRewriteArguments "--in-place requires an input file"))+ (throwIO (InvalidCLIArguments "--in-place requires an input file")) when (inPlace && isJust targetFile)- (throwIO (InvalidRewriteArguments "--in-place and --target cannot be used together"))+ (throwIO (InvalidCLIArguments "--in-place and --target cannot be used together"))+ when+ (nonumber && outputFormat /= LATEX)+ (throwIO (InvalidCLIArguments "The --nonumber option can stay together with --output=latex only")) validateMaxDepth maxDepth validateMaxCycles maxCycles validateMust must+ validateXmirOptions outputFormat omitListing omitComments output :: Maybe FilePath -> String -> IO () output target prog = case (inPlace, target, inputFile) of (True, _, Just file) -> do@@ -304,7 +364,7 @@ (False, Nothing, _) -> do logDebug "The option '--target' is not specified, printing to console..." putStrLn prog- context :: Program -> Maybe XmirContext -> RewriteContext+ context :: Program -> PrintProgramContext -> RewriteContext context program ctx = RewriteContext program@@ -314,12 +374,12 @@ sequence buildTerm must- (saveStep stepsDir (ioToExtension outputFormat) (printProgram outputFormat (sugarType, flat) ctx))- printRewrittens :: Maybe XmirContext -> [Rewritten] -> IO String+ (saveStep stepsDir (ioToExtension outputFormat) (printProgram outputFormat ctx))+ printRewrittens :: PrintProgramContext -> [Rewritten] -> IO String printRewrittens ctx rewrittens- | outputFormat == LATEX = pure (rewrittensToLatex rewrittens (LatexContext sugarType flat))- | otherwise = mapM (printProgram outputFormat (sugarType, flat) ctx . program) rewrittens <&> intercalate "\n"- CmdDataize opts@OptsDataize {..} -> do+ | outputFormat == LATEX = pure (rewrittensToLatex rewrittens (LatexContext sugarType flat nonumber))+ | otherwise = mapM (printProgram outputFormat ctx . program) rewrittens <&> intercalate "\n"+ CmdDataize OptsDataize {..} -> do validateOpts input <- readInput inputFile prog <- parseProgram input inputFormat@@ -338,8 +398,8 @@ maxCycles depthSensitive buildTerm- (saveStep stepsDir (ioToExtension PHI) (printProgram PHI (SWEET, MULTILINE) Nothing))- CmdExplain opts@OptsExplain {..} -> do+ (saveStep stepsDir (ioToExtension PHI) (printProgram PHI (PrintProgCtx sugarType flat defaultXmirContext False)))+ CmdExplain OptsExplain {..} -> do validateOpts rules' <- getRules normalize shuffle rules let latex = explainRules rules'@@ -349,13 +409,38 @@ validateOpts = when (null rules && not normalize)- (throwIO (InvalidRewriteArguments "Either --rule or --normalize must be specified"))+ (throwIO (InvalidCLIArguments "Either --rule or --normalize must be specified"))+ CmdMerge OptsMerge {..} -> do+ validateOpts+ inputs' <- traverse (readInput . Just) inputs+ progs <- traverse (`parseProgram` inputFormat) inputs'+ prog <- merge progs+ let listing = const (P.printProgram' prog (sugarType, UNICODE, flat))+ xmirCtx = XmirContext omitListing omitComments listing+ printProgCtx = PrintProgCtx sugarType flat xmirCtx False+ prog' <- printProgram outputFormat printProgCtx prog+ output targetFile prog'+ where+ validateOpts :: IO ()+ validateOpts = do+ when+ (null inputs)+ (throwIO (InvalidCLIArguments "At least one input file must be specified for 'merge' command"))+ validateXmirOptions outputFormat omitListing omitComments where+ validateXmirOptions :: IOFormat -> Bool -> Bool -> IO ()+ validateXmirOptions outputFormat omitListing omitComments = do+ when+ (outputFormat /= XMIR && omitListing)+ (throwIO (InvalidCLIArguments "--omit-listing can be used only with --output-format=xmir"))+ when+ (outputFormat /= XMIR && omitComments)+ (throwIO (InvalidCLIArguments "--omit-comments can be used only with --output-format=xmir")) validateIntArgument :: Integer -> (Integer -> Bool) -> String -> IO () validateIntArgument num cmp msg = when (cmp num)- (throwIO (InvalidRewriteArguments msg))+ (throwIO (InvalidCLIArguments msg)) validateMaxDepth :: Integer -> IO () validateMaxDepth depth = validateIntArgument depth (<= 0) "--max-depth must be positive" validateMaxCycles :: Integer -> IO ()@@ -370,7 +455,7 @@ (Just min, Just max) | min > max -> throwIO- ( InvalidRewriteArguments+ ( InvalidCLIArguments (printf "--must range invalid: minimum (%d) is greater than maximum (%d)" min max) ) _ -> pure ()@@ -387,11 +472,10 @@ parseProgram xmir XMIR = do doc <- parseXMIRThrows xmir xmirToPhi doc- printProgram :: IOFormat -> (SugarType, LineFormat) -> Maybe XmirContext -> Program -> IO String- printProgram PHI (sugar, line) _ prog = pure (P.printProgram' prog (sugar, UNICODE, line))- printProgram XMIR cfg Nothing prog = printProgram XMIR cfg (Just defaultXmirContext) prog- printProgram XMIR _ (Just ctx) prog = programToXMIR prog ctx <&> printXMIR- printProgram LATEX (sugar, line) _ prog = pure (programToLaTeX prog (LatexContext sugar line))+ 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)) getRules :: Bool -> Bool -> [FilePath] -> IO [Y.Rule] getRules normalize shuffle rules = do ordered <-
src/LaTeX.hs view
@@ -22,41 +22,52 @@ data LatexContext = LatexContext { sugar :: SugarType,- line :: LineFormat+ line :: LineFormat,+ nonumber :: Bool } renderToLatex :: Program -> LatexContext -> String renderToLatex prog LatexContext {..} = render (toLaTeX $ withLineFormat line $ withEncoding ASCII $ withSugarType sugar $ programToCST prog) +phiquation :: LatexContext -> String+phiquation LatexContext {nonumber = True} = "phiquation*"+phiquation LatexContext {nonumber = False} = "phiquation"+ rewrittensToLatex :: [Rewritten] -> LatexContext -> String rewrittensToLatex rewrittens ctx =- concat- [ "\\begin{phiquation}\n",- intercalate- "\n\\leadsto "- ( map- ( \Rewritten {..} ->- 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- )- rewrittens- ),- "\n\\end{phiquation}"- ]+ let equation = phiquation ctx+ in concat+ [ printf "\\begin{%s}\n" equation,+ intercalate+ "\n \\leadsto "+ ( map+ ( \Rewritten {..} ->+ 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+ )+ rewrittens+ ),+ printf "\n\\end{%s}" equation+ ] programToLaTeX :: Program -> LatexContext -> String programToLaTeX prog ctx =- unlines- [ "\\begin{phiquation}",- renderToLatex prog ctx,- "\\end{phiquation}"- ]+ let equation = phiquation ctx+ in concat+ [ "\\begin{",+ equation,+ "}\n",+ renderToLatex prog ctx,+ "\n\\end{",+ equation,+ "}"+ ] class ToLaTeX a where toLaTeX :: a -> a@@ -70,10 +81,14 @@ 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_DISPATCH{..} = EX_DISPATCH (toLaTeX expr) (toLaTeX attr) toLaTeX expr = expr instance ToLaTeX ATTRIBUTE where- toLaTeX AT_LABEL {..} = AT_LABEL (toLaTeX label)+ toLaTeX AT_LABEL {..} = AT_LABEL (piped (toLaTeX label))+ where+ piped :: String -> String+ piped str = "|" <> str <> "|" toLaTeX attr = attr instance ToLaTeX BINDING where
+ src/Merge.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE RecordWildCards #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module Merge (merge) where++import AST+import Control.Exception (throwIO)+import Control.Exception.Base+import Data.Functor ((<&>))+import Deps (BuildTermFunc, Term (TeBindings))+import Matcher (substEmpty)+import Misc+import Printer (printBinding, printExpression, printProgram)+import Text.Printf (printf)+import qualified Yaml as Y++data MergeException+ = WrongProgramFormat {program :: Program}+ | CanNotMergeBinding {first :: Binding, second :: Binding}+ | EmptyProgramList+ deriving (Exception)++instance Show MergeException where+ show WrongProgramFormat {..} =+ printf+ "Invalid program format, only programs with top level formations are supported for 'merge' command, given:\n%s"+ (printProgram program)+ show CanNotMergeBinding {..} =+ printf+ "Can't merge two bindings, conflict found:\n%s"+ (printExpression (ExFormation [first, second]))+ show EmptyProgramList = "Nothing to merge: provide at least one program"++mergeBinding :: Binding -> Binding -> IO Binding+mergeBinding first@(BiTau a (ExFormation xs)) second@(BiTau b (ExFormation ys))+ | a == b = mergeBindings xs ys <&> BiTau a . ExFormation+ | otherwise = throwIO (CanNotMergeBinding first second)+mergeBinding x y+ | x == y = pure x+ | otherwise = throwIO (CanNotMergeBinding x y)++mergeBindings :: [Binding] -> [Binding] -> IO [Binding]+mergeBindings xs ys = do+ let as = attributesFromBindings' xs+ bs = attributesFromBindings' ys+ xs' = [x | x <- xs, attributeFromBinding x `notElem` bs]+ ys' = [y | y <- ys, attributeFromBinding y `notElem` as]+ collisions = [(x, y) | x <- xs, y <- ys, attributeFromBinding x == attributeFromBinding y]+ ws <- mapM (uncurry mergeBinding) collisions+ pure (xs' <> ys' <> ws)++merge' :: [Program] -> IO Program+merge' [] = throwIO EmptyProgramList+merge' [prog@(Program (ExFormation bds))] = pure prog+merge' (prog@(Program (ExFormation bds)) : rest) = do+ Program (ExFormation bds') <- merge' rest+ merged <- mergeBindings bds' bds+ pure (Program (ExFormation merged))+merge' (prog : rest) = throwIO (WrongProgramFormat prog)++merge :: [Program] -> IO Program+merge progs = merge' (reverse progs)
src/Misc.hs view
@@ -21,6 +21,8 @@ toDouble, btsToUnescapedStr, attributesFromBindings,+ attributesFromBindings',+ attributeFromBinding, uniqueBindings, uniqueBindings', validateYamlObject,@@ -33,6 +35,9 @@ import AST import Control.Exception import Control.Monad+import Data.Aeson (Object)+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap import Data.Binary.IEEE754 import Data.Bits (Bits (shiftL), (.|.)) import qualified Data.Bits as IOArray@@ -42,6 +47,7 @@ import qualified Data.ByteString.Lazy.UTF8 as U import Data.Char (chr, isPrint, ord) import Data.List (intercalate)+import Data.Maybe (catMaybes) import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -53,9 +59,6 @@ import System.FilePath ((</>)) import System.Random.Stateful import Text.Printf (printf)-import Data.Aeson (Object)-import qualified Data.Aeson.KeyMap as KeyMap-import qualified Data.Aeson.Key as Key data FsException = FileDoesNotExist {file :: FilePath}@@ -107,21 +110,23 @@ ) ) +-- Extract attribute from binding+attributeFromBinding :: Binding -> Maybe Attribute+attributeFromBinding (BiTau attr _) = Just attr+attributeFromBinding (BiDelta _) = Just AtDelta+attributeFromBinding (BiLambda _) = Just AtLambda+attributeFromBinding (BiVoid attr) = Just attr+attributeFromBinding (BiMeta _) = Nothing+attributeFromBinding (BiMetaLambda _) = Just AtLambda+ -- Extract attributes from bindings attributesFromBindings :: [Binding] -> [Attribute] attributesFromBindings [] = []-attributesFromBindings (bd : bds) =- let attr = case bd of- BiTau attr _ -> Just attr- BiDelta _ -> Just AtDelta- BiLambda _ -> Just AtLambda- BiVoid attr -> Just attr- BiMeta _ -> Nothing- BiMetaLambda _ -> Just AtLambda- in case attr of- Just attr' -> attr' : attributesFromBindings bds- _ -> attributesFromBindings bds+attributesFromBindings bds = catMaybes (attributesFromBindings' bds) +attributesFromBindings' :: [Binding] -> [Maybe Attribute]+attributesFromBindings' = map attributeFromBinding+ uniqueBindings' :: [Binding] -> IO [Binding] uniqueBindings' bds = case uniqueBindings bds of Left msg -> throwIO (userError msg)@@ -193,7 +198,6 @@ -- >>> toDouble 5 -- 5.0 toDouble :: Integer -> Double- toDouble = fromIntegral -- >>> btsToWord8 BtEmpty
src/XMIR.hs view
@@ -47,11 +47,11 @@ data XmirContext = XmirContext { omitListing :: Bool, omitComments :: Bool,- listing :: String+ listing :: Program -> String } defaultXmirContext :: XmirContext-defaultXmirContext = XmirContext True True ""+defaultXmirContext = XmirContext True True (const "") data XMIRException = UnsupportedProgram {prog :: Program}@@ -176,10 +176,11 @@ (pckg, expr') <- getPackage expr root <- rootExpression expr' ctx now <- getCurrentTime- let listingContent =+ let text = listing prog+ listingContent = if omitListing- then show (length (lines listing)) ++ " line(s)"- else listing+ then show (length (lines text)) ++ " line(s)"+ else text listing' = NodeElement (element "listing" [] [NodeContent (T.pack listingContent)]) metas = metasWithPackage (intercalate "." pckg) pure@@ -261,20 +262,24 @@ indent :: Int -> TB.Builder indent n = TB.fromText (T.replicate n (T.pack " ")) +newline' :: Bool -> TB.Builder+newline' True = newline+newline' False = ""+ newline :: TB.Builder newline = TB.fromString "\n" --- >>> printElement 0 (element "doc" [("a", ""), ("b", ""), ("c", ""), ("d", ""), ("e", "")] [])+-- >>> printElement 0 (element "doc" [("a", ""), ("b", ""), ("c", ""), ("d", ""), ("e", "")] []) True -- "<doc a=\"\" b=\"\" c=\"\" d=\"\" e=\"\"/>\n"-printElement :: Int -> Element -> TB.Builder-printElement indentLevel (Element name attrs nodes)+printElement :: Int -> Element -> Bool -> TB.Builder+printElement indentLevel (Element name attrs nodes) eol | null nodes = indent indentLevel <> TB.fromString "<" <> TB.fromText (nameLocalName name) <> attrsText <> TB.fromString "/>"- <> newline+ <> newline' eol | all isTextNode nodes = indent indentLevel <> TB.fromString "<"@@ -285,7 +290,7 @@ <> TB.fromString "</" <> TB.fromText (nameLocalName name) <> TB.fromString ">"- <> newline+ <> newline' eol | otherwise = indent indentLevel <> TB.fromString "<"@@ -298,7 +303,7 @@ <> TB.fromString "</" <> TB.fromText (nameLocalName name) <> TB.fromString ">"- <> newline+ <> newline' eol where attrsText = mconcat@@ -316,7 +321,7 @@ -- "<!-- --hello-- -->\n" printNode :: Int -> Node -> TB.Builder printNode _ (NodeContent t) = TB.fromText t -- print text exactly as-is-printNode i (NodeElement e) = printElement i e -- pretty-print elements+printNode i (NodeElement e) = printElement i e True -- pretty-print elements printNode i (NodeComment t) = indent i <> TB.fromString "<!-- "@@ -331,7 +336,7 @@ ( TB.toLazyText ( TB.fromString "<?xml version=\"1.0\" encoding=\"UTF-8\"?>" <> newline- <> printElement 0 root+ <> printElement 0 root False ) )
test/CLISpec.hs view
@@ -88,6 +88,12 @@ testCLIFailed :: [String] -> [String] -> Expectation testCLIFailed args outputs = testCLI' args outputs (Left (ExitFailure 1)) +resource :: String -> String+resource file = "test-resources/cli/" <> file++rule :: String -> String+rule file = "--rule=" <> resource file+ spec :: Spec spec = do it "prints version" $@@ -139,37 +145,49 @@ it "with --depth-sensitive" $ withStdin "Q -> [[ x -> \"x\"]]" $ testCLIFailed- ["rewrite", "--depth-sensitive", "--max-depth=1", "--max-cycles=1", "--rule=test-resources/cli/infinite.yaml"]+ ["rewrite", "--depth-sensitive", "--max-depth=1", "--max-cycles=1", rule "infinite.yaml"] ["[ERROR]: With option --depth-sensitive it's expected rewriting iterations amount does not reach the limit: --max-depth=1"] - it "on --sweet and --output=xmir together" $- withStdin "Q -> [[ ]]" $- testCLIFailed- ["rewrite", "--sweet", "--output=xmir"]- ["The --sweet and --output=xmir can't stay together"]- it "with looping rules" $ withStdin "Q -> [[ x -> \"0\" ]]" $ testCLIFailed- ["rewrite", "--rule=test-resources/cli/first.yaml", "--rule=test-resources/cli/second.yaml", "--max-depth=1", "--max-cycles=3"]+ ["rewrite", rule "first.yaml", rule "second.yaml", "--max-depth=1", "--max-cycles=3"] ["it seems rewriting is looping"] it "with wrong attribute and valid error message" $ testCLIFailed- ["rewrite", "test-resources/cli/with-$this-attribute.phi"]+ ["rewrite", resource "with-$this-attribute.phi"] [ "[ERROR]: Couldn't parse given phi program, cause: program:10:13:", "10 | $this ↦ ⟦⟧", " | ^^", "unexpected \"$t\"" ] + it "with --output != latex and --nonumber" $+ withStdin "{[[]]}" $+ testCLIFailed+ ["rewrite", "--nonumber", "--output=xmir"]+ ["The --nonumber option can stay together with --output=latex only"]++ it "with --omit-listing and --output != xmir" $+ withStdin "{[[]]}" $+ testCLIFailed+ ["rewrite", "--omit-listing", "--output=phi"]+ ["--omit-listing"]++ it "with --omit-comments and --output != xmir" $+ withStdin "{[[]]}" $+ testCLIFailed+ ["rewrite", "--omit-comments", "--output=phi"]+ ["--omit-comments"]+ it "saves steps to dir with --steps-dir" $ do let dir = "test-steps-temp" dirExists <- doesDirectoryExist dir when dirExists (removeDirectoryRecursive dir) withStdin "Q -> [[ x -> \"hello\"]]" $ do testCLISucceeded- ["rewrite", "--rule=test-resources/cli/infinite.yaml", "--max-cycles=2", "--max-depth=2", "--steps-dir=" ++ dir, "--sweet"]+ ["rewrite", rule "infinite.yaml", "--max-cycles=2", "--max-depth=2", "--steps-dir=" ++ dir, "--sweet"] ["hello_hi_hi"] (`shouldBe` True) <$> doesDirectoryExist dir files <- listDirectory dir@@ -180,7 +198,7 @@ it "desugares without any rules flag from file" $ testCLISucceeded- ["rewrite", "test-resources/cli/desugar.phi"]+ ["rewrite", resource "desugar.phi"] ["Φ ↦ ⟦\n foo ↦ Φ.org.eolang,\n ρ ↦ ∅\n⟧"] it "desugares with without any rules flag from stdin" $@@ -193,7 +211,7 @@ it "normalizes with --normalize flag" $ testCLISucceeded- ["rewrite", "--normalize", "test-resources/cli/normalize.phi"]+ ["rewrite", "--normalize", resource "normalize.phi"] [ unlines [ "Φ ↦ ⟦", " x ↦ ⟦",@@ -240,18 +258,27 @@ ["rewrite", "--output=latex", "--sweet"] [ "\\begin{phiquation}", "{[[",- " x -> QQ.z(",- " y -> 5",+ " |x| -> QQ.|z|(",+ " |y| -> 5", " ),",- " q -> T,",- " w -> $,",+ " |q| -> T,",+ " |w| -> $,", " ^ -> Q,", " @ -> 1,",- " y -> \"H$@^M\"",+ " |y| -> \"H$@^M\"", "]]}", "\\end{phiquation}" ] + it "rewrites as LaTeX without numeration" $+ withStdin "Q -> [[ x -> 5 ]]" $+ testCLISucceeded+ ["rewrite", "--output=latex", "--sweet", "--nonumber", "--flat"]+ [ "\\begin{phiquation*}",+ "{[[ |x| -> 5 ]]}",+ "\\end{phiquation*}"+ ]+ it "rewrites with XMIR as input" $ withStdin "<object><o name=\"app\"><o name=\"x\" base=\"Φ.number\"/></o></object>" $ testCLISucceeded@@ -274,15 +301,15 @@ it "does not fail on exactly 1 rewriting" $ withStdin "{⟦ t ↦ ⟦ x ↦ \"foo\" ⟧ ⟧}" $ testCLISucceeded- ["rewrite", "--rule=test-resources/cli/simple.yaml", "--must=1", "--sweet"]+ ["rewrite", rule "simple.yaml", "--must=1", "--sweet"] ["x ↦ \"bar\""] it "prints many programs with --sequence" $ withStdin "{[[ x -> \"foo\" ]]}" $ testCLISucceeded [ "rewrite",- "--rule=test-resources/cli/first.yaml",- "--rule=test-resources/cli/second.yaml",+ rule "first.yaml",+ rule "second.yaml", "--max-depth=1", "--max-cycles=2", "--sequence",@@ -300,8 +327,8 @@ withStdin "{[[ x -> \"foo\" ]]}" $ testCLISucceeded [ "rewrite",- "--rule=test-resources/cli/first.yaml",- "--rule=test-resources/cli/second.yaml",+ rule "first.yaml",+ rule "second.yaml", "--max-depth=1", "--max-cycles=2", "--sequence",@@ -311,13 +338,25 @@ ] [ unlines [ "\\begin{phiquation}",- "{[[ x -> \"foo\" ]]} \\leadsto_{\\nameref{r:first}}",- "\\leadsto {Q.x( y -> \"foo\" )} \\leadsto_{\\nameref{r:second}}",- "\\leadsto {[[ x -> \"foo\" ]]}",+ "{[[ |x| -> \"foo\" ]]} \\leadsto_{\\nameref{r:first}}",+ " \\leadsto {Q.|x|( |y| -> \"foo\" )} \\leadsto_{\\nameref{r:second}}",+ " \\leadsto {[[ |x| -> \"foo\" ]]}", "\\end{phiquation}" ] ] + it "prints input as listing in XMIR" $+ withStdin "{[[ app -> [[]] ]]}" $+ testCLISucceeded+ ["rewrite", "--output=xmir", "--omit-comments", "--sweet", "--flat"]+ [" <listing>{[[ app -> [[]] ]]}</listing>"]++ it "print program in listing in XMIRs with --sequence" $+ withStdin "{[[ x -> \"foo\" ]]}" $+ testCLISucceeded+ ["rewrite", "--output=xmir", "--omit-comments", "--sweet", "--flat", "--sequence", rule "simple.yaml"]+ [" <listing>{⟦ x ↦ \"foo\" ⟧}</listing>", " <listing>{⟦ x ↦ \"bar\" ⟧}</listing>"]+ describe "must range tests" $ do describe "fails" $ do it "when cycles exceed range ..1" $@@ -329,7 +368,7 @@ it "when cycles below range 2.." $ withStdin "{⟦ t ↦ ⟦ x ↦ \"foo\" ⟧ ⟧}" $ testCLIFailed- ["rewrite", "--rule=test-resources/cli/simple.yaml", "--must=2.."]+ ["rewrite", rule "simple.yaml", "--must=2.."] ["it's expected rewriting cycles to be in range [2..], but rewriting stopped after 1"] it "with invalid range 5..3" $@@ -361,13 +400,13 @@ it "accepts range 1..1 (exactly 1 cycle)" $ withStdin "{⟦ t ↦ ⟦ x ↦ \"foo\" ⟧ ⟧}" $ testCLISucceeded- ["rewrite", "--rule=test-resources/cli/simple.yaml", "--must=1..1", "--sweet"]+ ["rewrite", rule "simple.yaml", "--must=1..1", "--sweet"] ["x ↦ \"bar\""] it "accepts range 1..3 when 1 cycle happens" $ withStdin "{⟦ t ↦ ⟦ x ↦ \"foo\" ⟧ ⟧}" $ testCLISucceeded- ["rewrite", "--rule=test-resources/cli/simple.yaml", "--must=1..3", "--sweet"]+ ["rewrite", rule "simple.yaml", "--must=1..3", "--sweet"] ["x ↦ \"bar\""] it "accepts range 0.. (0 or more)" $@@ -389,7 +428,7 @@ hPutStr h "Q -> [[ x -> \"foo\" ]]" hClose h testCLISucceeded- ["rewrite", "--rule=test-resources/cli/simple.yaml", "--in-place", "--sweet", path]+ ["rewrite", rule "simple.yaml", "--in-place", "--sweet", path] [printf "The file '%s' was modified in-place" path] content <- readFile path content `shouldBe` "{⟦\n x ↦ \"bar\"\n⟧}"@@ -397,7 +436,7 @@ it "rewrites with cycles" $ withStdin "Q -> [[ x -> \"x\" ]]" $ testCLISucceeded- ["rewrite", "--sweet", "--rule=test-resources/cli/infinite.yaml", "--max-depth=1", "--max-cycles=2"]+ ["rewrite", "--sweet", rule "infinite.yaml", "--max-depth=1", "--max-cycles=2"] [ unlines [ "{⟦", " x ↦ \"x_hi_hi\"",@@ -454,3 +493,48 @@ content `shouldContain` "\\documentclass{article}" content `shouldContain` "\\begin{document}" )++ describe "merge" $ do+ it "merges single program" $+ testCLISucceeded+ ["merge", resource "desugar.phi", "--sweet", "--flat"]+ ["{⟦ foo ↦ Φ̇ ⟧}"]++ it "merges EO programs" $+ testCLISucceeded+ ["merge", "--sweet", resource "number.phi", resource "bytes.phi", resource "string.phi"]+ [ unlines+ [ "{⟦",+ " org ↦ ⟦",+ " eolang ↦ ⟦",+ " number ↦ ⟦",+ " φ ↦ ∅",+ " ⟧,",+ " bytes ↦ ⟦",+ " data ↦ ∅",+ " ⟧,",+ " string ↦ ⟦",+ " φ ↦ ∅",+ " ⟧,",+ " λ ⤍ Package",+ " ⟧,",+ " λ ⤍ Package",+ " ⟧",+ "⟧}"+ ]+ ]++ it "fails on merging non formations" $+ testCLIFailed+ ["merge", resource "dispatch.phi", resource "number.phi"]+ ["Invalid program format, only programs with top level formations are supported for 'merge' command"]++ it "fails on merging conflicted bindings" $+ testCLIFailed+ ["merge", resource "foo.phi", resource "desugar.phi"]+ ["Can't merge two bindings, conflict found"]++ it "fails on merging empty list of programs" $+ testCLIFailed+ ["merge"]+ ["At least one input file must be specified for 'merge' command"]
+ test/MergeSpec.hs view
@@ -0,0 +1,55 @@+-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module MergeSpec where++import AST+import Control.Monad (forM_)+import Data.List (intercalate)+import Merge (merge)+import Parser (parseExpressionThrows)+import Test.Hspec (Spec, anyException, describe, it, shouldBe, shouldThrow)++spec :: Spec+spec = do+ describe "merge programs" $+ forM_+ [ ( ["[[ x -> 1 ]]", "[[ y -> 2 ]]"],+ "[[ x -> 1, y -> 2 ]]"+ ),+ ( ["[[ x -> [[ y -> 1 ]] ]]", "[[ x -> [[ z -> 2 ]] ]]"],+ "[[ x -> [[ y -> 1, z -> 2 ]] ]]"+ ),+ ( ["[[ x -> 1 ]]", "[[ x -> 1]]"],+ "[[ x -> 1]]"+ ),+ ( ["[[ org -> [[ eolang -> [[ number -> [[ ]] ]] ]] ]]", "[[ org -> [[ eolang -> [[ bytes -> [[ ]] ]] ]] ]]"],+ "[[ org -> [[ eolang -> [[ number -> [[ ]], bytes -> [[ ]] ]] ]] ]]"+ ),+ ( ["[[ x -> 1 ]]", "[[ y -> 2 ]]", "[[ z -> 3 ]]"],+ "[[ x -> 1, y -> 2, z -> 3 ]]"+ ),+ ( ["[[ x -> ? ]]", "[[ x -> ? ]]"],+ "[[ x -> ? ]]"+ ),+ ( ["[[ D> 42-, x -> [[ ]] ]]", "[[ D> 42-, y -> [[ ]] ]]"],+ "[[ x -> [[ ]], y -> [[ ]], D> 42- ]]"+ )+ ]+ ( \(exprs, res) -> it res $ do+ progs <- mapM (fmap Program . parseExpressionThrows) exprs+ merged <- merge progs+ res' <- fmap Program (parseExpressionThrows res)+ merged `shouldBe` res'+ )++ describe "fails to merge" $+ forM_+ [ ["Q", "$"],+ ["[[ x -> 1]]", "[[ x -> 2 ]]"],+ ["[[ x -> [[ y -> Q ]] ]]", "[[ x -> [[ y -> $ ]] ]]"]+ ]+ ( \exprs -> it (intercalate " and " exprs) $ do+ progs <- mapM (fmap Program . parseExpressionThrows) exprs+ merge progs `shouldThrow` anyException+ )