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.10 +version: 0.0.0.11 license: MIT synopsis: Command-Line Manipulator of šœ‘-Calculus Expressions description: Please see the README on GitHub at @@ -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, diff --git a/src/CLI.hs b/src/CLI.hs --- a/src/CLI.hs +++ b/src/CLI.hs @@ -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) diff --git a/src/Misc.hs b/src/Misc.hs --- a/src/Misc.hs +++ b/src/Misc.hs @@ -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] = diff --git a/src/Parser.hs b/src/Parser.hs --- a/src/Parser.hs +++ b/src/Parser.hs @@ -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 diff --git a/src/Printer.hs b/src/Printer.hs deleted file mode 100644 --- a/src/Printer.hs +++ /dev/null @@ -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) diff --git a/src/XMIR.hs b/src/XMIR.hs --- a/src/XMIR.hs +++ b/src/XMIR.hs @@ -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 element in " 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 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 element can't be empty" cur) diff --git a/test/CLISpec.hs b/test/CLISpec.hs --- a/test/CLISpec.hs +++ b/test/CLISpec.hs @@ -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"] ["", ""] + + it "rewrites with XMIR as input" $ + withStdin "" $ + testCLI + ["rewrite", "--nothing", "--input=xmir", "--sweet"] + [ unlines + [ "{āŸ¦", + " app ā†¦ āŸ¦", + " x ā†¦ Ī¦.number,", + " Ļ ā†¦ āˆ…", + " āŸ§,", + " Ļ ā†¦ āˆ…", + "āŸ§}" + ] + ] diff --git a/test/XMIRSpec.hs b/test/XMIRSpec.hs --- a/test/XMIRSpec.hs +++ b/test/XMIRSpec.hs @@ -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' + )