diff --git a/phino.cabal b/phino.cabal --- a/phino.cabal +++ b/phino.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: phino -version: 0.0.0.7 +version: 0.0.0.8 license: MIT synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions description: Please see the README on GitHub at @@ -30,12 +30,14 @@ Matcher, Builder, Replacer, - Printer, Rewriter, Yaml, Condition, Misc, - Logger + Logger, + Printer, + Pretty, + XMIR hs-source-dirs: src other-modules: Paths_phino @@ -58,7 +60,8 @@ prettyprinter, optparse-applicative, vector, - random + random, + xml-conduit ^>=1.10 default-language: Haskell2010 -- Executable using the library @@ -89,6 +92,7 @@ ConditionSpec, YamlSpec, MiscSpec, + XMIRSpec, Paths_phino autogen-modules: Paths_phino @@ -109,7 +113,8 @@ yaml, text, silently, - directory + directory, + xml-conduit ^>=1.10 build-tool-depends: hspec-discover:hspec-discover default-language: Haskell2010 diff --git a/src/CLI.hs b/src/CLI.hs --- a/src/CLI.hs +++ b/src/CLI.hs @@ -11,7 +11,7 @@ import Control.Exception (Exception (displayException), SomeException, handle, throw, throwIO) import Control.Exception.Base import Control.Monad (when) -import Data.Char (toUpper) +import Data.Char (toLower, toUpper) import Data.List (intercalate) import Data.Version (showVersion) import Logger @@ -20,7 +20,7 @@ import Options.Applicative import Parser (parseProgramThrows) import Paths_phino (version) -import Printer (printProgram) +import Printer (PrintFormat (PHI, XMIR), printProgram) import Rewriter (rewrite) import System.Exit (ExitCode (..), exitFailure) import System.IO (getContents') @@ -47,18 +47,26 @@ data OptsRewrite = OptsRewrite { rules :: [FilePath], phiInput :: Maybe FilePath, + printFormat :: PrintFormat, normalize :: Bool, nothing :: Bool, shuffle :: Bool, maxDepth :: Integer } +parsePrintFormat :: ReadM PrintFormat +parsePrintFormat = eitherReader $ \format -> case map toLower format of + "xmir" -> Right XMIR + "phi" -> Right PHI + _ -> Left "invalid output format: expected 'xmir' or 'phi'" + rewriteParser :: Parser Command rewriteParser = CmdRewrite <$> ( OptsRewrite <$> many (strOption (long "rule" <> metavar "FILE" <> help "Path to custom rule")) <*> optional (strOption (long "phi-input" <> metavar "FILE" <> help "Path .phi file with 𝜑-expression")) + <*> option parsePrintFormat (long "output" <> metavar "FORMAT" <> help "Program output format" <> value PHI <> showDefault) <*> switch (long "normalize" <> help "Use built-in normalization rules") <*> switch (long "nothing" <> help "Desugar provided 𝜑-expression") <*> switch (long "shuffle" <> help "Shuffle rules before applying") @@ -68,8 +76,8 @@ commandParser :: Parser Command commandParser = hsubparser (command "rewrite" (info rewriteParser (progDesc "Rewrite the expression"))) -readLogLevel :: String -> Either String LogLevel -readLogLevel lvl = case map toUpper lvl of +parseLogLevel :: ReadM LogLevel +parseLogLevel = eitherReader $ \lvl -> case map toUpper lvl of "DEBUG" -> Right DEBUG "INFO" -> Right INFO "WARNING" -> Right WARNING @@ -83,7 +91,7 @@ appParser = App <$> option - (eitherReader readLogLevel) + parseLogLevel ( long "log-level" <> metavar "LEVEL" <> help ("Log level (" <> intercalate ", " (map show [DEBUG, INFO, WARNING, ERROR, NONE]) <> ")") @@ -145,7 +153,9 @@ else pure ordered program <- parseProgramThrows prog rewritten <- rewrite' program rules' 1 - putStrLn (printProgram rewritten) + logDebug (printf "Printing rewritten 𝜑-program as %s" (show printFormat)) + out <- printProgram rewritten printFormat + putStrLn out where rewrite' :: Program -> [Y.Rule] -> Integer -> IO Program rewrite' prog rules count = do diff --git a/src/Condition.hs b/src/Condition.hs --- a/src/Condition.hs +++ b/src/Condition.hs @@ -7,11 +7,10 @@ import Builder (buildAttribute, buildBinding) import Data.Aeson (FromJSON) import qualified Data.Map.Strict as M -import GHC.Generics import GHC.IO (unsafePerformIO) import Matcher import Misc (allPathsIn) -import Printer (printCondition, printExpression, printSubstitutions) +import Pretty (prettyExpression, prettySubsts) import Yaml (normalizationRules) import qualified Yaml as Y diff --git a/src/Pretty.hs b/src/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Pretty.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE FlexibleInstances #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module Pretty + ( prettyExpression, + prettyProgram, + prettyAttribute, + prettySubsts, + prettyBinding, + ) +where + +import Ast +import qualified Data.Map.Strict as Map +import Matcher +import Prettyprinter +import Prettyprinter.Render.String (renderString) + +prettyMeta :: String -> Doc ann +prettyMeta meta = pretty "!" <> pretty meta + +prettyArrow :: Doc ann +prettyArrow = pretty "↦" + +prettyDashedArrow :: Doc ann +prettyDashedArrow = pretty "⤍" + +instance Pretty Attribute where + pretty (AtLabel name) = pretty name + pretty (AtAlpha index) = pretty "α" <> pretty index + pretty AtRho = pretty "ρ" + pretty AtPhi = pretty "φ" + pretty (AtMeta meta) = prettyMeta meta + +instance Pretty Binding where + pretty (BiTau attr expr) = pretty attr <+> prettyArrow <+> pretty expr + pretty (BiMeta meta) = prettyMeta meta + pretty (BiDelta bytes) = pretty "Δ" <+> prettyDashedArrow <+> pretty bytes + pretty (BiMetaDelta meta) = pretty "Δ" <+> prettyDashedArrow <+> prettyMeta meta + pretty (BiVoid attr) = pretty attr <+> prettyArrow <+> pretty "∅" + pretty (BiLambda func) = pretty "λ" <+> prettyDashedArrow <+> pretty func + pretty (BiMetaLambda meta) = pretty "λ" <+> prettyDashedArrow <+> prettyMeta meta + +instance {-# OVERLAPPING #-} Pretty [Binding] where + pretty bindings = vsep (punctuate comma (map pretty bindings)) + +instance Pretty Expression where + pretty (ExFormation []) = pretty "⟦⟧" + pretty (ExFormation [binding]) = case binding of + BiTau _ _ -> vsep [pretty "⟦", indent 2 (pretty binding), pretty "⟧"] + _ -> pretty "⟦" <+> pretty binding <+> pretty "⟧" + pretty (ExFormation bindings) = vsep [pretty "⟦", indent 2 (pretty bindings), pretty "⟧"] + pretty ExThis = pretty "ξ" + pretty ExGlobal = pretty "Φ" + pretty ExTermination = pretty "⊥" + pretty (ExMeta meta) = prettyMeta meta + pretty (ExApplication expr tau) = pretty expr <> vsep [lparen, indent 2 (pretty tau), rparen] + pretty (ExDispatch expr attr) = pretty expr <> pretty "." <> pretty attr + pretty (ExMetaTail expr meta) = pretty expr <+> pretty "*" <+> prettyMeta meta + +instance Pretty Program where + pretty (Program expr) = pretty "Φ" <+> prettyArrow <+> pretty expr + +instance Pretty Tail where + pretty (TaApplication tau) = vsep [lparen, indent 2 (pretty tau), rparen] + pretty (TaDispatch attr) = pretty "." <> pretty attr + +instance Pretty MetaValue where + pretty (MvAttribute attr) = pretty attr + pretty (MvBytes bytes) = pretty bytes + pretty (MvBindings []) = pretty "[]" + pretty (MvBindings bindings) = vsep [pretty "[", indent 2 (pretty bindings), pretty "]"] + pretty (MvFunction func) = pretty func + pretty (MvExpression expr) = pretty expr + pretty (MvTail tails) = vsep (punctuate comma (map pretty tails)) + +instance Pretty Subst where + pretty (Subst mp) = + vsep + [ lparen, + indent + 2 + ( vsep + ( punctuate + comma + ( map + (\(key, value) -> prettyMeta key <+> pretty ">>" <+> pretty value) + (Map.toList mp) + ) + ) + ), + rparen + ] + +instance {-# OVERLAPPING #-} Pretty [Subst] where + pretty [] = pretty "[]" + pretty substs = vsep [pretty "[", indent 2 (vsep (punctuate comma (map pretty substs))), pretty "]"] + +render :: (Pretty a) => a -> String +render printable = renderString (layoutPretty defaultLayoutOptions (pretty printable)) + +prettyBinding :: Binding -> String +prettyBinding = render + +prettyAttribute :: Attribute -> String +prettyAttribute = render + +prettySubsts :: [Subst] -> String +prettySubsts = render + +prettyExpression :: Expression -> String +prettyExpression = render + +prettyProgram :: Program -> String +prettyProgram = render diff --git a/src/Printer.hs b/src/Printer.hs --- a/src/Printer.hs +++ b/src/Printer.hs @@ -1,115 +1,21 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} - -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module Printer (printExpression, printProgram, printSubstitutions, printCondition) where +module Printer where import Ast -import qualified Data.Map.Strict as Map -import Matcher -import Prettyprinter -import Prettyprinter.Render.String (renderString) -import Text.Printf (vFmt) -import Yaml (Condition) -import qualified Yaml as Y - -prettyMeta :: String -> Doc ann -prettyMeta meta = pretty "!" <> pretty meta - -prettyArrow :: Doc ann -prettyArrow = pretty "↦" - -prettyDashedArrow :: Doc ann -prettyDashedArrow = pretty "⤍" - -instance Pretty Attribute where - pretty (AtLabel name) = pretty name - pretty (AtAlpha index) = pretty "α" <> pretty index - pretty AtRho = pretty "ρ" - pretty AtPhi = pretty "φ" - pretty (AtMeta meta) = prettyMeta meta - -instance Pretty Binding where - pretty (BiTau attr expr) = pretty attr <+> prettyArrow <+> pretty expr - pretty (BiMeta meta) = prettyMeta meta - pretty (BiDelta bytes) = pretty "Δ" <+> prettyDashedArrow <+> pretty bytes - pretty (BiMetaDelta meta) = pretty "Δ" <+> prettyDashedArrow <+> prettyMeta meta - pretty (BiVoid attr) = pretty attr <+> prettyArrow <+> pretty "∅" - pretty (BiLambda func) = pretty "λ" <+> prettyDashedArrow <+> pretty func - pretty (BiMetaLambda meta) = pretty "λ" <+> prettyDashedArrow <+> prettyMeta meta - -instance {-# OVERLAPPING #-} Pretty [Binding] where - pretty bindings = vsep (punctuate comma (map pretty bindings)) - -instance Pretty Expression where - pretty (ExFormation []) = pretty "⟦⟧" - pretty (ExFormation [binding]) = case binding of - BiTau _ _ -> vsep [pretty "⟦", indent 2 (pretty binding), pretty "⟧"] - _ -> pretty "⟦" <+> pretty binding <+> pretty "⟧" - pretty (ExFormation bindings) = vsep [pretty "⟦", indent 2 (pretty bindings), pretty "⟧"] - pretty ExThis = pretty "ξ" - pretty ExGlobal = pretty "Φ" - pretty ExTermination = pretty "⊥" - pretty (ExMeta meta) = prettyMeta meta - pretty (ExApplication expr tau) = pretty expr <> vsep [lparen, indent 2 (pretty tau), rparen] - pretty (ExDispatch expr attr) = pretty expr <> pretty "." <> pretty attr - pretty (ExMetaTail expr meta) = pretty expr <+> pretty "*" <+> prettyMeta meta - -instance Pretty Program where - pretty (Program expr) = pretty "Φ" <+> prettyArrow <+> pretty expr - -instance Pretty Tail where - pretty (TaApplication tau) = vsep [lparen, indent 2 (pretty tau), rparen] - pretty (TaDispatch attr) = pretty "." <> pretty attr - -instance Pretty MetaValue where - pretty (MvAttribute attr) = pretty attr - pretty (MvBytes bytes) = pretty bytes - pretty (MvBindings []) = pretty "[]" - pretty (MvBindings bindings) = vsep [pretty "[", indent 2 (pretty bindings), pretty "]"] - pretty (MvFunction func) = pretty func - pretty (MvExpression expr) = pretty expr - pretty (MvTail tails) = vsep (punctuate comma (map pretty tails)) - -instance Pretty Subst where - pretty (Subst mp) = - vsep - [ lparen, - indent - 2 - ( vsep - ( punctuate - comma - ( map - (\(key, value) -> prettyMeta key <+> pretty ">>" <+> pretty value) - (Map.toList mp) - ) - ) - ), - rparen - ] - -instance Pretty Condition where - pretty (Y.NF expr) = pretty "NF(" <+> pretty expr <+> rparen - -instance {-# OVERLAPPING #-} Pretty [Subst] where - pretty :: [Subst] -> Doc ann - pretty [] = pretty "[]" - pretty substs = vsep [pretty "[", indent 2 (vsep (punctuate comma (map pretty substs))), pretty "]"] - -prettyPrint :: (Pretty a) => a -> String -prettyPrint printable = renderString (layoutPretty defaultLayoutOptions (pretty printable)) - -printCondition :: Condition -> String -printCondition = prettyPrint +import Pretty (prettyProgram) +import XMIR (programToXMIR, printXMIR) -printSubstitutions :: [Subst] -> String -printSubstitutions = prettyPrint +data PrintFormat = XMIR | PHI + deriving (Eq) -printExpression :: Expression -> String -printExpression = prettyPrint +instance Show PrintFormat where + show XMIR = "xmir" + show PHI = "phi" -printProgram :: Program -> String -printProgram = prettyPrint +printProgram :: Program -> PrintFormat -> IO String +printProgram prog PHI = pure (prettyProgram prog) +printProgram prog XMIR = do + xmir <- programToXMIR prog + pure (printXMIR xmir) diff --git a/src/Rewriter.hs b/src/Rewriter.hs --- a/src/Rewriter.hs +++ b/src/Rewriter.hs @@ -18,7 +18,7 @@ import Matcher (MetaValue (MvAttribute, MvBindings, MvExpression), Subst (Subst), combine, combineMany, matchProgram, substEmpty, substSingle) import Misc (ensuredFile) import Parser (parseProgram, parseProgramThrows) -import Printer (printExpression, printProgram, printSubstitutions) +import Pretty (prettyExpression, prettyProgram, prettySubsts) import Replacer (replaceProgram) import Text.Printf import qualified Yaml as Y @@ -32,14 +32,14 @@ show CouldNotBuild {..} = printf "Couldn't build given expression with provided substitutions\n--Expression: %s\n--Substitutions: %s" - (printExpression expr) - (printSubstitutions substs) + (prettyExpression expr) + (prettySubsts substs) show CouldNotReplace {..} = printf "Couldn't replace expression in program by pattern\nProgram: %s\n--Pattern: %s\n--Result: %s" - (printProgram prog) - (printExpression ptn) - (printExpression res) + (prettyProgram prog) + (prettyExpression ptn) + (prettyExpression res) -- Build pattern and result expression and replace patterns to results in given program buildAndReplace :: Program -> Expression -> Expression -> [Subst] -> IO Program @@ -83,6 +83,6 @@ pure program Just matched -> do let substs = extended matched - logDebug (printf "Rule has been matched, substitutions are:\n%s" (printSubstitutions substs)) + logDebug (printf "Rule has been matched, substitutions are:\n%s" (prettySubsts substs)) replaced substs rewrite prog rest diff --git a/src/XMIR.hs b/src/XMIR.hs new file mode 100644 --- /dev/null +++ b/src/XMIR.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE RecordWildCards #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module XMIR (programToXMIR, printXMIR) where + +import Ast +import Control.Exception (throwIO) +import Control.Exception.Base (Exception) +import qualified Data.Bifunctor +import Data.List (intercalate) +import qualified Data.List +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (catMaybes, mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TB +import Debug.Trace (trace) +import Pretty (prettyAttribute, prettyBinding, prettyExpression, prettyProgram) +import Text.Printf (printf) +import Text.XML + +data XMIRException + = UnsupportedExpression {expr :: Expression} + | UnsupportedBinding {binding :: Binding} + deriving (Exception) + +instance Show XMIRException where + show UnsupportedExpression {..} = printf "XMIR does not support such expression: %s" (prettyExpression expr) + show UnsupportedBinding {..} = printf "XMIR does not support such bindings: %s" (prettyBinding binding) + +toName :: String -> Name +toName str = Name (T.pack str) Nothing Nothing + +element :: String -> [(String, String)] -> [Node] -> Element +element name attrs children = do + let name' = toName name + attrs' = M.fromList (map (Data.Bifunctor.bimap toName T.pack) attrs) + Element name' attrs' children + +object :: [(String, String)] -> [Node] -> Node +object attrs children = NodeElement (element "o" attrs children) + +expression :: Expression -> IO (String, [Node]) +expression ExThis = pure ("$", []) +expression ExGlobal = pure ("Q", []) +expression (ExFormation bds) = do + nested <- nestedBindings bds + pure ("", nested) +expression (ExDispatch expr attr) = do + (base, children) <- expression expr + let attr' = prettyAttribute attr + if null base + then pure ('.' : attr', [object [] children]) + else + if head base == '.' || not (null children) + then pure ('.' : attr', [object [("base", base)] children]) + else pure (base ++ ('.' : attr'), children) +expression (ExApplication expr (BiTau attr texpr)) = do + (base, children) <- expression expr + (base', children') <- expression texpr + let as = prettyAttribute attr + attrs = + if null base' + then [("as", as)] + else [("as", as), ("base", base')] + pure (base, object attrs children' : children) +expression (ExApplication (ExFormation bds) tau) = throwIO (UnsupportedExpression (ExApplication (ExFormation bds) tau)) +expression expr = throwIO (UnsupportedExpression expr) + +nestedBindings :: [Binding] -> IO [Node] +nestedBindings bds = catMaybes <$> mapM formationBinding bds + +formationBinding :: Binding -> IO (Maybe Node) +formationBinding (BiTau (AtLabel label) (ExFormation bds)) = do + inners <- nestedBindings bds + pure (Just (object [("name", label)] inners)) +formationBinding (BiTau (AtLabel label) expr) = do + (base, children) <- expression expr + pure (Just (object [("name", label), ("base", base)] (reverse children))) +formationBinding (BiTau AtRho _) = pure Nothing +formationBinding (BiDelta bytes) = pure (Just (NodeContent (T.pack bytes))) +formationBinding (BiLambda func) = pure (Just (object [("name", "λ")] [])) +formationBinding (BiVoid AtRho) = pure Nothing +formationBinding (BiVoid AtPhi) = pure (Just (object [("name", "φ"), ("base", "∅")] [])) +formationBinding (BiVoid (AtLabel label)) = pure (Just (object [("name", label), ("base", "∅")] [])) +formationBinding binding = throwIO (UnsupportedBinding binding) + +rootExpression :: Expression -> IO Node +rootExpression (ExFormation [bd, BiVoid AtRho]) = do + [bd'] <- nestedBindings [bd] + pure bd' +rootExpression expr = throwIO (UnsupportedExpression expr) + +-- Extract package from given expression +-- The function returns tuple (X, Y), where +-- - X: list of package parts +-- - Y: root object expression +getPackage :: Expression -> IO ([String], Expression) +getPackage (ExFormation [BiTau (AtLabel label) (ExFormation [bd, BiLambda "Package", BiVoid AtRho]), BiVoid AtRho]) = do + (pckg, expr') <- getPackage (ExFormation [bd, BiLambda "Package", BiVoid AtRho]) + pure (label : pckg, expr') +getPackage (ExFormation [BiTau (AtLabel label) (ExFormation [bd, BiLambda "Package", BiVoid AtRho]), BiLambda "Package", BiVoid AtRho]) = do + (pckg, expr') <- getPackage (ExFormation [bd, BiLambda "Package", BiVoid AtRho]) + pure (label : pckg, expr') +getPackage (ExFormation [BiTau attr expr, BiLambda "Package", BiVoid AtRho]) = pure ([], ExFormation [BiTau attr expr, BiVoid AtRho]) +getPackage (ExFormation [bd, BiVoid AtRho]) = pure ([], ExFormation [bd, BiVoid AtRho]) +getPackage expr = throwIO (userError (printf "Can't extract package from given expression:\n %s" (prettyExpression expr))) + +metasWithPackage :: String -> [Node] +metasWithPackage pckg = + [ NodeElement + ( element + "metas" + [] + [ NodeElement + ( element + "meta" + [] + [ NodeElement (element "head" [] [NodeContent (T.pack "package")]), + NodeElement (element "tail" [] [NodeContent (T.pack pckg)]), + NodeElement (element "part" [] [NodeContent (T.pack pckg)]) + ] + ) + ] + ) + | not (null pckg) + ] + +programToXMIR :: Program -> IO Document +programToXMIR (Program expr) = do + (pckg, expr') <- getPackage expr + root <- rootExpression expr' + pure + ( Document + (Prologue [] Nothing []) + ( element + "object" + [("xmlns:xsi", "http://www.w3.org/2001/XMLSchema-instance")] + ( NodeElement (element "listing" [] [NodeContent (T.pack (prettyProgram (Program expr)))]) + : root + : metasWithPackage (intercalate "." pckg) + ) + ) + [] + ) + +-- Add indentation (2 spaces per level). +indent :: Int -> TB.Builder +indent n = TB.fromText (T.replicate n (T.pack " ")) + +newline :: TB.Builder +newline = TB.fromString "\n" + +printElement :: Int -> Element -> TB.Builder +printElement indentLevel (Element name attrs nodes) + | null nodes = + indent indentLevel + <> TB.fromString "<" + <> TB.fromText (nameLocalName name) + <> attrsText + <> TB.fromString "/>" + <> newline + | all isTextNode nodes = + indent indentLevel + <> TB.fromString "<" + <> TB.fromText (nameLocalName name) + <> attrsText + <> TB.fromString ">" + <> mconcat (map printRawText nodes) + <> TB.fromString " TB.fromText (nameLocalName name) + <> TB.fromString ">" + <> newline + | otherwise = + indent indentLevel + <> TB.fromString "<" + <> TB.fromText (nameLocalName name) + <> attrsText + <> TB.fromString ">" + <> newline + <> mconcat (map (printNode (indentLevel + 1)) nodes) + <> indent indentLevel + <> TB.fromString " TB.fromText (nameLocalName name) + <> TB.fromString ">" + <> newline + where + attrsText = + mconcat + [ TB.fromString " " <> TB.fromText (nameLocalName k) <> TB.fromString "=\"" <> TB.fromText v <> TB.fromString "\"" + | (k, v) <- M.toList attrs + ] + + isTextNode (NodeContent _) = True + isTextNode _ = False + + printRawText (NodeContent t) = TB.fromText t + printRawText _ = mempty + +printNode :: Int -> Node -> TB.Builder +printNode _ (NodeContent t) = TB.fromText t -- print text exactly as-is +printNode i (NodeElement e) = printElement i e -- pretty-print elements +printNode i (NodeComment t) = indent i <> TB.fromString "" <> newline +printNode _ _ = mempty + +printXMIR :: Document -> String +printXMIR (Document _ root _) = + TL.unpack + ( TB.toLazyText + ( TB.fromString "" + <> newline + <> printElement 0 root + ) + ) diff --git a/test/CLISpec.hs b/test/CLISpec.hs --- a/test/CLISpec.hs +++ b/test/CLISpec.hs @@ -8,7 +8,7 @@ import CLI (runCLI) import Control.Exception -import Control.Monad (unless) +import Control.Monad (forM_, unless) import Data.List (isInfixOf) import Data.Version (showVersion) import GHC.IO.Handle @@ -63,12 +63,16 @@ where cleanup (fp, _) = removeFile fp -testCLI :: [String] -> String -> Expectation -testCLI args output = do +testCLI :: [String] -> [String] -> Expectation +testCLI args outputs = do out <- capture_ (runCLI args) - unless (output `isInfixOf` out) $ - expectationFailure - ("Expected that output contains:\n" ++ output ++ "\nbut got:\n" ++ out) + forM_ + outputs + ( \output -> + unless (output `isInfixOf` out) $ + expectationFailure + ("Expected that output contains:\n" ++ output ++ "\nbut got:\n" ++ out) + ) testCLIFailed :: [String] -> String -> Expectation testCLIFailed args output = withStdin "" $ do @@ -79,7 +83,7 @@ spec :: Spec spec = do it "prints version" $ do - testCLI ["--version"] (showVersion version) + testCLI ["--version"] [showVersion version] it "prints help" $ do output <- capture_ (runCLI ["--help"]) @@ -87,26 +91,26 @@ output `shouldContain` "Usage:" it "prints debug info with --log-level=DEBUG" $ do - withStdin "Q -> [[]]" $ testCLI ["rewrite", "--nothing", "--log-level=DEBUG"] "[DEBUG]:" + withStdin "Q -> [[]]" $ testCLI ["rewrite", "--nothing", "--log-level=DEBUG"] ["[DEBUG]:"] describe "rewrites" $ do it "desugares with --nothing flag from file" $ testCLI ["rewrite", "--nothing", "--phi-input=test-resources/cli/desugar.phi"] - "Φ ↦ ⟦\n foo ↦ Φ.org.eolang,\n ρ ↦ ∅\n⟧" + ["Φ ↦ ⟦\n foo ↦ Φ.org.eolang,\n ρ ↦ ∅\n⟧"] it "desugares with --nothing flag from stdin" $ withStdin "{[[foo ↦ QQ]]}" $ - testCLI ["rewrite", "--nothing"] "Φ ↦ ⟦\n foo ↦ Φ.org.eolang,\n ρ ↦ ∅\n⟧" + testCLI ["rewrite", "--nothing"] ["Φ ↦ ⟦\n foo ↦ Φ.org.eolang,\n ρ ↦ ∅\n⟧"] it "rewrites with single rule" $ withStdin "{T(x -> Q.y)}" $ - testCLI ["rewrite", "--rule=resources/dc.yaml"] "Φ ↦ ⊥" + testCLI ["rewrite", "--rule=resources/dc.yaml"] ["Φ ↦ ⊥"] it "normalizes with --normalize flag" $ testCLI ["rewrite", "--normalize", "--phi-input=test-resources/cli/normalize.phi"] - ( unlines + [ unlines [ "Φ ↦ ⟦", " x ↦ ⟦", " ρ ↦ ⟦", @@ -117,7 +121,7 @@ " ρ ↦ ∅", "⟧" ] - ) + ] it "fails with negative --max-depth" $ testCLIFailed @@ -129,11 +133,11 @@ ["rewrite"] "no --rule, no --normalize, no --nothing are provided" - it "normalizes from stdin" $ do + it "normalizes from stdin" $ withStdin "Φ ↦ ⟦ a ↦ ⟦ b ↦ ∅ ⟧ (b ↦ [[ ]]) ⟧" $ testCLI ["rewrite", "--normalize"] - ( unlines + [ unlines [ "Φ ↦ ⟦", " a ↦ ⟦", " b ↦ ⟦ ρ ↦ ∅ ⟧,", @@ -142,4 +146,10 @@ " ρ ↦ ∅", "⟧" ] - ) + ] + + it "rewrites as XMIR" $ + withStdin "Q -> [[ x -> Q.y ]]" $ + testCLI + ["rewrite", "--nothing", "--output=xmir"] + ["", ""] diff --git a/test/ConditionSpec.hs b/test/ConditionSpec.hs --- a/test/ConditionSpec.hs +++ b/test/ConditionSpec.hs @@ -14,7 +14,7 @@ import GHC.Generics import Matcher (matchProgram) import Misc -import Printer (printSubstitutions) +import Pretty (prettySubsts) import System.FilePath import Test.Hspec (Spec, describe, expectationFailure, it, runIO) import Yaml qualified @@ -42,6 +42,6 @@ (null met) ( expectationFailure $ "List of substitution after condition check must be not empty\nOriginal substitutions:\n" - ++ printSubstitutions matched + ++ prettySubsts matched ) ) diff --git a/test/PrinterSpec.hs b/test/PrinterSpec.hs --- a/test/PrinterSpec.hs +++ b/test/PrinterSpec.hs @@ -8,7 +8,7 @@ import Matcher (MetaValue (MvAttribute, MvExpression), substEmpty, substSingle) import Parser (parseProgramThrows) import Prettyprinter -import Printer +import Pretty import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, describe, it, runIO, shouldBe) test :: (Pretty a) => (a -> String) -> [(String, String, a)] -> SpecWith (Arg Expectation) @@ -35,11 +35,11 @@ "Φ ↦ ⟦\n Δ ⤍ 00-,\n λ ⤍ F,\n ρ ↦ ∅,\n !B,\n φ ↦ ⟦\n y ↦ ∅,\n ρ ↦ ∅\n ⟧\n⟧" ) ] - test printProgram useCases + test prettyProgram useCases describe "print substitution" $ test - printSubstitutions + prettySubsts [ ("[()]", "[\n (\n \n )\n]", [substEmpty]), ("[(!e >> Q.x)]", "[\n (\n !e >> Φ.x\n )\n]", [substSingle "e" (MvExpression (ExDispatch ExGlobal (AtLabel "x")))]), ("[(!a >> x)]", "[\n (\n !a >> x\n )\n]", [substSingle "a" (MvAttribute (AtLabel "x"))]) diff --git a/test/RewriterSpec.hs b/test/RewriterSpec.hs --- a/test/RewriterSpec.hs +++ b/test/RewriterSpec.hs @@ -16,7 +16,7 @@ import GHC.Generics import Misc (allPathsIn, ensuredFile) import Parser (parseProgramThrows) -import Printer (printProgram) +import Pretty (prettyProgram) import Rewriter (rewrite) import System.FilePath (makeRelative, replaceExtension, ()) import Test.Hspec (Spec, describe, expectationFailure, it, pending, runIO) @@ -97,8 +97,8 @@ unless (rewritten == result') $ expectationFailure ( "Wrong rewritten program. Expected:\n" - ++ printProgram result' + ++ prettyProgram result' ++ "\nGot:\n" - ++ printProgram rewritten + ++ prettyProgram rewritten ) ) diff --git a/test/XMIRSpec.hs b/test/XMIRSpec.hs new file mode 100644 --- /dev/null +++ b/test/XMIRSpec.hs @@ -0,0 +1,19 @@ +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module XMIRSpec where + +import Test.Hspec (Spec, it, shouldBe, runIO) +import XMIR +import Misc (ensuredFile) +import Parser (parseProgramThrows) +import qualified Data.Text as T + +spec :: Spec +spec = do + phi <- runIO $ readFile =<< ensuredFile "test-resources/xmir/program.phi" + xmir <- runIO $ readFile =<< ensuredFile "test-resources/xmir/program.xmir" + prog <- runIO (parseProgramThrows phi) + doc <- runIO $ programToXMIR prog + let xmir' = printXMIR doc + it "prints valid xmir" $ T.stripEnd (T.pack xmir) `shouldBe` T.stripEnd (T.pack xmir')