phino 0.0.0.10 → 0.0.0.11

raw patch · 8 files changed

+366/−127 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• phino.cabal +2/−4
• src/CLI.hs +73/−46
• src/Misc.hs +9/−9
• src/Parser.hs +25/−20
• src/Printer.hs +0/−21
• src/XMIR.hs +202/−8
• test/CLISpec.hs +20/−4
• test/XMIRSpec.hs +35/−15

@@ -1,7 +1,7 @@ cabal-version:      3.0  name:               phino-version:            0.0.0.10+version:            0.0.0.11 license:            MIT synopsis:           Command-Line Manipulator of 𝜑-Calculus Expressions description:        Please see the README on GitHub at <https://github.com/objectionary/phino#readme>@@ -20,7 +20,7 @@   location: https://github.com/objectionary/phino  common warnings-  ghc-options: -Wall+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wno-missing-export-lists  library   exposed-modules:@@ -35,7 +35,6 @@     Condition,     Misc,     Logger,-    Printer,     Pretty,     XMIR   hs-source-dirs: src@@ -100,7 +99,6 @@     Paths_phino   default-extensions:     ImportQualifiedPost-  ghc-options: -Wall   build-depends:     optparse-applicative,     base,

@@ -20,12 +20,12 @@ import Options.Applicative import Parser (parseProgramThrows) import Paths_phino (version)-import Pretty (PrintMode (SALTY, SWEET))-import Printer (PrintFormat (PHI, XMIR), printProgram)+import Pretty (PrintMode (SALTY, SWEET), prettyProgram') import Rewriter (rewrite) import System.Exit (ExitCode (..), exitFailure) import System.IO (getContents') import Text.Printf (printf)+import XMIR (printXMIR, programToXMIR, parseXMIRThrows, xmirToPhi) import Yaml (normalizationRules) import qualified Yaml as Y @@ -36,7 +36,7 @@  instance Show CmdException where   show InvalidRewriteArguments {..} = printf "Invalid set of arguments for 'rewrite' command: %s" message-  show CouldNotReadFromStdin {..} = printf "Could not read 𝜑-expression from stdin\nReason: %s" message+  show CouldNotReadFromStdin {..} = printf "Could not read input from stdin\nReason: %s" message  data App = App   { logLevel :: LogLevel,@@ -45,10 +45,18 @@  newtype Command = CmdRewrite OptsRewrite +data IOFormat = XMIR | PHI+  deriving (Eq)++instance Show IOFormat where+  show XMIR = "xmir"+  show PHI = "phi"+ data OptsRewrite = OptsRewrite-  { rules :: [FilePath],-    phiInput :: Maybe FilePath,-    printFormat :: PrintFormat,+  { inputFile :: Maybe FilePath,+    rules :: [FilePath],+    inputFormat :: IOFormat,+    outputFormat :: IOFormat,     printMode :: PrintMode,     normalize :: Bool,     nothing :: Bool,@@ -56,22 +64,23 @@     maxDepth :: Integer   } -parsePrintFormat :: ReadM PrintFormat-parsePrintFormat = eitherReader $ \format -> case map toLower format of+parseIOFormat :: String -> ReadM IOFormat+parseIOFormat type' = eitherReader $ \format -> case map toLower format of   "xmir" -> Right XMIR   "phi" -> Right PHI-  _ -> Left "invalid output format: expected 'xmir' or 'phi'"+  _ -> Left (printf "invalid %s format: expected 'xmir' or 'phi'" type')  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)+            <$> optional (argument str (metavar "FILE" <> help "Path to input file"))+            <*> many (strOption (long "rule" <> metavar "FILE" <> help "Path to custom rule"))+            <*> option (parseIOFormat "input") (long "input" <> metavar "FORMAT" <> help "Program input format" <> value PHI <> showDefault)+            <*> option (parseIOFormat "output") (long "output" <> metavar "FORMAT" <> help "Program output format" <> value PHI <> showDefault)             <*> flag SALTY SWEET (long "sweet" <> help "Print 𝜑-program using syntax sugar")             <*> switch (long "normalize" <> help "Use built-in normalization rules")-            <*> switch (long "nothing" <> help "Desugar provided 𝜑-expression")+            <*> switch (long "nothing" <> help "Just desugar provided 𝜑-program")             <*> switch (long "shuffle" <> help "Shuffle rules before applying")             <*> option auto (long "max-depth" <> metavar "DEPTH" <> help "Max amount of rewritng cycles" <> value 25 <> showDefault)         )@@ -124,42 +133,54 @@     CmdRewrite OptsRewrite {..} -> do       when (maxDepth <= 0) $ throwIO (InvalidRewriteArguments "--max-depth must be positive")       logDebug (printf "Amount of rewriting cycles: %d" maxDepth)-      prog <- case phiInput of-        Just pth -> do-          logDebug (printf "Reading 𝜑-program from file: '%s'" pth)-          readFile =<< ensuredFile pth-        Nothing -> do-          logDebug "Reading 𝜑-program from stdin"-          getContents' `catch` (\(e :: SomeException) -> throwIO (CouldNotReadFromStdin (show e)))-      rules' <- do-        ordered <--          if nothing-            then do-              logDebug "The --nothing option is provided, no rules are used"-              pure []-            else-              if normalize-                then do-                  logDebug "The --normalize option is provided, built-it normalization rules are used"-                  pure normalizationRules-                else-                  if null rules-                    then throwIO (InvalidRewriteArguments "no --rule, no --normalize, no --nothing are provided")-                    else do-                      logDebug (printf "Using rules from files: [%s]" (intercalate ", " rules))-                      yamls <- mapM ensuredFile rules-                      mapM Y.yamlRule yamls-        if shuffle-          then do-            logDebug "The --shuffle option is provided, rules are used in random order"-            Misc.shuffle ordered-          else pure ordered-      program <- parseProgramThrows prog+      input <- readInput+      rules' <- getRules+      program <- parseProgram input inputFormat       rewritten <- rewrite' program rules' 1-      logDebug (printf "Printing rewritten 𝜑-program as %s" (show printFormat))-      out <- printProgram rewritten printFormat printMode+      logDebug (printf "Printing rewritten 𝜑-program as %s" (show outputFormat))+      out <- printProgram rewritten outputFormat printMode       putStrLn out       where+        readInput :: IO String+        readInput = case inputFile of+          Just pth -> do+            logDebug (printf "Reading from file: '%s'" pth)+            readFile =<< ensuredFile pth+          Nothing -> do+            logDebug "Reading from stdin"+            getContents' `catch` (\(e :: SomeException) -> throwIO (CouldNotReadFromStdin (show e)))++        getRules :: IO [Y.Rule]+        getRules = do+          ordered <-+            if nothing+              then do+                logDebug "The --nothing option is provided, no rules are used"+                pure []+              else+                if normalize+                  then do+                    logDebug "The --normalize option is provided, built-it normalization rules are used"+                    pure normalizationRules+                  else+                    if null rules+                      then throwIO (InvalidRewriteArguments "no --rule, no --normalize, no --nothing are provided")+                      else do+                        logDebug (printf "Using rules from files: [%s]" (intercalate ", " rules))+                        yamls <- mapM ensuredFile rules+                        mapM Y.yamlRule yamls+          if shuffle+            then do+              logDebug "The --shuffle option is provided, rules are used in random order"+              Misc.shuffle ordered+            else pure ordered++        parseProgram :: String -> IOFormat -> IO Program+        parseProgram phi PHI = parseProgramThrows phi+        parseProgram xmir XMIR = do+          doc <- parseXMIRThrows xmir+          xmirToPhi doc+         rewrite' :: Program -> [Y.Rule] -> Integer -> IO Program         rewrite' prog rules count = do           logDebug (printf "Starting rewriting cycle %d out of %d" count maxDepth)@@ -174,3 +195,9 @@                   logDebug "Rewriting is stopped since it does not affect program anymore"                   pure rewritten                 else rewrite' rewritten rules (count + 1)++        printProgram :: Program -> IOFormat -> PrintMode -> IO String+        printProgram prog PHI mode = pure (prettyProgram' prog mode)+        printProgram prog XMIR mode = do+          xmir <- programToXMIR prog mode+          pure (printXMIR xmir)

@@ -101,16 +101,16 @@ -- >>> hexToNum "40-45" -- Expected 8 bytes for conversion, got 2 hexToNum :: String -> Either Integer Double-hexToNum hx =+hexToNum hx = do   let bytes = hexToBts hx-   in if length bytes /= 8-        then error $ "Expected 8 bytes for conversion, got " ++ show (length bytes)-        else-          let word = toWord64BE bytes-              val = wordToDouble word-           in case properFraction val of-                (n, 0.0) -> Left n-                _ -> Right val+  if length bytes /= 8+    then error $ "Expected 8 bytes for conversion, got " ++ show (length bytes)+    else do+      let word = toWord64BE bytes+          val = wordToDouble word+      case properFraction val of+        (n, 0.0) -> Left n+        _ -> Right val   where     toWord64BE :: [Word8] -> Word64     toWord64BE [a, b, c, d, e, f, g, h] =

@@ -103,16 +103,19 @@             case readHex lowHexDigits of               [(low, "")] ->                 if low >= 0xDC00 && low <= 0xDFFF-                  then -- Valid surrogate pair, combine them+                  then do+                    -- Valid surrogate pair, combine them                     let codePoint = 0x10000 + ((n - 0xD800) * 0x400) + (low - 0xDC00)-                     in return (chr codePoint)+                    return (chr codePoint)                   else fail ("Invalid low surrogate: \\u" ++ lowHexDigits)               _ -> fail ("Invalid low surrogate hex: \\u" ++ lowHexDigits)-        else if n >= 0xDC00 && n <= 0xDFFF-          then fail ("Unexpected low surrogate: \\u" ++ hexDigits)-          else if n >= 0 && n <= 0x10FFFF-            then return (chr n)-            else fail ("Invalid Unicode code point: \\u" ++ hexDigits)+        else+          if n >= 0xDC00 && n <= 0xDFFF+            then fail ("Unexpected low surrogate: \\u" ++ hexDigits)+            else+              if n >= 0 && n <= 0x10FFFF+                then return (chr n)+                else fail ("Invalid Unicode code point: \\u" ++ hexDigits)  function :: Parser String function = lexeme $ do@@ -180,19 +183,21 @@ -- 2. one byte: 01- -- 3. many bytes: 01-02-...-FF bytes :: Parser String-bytes = lexeme-  (choice-    [ symbol "--",-      try $ do-        first <- byte-        rest <- some $ do-          dash <- char '-'-          bte <- byte-          return (dash : bte)-        return (first ++ concat rest),-      byte >>= \bte -> char '-' >>= \dash -> return (bte ++ [dash])-    ]-    <?> "bytes")+bytes =+  lexeme+    ( choice+        [ symbol "--",+          try $ do+            first <- byte+            rest <- some $ do+              dash <- char '-'+              bte <- byte+              return (dash : bte)+            return (first ++ concat rest),+          byte >>= \bte -> char '-' >>= \dash -> return (bte ++ [dash])+        ]+        <?> "bytes"+    )  tauBinding :: Parser Attribute -> Parser Binding tauBinding attr = do

@@ -1,21 +0,0 @@--- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com--- SPDX-License-Identifier: MIT--module Printer where--import Ast-import Pretty (prettyProgram', PrintMode)-import XMIR (programToXMIR, printXMIR)--data PrintFormat = XMIR | PHI-  deriving (Eq)--instance Show PrintFormat where-  show XMIR = "xmir"-  show PHI = "phi"--printProgram :: Program -> PrintFormat -> PrintMode -> IO String-printProgram prog PHI mode = pure (prettyProgram' prog mode)-printProgram prog XMIR mode = do-  xmir <- programToXMIR prog mode-  pure (printXMIR xmir)

@@ -1,16 +1,18 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}  -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module XMIR (programToXMIR, printXMIR, toName, element) where+module XMIR (programToXMIR, printXMIR, toName, parseXMIR, parseXMIRThrows, xmirToPhi) where  import Ast-import Control.Exception (throwIO)+import Control.Exception (Exception (displayException), SomeException, throwIO) import Control.Exception.Base (Exception) import qualified Data.Bifunctor+import Data.Foldable (foldlM) import Data.List (intercalate) import qualified Data.List import Data.Map (Map)@@ -24,20 +26,38 @@ import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Data.Time.Format (defaultTimeLocale, formatTime) import Data.Version (showVersion)-import Debug.Trace (trace)+import Misc (withVoidRho) import Paths_phino (version)-import Pretty (prettyAttribute, prettyBinding, prettyExpression, prettyProgram', PrintMode)+import Pretty (PrintMode, prettyAttribute, prettyBinding, prettyExpression, prettyProgram') import Text.Printf (printf)+import Text.Read (readMaybe)+import qualified Text.Read as TR import Text.XML+import qualified Text.XML.Cursor as C +-- @todo #116:30min Refactor XMIR module. This module became so big and hard to read.+--  Now it's responsible for 3 different operations: 1) converting Phi AST to XML Document Ast,+--  2) printing XML Document, 3) parsing XMIR to Phi AST. I think we should separate the logic+--  in order to keep modules as little as possible. data XMIRException   = UnsupportedExpression {expr :: Expression}   | UnsupportedBinding {binding :: Binding}+  | CouldNotParseXMIR {message :: String}+  | InvalidXMIRFormat {message :: String, cursor :: C.Cursor}   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)+  show CouldNotParseXMIR {..} = printf "Couldn't parse given XMIR, cause: %s" message+  show InvalidXMIRFormat {..} =+    printf+      "Couldn't traverse though given XMIR, cause: %s\nXMIR:\n%s"+      message+      ( case C.node cursor of+          NodeElement el -> printXMIR (Document (Prologue [] Nothing []) el [])+          _ -> "Unknown"+      )  toName :: String -> Name toName str = Name (T.pack str) Nothing Nothing@@ -187,7 +207,6 @@         <> TB.fromText (nameLocalName name)         <> attrsText         <> TB.fromString "/>"-        <> newline   | all isTextNode nodes =       indent indentLevel         <> TB.fromString "<"@@ -198,20 +217,17 @@         <> 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 = do       let attrs' = M.toList attrs@@ -242,3 +258,181 @@             <> printElement 0 root         )     )++parseXMIR :: String -> Either String Document+parseXMIR xmir = case parseText def (TL.pack xmir) of+  Right doc -> Right doc+  Left err -> Left (displayException err)++parseXMIRThrows :: String -> IO Document+parseXMIRThrows xmir = case parseXMIR xmir of+  Right doc -> pure doc+  Left err -> throwIO (CouldNotParseXMIR err)++xmirToPhi :: Document -> IO Program+xmirToPhi xmir = do+  let doc = C.fromDocument xmir+  case C.node doc of+    NodeElement el+      | nameLocalName (elementName el) == "object" -> do+          obj <- case doc C.$/ C.element (toName "o") of+            [o] -> xmirToFormationBinding o []+            _ -> throwIO (InvalidXMIRFormat "Expected single <o> element in <object>" doc)+          let pckg =+                [ T.unpack t+                  | meta <- doc C.$/ C.element (toName "metas") C.&/ C.element (toName "meta"),+                    let heads = meta C.$/ C.element (toName "head") C.&/ C.content,+                    heads == ["package"],+                    tail' <- meta C.$/ C.element (toName "tail") C.&/ C.content,+                    t <- T.splitOn "." tail'+                ]+          if null pckg+            then pure (Program (ExFormation [obj, BiVoid AtRho]))+            else do+              let bd = foldr (\part acc -> BiTau (AtLabel part) (ExFormation [acc, BiLambda "Package", BiVoid AtRho])) obj pckg+              pure (Program (ExFormation [bd, BiVoid AtRho]))+      | otherwise -> throwIO (InvalidXMIRFormat "Expected single <object> element" doc)+    _ -> throwIO (InvalidXMIRFormat "NodeElement is expected as root element" doc)++xmirToFormationBinding :: C.Cursor -> [String] -> IO Binding+xmirToFormationBinding cur fqn+  | not (hasAttr "name" cur) = throwIO (InvalidXMIRFormat "Formation children must have @name attribute" cur)+  | not (hasAttr "base" cur) = do+      name <- getAttr "name" cur+      bds <- mapM (`xmirToFormationBinding` (name : fqn)) (cur C.$/ C.element (toName "o"))+      case name of+        "λ" -> pure (BiLambda (intercalate "_" ("L" : reverse fqn)))+        ('α' : _) -> throwIO (InvalidXMIRFormat "Formation child @name can't start with α" cur)+        "@" -> pure (BiTau AtPhi (ExFormation (withVoidRho bds)))+        _ -> pure (BiTau (AtLabel name) (ExFormation (withVoidRho bds)))+  | otherwise = do+      name <- getAttr "name" cur+      base <- getAttr "base" cur+      attr <- case name of+        "@" -> pure AtPhi+        ('α' : _) -> throwIO (InvalidXMIRFormat "Formation child @name can't start with α" cur)+        _ -> pure (AtLabel name)+      case base of+        "∅" -> pure (BiVoid attr)+        _ -> do+          expr <- xmirToExpression cur fqn+          pure (BiTau attr expr)++xmirToExpression :: C.Cursor -> [String] -> IO Expression+xmirToExpression cur fqn+  | hasAttr "base" cur = do+      base <- getAttr "base" cur+      case base of+        '.' : rest ->+          if null rest+            then throwIO (InvalidXMIRFormat "The @base attribute can't be just '.'" cur)+            else do+              let args = cur C.$/ C.element (toName "o")+              if null args+                then throwIO (InvalidXMIRFormat (printf "Element with @base='%s' must have at least one child" base) cur)+                else do+                  expr <- xmirToExpression (head args) fqn+                  attr <- toAttr rest cur+                  let disp = ExDispatch expr attr+                  xmirToApplication disp (tail args) fqn+        "$" -> do+          if null (cur C.$/ C.element (toName "o"))+            then pure ExThis+            else throwIO (InvalidXMIRFormat "Application of '$' is illegal in XMIR" cur)+        "Q" -> do+          if null (cur C.$/ C.element (toName "o"))+            then pure ExGlobal+            else throwIO (InvalidXMIRFormat "Application of 'Q' is illegal in XMIR" cur)+        'Q' : '.' : rest -> xmirToExpression' ExGlobal "Q" rest cur fqn+        '$' : '.' : rest -> xmirToExpression' ExThis "$" rest cur fqn+        _ -> throwIO (InvalidXMIRFormat "The @base attribute must be either ['∅'|'Q'] or start with ['Q.'|'$.'|'.']" cur)+  | otherwise = do+      bds <- mapM (`xmirToFormationBinding` fqn) (cur C.$/ C.element (toName "o"))+      pure (ExFormation (withVoidRho bds))+  where+    xmirToExpression' :: Expression -> String -> String -> C.Cursor -> [String] -> IO Expression+    xmirToExpression' start symbol rest cur fqn =+      if null rest+        then throwIO (InvalidXMIRFormat (printf "The @base='%s.' is illegal in XMIR" symbol) cur)+        else do+          head' <-+            foldlM+              (\acc part -> ExDispatch acc <$> toAttr (T.unpack part) cur)+              start+              (T.splitOn "." (T.pack rest))+          let args = cur C.$/ C.element (toName "o")+          xmirToApplication head' args fqn++xmirToApplication :: Expression -> [C.Cursor] -> [String] -> IO Expression+xmirToApplication = xmirToApplication' 0+  where+    xmirToApplication' :: Integer -> Expression -> [C.Cursor] -> [String] -> IO Expression+    xmirToApplication' _ expr [] _ = pure expr+    xmirToApplication' idx expr (arg : args) fqn = do+      let app+            | hasAttr "name" arg = throwIO (InvalidXMIRFormat "Application argument can't have @name attribute" arg)+            | hasAttr "base" arg && hasText arg = throwIO (InvalidXMIRFormat "It's illegal in XMIR to have @base and text() at the same time" arg)+            | not (hasAttr "base" arg) && not (hasText arg) = do+                bds <- mapM (`xmirToFormationBinding` fqn) (arg C.$/ C.element (toName "o"))+                as <- asToAttr arg idx+                pure (ExApplication expr (BiTau as (ExFormation (withVoidRho bds))))+            | not (hasAttr "base" arg) && hasText arg = do+                as <- asToAttr arg idx+                text <- getText arg+                pure (ExApplication expr (BiTau as (ExFormation [BiDelta text, BiVoid AtRho])))+            | otherwise = do+                as <- asToAttr arg idx+                arg' <- xmirToExpression arg fqn+                pure (ExApplication expr (BiTau as arg'))+      app' <- app+      xmirToApplication' (idx + 1) app' args fqn++    asToAttr :: C.Cursor -> Integer -> IO Attribute+    asToAttr cur idx+      | hasAttr "as" cur = do+          as <- getAttr "as" cur+          attr <- toAttr as cur+          case attr of+            AtRho -> throwIO (InvalidXMIRFormat "The '^' in @as attribute is illegal in XMIR" cur)+            other -> pure other+      | otherwise = pure (AtAlpha idx)++toAttr :: String -> C.Cursor -> IO Attribute+toAttr attr cur = case attr of+  'α' : rest' -> do+    case TR.readMaybe rest' :: Maybe Integer of+      Just idx -> pure (AtAlpha idx)+      Nothing -> throwIO (InvalidXMIRFormat "The attribute started with 'α' must be followed by integer" cur)+  "@" -> pure AtPhi+  "^" -> pure AtRho+  _+    | head attr `notElem` ['a' .. 'z'] -> throwIO (InvalidXMIRFormat (printf "The attribute '%s' must start with ['a'..'z']" attr) cur)+    | '.' `elem` attr -> throwIO (InvalidXMIRFormat "Attribute can't contain dots" cur)+    | otherwise -> pure (AtLabel attr)++hasAttr :: String -> C.Cursor -> Bool+hasAttr key cur = not (null (C.attribute (toName key) cur))++getAttr :: String -> C.Cursor -> IO String+getAttr key cur = do+  let attrs = C.attribute (toName key) cur+  if null attrs+    then throwIO (InvalidXMIRFormat (printf "Couldn't find attribute '%s'" key) cur)+    else do+      let attr = (T.unpack . head) attrs+      if null attr+        then throwIO (InvalidXMIRFormat (printf "The attribute '%s' is not expected to be empty" attr) cur)+        else pure attr++hasText :: C.Cursor -> Bool+hasText cur = any isNonEmptyTextNode (C.child cur)+  where+    isNonEmptyTextNode cur' = case C.node cur' of+      NodeContent t -> not (T.null (T.strip t)) -- strip to ignore whitespace-only+      _ -> False++getText :: C.Cursor -> IO String+getText cur =+  case [t | c <- C.child cur, NodeContent t <- [C.node c]] of+    (t : _) -> pure (T.unpack t)+    [] -> throwIO (InvalidXMIRFormat "Text content inside <o> element can't be empty" cur)

@@ -91,12 +91,13 @@     output `shouldContain` "Usage:"    it "prints debug info with --log-level=DEBUG" $-    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"]+        ["rewrite", "--nothing", "test-resources/cli/desugar.phi"]         ["Φ ↦ ⟦\n  foo ↦ Φ.org.eolang,\n  ρ ↦ ∅\n⟧"]      it "desugares with --nothing flag from stdin" $@@ -109,7 +110,7 @@      it "normalizes with --normalize flag" $       testCLI-        ["rewrite", "--normalize", "--phi-input=test-resources/cli/normalize.phi"]+        ["rewrite", "--normalize", "test-resources/cli/normalize.phi"]         [ unlines             [ "Φ ↦ ⟦",               "  x ↦ ⟦",@@ -147,7 +148,7 @@                 "⟧"               ]           ]-    +     it "rewrites with --sweet flag" $       withStdin "Q -> [[ x -> 5]]" $         testCLI@@ -159,3 +160,18 @@         testCLI           ["rewrite", "--nothing", "--output=xmir"]           ["<?xml version=\"1.0\" encoding=\"UTF-8\"?>", "<object", "  <o base=\"Q.y\" name=\"x\"/>"]++    it "rewrites with XMIR as input" $+      withStdin "<object><o name=\"app\"><o name=\"x\" base=\"Q.number\"/></o></object>" $+        testCLI+          ["rewrite", "--nothing", "--input=xmir", "--sweet"]+          [ unlines+              [ "{⟦",+                "  app ↦ ⟦",+                "    x ↦ Φ.number,",+                "    ρ ↦ ∅",+                "  ⟧,",+                "  ρ ↦ ∅",+                "⟧}"+              ]+          ]

@@ -1,25 +1,45 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT  module XMIRSpec where -import Test.Hspec (Spec, it, shouldBe, runIO, pending)-import XMIR-import Misc (ensuredFile)+import Control.Monad (forM_)+import Data.Aeson+import Data.Yaml qualified as Yaml+import GHC.Generics (Generic)+import Misc (allPathsIn) import Parser (parseProgramThrows)-import qualified Data.Text as T-import Pretty (PrintMode(SALTY))+import System.FilePath (makeRelative)+import Test.Hspec (Spec, describe, it, runIO, shouldBe)+import XMIR (parseXMIRThrows, xmirToPhi) --- @todo #126:30min Enable XMIR test. It's not possible anymore to compare XMIRs like strings+data XMIRPack = XMIRPack+  { xmir :: String,+    phi :: String+  }+  deriving (Generic, Show, FromJSON)++xmirPack :: FilePath -> IO XMIRPack+xmirPack = Yaml.decodeFileThrow++-- @todo #126:30min Introduce XMIR printing test. It's not possible anymore to compare XMIRs like strings --  because they contain random data, e.g. system time. We need to introduce some convenient --  test system for testing XML and use it here here. 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 SALTY-  let xmir' = printXMIR doc-  it "prints valid xmir" $ do-    pending-    T.stripEnd (T.pack xmir) `shouldBe` T.stripEnd (T.pack xmir')+spec =+  describe "XMIR parsing packs" $ do+    let resources = "test-resources/xmir-parsing-packs"+    packs <- runIO (allPathsIn resources)+    forM_+      packs+      ( \pth -> it (makeRelative resources pth) $ do+          pack <- xmirPack pth+          xmir' <- do+            doc <- parseXMIRThrows (xmir pack)+            xmirToPhi doc+          phi' <- parseProgramThrows (phi pack)+          xmir' `shouldBe` phi'+      )