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.46 +version: 0.0.0.47 license: MIT synopsis: Command-Line Manipulator of šœ‘-Calculus Expressions description: Please see the README on GitHub at @@ -44,6 +44,7 @@ Lining Logger Matcher + Merge Misc Must Parser @@ -114,6 +115,7 @@ DataizeSpec FunctionsSpec MatcherSpec + MergeSpec MiscSpec ParserSpec Paths_phino diff --git a/src/CLI.hs b/src/CLI.hs --- a/src/CLI.hs +++ b/src/CLI.hs @@ -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 <- diff --git a/src/LaTeX.hs b/src/LaTeX.hs --- a/src/LaTeX.hs +++ b/src/LaTeX.hs @@ -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 diff --git a/src/Merge.hs b/src/Merge.hs new file mode 100644 --- /dev/null +++ b/src/Merge.hs @@ -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) diff --git a/src/Misc.hs b/src/Misc.hs --- a/src/Misc.hs +++ b/src/Misc.hs @@ -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 diff --git a/src/XMIR.hs b/src/XMIR.hs --- a/src/XMIR.hs +++ b/src/XMIR.hs @@ -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 -- "\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 @@ -- "\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 "