packages feed

phino 0.0.0.7 → 0.0.0.8

raw patch · 12 files changed

+436/−151 lines, 12 filesdep +xml-conduit

Dependencies added: xml-conduit

Files

phino.cabal view
@@ -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 <https://github.com/objectionary/phino#readme>@@ -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
src/CLI.hs view
@@ -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
src/Condition.hs view
@@ -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
+ src/Pretty.hs view
@@ -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
src/Printer.hs view
@@ -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)
src/Rewriter.hs view
@@ -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
+ src/XMIR.hs view
@@ -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 "<!-- " <> TB.fromText t <> TB.fromString " -->" <> newline+printNode _ _ = mempty++printXMIR :: Document -> String+printXMIR (Document _ root _) =+  TL.unpack+    ( TB.toLazyText+        ( TB.fromString "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"+            <> newline+            <> printElement 0 root+        )+    )
test/CLISpec.hs view
@@ -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"]+          ["<?xml version=\"1.0\" encoding=\"UTF-8\"?>", "<object", "  <o base=\"Q.y\" name=\"x\"/>"]
test/ConditionSpec.hs view
@@ -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             )       )
test/PrinterSpec.hs view
@@ -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"))])
test/RewriterSpec.hs view
@@ -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                   )       )
+ test/XMIRSpec.hs view
@@ -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')