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.15 +version: 0.0.0.16 license: MIT synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions description: Please see the README on GitHub at diff --git a/src/CLI.hs b/src/CLI.hs --- a/src/CLI.hs +++ b/src/CLI.hs @@ -28,7 +28,7 @@ import System.Exit (ExitCode (..), exitFailure) import System.IO (getContents') import Text.Printf (printf) -import XMIR (parseXMIRThrows, printXMIR, programToXMIR, xmirToPhi) +import XMIR (parseXMIRThrows, printXMIR, programToXMIR, xmirToPhi, XmirContext (XmirContext)) import Yaml (normalizationRules) import qualified Yaml as Y @@ -70,6 +70,7 @@ nothing :: Bool, shuffle :: Bool, omitListing :: Bool, + omitComments :: Bool, maxDepth :: Integer, inputFile :: Maybe FilePath } @@ -130,6 +131,7 @@ <*> switch (long "nothing" <> help "Just desugar provided 𝜑-program") <*> switch (long "shuffle" <> help "Shuffle rules before applying") <*> switch (long "omit-listing" <> help "Omit full program listing in XMIR output") + <*> switch (long "omit-comments" <> help "Omit comments in XMIR output") <*> option auto (long "max-depth" <> metavar "DEPTH" <> help "Max amount of rewritng cycles" <> value 25 <> showDefault) <*> argInputFile ) @@ -204,7 +206,7 @@ printProgram :: Program -> IOFormat -> PrintMode -> IO String printProgram prog PHI mode = pure (prettyProgram' prog mode) printProgram prog XMIR mode = do - xmir <- programToXMIR prog mode omitListing + xmir <- programToXMIR prog (XmirContext omitListing omitComments printMode) pure (printXMIR xmir) CmdDataize OptsDataize {..} -> do input <- readInput inputFile diff --git a/src/Dataize.hs b/src/Dataize.hs --- a/src/Dataize.hs +++ b/src/Dataize.hs @@ -143,6 +143,9 @@ Just morphed -> dataize' morphed prog _ -> pure Nothing +toDouble :: Integer -> Double +toDouble = fromIntegral + atom :: String -> Expression -> Program -> IO (Maybe Expression) atom "L_org_eolang_number_plus" self prog = do left <- dataize' (ExDispatch self (AtLabel "x")) prog @@ -154,7 +157,25 @@ sum = first + second pure (Just (DataObject "number" (numToHex sum))) _ -> pure Nothing - where - toDouble :: Integer -> Double - toDouble = fromIntegral +atom "L_org_eolang_number_times" self prog = do + left <- dataize' (ExDispatch self (AtLabel "x")) prog + right <- dataize' (ExDispatch self AtRho) prog + case (left, right) of + (Just left', Just right') -> do + let first = either toDouble id (hexToNum left') + second = either toDouble id (hexToNum right') + sum = first * second + pure (Just (DataObject "number" (numToHex sum))) + _ -> pure Nothing +atom "L_org_eolang_number_eq" self prog = do + x <- dataize' (ExDispatch self (AtLabel "x")) prog + rho <- dataize' (ExDispatch self AtRho) prog + case (x, rho) of + (Just x', Just rho') -> do + let self' = either toDouble id (hexToNum rho') + first = either toDouble id (hexToNum x') + if self' == first + then pure (Just (DataObject "number" (numToHex first))) + else pure (Just (ExDispatch self (AtLabel "y"))) + _ -> pure Nothing atom func _ _ = throwIO (userError (printf "Atom '%s' does not exist" func)) diff --git a/src/Logger.hs b/src/Logger.hs --- a/src/Logger.hs +++ b/src/Logger.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE LambdaCase #-} - -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT @@ -27,20 +25,15 @@ logger :: IORef Logger {-# NOINLINE logger #-} -logger = unsafePerformIO (newIORef (Logger DEBUG)) +logger = unsafePerformIO (newIORef (Logger INFO)) setLogLevel :: LogLevel -> IO () setLogLevel lvl = writeIORef logger (Logger lvl) -handle :: LogLevel -> Handle -handle = \case - ERROR -> stderr - _ -> stdout - logMessage :: LogLevel -> String -> IO () logMessage lvl message = do log <- readIORef logger - when (lvl >= level log) $ hPutStrLn (handle lvl) ("[" ++ show lvl ++ "]: " ++ message) + when (lvl >= level log) $ hPutStrLn stderr ("[" ++ show lvl ++ "]: " ++ message) logDebug, logInfo, logWarning, logError :: String -> IO () logDebug = logMessage DEBUG diff --git a/src/Matcher.hs b/src/Matcher.hs --- a/src/Matcher.hs +++ b/src/Matcher.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT @@ -98,21 +100,28 @@ -- If there's one - build the list of all the tail operations after head expression. -- The tail operations may be only dispatches or applications tailExpressions :: Expression -> Expression -> Expression -> ([Subst], [Tail]) -tailExpressions ptn tgt scope = - let (substs, tails) = tailExpressionsReversed ptn tgt - in (substs, reverse tails) +tailExpressions ptn tgt scope = case tailExpressionsReversed ptn tgt of + Just (substs, tails) -> (substs, reverse tails) + _ -> ([], []) where - tailExpressionsReversed :: Expression -> Expression -> ([Subst], [Tail]) + tailExpressionsReversed :: Expression -> Expression -> Maybe ([Subst], [Tail]) tailExpressionsReversed ptn' tgt' = case matchExpression ptn' tgt' scope of [] -> case tgt' of - ExDispatch expr attr -> - let (substs, tails) = tailExpressionsReversed ptn' expr - in (substs, TaDispatch attr : tails) - ExApplication expr tau -> - let (substs, tails) = tailExpressionsReversed ptn' expr - in (substs, TaApplication tau : tails) - _ -> ([], []) - substs -> (substs, []) + ExDispatch expr attr -> do + (substs, tails) <- tailExpressionsReversed ptn' expr + Just (substs, TaDispatch attr : tails) + ExApplication expr tau -> do + (substs, tails) <- tailExpressionsReversed ptn' expr + if not (null tails) && isDispatch (head tails) + then Just (substs, TaApplication tau : tails) + else Nothing + where + isDispatch :: Tail -> Bool + isDispatch = \case + TaDispatch _ -> True + TaApplication _ -> False + _ -> Just ([], []) + substs -> Just (substs, []) matchExpression :: Expression -> Expression -> Expression -> [Subst] matchExpression (ExMeta meta) tgt scope = [substSingle meta (MvExpression tgt scope)] diff --git a/src/XMIR.hs b/src/XMIR.hs --- a/src/XMIR.hs +++ b/src/XMIR.hs @@ -6,7 +6,7 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module XMIR (programToXMIR, printXMIR, toName, parseXMIR, parseXMIRThrows, xmirToPhi) where +module XMIR (programToXMIR, printXMIR, toName, parseXMIR, parseXMIRThrows, xmirToPhi, XmirContext (XmirContext)) where import Ast import Control.Exception (Exception (displayException), SomeException, throwIO) @@ -35,6 +35,12 @@ import Text.XML import qualified Text.XML.Cursor as C +data XmirContext = XmirContext + { omitListing :: Bool, + omitComments :: Bool, + printMode :: PrintMode + } + -- @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 @@ -71,14 +77,14 @@ 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 +expression :: Expression -> XmirContext -> IO (String, [Node]) +expression ExThis _ = pure ("$", []) +expression ExGlobal _ = pure ("Q", []) +expression (ExFormation bds) ctx = do + nested <- nestedBindings bds ctx pure ("", nested) -expression (ExDispatch expr attr) = do - (base, children) <- expression expr +expression (ExDispatch expr attr) ctx = do + (base, children) <- expression expr ctx let attr' = prettyAttribute attr if null base then pure ('.' : attr', [object [] children]) @@ -86,64 +92,76 @@ if head base == '.' || not (null children) then pure ('.' : attr', [object [("base", base)] children]) else pure (base ++ ('.' : attr'), children) -expression (DataObject "number" bytes) = - pure - ( "Q.org.eolang.number", - [ NodeComment (T.pack (either show show (hexToNum bytes))), +expression (DataObject "number" bytes) XmirContext {..} = + let bts = object - [("base", "Q.org.eolang.bytes")] + [("as", prettyAttribute (AtAlpha 0)), ("base", "Q.org.eolang.bytes")] [object [] [NodeContent (T.pack bytes)]] - ] - ) -expression (DataObject "string" bytes) = - pure - ( "Q.org.eolang.string", - [ NodeComment (T.pack ('"' : hexToStr bytes ++ "\"")), + in pure + ( "Q.org.eolang.number", + if omitComments + then [bts] + else + [ NodeComment (T.pack (either show show (hexToNum bytes))), + bts + ] + ) +expression (DataObject "string" bytes) XmirContext {..} = + let bts = object - [("base", "Q.org.eolang.bytes")] + [("as", prettyAttribute (AtAlpha 0)), ("base", "Q.org.eolang.bytes")] [object [] [NodeContent (T.pack bytes)]] - ] - ) -expression (ExApplication expr (BiTau attr texpr)) = do - (base, children) <- expression expr - (base', children') <- expression texpr + in pure + ( "Q.org.eolang.string", + if omitComments + then [bts] + else + [ NodeComment (T.pack ('"' : hexToStr bytes ++ "\"")), + bts + ] + ) +expression (ExApplication expr (BiTau attr texpr)) ctx = do + (base, children) <- expression expr ctx + (base', children') <- expression texpr ctx let as = prettyAttribute attr attrs = if null base' then [("as", as)] else [("as", as), ("base", base')] pure (base, children ++ [object attrs children']) -expression (ExApplication (ExFormation bds) tau) = throwIO (UnsupportedExpression (ExApplication (ExFormation bds) tau)) -expression expr = throwIO (UnsupportedExpression expr) +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 +nestedBindings :: [Binding] -> XmirContext -> IO [Node] +nestedBindings bds ctx = catMaybes <$> mapM (`formationBinding` ctx) bds -formationBinding :: Binding -> IO (Maybe Node) -formationBinding (BiTau (AtLabel label) (ExFormation bds)) = do - inners <- nestedBindings bds +formationBinding :: Binding -> XmirContext -> IO (Maybe Node) +formationBinding (BiTau (AtLabel label) (ExFormation bds)) ctx = do + inners <- nestedBindings bds ctx pure (Just (object [("name", label)] inners)) -formationBinding (BiTau (AtLabel label) expr) = do - (base, children) <- expression expr +formationBinding (BiTau (AtLabel label) expr) ctx = do + (base, children) <- expression expr ctx pure (Just (object [("name", label), ("base", base)] 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) +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] +rootExpression :: Expression -> XmirContext -> IO Node +rootExpression (ExFormation [bd, BiVoid AtRho]) ctx = do + [bd'] <- nestedBindings [bd] ctx pure bd' -rootExpression expr = throwIO (UnsupportedExpression expr) +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 +-- @todo #197:30min Make patterns with L> Package softer. Right now we expect L> Package only in the end +-- of the formation bindings list. That's not really correct since this binding may be anywhere. Let's fix it 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]) @@ -155,25 +173,23 @@ 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 :: 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) - ] + 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)]) + ] + ) + ] + ) time :: UTCTime -> String time now = do @@ -184,16 +200,18 @@ nanos = floor (fractional * 1_000_000_000) :: Int base ++ "." ++ printf "%09d" nanos ++ "Z" -programToXMIR :: Program -> PrintMode -> Bool -> IO Document -programToXMIR (Program expr) mode omitListing = do +programToXMIR :: Program -> XmirContext -> IO Document +programToXMIR (Program expr) ctx = do (pckg, expr') <- getPackage expr - root <- rootExpression expr' + root <- rootExpression expr' ctx now <- getCurrentTime - let phi = prettyProgram' (Program expr) mode + let phi = prettyProgram' (Program expr) (printMode ctx) listing = - if omitListing + if omitListing ctx then show (length (lines phi)) ++ " lines of phi" else phi + listing' = NodeElement (element "listing" [] [NodeContent (T.pack listing)]) + metas = metasWithPackage (intercalate "." pckg) pure ( Document (Prologue [] Nothing []) @@ -207,9 +225,9 @@ ("version", showVersion version), ("xsi:noNamespaceSchemaLocation", "https://raw.githubusercontent.com/objectionary/eo/refs/heads/gh-pages/XMIR.xsd") ] - ( NodeElement (element "listing" [] [NodeContent (T.pack listing)]) - : root - : metasWithPackage (intercalate "." pckg) + ( if null pckg + then [listing', root] + else [listing', metas, root] ) ) [] @@ -222,6 +240,8 @@ newline :: TB.Builder newline = TB.fromString "\n" +-- >>> printElement 0 (element "doc" [("a", ""), ("b", ""), ("c", ""), ("d", ""), ("e", "")] []) +-- "\n" printElement :: Int -> Element -> TB.Builder printElement indentLevel (Element name attrs nodes) | null nodes = @@ -257,12 +277,10 @@ <> newline where attrsText = - let attrs' = M.toList attrs - first = if length attrs' > 4 then newline <> indent (indentLevel + 1) else TB.fromString " " - in mconcat - [ first <> TB.fromText (nameLocalName k) <> TB.fromString "=\"" <> TB.fromText v <> TB.fromString "\"" - | (k, v) <- attrs' - ] + mconcat + [ TB.fromString " " <> TB.fromText (nameLocalName k) <> TB.fromString "=\"" <> TB.fromText v <> TB.fromString "\"" + | (k, v) <- M.toList attrs + ] isTextNode (NodeContent _) = True isTextNode _ = False diff --git a/test/CLISpec.hs b/test/CLISpec.hs --- a/test/CLISpec.hs +++ b/test/CLISpec.hs @@ -65,7 +65,7 @@ testCLI :: [String] -> [String] -> Expectation testCLI args outputs = do - out <- capture_ (runCLI args) + (out, _) <- withStdout (try (runCLI args) :: IO (Either ExitCode ())) forM_ outputs ( \output -> diff --git a/test/DataizeSpec.hs b/test/DataizeSpec.hs --- a/test/DataizeSpec.hs +++ b/test/DataizeSpec.hs @@ -16,6 +16,14 @@ res <- func input (Program prog) res `shouldBe` output +testDataize :: [(String, String, String)] -> Spec +testDataize useCases = + forM_ useCases $ \(name, prog, res) -> + it name $ do + program <- parseProgramThrows prog + value <- dataize program + value `shouldBe` Just res + spec :: Spec spec = do describe "morph" $ @@ -74,27 +82,79 @@ ) ] - it "dataizes 5.plus(5)" $ do - prog <- - parseProgramThrows - ( unlines - [ "Q -> [[", - " org -> [[", - " eolang -> [[", - " bytes -> [[", - " data -> ?,", - " @ -> $.data", - " ]],", - " number -> [[", - " as-bytes -> ?,", - " @ -> $.as-bytes,", - " plus -> [[ x -> ?, L> L_org_eolang_number_plus ]]", - " ]]", - " ]]", - " ]],", - " @ -> 5.plus(5)", - "]]" - ] - ) - value <- dataize prog - value `shouldBe` Just "40-24-00-00-00-00-00-00" + testDataize + [ ( "5.plus(5)", + unlines + [ "Q -> [[", + " org -> [[", + " eolang -> [[", + " bytes -> [[", + " data -> ?,", + " @ -> $.data", + " ]],", + " number -> [[", + " as-bytes -> ?,", + " @ -> $.as-bytes,", + " plus -> [[ x -> ?, L> L_org_eolang_number_plus ]]", + " ]]", + " ]]", + " ]],", + " @ -> 5.plus(5)", + "]]" + ], + "40-24-00-00-00-00-00-00" + ), + ( "Fahrenheit", + unlines + [ "Q -> [[", + " org -> [[", + " eolang -> [[", + " bytes -> [[", + " data -> ?,", + " @ -> $.data", + " ]],", + " number -> [[", + " as-bytes -> ?,", + " @ -> $.as-bytes,", + " plus -> [[ x -> ?, L> L_org_eolang_number_plus ]],", + " times -> [[ x -> ?, L> L_org_eolang_number_times ]]", + " ]]", + " ]]", + " ]],", + " @ -> $.c.times(1.8).plus(32),", + " c -> 25", + "]]" + ], + "40-53-40-00-00-00-00-00" + ), + ( "Factorial", + unlines + [ "Q -> [[", + " org -> [[", + " eolang -> [[", + " bytes -> [[", + " data -> ?,", + " @ -> $.data", + " ]],", + " number -> [[", + " as-bytes -> ?,", + " @ -> $.as-bytes,", + " times -> [[ x -> ?, L> L_org_eolang_number_times ]],", + " plus -> [[ x -> ?, L> L_org_eolang_number_plus ]],", + " eq -> [[ x -> ?, y -> ?, L> L_org_eolang_number_eq ]]", + " ]]", + " ]]", + " ]],", + " fac -> [[", + " x -> ?,", + " @ -> $.x.eq(", + " 1,", + " $.x.times($.^.fac($.x.plus(-1)))", + " )", + " ]],", + " @ -> $.fac(3)", + "]]" + ], + "40-18-00-00-00-00-00-00" + ) + ] diff --git a/test/MatcherSpec.hs b/test/MatcherSpec.hs --- a/test/MatcherSpec.hs +++ b/test/MatcherSpec.hs @@ -343,11 +343,11 @@ defaultScope, [[("t", MvTail [TaDispatch (AtLabel "org"), TaApplication (BiTau (AtLabel "x") defaultScope)])]] ), - ( "Q.!a * !t => Q.org(x -> [[]]) => [(!a >> org, !t >> [(x -> [[]])])]", + ( "Q.!a * !t => Q.org.eolang(x -> [[]]) => [(!a >> org, !t >> [ .eolang, ( x -> [[ ]] ) ])]", ExMetaTail (ExDispatch ExGlobal (AtMeta "a")) "t", - ExApplication (ExDispatch ExGlobal (AtLabel "org")) (BiTau (AtLabel "x") defaultScope), + ExApplication (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (BiTau (AtLabel "x") defaultScope), defaultScope, - [[("a", MvAttribute (AtLabel "org")), ("t", MvTail [TaApplication (BiTau (AtLabel "x") defaultScope)])]] + [[("a", MvAttribute (AtLabel "org")), ("t", MvTail [TaDispatch (AtLabel "eolang"), TaApplication (BiTau (AtLabel "x") defaultScope)])]] ), ( "Q.x(y -> $ * !t1) * !t2 => Q.x(y -> $.q).p => [(!t1 >> [.q], !t2 >> [.p])]", ExMetaTail (ExApplication (ExDispatch ExGlobal (AtLabel "x")) (BiTau (AtLabel "y") (ExMetaTail ExThis "t1"))) "t2",