phino 0.0.0.9 → 0.0.0.10
raw patch · 20 files changed
+399/−126 lines, 20 filesdep +processdep ~base
Dependencies added: process
Dependency ranges changed: base
Files
- phino.cabal +5/−3
- src/CLI.hs +4/−1
- src/Misc.hs +72/−2
- src/Parser.hs +22/−10
- src/Pretty.hs +143/−34
- src/Printer.hs +5/−5
- src/Rewriter.hs +1/−1
- src/XMIR.hs +4/−4
- test/BuilderSpec.hs +3/−5
- test/CLISpec.hs +9/−3
- test/HLintSpec.hs +48/−0
- test/MatcherSpec.hs +3/−3
- test/MiscSpec.hs +2/−2
- test/ParserSpec.hs +6/−2
- test/PrettySpec.hs +66/−0
- test/PrinterSpec.hs +0/−46
- test/ReplacerSpec.hs +2/−2
- test/RewriterSpec.hs +1/−1
- test/XMIRSpec.hs +2/−1
- test/YamlSpec.hs +1/−1
phino.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 name: phino-version: 0.0.0.9+version: 0.0.0.10 license: MIT synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions description: Please see the README on GitHub at <https://github.com/objectionary/phino#readme>@@ -45,7 +45,7 @@ Paths_phino build-depends: file-embed ^>=0.0.16.0,- base ^>=4.18.3.0,+ base >=4.18.3.0 && <5, containers, megaparsec >= 9.0, text,@@ -88,12 +88,13 @@ MatcherSpec, BuilderSpec, ReplacerSpec,- PrinterSpec,+ PrettySpec, RewriterSpec, ConditionSpec, YamlSpec, MiscSpec, XMIRSpec,+ HLintSpec, Paths_phino autogen-modules: Paths_phino@@ -115,6 +116,7 @@ text, silently, directory,+ process, xml-conduit ^>=1.10 build-tool-depends: hspec-discover:hspec-discover
src/CLI.hs view
@@ -20,6 +20,7 @@ import Options.Applicative import Parser (parseProgramThrows) import Paths_phino (version)+import Pretty (PrintMode (SALTY, SWEET)) import Printer (PrintFormat (PHI, XMIR), printProgram) import Rewriter (rewrite) import System.Exit (ExitCode (..), exitFailure)@@ -48,6 +49,7 @@ { rules :: [FilePath], phiInput :: Maybe FilePath, printFormat :: PrintFormat,+ printMode :: PrintMode, normalize :: Bool, nothing :: Bool, shuffle :: Bool,@@ -67,6 +69,7 @@ <$> 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)+ <*> 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 "shuffle" <> help "Shuffle rules before applying")@@ -154,7 +157,7 @@ program <- parseProgramThrows prog rewritten <- rewrite' program rules' 1 logDebug (printf "Printing rewritten 𝜑-program as %s" (show printFormat))- out <- printProgram rewritten printFormat+ out <- printProgram rewritten printFormat printMode putStrLn out where rewrite' :: Program -> [Y.Rule] -> Integer -> IO Program
src/Misc.hs view
@@ -11,14 +11,20 @@ import Control.Exception import Control.Monad import Data.Binary.IEEE754+import Data.Bits (Bits (shiftL), (.|.)) import qualified Data.Bits as IOArray+import qualified Data.ByteString as B import Data.ByteString.Builder (toLazyByteString, word64BE) import Data.ByteString.Lazy (unpack) import qualified Data.ByteString.Lazy.UTF8 as U+import Data.Char (chr) import Data.List (intercalate)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T import qualified Data.Vector as V import qualified Data.Vector.Mutable as M-import Data.Word (Word8)+import Data.Word (Word64, Word8)+import Numeric (readHex) import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) import System.FilePath ((</>)) import System.Random.Stateful@@ -39,7 +45,7 @@ where withVoidRho' :: [Binding] -> Bool -> [Binding] withVoidRho' [] hasRho = [BiVoid AtRho | not hasRho]- withVoidRho' (bd : bds) hasRho = + withVoidRho' (bd : bds) hasRho = case bd of BiMeta _ -> bd : bds BiVoid (AtMeta _) -> bd : bds@@ -70,9 +76,54 @@ ) return (concat paths) +-- >>> hexToBts "40-14-00-00-00-00-00-00"+-- [64,20,0,0,0,0,0,0]+-- >>> hexToBts "68-65-6C-6C-6F"+-- [104,101,108,108,111]+hexToBts :: String -> [Word8]+hexToBts = map readHexByte . splitOnDash+ where+ splitOnDash = words . map (\c -> if c == '-' then ' ' else c)+ readHexByte hx = case readHex hx of+ [(v, "")] -> fromIntegral v+ _ -> error $ "Invalid hex byte: " ++ hx+ btsToHex :: [Word8] -> String btsToHex bts = intercalate "-" (map (printf "%02X") bts) +-- Convert hex string back to Double+-- >>> hexToNum "40-14-00-00-00-00-00-00"+-- Left 5+-- >>> hexToNum "BF-D0-00-00-00-00-00-00"+-- Right (-0.25)+-- >>> hexToNum "40-45-00-00-00-00-00-00"+-- Left 42+-- >>> hexToNum "40-45"+-- Expected 8 bytes for conversion, got 2+hexToNum :: String -> Either Integer Double+hexToNum hx =+ 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+ where+ toWord64BE :: [Word8] -> Word64+ toWord64BE [a, b, c, d, e, f, g, h] =+ fromIntegral a `shiftL` 56+ .|. fromIntegral b `shiftL` 48+ .|. fromIntegral c `shiftL` 40+ .|. fromIntegral d `shiftL` 32+ .|. fromIntegral e `shiftL` 24+ .|. fromIntegral f `shiftL` 16+ .|. fromIntegral g `shiftL` 8+ .|. fromIntegral h+ toWord64BE _ = error "Expected 8 bytes for Double"+ -- >>> numToHex 0.0 -- "00-00-00-00-00-00-00-00" -- >>> numToHex 42@@ -96,6 +147,25 @@ strToHex "" = "--" strToHex [ch] = btsToHex (unpack (U.fromString [ch])) ++ "-" strToHex str = btsToHex (unpack (U.fromString str))++-- Convert hex string like "68-65-6C-6C-6F" to "hello"+-- >>> hexToStr "68-65-6C-6C-6F"+-- "hello"+-- >>> hexToStr "--"+-- ""+-- >>> hexToStr "68-"+-- "h"+-- >>> hexToStr "77-6F-72-6C-64"+-- "world"+-- >>> hexToStr ""+-- ""+hexToStr :: String -> String+hexToStr "--" = ""+hexToStr [] = ""+hexToStr hx = T.unpack $ T.decodeUtf8 $ B.pack (hexToBts cleaned)+ where+ -- Remove trailing dash if present (from single-char case)+ cleaned = if not (null hx) && last hx == '-' then init hx else hx -- Fast Fisher-Yates with mutable vectors. -- The function is generated by ChatGPT and claimed as
src/Parser.hs view
@@ -95,9 +95,24 @@ hexDigits <- count 4 hexDigitChar case readHex hexDigits of [(n, "")] ->- if (n >= 0 && n <= 0x10FFFF) && not (n >= 0xD800 && n <= 0xDFFF)- then return (chr n)- else fail ("Invalid Unicode code point: \\u" ++ hexDigits)+ if n >= 0xD800 && n <= 0xDBFF+ then -- High surrogate, look for low surrogate+ do+ _ <- string "\\u"+ lowHexDigits <- count 4 hexDigitChar+ case readHex lowHexDigits of+ [(low, "")] ->+ if low >= 0xDC00 && low <= 0xDFFF+ then -- Valid surrogate pair, combine them+ let codePoint = 0x10000 + ((n - 0xD800) * 0x400) + (low - 0xDC00)+ in 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) function :: Parser String function = lexeme $ do@@ -165,8 +180,8 @@ -- 2. one byte: 01- -- 3. many bytes: 01-02-...-FF bytes :: Parser String-bytes = lexeme $ do- choice+bytes = lexeme+ (choice [ symbol "--", try $ do first <- byte@@ -175,12 +190,9 @@ bte <- byte return (dash : bte) return (first ++ concat rest),- do- bte <- byte- dash <- char '-'- return (bte ++ [dash])+ byte >>= \bte -> char '-' >>= \dash -> return (bte ++ [dash]) ]- <?> "bytes"+ <?> "bytes") tauBinding :: Parser Attribute -> Parser Binding tauBinding attr = do
src/Pretty.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT@@ -6,9 +8,12 @@ module Pretty ( prettyExpression, prettyProgram,+ prettyProgram', prettyAttribute, prettySubsts,+ prettySubsts', prettyBinding,+ PrintMode (SWEET, SALTY), ) where @@ -17,13 +22,64 @@ import Matcher import Prettyprinter import Prettyprinter.Render.String (renderString)+import Misc (hexToStr, hexToNum) +data PrintMode = SWEET | SALTY+ deriving (Eq)++instance Show PrintMode where+ show SWEET = "sweet"+ show SALTY = "salty"++newtype Formatted a = Formatted {unFormatted :: (PrintMode, a)}++-- Minimal matcher function (required for view pattern)+matchDataoObject :: Expression -> Maybe (String, String)+matchDataoObject+ ( ExApplication+ (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel label))+ ( BiTau+ (AtAlpha 0)+ ( ExApplication+ (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "bytes"))+ ( BiTau+ (AtAlpha 0)+ (ExFormation [BiDelta bts, BiVoid AtRho])+ )+ )+ )+ ) = Just (label, bts)+matchDataoObject _ = Nothing++pattern DataObject :: String -> String -> Expression+pattern DataObject label bts <- (matchDataoObject -> Just (label, bts))+ where+ DataObject label bts =+ ExApplication+ (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel label))+ ( BiTau+ (AtAlpha 0)+ ( ExApplication+ (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "bytes"))+ ( BiTau+ (AtAlpha 0)+ (ExFormation [BiDelta bts, BiVoid AtRho])+ )+ )+ )+ prettyMeta :: String -> Doc ann prettyMeta meta = pretty "!" <> pretty meta prettyArrow :: Doc ann prettyArrow = pretty "↦" +prettyLsb :: Doc ann+prettyLsb = pretty "⟦"++prettyRsb :: Doc ann+prettyRsb = pretty "⟧"+ prettyDashedArrow :: Doc ann prettyDashedArrow = pretty "⤍" @@ -34,46 +90,93 @@ 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 Pretty (Formatted Binding) where+ pretty (Formatted (SWEET, BiTau attr (ExFormation bindings))) = do+ let voids' = voids bindings+ if null voids'+ then pretty attr <+> prettyArrow <+> pretty (Formatted (SWEET, ExFormation bindings))+ else+ pretty attr+ <> lparen+ <> hsep (punctuate comma (map pretty voids'))+ <> rparen+ <+> prettyArrow+ <+> pretty (Formatted (SWEET, ExFormation (drop (length voids') bindings)))+ where+ voids :: [Binding] -> [Attribute]+ voids [] = []+ voids (bd : bds) = case bd of+ BiVoid attr -> attr : voids bds+ _ -> []+ pretty (Formatted (mode, BiTau attr expr)) = pretty attr <+> prettyArrow <+> pretty (Formatted (mode, expr))+ pretty (Formatted (_, BiMeta meta)) = prettyMeta meta+ pretty (Formatted (_, BiDelta bytes)) = pretty "Δ" <+> prettyDashedArrow <+> pretty bytes+ pretty (Formatted (_, BiMetaLambda meta)) = pretty "λ" <+> prettyDashedArrow <+> prettyMeta meta+ pretty (Formatted (_, BiMetaDelta meta)) = pretty "Δ" <+> prettyDashedArrow <+> prettyMeta meta+ pretty (Formatted (_, BiVoid attr)) = pretty attr <+> prettyArrow <+> pretty "∅"+ pretty (Formatted (_, BiLambda func)) = pretty "λ" <+> prettyDashedArrow <+> pretty func -instance {-# OVERLAPPING #-} Pretty [Binding] where- pretty bindings = vsep (punctuate comma (map pretty bindings))+instance {-# OVERLAPPING #-} Pretty (Formatted [Binding]) where+ pretty (Formatted (mode, bds)) = vsep (punctuate comma (map (\bd -> pretty (Formatted (mode, bd))) bds)) -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+complexApplication :: Expression -> (Expression, [Binding], [Expression])+complexApplication (ExApplication (ExApplication expr tau) tau') = do+ let (before, taus, exprs) = complexApplication (ExApplication expr tau)+ taus' = tau' : taus+ if null exprs+ then (before, taus', [])+ else case tau' of+ BiTau (AtAlpha idx) expr' -> if idx == fromIntegral (length exprs)+ then (before, taus', expr' : exprs)+ else (before, taus', [])+ _ -> (before, taus', [])+complexApplication (ExApplication expr (BiTau (AtAlpha 0) expr')) = (expr, [BiTau (AtAlpha 0) expr'], [expr'])+complexApplication (ExApplication expr tau) = (expr, [tau], []) -instance Pretty Program where- pretty (Program expr) = pretty "Φ" <+> prettyArrow <+> pretty expr+instance Pretty (Formatted Expression) where+ pretty (Formatted (SWEET, ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang"))) = pretty "Φ̇"+ pretty (Formatted (SWEET, DataObject "string" bytes)) = pretty "\"" <> pretty (hexToStr bytes) <> pretty "\""+ pretty (Formatted (SWEET, DataObject "number" bytes)) = either pretty pretty (hexToNum bytes)+ pretty (Formatted (SWEET, DataObject other bytes)) = pretty (Formatted (SALTY, DataObject other bytes))+ pretty (Formatted (mode, ExFormation [binding])) = case binding of+ BiTau _ _ -> vsep [pretty "⟦", indent 2 (pretty (Formatted (mode, binding))), pretty "⟧"]+ _ -> pretty "⟦" <+> pretty (Formatted (mode, binding)) <+> pretty "⟧"+ pretty (Formatted (_, ExFormation [])) = pretty "⟦⟧"+ pretty (Formatted (mode, ExFormation bindings)) = vsep [pretty "⟦", indent 2 (pretty (Formatted (mode, bindings))), pretty "⟧"]+ pretty (Formatted (_, ExThis)) = pretty "ξ"+ pretty (Formatted (_, ExGlobal)) = pretty "Φ"+ pretty (Formatted (_, ExTermination)) = pretty "⊥"+ pretty (Formatted (_, ExMeta meta)) = prettyMeta meta+ pretty (Formatted (SWEET, ExApplication (ExApplication expr tau) tau')) = do+ let (expr', taus, exprs) = complexApplication (ExApplication (ExApplication expr tau) tau')+ args = if null exprs+ then pretty (Formatted (SWEET, reverse taus))+ else vsep (punctuate comma (map (\exp -> pretty (Formatted (SWEET, exp))) (reverse exprs)))+ pretty (Formatted (SWEET, expr')) <> vsep [lparen, indent 2 args, rparen]+ pretty (Formatted (SWEET, ExApplication expr tau)) = do+ let arg = case tau of+ BiTau (AtAlpha 0) expr' -> pretty (Formatted (SWEET, expr'))+ _ -> pretty (Formatted (SWEET, tau))+ pretty (Formatted (SWEET, expr)) <> vsep [lparen, indent 2 arg, rparen]+ pretty (Formatted (mode, ExApplication expr tau)) = pretty (Formatted (mode, expr)) <> vsep [lparen, indent 2 (pretty (Formatted (mode, tau))), rparen]+ pretty (Formatted (mode, ExDispatch expr attr)) = pretty (Formatted (mode, expr)) <> pretty "." <> pretty attr+ pretty (Formatted (mode, ExMetaTail expr meta)) = pretty (Formatted (mode, expr)) <+> pretty "*" <+> prettyMeta meta +instance Pretty (Formatted Program) where+ pretty (Formatted (SALTY, Program expr)) = pretty "Φ" <+> prettyArrow <+> pretty (Formatted (SALTY, expr))+ pretty (Formatted (SWEET, Program expr)) = pretty "{" <> pretty (Formatted (SWEET, expr)) <> pretty "}"+ instance Pretty Tail where- pretty (TaApplication tau) = vsep [lparen, indent 2 (pretty tau), rparen]+ pretty (TaApplication tau) = vsep [lparen, indent 2 (pretty (Formatted (SALTY, 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 (MvBindings bindings) = vsep [pretty "[", indent 2 (pretty (Formatted (SALTY, bindings))), pretty "]"] pretty (MvFunction func) = pretty func- pretty (MvExpression expr) = pretty expr+ pretty (MvExpression expr) = pretty (Formatted (SALTY, expr)) pretty (MvTail tails) = vsep (punctuate comma (map pretty tails)) instance Pretty Subst where@@ -94,15 +197,15 @@ rparen ] -instance {-# OVERLAPPING #-} Pretty [Subst] where- pretty [] = pretty "[]"- pretty substs = vsep [pretty "[", indent 2 (vsep (punctuate comma (map pretty substs))), pretty "]"]+instance {-# OVERLAPPING #-} Pretty (Formatted [Subst]) where+ pretty (Formatted (_, [])) = pretty "[]"+ pretty (Formatted (mode, 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+prettyBinding binding = render (Formatted (SALTY, binding)) prettyAttribute :: Attribute -> String prettyAttribute = render@@ -110,8 +213,14 @@ prettySubsts :: [Subst] -> String prettySubsts = render +prettySubsts' :: [Subst] -> PrintMode -> String+prettySubsts' substs mode = render (Formatted (mode, substs))+ prettyExpression :: Expression -> String-prettyExpression = render+prettyExpression expr = render (Formatted (SALTY, expr)) prettyProgram :: Program -> String-prettyProgram = render+prettyProgram prog = render (Formatted (SALTY, prog))++prettyProgram' :: Program -> PrintMode -> String+prettyProgram' prog mode = render (Formatted (mode, prog))
src/Printer.hs view
@@ -4,7 +4,7 @@ module Printer where import Ast-import Pretty (prettyProgram)+import Pretty (prettyProgram', PrintMode) import XMIR (programToXMIR, printXMIR) data PrintFormat = XMIR | PHI@@ -14,8 +14,8 @@ show XMIR = "xmir" show PHI = "phi" -printProgram :: Program -> PrintFormat -> IO String-printProgram prog PHI = pure (prettyProgram prog)-printProgram prog XMIR = do- xmir <- programToXMIR prog+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)
src/Rewriter.hs view
@@ -55,7 +55,7 @@ extraSubstitutions :: Program -> Maybe [Y.Extra] -> [Subst] -> [Subst] extraSubstitutions prog extras substs = case extras of Nothing -> substs- Just extras' -> do+ Just extras' -> catMaybes [ case Y.meta extra of ExMeta name -> do
src/XMIR.hs view
@@ -26,7 +26,7 @@ import Data.Version (showVersion) import Debug.Trace (trace) import Paths_phino (version)-import Pretty (prettyAttribute, prettyBinding, prettyExpression, prettyProgram)+import Pretty (prettyAttribute, prettyBinding, prettyExpression, prettyProgram', PrintMode) import Text.Printf (printf) import Text.XML @@ -146,8 +146,8 @@ nanos = floor (fractional * 1_000_000_000) :: Int base ++ "." ++ printf "%09d" nanos ++ "Z" -programToXMIR :: Program -> IO Document-programToXMIR (Program expr) = do+programToXMIR :: Program -> PrintMode -> IO Document+programToXMIR (Program expr) mode = do (pckg, expr') <- getPackage expr root <- rootExpression expr' now <- getCurrentTime@@ -164,7 +164,7 @@ ("version", showVersion version), ("xsi:noNamespaceSchemaLocation", "https://raw.githubusercontent.com/objectionary/eo/refs/heads/gh-pages/XMIR.xsd") ]- ( NodeElement (element "listing" [] [NodeContent (T.pack (prettyProgram (Program expr)))])+ ( NodeElement (element "listing" [] [NodeContent (T.pack (prettyProgram' (Program expr) mode))]) : root : metasWithPackage (intercalate "." pckg) )
test/BuilderSpec.hs view
@@ -17,7 +17,7 @@ spec :: Spec spec = do- describe "buildExpression" $ do+ describe "buildExpression" $ test buildExpression [ ( "Q.!a => (!a >> x) => Q.x",@@ -80,16 +80,14 @@ describe "buildExpressions" $ do it "!e => [(!e >> Q.x), (!e >> $.y)] => [Q.x, $.y]" $- do- buildExpressions+ buildExpressions (ExMeta "e") [ substSingle "e" (MvExpression (ExDispatch ExGlobal (AtLabel "x"))), substSingle "e" (MvExpression (ExDispatch ExThis (AtLabel "y"))) ] `shouldBe` Just [ExDispatch ExGlobal (AtLabel "x"), ExDispatch ExThis (AtLabel "y")] it "!e => [(!e1 >> Q.x)] => X" $- do- buildExpressions+ buildExpressions (ExMeta "e") [substSingle "e1" (MvExpression (ExDispatch ExGlobal (AtLabel "x")))] `shouldBe` Nothing
test/CLISpec.hs view
@@ -20,7 +20,7 @@ import Test.Hspec withStdin :: String -> IO a -> IO a-withStdin input action = do+withStdin input action = bracket (openTempFile "." "stdinXXXXXX.tmp") cleanup $ \(filePath, h) -> do hSetEncoding h utf8 hPutStr h input@@ -82,7 +82,7 @@ spec :: Spec spec = do- it "prints version" $ do+ it "prints version" $ testCLI ["--version"] [showVersion version] it "prints help" $ do@@ -90,7 +90,7 @@ output `shouldContain` "Phino - CLI Manipulator of 𝜑-Calculus Expressions" output `shouldContain` "Usage:" - it "prints debug info with --log-level=DEBUG" $ do+ it "prints debug info with --log-level=DEBUG" $ withStdin "Q -> [[]]" $ testCLI ["rewrite", "--nothing", "--log-level=DEBUG"] ["[DEBUG]:"] describe "rewrites" $ do@@ -147,6 +147,12 @@ "⟧" ] ]+ + it "rewrites with --sweet flag" $+ withStdin "Q -> [[ x -> 5]]" $+ testCLI+ ["rewrite", "--nothing", "--sweet"]+ ["{⟦\n x ↦ 5,\n ρ ↦ ∅\n⟧}"] it "rewrites as XMIR" $ withStdin "Q -> [[ x -> Q.y ]]" $
+ test/HLintSpec.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module HLintSpec (spec) where++import Control.Exception (try, IOException)+import System.Exit (ExitCode(..))+import System.Process (readProcessWithExitCode)+import Test.Hspec++-- | Check if hlint is available on the system+isHLintAvailable :: IO Bool+isHLintAvailable = do+ result <- try (readProcessWithExitCode "hlint" ["--version"] "")+ case result of+ Left (_ :: IOException) -> return False+ Right (ExitSuccess, _, _) -> return True+ Right (ExitFailure _, _, _) -> return False++-- | Run hlint on a directory and check for success+runHLintCheck :: String -> IO ()+runHLintCheck dir = do+ available <- isHLintAvailable+ if not available + then pendingWith "hlint is not available on this system"+ else do+ (exitCode, stdout, stderr) <- readProcessWithExitCode "hlint" [dir] ""+ case exitCode of+ ExitSuccess -> return ()+ ExitFailure _ -> do+ putStrLn $ "HLint warnings/errors in " ++ dir ++ ":"+ putStrLn stdout+ putStrLn stderr+ exitCode `shouldBe` ExitSuccess++spec :: Spec+spec =+ describe "HLint" $ do+ it "should pass hlint check for src/" $+ runHLintCheck "src/"++ it "should pass hlint check for app/" $+ runHLintCheck "app/"+ + it "should pass hlint check for test/" $+ runHLintCheck "test/"
test/MatcherSpec.hs view
@@ -338,9 +338,9 @@ ] describe "combine" $ do- it "combines empty substitutions" $ do+ it "combines empty substitutions" $ combine substEmpty substEmpty `shouldBe` Just substEmpty- it "combines two empty substs from list" $ do+ it "combines two empty substs from list" $ combine (Subst Map.empty) (Subst Map.empty) `shouldBe` Just substEmpty it "combines empty subst with single one" $ do let Subst joined = maybeCombined substEmpty (Subst (Map.singleton "at" (MvAttribute AtPhi)))@@ -364,7 +364,7 @@ second = Subst (Map.singleton "first" rho) Subst joined = maybeCombined first second Map.lookup "first" joined `shouldBe` Just (MvAttribute AtRho)- it "returns Nothing if values are different" $ do+ it "returns Nothing if values are different" $ combine (Subst (Map.singleton "x" (MvAttribute AtPhi))) (Subst (Map.singleton "x" (MvAttribute AtRho))) `shouldBe` Nothing it "clears all the values" $ do let first =
test/MiscSpec.hs view
@@ -14,8 +14,8 @@ it desc $ withVoidRho before `shouldBe` after spec :: Spec-spec = do- describe "with void rho binding" $ do+spec =+ describe "with void rho binding" $ testWithVoidRho [ ( "[[x -> ?]] => [[x -> ?, ^ -> ?]]", [BiVoid (AtLabel "x")],
test/ParserSpec.hs view
@@ -241,7 +241,8 @@ "[[x -> -42, y -> +34]]", "⟦x ↦ Φ.org.eolang(z ↦ ξ.f, x ↦ α0, φ ↦ ρ, t ↦ φ, first ↦ ⟦ λ ⤍ Function_name, Δ ⤍ 42- ⟧)⟧", "[[x -> 1.00e+3, y -> 2.32e-4]]",- "[[ x -> \"\\u0001\\u0001\"]]"+ "[[ x -> \"\\u0001\\u0001\"]]",+ "[[ x -> \"\\uD835\\uDF11\"]]" ] (\expr -> it expr (parseExpression expr `shouldSatisfy` isRight)) @@ -267,7 +268,10 @@ "Q.x(y(~1) -> [[]])", "Q.x(1, 2, !B)", "Q.x(~1 -> Q.y, x -> 5, !B1)",- "Q.x(𝐵1, 𝜏0 -> $, x -> 𝑒)"+ "Q.x(𝐵1, 𝜏0 -> $, x -> 𝑒)",+ "[[ x -> \"\\uD800\"]]",+ "[[ x -> \"\\uDFFF\"]]",+ "[[ x -> \"\\uD835\\u0041\"]]" ] )
+ test/PrettySpec.hs view
@@ -0,0 +1,66 @@+-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module PrettySpec where++import Ast+import Control.Monad (forM_)+import Matcher (MetaValue (MvAttribute, MvExpression), substEmpty, substSingle)+import Parser (parseProgramThrows)+import Pretty+import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, describe, it, runIO, shouldBe)++test :: (a -> PrintMode -> String) -> [(String, String, a, PrintMode)] -> SpecWith (Arg Expectation)+test function useCases =+ forM_ useCases $ \(input, output, arg, mode) ->+ it input $ function arg mode `shouldBe` output++prep :: PrintMode -> (String, String) -> IO (String, String, Program, PrintMode)+prep mode (input, output) = do+ prog <- parseProgramThrows input+ return (input, output, prog, mode)++spec :: Spec+spec = do+ describe "saltify program" $ do+ useCases <-+ runIO $+ mapM+ (prep SALTY)+ [ ("Q -> $", "Φ ↦ ξ"),+ ("Q -> Q.org.x", "Φ ↦ Φ.org.x"),+ ("Q -> [[]]", "Φ ↦ ⟦ ρ ↦ ∅ ⟧"),+ ("Q -> [[@ -> ?]](~1 -> Q.x)", "Φ ↦ ⟦\n φ ↦ ∅,\n ρ ↦ ∅\n⟧(\n α1 ↦ Φ.x\n)"),+ ("Q -> !e * !t", "Φ ↦ !e * !t"),+ ( "Q -> [[D> 00-,L> F,^ -> ?,!B,@ -> [[y -> ?]]]]",+ "Φ ↦ ⟦\n Δ ⤍ 00-,\n λ ⤍ F,\n ρ ↦ ∅,\n !B,\n φ ↦ ⟦\n y ↦ ∅,\n ρ ↦ ∅\n ⟧\n⟧"+ )+ ]+ test prettyProgram' useCases++ describe "sweetify program" $ do+ useCases <-+ runIO $+ mapM+ (prep SWEET)+ [ ("Q -> $", "{ξ}"),+ ("Q -> Q.org.eolang(x -> Q.x)", "{Φ̇(\n x ↦ Φ.x\n)}"),+ ("Q -> [[ x -> [[ y -> ?, z -> ? ]] ]]", "{⟦\n x(y, z, ρ) ↦ ⟦⟧,\n ρ ↦ ∅\n⟧}"),+ ("Q -> 5", "{5}"),+ ("Q -> [[ x -> \"hello\"]]", "{⟦\n x ↦ \"hello\",\n ρ ↦ ∅\n⟧}"),+ ("Q -> Q.x(x -> 1)(y -> 2)(z -> 3)", "{Φ.x(\n x ↦ 1,\n y ↦ 2,\n z ↦ 3\n)}"),+ ("Q -> Q.x(~0 -> Q.y)", "{Φ.x(\n Φ.y\n)}"),+ ("Q -> Q.x(~0 -> 1)(~1 -> 2)(~2 -> 3)", "{Φ.x(\n 1,\n 2,\n 3\n)}"),+ ("Q -> Q.x(~0 -> 1)(~2 -> 2)(~1 -> 3)", "{Φ.x(\n α0 ↦ 1,\n α2 ↦ 2,\n α1 ↦ 3\n)}")+ ]+ test prettyProgram' useCases++ describe "prettify substitution" $ do+ let useCases =+ map+ (\(desc, output, substs) -> (desc, output, substs, SALTY))+ [ ("[()]", "[\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 prettySubsts' useCases
− test/PrinterSpec.hs
@@ -1,46 +0,0 @@--- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com--- SPDX-License-Identifier: MIT--module PrinterSpec where--import Ast-import Control.Monad (forM_)-import Matcher (MetaValue (MvAttribute, MvExpression), substEmpty, substSingle)-import Parser (parseProgramThrows)-import Prettyprinter-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)-test function useCases =- forM_ useCases $ \(input, output, arg) ->- it input $ function arg `shouldBe` output--spec :: Spec-spec = do- describe "print program" $ do- useCases <-- runIO $- mapM- ( \(input, output) -> do- prog <- parseProgramThrows input- return (input, output, prog)- )- [ ("Q -> $", "Φ ↦ ξ"),- ("Q -> Q.org.x", "Φ ↦ Φ.org.x"),- ("Q -> [[]]", "Φ ↦ ⟦ ρ ↦ ∅ ⟧"),- ("Q -> [[@ -> ?]](~1 -> Q.x)", "Φ ↦ ⟦\n φ ↦ ∅,\n ρ ↦ ∅\n⟧(\n α1 ↦ Φ.x\n)"),- ("Q -> !e * !t", "Φ ↦ !e * !t"),- ( "Q -> [[D> 00-,L> F,^ -> ?,!B,@ -> [[y -> ?]]]]",- "Φ ↦ ⟦\n Δ ⤍ 00-,\n λ ⤍ F,\n ρ ↦ ∅,\n !B,\n φ ↦ ⟦\n y ↦ ∅,\n ρ ↦ ∅\n ⟧\n⟧"- )- ]- test prettyProgram useCases-- describe "print substitution" $- test- 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/ReplacerSpec.hs view
@@ -17,8 +17,8 @@ it desc $ function prog ptns repls `shouldBe` res spec :: Spec-spec = do- describe "replaceProgram: program => ([expression], [expression]) => program" $ do+spec =+ describe "replaceProgram: program => ([expression], [expression]) => program" $ test replaceProgram [ ( "Q -> Q.y.x => ([Q.y], [$]) => Q -> $.x",
test/RewriterSpec.hs view
@@ -55,7 +55,7 @@ noSpaces = filter (not . isSpace) spec :: Spec-spec = do+spec = describe "rewrite packs" $ do let resources = "test-resources/rewriter-packs" packs <- runIO (allPathsIn resources)
test/XMIRSpec.hs view
@@ -8,6 +8,7 @@ import Misc (ensuredFile) import Parser (parseProgramThrows) import qualified Data.Text as T+import Pretty (PrintMode(SALTY)) -- @todo #126:30min Enable XMIR 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@@ -17,7 +18,7 @@ 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+ doc <- runIO $ programToXMIR prog SALTY let xmir' = printXMIR doc it "prints valid xmir" $ do pending
test/YamlSpec.hs view
@@ -10,7 +10,7 @@ import Yaml (yamlRule) spec :: Spec-spec = do+spec = describe "parses yaml rule" $ do let resources = "test-resources/yaml-packs" packs <- runIO (allPathsIn resources)