phino 0.0.0.15 → 0.0.0.16
raw patch · 9 files changed
+235/−132 lines, 9 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ XMIR: XmirContext :: Bool -> Bool -> PrintMode -> XmirContext
+ XMIR: data XmirContext
- XMIR: programToXMIR :: Program -> PrintMode -> Bool -> IO Document
+ XMIR: programToXMIR :: Program -> XmirContext -> IO Document
Files
- phino.cabal +1/−1
- src/CLI.hs +4/−2
- src/Dataize.hs +24/−3
- src/Logger.hs +2/−9
- src/Matcher.hs +21/−12
- src/XMIR.hs +95/−77
- test/CLISpec.hs +1/−1
- test/DataizeSpec.hs +84/−24
- test/MatcherSpec.hs +3/−3
phino.cabal view
@@ -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 <https://github.com/objectionary/phino#readme>
src/CLI.hs view
@@ -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
src/Dataize.hs view
@@ -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))
src/Logger.hs view
@@ -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
src/Matcher.hs view
@@ -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)]
src/XMIR.hs view
@@ -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", "")] [])+-- "<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
test/CLISpec.hs view
@@ -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 ->
test/DataizeSpec.hs view
@@ -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"+ )+ ]
test/MatcherSpec.hs view
@@ -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",