diff --git a/phino.cabal b/phino.cabal --- a/phino.cabal +++ b/phino.cabal @@ -1,18 +1,17 @@ -cabal-version: 3.0 - -name: phino -version: 0.0.0.45 -license: MIT -synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions -description: Please see the README on GitHub at -homepage: https://github.com/objectionary/phino#readme -bug-reports: https://github.com/objectionary/phino/issues -license-file: LICENSES/MIT.txt -author: maxonfjvipon -maintainer: mtrunnikov@gmail.com -copyright: 2025 Objectionary.com -category: Language, Code Analysis -build-type: Simple +cabal-version: 3.0 +name: phino +version: 0.0.0.46 +license: MIT +synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions +description: Please see the README on GitHub at +homepage: https://github.com/objectionary/phino#readme +bug-reports: https://github.com/objectionary/phino/issues +license-file: LICENSES/MIT.txt +author: maxonfjvipon +maintainer: mtrunnikov@gmail.com +copyright: 2025 Objectionary.com +category: Language, Code Analysis +build-type: Simple extra-source-files: resources/*.yaml source-repository head @@ -20,113 +19,135 @@ location: https://github.com/objectionary/phino common warnings - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wno-missing-export-lists + 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: - CLI, - Ast, - Parser, - Matcher, - Builder, - Replacer, - Rewriter, - Yaml, - Rule, - Dataize, - Functions, - Deps, - Misc, - Must, - Logger, - Regexp, - Pretty, - Random, - XMIR, + AST + Builder + CLI + CST + Dataize + Deps + Encoding + Functions LaTeX + Lining + Logger + Matcher + Misc + Must + Parser + Printer + Random + Regexp + Render + Replacer + Rewriter + Rule + Sugar + XMIR + Yaml + hs-source-dirs: src other-modules: Paths_phino + autogen-modules: Paths_phino + build-depends: - file-embed ^>=0.0.16.0, + aeson, + array, base >=4.18.3.0 && <5, + binary-ieee754, + bytestring, containers, - megaparsec >= 9.0, - text, - aeson, - yaml, directory, + file-embed ^>=0.0.16.0, filepath, - scientific, - binary-ieee754, - bytestring, - utf8-string, - prettyprinter, + megaparsec >=9.0, optparse-applicative, - vector, random, - xml-conduit ^>=1.10, + regex-pcre-builtin, + scientific, + text, time ^>=1.12, transformers, - regex-pcre-builtin, - array + utf8-string, + vector, + xml-conduit ^>=1.10, + yaml, + default-language: Haskell2010 -- Executable using the library executable phino - import: warnings - main-is: Main.hs - hs-source-dirs: app + import: warnings + main-is: Main.hs + hs-source-dirs: app build-depends: + base, phino, - base + default-language: Haskell2010 -- Test suite for Matcher test-suite spec - import: warnings - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: test + import: warnings + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test other-modules: - Spec, - CLISpec, - ParserSpec, - MatcherSpec, - BuilderSpec, - ReplacerSpec, - PrettySpec, - RewriterSpec, - RuleSpec, - YamlSpec, - MiscSpec, - XMIRSpec, - DataizeSpec, - FunctionsSpec, + BuilderSpec + CLISpec + CSTSpec + DataizeSpec + FunctionsSpec + MatcherSpec + MiscSpec + ParserSpec Paths_phino + ReplacerSpec + RewriterSpec + RuleSpec + Spec + XMIRSpec + YamlSpec + autogen-modules: Paths_phino + default-extensions: ImportQualifiedPost + build-depends: - optparse-applicative, + aeson, base, - megaparsec, - phino, containers, + directory, + filepath, hspec, hspec-core, - filepath, - prettyprinter, - aeson, - yaml, - text, - silently, - directory, + megaparsec, + optparse-applicative, + phino, process, - xml-conduit ^>=1.10 + silently, + text, + xml-conduit ^>=1.10, + yaml, + build-tool-depends: hspec-discover:hspec-discover + default-language: Haskell2010 diff --git a/resources/miss.yaml b/resources/miss.yaml --- a/resources/miss.yaml +++ b/resources/miss.yaml @@ -1,7 +1,7 @@ # SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com # SPDX-License-Identifier: MIT --- -name: 'MISS' +name: MISS pattern: ⟦𝐵⟧(𝜏 ↦ 𝑒) result: ⊥ when: diff --git a/src/AST.hs b/src/AST.hs new file mode 100644 --- /dev/null +++ b/src/AST.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +-- This module represents AST tree for parsed phi-calculus program +module AST where + +import Data.List (intercalate) +import GHC.Generics (Generic) + +newtype Program = Program Expression -- Q -> expr + deriving (Eq, Ord, Show) + +data Expression + = ExFormation [Binding] -- [[ bindings ]] + | ExThis + | ExGlobal -- Q + | ExTermination -- T + | ExMeta String -- !e + | ExApplication Expression Binding -- expr(attr -> expr) + | ExDispatch Expression Attribute -- expr.attr + | ExMetaTail Expression String -- expr * !t + deriving (Eq, Ord, Show, Generic) + +data Binding + = BiTau Attribute Expression -- attr -> expr + | BiMeta String -- !B + | BiDelta Bytes -- Δ ⤍ 1F-2A + | BiVoid Attribute -- attr ↦ ? + | BiLambda String -- λ ⤍ Function + | BiMetaLambda String -- λ ⤍ !F + deriving (Eq, Ord, Show, Generic) + +data Bytes + = BtEmpty -- -- + | BtOne String -- 1F- + | BtMany [String] -- 00-01-02-...04 + | BtMeta String -- !b + deriving (Eq, Ord, Show, Generic) + +data Attribute + = AtLabel String -- attr + | AtAlpha Integer -- α1 + | AtPhi -- φ + | AtRho -- ρ + | AtLambda -- λ, used only in yaml conditions + | AtDelta -- Δ, used only in yaml conditions + | AtMeta String -- !a + deriving (Eq, Generic, Ord) + +instance Show Attribute where + show (AtLabel label) = label + show (AtAlpha idx) = 'α' : show idx + show AtRho = "ρ" + show AtPhi = "φ" + show AtDelta = "Δ" + show AtLambda = "λ" + show (AtMeta meta) = '!' : meta + +countNodes :: Program -> Integer +countNodes (Program expr) = countNodes' expr + where + countNodes' :: Expression -> Integer + countNodes' ExGlobal = 1 + countNodes' ExTermination = 1 + countNodes' ExThis = 1 + countNodes' (ExApplication expr' (BiTau attr bexpr')) = 2 + countNodes' expr' + countNodes' bexpr' + countNodes' (ExDispatch expr' attr) = 2 + countNodes' expr' + countNodes' (ExFormation bds) = 1 + sum (map (\case BiTau attr expr' -> countNodes' expr'; _ -> 1) bds) + countNodes' _ = 0 diff --git a/src/Ast.hs b/src/Ast.hs deleted file mode 100644 --- a/src/Ast.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} - --- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com --- SPDX-License-Identifier: MIT - --- This module represents Ast tree for parsed phi-calculus program -module Ast where - -import GHC.Generics (Generic) - -newtype Program = Program Expression -- Q -> expr - deriving (Eq, Ord, Show) - -data Expression - = ExFormation [Binding] -- [[ bindings ]] - | ExThis -- $ - | ExGlobal -- Q - | ExTermination -- T - | ExMeta String -- !e - | ExApplication Expression Binding -- expr(attr -> expr) - | ExDispatch Expression Attribute -- expr.attr - | ExMetaTail Expression String -- expr * !t - deriving (Eq, Ord, Show, Generic) - -data Binding - = BiTau Attribute Expression -- attr -> expr - | BiMeta String -- !B - | BiDelta Bytes -- Δ ⤍ 1F-2A - | BiVoid Attribute -- attr ↦ ? - | BiLambda String -- λ ⤍ Function - | BiMetaLambda String -- λ ⤍ !F - deriving (Eq, Ord, Show, Generic) - -data Bytes - = BtEmpty -- -- - | BtOne String -- 1F- - | BtMany [String] -- 00-01-02-...04 - | BtMeta String -- !b - deriving (Eq, Ord, Show, Generic) - -data Attribute - = AtLabel String -- attr - | AtAlpha Integer -- α1 - | AtPhi -- φ - | AtRho -- ρ - | AtLambda -- λ, used only in yaml conditions - | AtDelta -- Δ, used only in yaml conditions - | AtMeta String -- !a - deriving (Eq, Generic, Ord) - -instance Show Attribute where - show (AtLabel label) = label - show (AtAlpha idx) = 'α' : show idx - show AtRho = "ρ" - show AtPhi = "φ" - show AtDelta = "Δ" - show AtLambda = "λ" - show (AtMeta meta) = '!' : meta - -countNodes :: Program -> Integer -countNodes (Program expr) = countNodes' expr - where - countNodes' :: Expression -> Integer - countNodes' ExGlobal = 1 - countNodes' ExTermination = 1 - countNodes' ExThis = 1 - countNodes' (ExApplication expr' (BiTau attr bexpr')) = 2 + countNodes' expr' + countNodes' bexpr' - countNodes' (ExDispatch expr' attr) = 2 + countNodes' expr' - countNodes' (ExFormation bds) = 1 + sum (map (\case BiTau attr expr' -> countNodes' expr'; _ -> 1) bds) - countNodes' _ = 0 diff --git a/src/Builder.hs b/src/Builder.hs --- a/src/Builder.hs +++ b/src/Builder.hs @@ -22,12 +22,12 @@ ) where -import Ast +import AST import Control.Exception (Exception, throwIO) import qualified Data.Map.Strict as Map import Matcher import Misc (uniqueBindings) -import Pretty (prettyAttribute, prettyBinding, prettyBytes, prettyExpression, prettySubst) +import Printer import Text.Printf (printf) import Yaml (ExtraArgument (..)) @@ -52,21 +52,21 @@ printf "Couldn't build expression, %s\n--Expression: %s" _msg - (prettyExpression _expr) + (printExpression _expr) show CouldNotBuildAttribute {..} = printf "Couldn't build attribute '%s', %s" - (prettyAttribute _attr) + (printAttribute _attr) _msg show CouldNotBuildBinding {..} = printf "Couldn't build binding, %s\n--Binding: %s" _msg - (prettyBinding _bd) + (printBinding _bd) show CouldNotBuildBytes {..} = printf "Couldn't build bytes '%s', %s" - (prettyBytes _bts) + (printBytes _bts) _msg contextualize :: Expression -> Expression -> Program -> Expression diff --git a/src/CLI.hs b/src/CLI.hs --- a/src/CLI.hs +++ b/src/CLI.hs @@ -9,19 +9,22 @@ module CLI (runCLI) where -import Ast (Program (Program)) +import AST (Program (Program)) import Control.Exception (Exception (displayException), SomeException, handle, throw, throwIO) import Control.Exception.Base import Control.Monad (when) import Data.Char (toLower, toUpper) +import Data.Functor ((<&>)) import Data.List (intercalate) import Data.Maybe (isJust, isNothing) import Data.Version (showVersion) import Dataize (DataizeContext (DataizeContext), dataize) import Deps (saveStep) +import Encoding (Encoding (ASCII, UNICODE)) import Functions (buildTerm) import qualified Functions -import LaTeX (explainRules, programToLaTeX) +import LaTeX (LatexContext (LatexContext), explainRules, programToLaTeX, rewrittensToLatex) +import Lining (LineFormat (MULTILINE, SINGLELINE)) import Logger import Misc (ensuredFile) import qualified Misc @@ -29,8 +32,9 @@ import Options.Applicative import Parser (parseProgramThrows) import Paths_phino (version) -import Pretty (Encoding (UNICODE), PrintMode (SALTY, SWEET), prettyBytes, prettyProgram') -import Rewriter (RewriteContext (RewriteContext), rewrite') +import qualified Printer as P +import Rewriter (RewriteContext (RewriteContext), Rewritten (..), rewrite') +import Sugar import System.Exit (ExitCode (..), exitFailure) import System.IO (getContents') import Text.Printf (printf) @@ -65,6 +69,8 @@ data OptsDataize = OptsDataize { logLevel :: LogLevel, inputFormat :: IOFormat, + sugarType :: SugarType, + flat :: LineFormat, maxDepth :: Integer, maxCycles :: Integer, depthSensitive :: Bool, @@ -85,7 +91,8 @@ rules :: [FilePath], inputFormat :: IOFormat, outputFormat :: IOFormat, - printMode :: PrintMode, + sugarType :: SugarType, + flat :: LineFormat, normalize :: Bool, shuffle :: Bool, omitListing :: Bool, @@ -95,6 +102,7 @@ maxDepth :: Integer, maxCycles :: Integer, inPlace :: Bool, + sequence :: Bool, targetFile :: Maybe FilePath, stepsDir :: Maybe FilePath, inputFile :: Maybe FilePath @@ -159,6 +167,12 @@ optShuffle :: Parser Bool optShuffle = switch (long "shuffle" <> help "Shuffle rules before applying") +optSugar :: Parser SugarType +optSugar = flag SALTY SWEET (long "sweet" <> help "Print result and intermediate (see --steps flag) 𝜑-programs using syntax sugar") + +optLineFormat :: Parser LineFormat +optLineFormat = flag MULTILINE SINGLELINE (long "flat" <> help "Print result and intermediate (see --steps flag) 𝜑-programs in one line") + explainParser :: Parser Command explainParser = CmdExplain @@ -176,6 +190,8 @@ <$> ( OptsDataize <$> optLogLevel <*> optInputFormat + <*> optSugar + <*> optLineFormat <*> optMaxDepth <*> optMaxCycles <*> optDepthSensitive @@ -191,7 +207,8 @@ <*> optRule <*> optInputFormat <*> option (parseIOFormat "output") (long "output" <> metavar "FORMAT" <> help "Program output format (phi, xmir)" <> value PHI <> showDefault) - <*> flag SALTY SWEET (long "sweet" <> help "Print 𝜑-program using syntax sugar") + <*> optSugar + <*> optLineFormat <*> optNormalize <*> optShuffle <*> switch (long "omit-listing" <> help "Omit full program listing in XMIR output") @@ -208,6 +225,7 @@ <*> optMaxDepth <*> optMaxCycles <*> switch (long "in-place" <> help "Edit file in-place instead of printing to output") + <*> switch (long "sequence" <> help "Result output contains all intermediate 𝜑-programs concatenated with EOL") <*> optTarget <*> optStepsDir <*> argInputFile @@ -216,8 +234,8 @@ commandParser :: Parser Command commandParser = hsubparser - ( command "rewrite" (info rewriteParser (progDesc "Rewrite the program")) - <> command "dataize" (info dataizeParser (progDesc "Dataize the program")) + ( command "rewrite" (info rewriteParser (progDesc "Rewrite the 𝜑-program")) + <> command "dataize" (info dataizeParser (progDesc "Dataize the 𝜑-program")) <> command "explain" (info explainParser (progDesc "Explain rules in LaTeX format")) ) @@ -254,15 +272,15 @@ let xmirCtx = Just (XmirContext omitListing omitComments input) rules' <- getRules normalize shuffle rules program <- parseProgram input inputFormat - rewritten <- rewrite' program rules' (context program xmirCtx) + rewrittens <- rewrite' program rules' (context program xmirCtx) logDebug (printf "Printing rewritten 𝜑-program as %s" (show outputFormat)) - prog <- printProgram outputFormat printMode xmirCtx rewritten - output targetFile prog + progs <- printRewrittens xmirCtx rewrittens + output targetFile progs where validateOpts :: IO () validateOpts = do when - (printMode == SWEET && outputFormat == XMIR) + (sugarType == SWEET && outputFormat == XMIR) (throwIO (InvalidRewriteArguments "The --sweet and --output=xmir can't stay together")) when (inPlace && isNothing inputFile) @@ -293,15 +311,20 @@ maxDepth maxCycles depthSensitive + sequence buildTerm must - (saveStep stepsDir (ioToExtension outputFormat) (printProgram outputFormat printMode ctx)) + (saveStep stepsDir (ioToExtension outputFormat) (printProgram outputFormat (sugarType, flat) ctx)) + printRewrittens :: Maybe XmirContext -> [Rewritten] -> IO String + printRewrittens ctx rewrittens + | outputFormat == LATEX = pure (rewrittensToLatex rewrittens (LatexContext sugarType flat)) + | otherwise = mapM (printProgram outputFormat (sugarType, flat) ctx . program) rewrittens <&> intercalate "\n" CmdDataize opts@OptsDataize {..} -> do validateOpts input <- readInput inputFile prog <- parseProgram input inputFormat dataized <- dataize prog (context prog) - maybe (throwIO CouldNotDataize) (putStrLn . prettyBytes) dataized + maybe (throwIO CouldNotDataize) (putStrLn . P.printBytes) dataized where validateOpts :: IO () validateOpts = do @@ -315,7 +338,7 @@ maxCycles depthSensitive buildTerm - (saveStep stepsDir (ioToExtension PHI) (printProgram PHI SWEET Nothing)) + (saveStep stepsDir (ioToExtension PHI) (printProgram PHI (SWEET, MULTILINE) Nothing)) CmdExplain opts@OptsExplain {..} -> do validateOpts rules' <- getRules normalize shuffle rules @@ -364,13 +387,11 @@ parseProgram xmir XMIR = do doc <- parseXMIRThrows xmir xmirToPhi doc - printProgram :: IOFormat -> PrintMode -> Maybe XmirContext -> Program -> IO String - printProgram PHI mode _ prog = pure (prettyProgram' prog mode UNICODE) - printProgram XMIR mode Nothing prog = printProgram XMIR mode (Just defaultXmirContext) prog - printProgram XMIR _ (Just ctx) prog = do - xmir <- programToXMIR prog ctx - pure (printXMIR xmir) - printProgram LATEX mode _ prog = pure (programToLaTeX prog mode) + printProgram :: IOFormat -> (SugarType, LineFormat) -> Maybe XmirContext -> Program -> IO String + printProgram PHI (sugar, line) _ prog = pure (P.printProgram' prog (sugar, UNICODE, line)) + printProgram XMIR cfg Nothing prog = printProgram XMIR cfg (Just defaultXmirContext) prog + printProgram XMIR _ (Just ctx) prog = programToXMIR prog ctx <&> printXMIR + printProgram LATEX (sugar, line) _ prog = pure (programToLaTeX prog (LatexContext sugar line)) getRules :: Bool -> Bool -> [FilePath] -> IO [Y.Rule] getRules normalize shuffle rules = do ordered <- diff --git a/src/CST.hs b/src/CST.hs new file mode 100644 --- /dev/null +++ b/src/CST.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT +-- This module represents concrete syntax tree for phi-calculus program +module CST where + +import AST +import Data.List (intercalate) +import Misc + +data LSB = LSB | LSB' + deriving (Eq, Show) + +data RSB = RSB | RSB' + deriving (Eq, Show) + +data COMMA = COMMA | NO_COMMA + deriving (Eq, Show) + +data ARROW = ARROW | ARROW' + deriving (Eq, Show) + +data DASHED_ARROW = DASHED_ARROW + deriving (Eq, Show) + +data VOID = EMPTY | QUESTION + deriving (Eq, Show) + +data PHI = PHI | AT + deriving (Eq, Show) + +data RHO = RHO | CARET + deriving (Eq, Show) + +data DELTA = DELTA + deriving (Eq, Show) + +data XI = XI | DOLLAR + deriving (Eq, Show) + +data LAMBDA = LAMBDA + deriving (Eq, Show) + +data GLOBAL = Φ | Q + deriving (Eq, Show) + +data DEF_PACKAGE = Φ̇ | QQ + deriving (Eq, Show) + +data TERMINATION = DEAD | T + deriving (Eq, Show) + +data SPACE = SPACE + deriving (Eq, Show) + +data EOL = EOL | NO_EOL + deriving (Eq, Show) + +data BYTES = BT_EMPTY | BT_ONE String | BT_MANY [String] + deriving (Eq, Show) + +data TAB + = TAB {indent :: Integer} + | TAB' + | NO_TAB + deriving (Eq, Show) + +data ALPHA = ALPHA | ALPHA' + deriving (Eq, Show) + +data PROGRAM + = PR_SWEET {expr :: EXPRESSION} + | PR_SALTY {global :: GLOBAL, arrow :: ARROW, expr :: EXPRESSION} + deriving (Eq, Show) + +data PAIR + = PA_TAU {attr :: ATTRIBUTE, arrow :: ARROW, expr :: EXPRESSION} + | PA_VOID {attr :: ATTRIBUTE, arrow :: ARROW, void :: VOID} + | PA_LAMBDA {func :: String} + | PA_LAMBDA' {func :: String} -- ASCII version of PA_LAMBDA + | PA_DELTA {bytes :: BYTES} + | PA_DELTA' {bytes :: BYTES} -- ASCII version of PA_DELTA + deriving (Eq, Show) + +data BINDING + = BI_PAIR {pair :: PAIR, bindings :: BINDINGS, tab :: TAB} + | BI_EMPTY {tab :: TAB} + deriving (Eq, Show) + +data BINDINGS + = BDS_PAIR {eol :: EOL, tab :: TAB, pair :: PAIR, bindings :: BINDINGS} + | BDS_EMPTY {tab :: TAB} + deriving (Eq, Show) + +-- Arguments for application with default α attributes +-- which are not necessary to be printed +data APP_ARG = APP_ARG {expr :: EXPRESSION, args :: APP_ARGS} + deriving (Eq, Show) + +data APP_ARGS + = AAS_EXPR {eol :: EOL, tab :: TAB, expr :: EXPRESSION, args :: APP_ARGS} + | AAS_EMPTY + deriving (Eq, Show) + +data EXPRESSION + = EX_GLOBAL {global :: GLOBAL} + | EX_DEF_PACKAGE {pckg :: DEF_PACKAGE} + | EX_XI {xi :: XI} + | EX_ATTR {attr :: ATTRIBUTE} -- sugar for $.x -> just x + | EX_TERMINATION {termination :: TERMINATION} + | EX_FORMATION {lsb :: LSB, eol :: EOL, tab :: TAB, binding :: BINDING, eol' :: EOL, tab' :: TAB, rsb :: RSB} + | EX_DISPATCH {expr :: EXPRESSION, attr :: ATTRIBUTE} + | EX_APPLICATION {expr :: EXPRESSION, eol :: EOL, tab :: TAB, bindings :: BINDING, eol' :: EOL, tab' :: TAB} + | EX_APPLICATION' {expr :: EXPRESSION, eol :: EOL, tab :: TAB, args :: APP_ARG, eol' :: EOL, tab' :: TAB} + | EX_STRING {str :: String, tab :: TAB} + | EX_NUMBER {num :: Either Integer Double, tab :: TAB} + deriving (Eq, Show) + +data ATTRIBUTE + = AT_LABEL {label :: String} + | AT_ALPHA {alpha :: ALPHA, idx :: Integer} + | AT_RHO {rho :: RHO} + | AT_PHI {phi :: PHI} + | AT_LAMBDA {lambda :: LAMBDA} + | AT_DELTA {delta :: DELTA} + deriving (Eq, Show) + +programToCST :: Program -> PROGRAM +programToCST prog = toCST prog 0 + +expressionToCST :: Expression -> EXPRESSION +expressionToCST expr = toCST expr 0 + +-- This class is used to convert AST to CST +-- CST is created with sugar and unicode +-- All further transformations much consider that +class ToCST a b where + toCST :: a -> Integer -> b + +instance ToCST Program PROGRAM where + toCST (Program expr) tabs = PR_SWEET (toCST expr tabs) + +instance ToCST Expression EXPRESSION where + toCST ExGlobal _ = EX_GLOBAL Φ + toCST ExThis _ = EX_XI XI + toCST ExTermination _ = EX_TERMINATION DEAD + toCST (ExFormation [BiVoid AtRho]) _ = toCST (ExFormation []) 0 + toCST (ExFormation []) _ = EX_FORMATION LSB NO_EOL NO_TAB (BI_EMPTY NO_TAB) NO_EOL NO_TAB RSB + toCST (ExFormation bds) tabs = + let next = tabs + 1 + bds' = toCST (withoutLastVoidRho bds) next :: BINDING + in EX_FORMATION + LSB + EOL + (TAB next) + bds' + EOL + (TAB tabs) + RSB + where + withoutLastVoidRho :: [Binding] -> [Binding] + withoutLastVoidRho [] = [] + withoutLastVoidRho [BiVoid AtRho] = [] + withoutLastVoidRho (bd : [BiVoid AtRho]) = [bd] + withoutLastVoidRho (bd : bds') = bd : withoutLastVoidRho bds' + toCST (DataString bts) tabs = EX_STRING (btsToStr bts) (TAB tabs) + toCST (DataNumber bts) tabs = EX_NUMBER (btsToNum bts) (TAB tabs) + toCST (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) _ = EX_DEF_PACKAGE Φ̇ + toCST (ExDispatch ExThis attr) tabs = EX_ATTR (toCST attr tabs) + toCST (ExDispatch expr attr) tabs = EX_DISPATCH (toCST expr tabs) (toCST attr tabs) + toCST app@(ExApplication (ExApplication expr tau) tau') tabs = + let (expr', taus, exprs) = complexApplication app + next = tabs + 1 + expr'' = toCST expr' tabs :: EXPRESSION + in if null exprs + then + EX_APPLICATION + (toCST expr' tabs) + EOL + (TAB next) + (toCST (reverse taus) next) + EOL + (TAB tabs) + else + EX_APPLICATION' + (toCST expr' tabs) + EOL + (TAB next) + (toCST (reverse exprs) next) + EOL + (TAB tabs) + where + -- Here we unroll nested application sequence into flat structure + -- The returned tuple consists of: + -- 1. deepest start expression + -- 2. list of tau bindings which are applied to start expression + -- 3. list of expressions which are applied to start expression with default + -- alpha attributes (~0 -> e1, ~1 -> e2, ...) + complexApplication :: Expression -> (Expression, [Binding], [Expression]) + complexApplication (ExApplication (ExApplication expr tau) tau') = + let (before, taus, exprs) = complexApplication (ExApplication expr tau) + taus' = tau' : taus + in 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], []) + toCST (ExApplication expr tau) tabs = + let next = tabs + 1 + in EX_APPLICATION (toCST expr tabs) EOL (TAB next) (toCST [tau] next) EOL (TAB tabs) + +instance ToCST [Expression] APP_ARG where + toCST (expr : exprs) tabs = APP_ARG (toCST expr tabs) (toCST exprs tabs) + +instance ToCST [Expression] APP_ARGS where + toCST [] _ = AAS_EMPTY + toCST (expr : exprs) tabs = AAS_EXPR EOL (TAB tabs) (toCST expr tabs) (toCST exprs tabs) + +instance ToCST [Binding] BINDING where + toCST [] tabs = BI_EMPTY (TAB tabs) + toCST (bd : bds) tabs = BI_PAIR (toCST bd tabs) (toCST bds tabs) (TAB tabs) + +instance ToCST [Binding] BINDINGS where + toCST [] tabs = BDS_EMPTY (TAB tabs) + toCST (bd : bds) tabs = BDS_PAIR EOL (TAB tabs) (toCST bd tabs) (toCST bds tabs) + +instance ToCST Binding PAIR where + toCST (BiTau attr exp) tabs = PA_TAU (toCST attr tabs) ARROW (toCST exp tabs) + toCST (BiVoid attr) tabs = PA_VOID (toCST attr tabs) ARROW EMPTY + toCST (BiDelta bts) tabs = PA_DELTA (toCST bts tabs) + toCST (BiLambda func) _ = PA_LAMBDA func + +instance ToCST Bytes BYTES where + toCST BtEmpty _ = BT_EMPTY + toCST (BtOne byte) _ = BT_ONE byte + toCST (BtMany bts) _ = BT_MANY bts + +instance ToCST Attribute ATTRIBUTE where + toCST (AtLabel label) _ = AT_LABEL label + toCST (AtAlpha idx) _ = AT_ALPHA ALPHA idx + toCST AtPhi _ = AT_PHI PHI + toCST AtRho _ = AT_RHO RHO + toCST AtDelta _ = AT_DELTA DELTA + toCST AtLambda _ = AT_LAMBDA LAMBDA + +class HasEOL a where + hasEOL :: a -> Bool + +instance HasEOL EXPRESSION where + hasEOL EX_FORMATION {eol = NO_EOL, binding, eol' = NO_EOL} = hasEOL binding + hasEOL EX_FORMATION {..} = True + hasEOL EX_DISPATCH {..} = hasEOL expr + hasEOL EX_APPLICATION {eol = NO_EOL, expr, bindings, eol' = NO_EOL} = hasEOL expr || hasEOL bindings + hasEOL EX_APPLICATION {..} = True + hasEOL EX_APPLICATION' {eol = NO_EOL, expr, args, eol' = NO_EOL} = hasEOL expr || hasEOL args + hasEOL EX_APPLICATION' {..} = True + hasEOL _ = False + +instance HasEOL BINDING where + hasEOL BI_EMPTY {..} = False + hasEOL BI_PAIR {..} = hasEOL pair || hasEOL bindings + +instance HasEOL BINDINGS where + hasEOL BDS_PAIR {eol = NO_EOL, pair, bindings} = hasEOL pair || hasEOL bindings + hasEOL BDS_PAIR {..} = True + hasEOL BDS_EMPTY {..} = False + +instance HasEOL PAIR where + hasEOL PA_TAU {..} = hasEOL expr + hasEOL _ = False + +instance HasEOL APP_ARG where + hasEOL APP_ARG {..} = hasEOL expr || hasEOL args + +instance HasEOL APP_ARGS where + hasEOL AAS_EMPTY = False + hasEOL AAS_EXPR {eol = NO_EOL, expr, args} = hasEOL expr || hasEOL args + hasEOL AAS_EXPR {..} = True diff --git a/src/Dataize.hs b/src/Dataize.hs --- a/src/Dataize.hs +++ b/src/Dataize.hs @@ -6,14 +6,14 @@ module Dataize (morph, dataize, dataize', DataizeContext (..)) where -import Ast +import AST import Builder (contextualize) import Control.Exception (throwIO) import Data.List (partition) import Deps (BuildTermFunc, SaveStepFunc) import Misc import Must (Must (..)) -import Rewriter (RewriteContext (RewriteContext), rewrite') +import Rewriter (RewriteContext (RewriteContext), Rewritten (Rewritten, program), rewrite') import Rule (RuleContext (RuleContext), isNF) import Text.Printf (printf) import XMIR (XmirContext (XmirContext)) @@ -35,6 +35,7 @@ _maxDepth _maxCycles _depthSensitive + False _buildTerm MtDisabled _saveStep @@ -130,7 +131,7 @@ if isNF expr (RuleContext (_program ctx) (_buildTerm ctx)) then pure Nothing else do - (Program expr') <- rewrite' (Program expr) normalizationRules (switchContext ctx) -- NMZ + [Rewritten {program = Program expr'}] <- rewrite' (Program expr) normalizationRules (switchContext ctx) -- NMZ morph expr' ctx -- The goal of 'dataize' function is retrieve bytes from given expression. diff --git a/src/Deps.hs b/src/Deps.hs --- a/src/Deps.hs +++ b/src/Deps.hs @@ -9,7 +9,7 @@ -- Functions module because Rewriter does not depend on Functions anymore. module Deps where -import Ast +import AST import Logger (logDebug) import Matcher import System.Directory (createDirectoryIfMissing) @@ -31,10 +31,10 @@ saveStep :: Maybe FilePath -> String -> (Program -> IO String) -> SaveStepFunc saveStep Nothing _ _ _ _ = pure () -saveStep (Just dir) ext print' prog step = do +saveStep (Just dir) ext print prog step = do createDirectoryIfMissing True dir let path = dir printf "%05d.%s" step ext - content <- print' prog + content <- print prog writeFile path content logDebug (printf "Saved step '%d' to '%s'" step path) diff --git a/src/Encoding.hs b/src/Encoding.hs new file mode 100644 --- /dev/null +++ b/src/Encoding.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE RecordWildCards #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module Encoding (toASCII, withEncoding, Encoding (..)) where + +import CST + +data Encoding = ASCII | UNICODE + deriving (Eq, Show) + +withEncoding :: (ToASCII a) => Encoding -> a -> a +withEncoding UNICODE prog = prog +withEncoding ASCII prog = toASCII prog + +class ToASCII a where + toASCII :: a -> a + +instance ToASCII PROGRAM where + toASCII PR_SALTY {..} = PR_SALTY Q ARROW' (toASCII expr) + toASCII PR_SWEET {..} = PR_SWEET (toASCII expr) + +instance ToASCII EXPRESSION where + toASCII EX_GLOBAL {..} = EX_GLOBAL Q + toASCII EX_DEF_PACKAGE {..} = EX_DEF_PACKAGE QQ + toASCII EX_XI {..} = EX_XI DOLLAR + toASCII EX_ATTR {..} = EX_ATTR (toASCII attr) + toASCII EX_TERMINATION {..} = EX_TERMINATION T + toASCII EX_FORMATION {..} = EX_FORMATION LSB' eol tab (toASCII binding) eol' tab' RSB' + toASCII EX_DISPATCH {..} = EX_DISPATCH (toASCII expr) (toASCII attr) + toASCII EX_APPLICATION {..} = EX_APPLICATION (toASCII expr) eol tab (toASCII bindings) eol' tab' + toASCII EX_APPLICATION' {..} = EX_APPLICATION' (toASCII expr) eol tab (toASCII args) eol' tab' + toASCII expr = expr + +instance ToASCII BINDING where + toASCII BI_PAIR {..} = BI_PAIR (toASCII pair) (toASCII bindings) tab + toASCII bd = bd + +instance ToASCII BINDINGS where + toASCII BDS_PAIR {..} = BDS_PAIR eol tab (toASCII pair) (toASCII bindings) + toASCII bds = bds + +instance ToASCII APP_ARG where + toASCII APP_ARG {..} = APP_ARG (toASCII expr) (toASCII args) + +instance ToASCII APP_ARGS where + toASCII AAS_EXPR {..} = AAS_EXPR eol tab (toASCII expr) (toASCII args) + toASCII args = args + +instance ToASCII PAIR where + toASCII PA_TAU {..} = PA_TAU (toASCII attr) ARROW' (toASCII expr) + toASCII PA_VOID {..} = PA_VOID (toASCII attr) ARROW' QUESTION + toASCII PA_LAMBDA {..} = PA_LAMBDA' func + toASCII PA_DELTA {..} = PA_DELTA' bytes + toASCII pair = pair + +instance ToASCII ATTRIBUTE where + toASCII AT_ALPHA {..} = AT_ALPHA ALPHA' idx + toASCII AT_PHI {..} = AT_PHI AT + toASCII AT_RHO {..} = AT_RHO CARET + toASCII attr = attr diff --git a/src/Functions.hs b/src/Functions.hs --- a/src/Functions.hs +++ b/src/Functions.hs @@ -5,7 +5,7 @@ module Functions (buildTerm) where -import Ast +import AST import Builder import Control.Exception (throwIO) import Control.Monad (replicateM, when) @@ -20,36 +20,42 @@ import Misc import Numeric (showHex) import Parser (parseAttributeThrows, parseNumberThrows) -import Pretty import Random (randomString) import Regexp import System.Random (randomRIO) import Deps import Text.Printf (printf) import qualified Yaml as Y +import Printer (printAttribute, printExpression, printExtraArg) +import Logger (logDebug) buildTerm :: BuildTermFunc -buildTerm "contextualize" = _contextualize -buildTerm "scope" = _scope -buildTerm "random-tau" = _randomTau -buildTerm "dataize" = _dataize -buildTerm "concat" = _concat -buildTerm "sed" = _sed -buildTerm "random-string" = _randomString -buildTerm "size" = _size -buildTerm "tau" = _tau -buildTerm "string" = _string -buildTerm "number" = _number -buildTerm "sum" = _sum -buildTerm "join" = _join -buildTerm func = _unsupported func +buildTerm func args subst prog = do + logDebug (printf "Building new term using '%s' function..." func) + buildTerm' func args subst prog +buildTerm' :: BuildTermFunc +buildTerm' "contextualize" = _contextualize +buildTerm' "scope" = _scope +buildTerm' "random-tau" = _randomTau +buildTerm' "dataize" = _dataize +buildTerm' "concat" = _concat +buildTerm' "sed" = _sed +buildTerm' "random-string" = _randomString +buildTerm' "size" = _size +buildTerm' "tau" = _tau +buildTerm' "string" = _string +buildTerm' "number" = _number +buildTerm' "sum" = _sum +buildTerm' "join" = _join +buildTerm' func = _unsupported func + argToBytes :: Y.ExtraArgument -> Subst -> Program -> IO Bytes argToBytes (Y.ArgBytes bytes) subst _ = buildBytesThrows bytes subst argToBytes (Y.ArgExpression expr) subst prog = do (TeBytes bts) <- _dataize [Y.ArgExpression expr] subst prog pure bts -argToBytes arg _ _ = throwIO (userError (printf "Can't extract bytes from given argument: %s" (prettyExtraArg arg))) +argToBytes arg _ _ = throwIO (userError (printf "Can't extract bytes from given argument: %s" (printExtraArg arg))) argToString :: Y.ExtraArgument -> Subst -> Program -> IO String argToString arg subst prog = argToBytes arg subst prog <&> btsToUnescapedStr @@ -83,7 +89,7 @@ Y.ArgAttribute attr -> do attr' <- buildAttributeThrows attr subst rest' <- argsToAttrs rest - pure (prettyAttribute attr' : rest') + pure (printAttribute attr' : rest') Y.ArgBinding bd -> do bds <- buildBindingThrows bd subst rest' <- argsToAttrs rest @@ -186,13 +192,13 @@ ( userError ( printf "Couldn't convert given expression to 'Φ̇.string' object, only 'Φ̇.number' or 'Φ̇.string' are allowed\n%s" - (prettyExpression' exp) + (printExpression exp) ) ) pure (TeExpression str) _string [Y.ArgAttribute attr] subst _ = do attr' <- buildAttributeThrows attr subst - pure (TeExpression (DataString (strToBts (prettyAttribute attr')))) + pure (TeExpression (DataString (strToBts (printAttribute attr')))) _string _ _ _ = throwIO (userError "Function string() requires exactly 1 argument as attribute or data expression (Φ̇.number or Φ̇.string)") _number :: BuildTermMethod @@ -202,7 +208,7 @@ DataString bts -> do num <- parseNumberThrows (btsToUnescapedStr bts) pure (TeExpression num) - _ -> throwIO (userError (printf "Function number() expects expression to be 'Φ̇.string', but got:\n%s" (prettyExpression' expr'))) + _ -> throwIO (userError (printf "Function number() expects expression to be 'Φ̇.string', but got:\n%s" (printExpression expr'))) _number _ _ _ = throwIO (userError "Function number() requires exactly 1 argument as 'Φ̇.string'") _sum :: BuildTermMethod diff --git a/src/LaTeX.hs b/src/LaTeX.hs --- a/src/LaTeX.hs +++ b/src/LaTeX.hs @@ -1,33 +1,113 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} + -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module LaTeX (explainRules, programToLaTeX) where +module LaTeX (explainRules, rewrittensToLatex, programToLaTeX, LatexContext (..)) where -import Ast (Program) +import AST (Program) +import CST +import Data.Char (toLower) import Data.List (intercalate) import Data.Maybe (fromMaybe) -import Pretty (Encoding (ASCII), PrintMode, prettyProgram') +import Encoding (Encoding (ASCII), withEncoding) +import Lining (LineFormat (MULTILINE, SINGLELINE), withLineFormat) +import Printer (printProgram') +import Render (Render (render)) +import Rewriter (Rewritten (..)) +import Sugar (SugarType (SWEET), withSugarType) +import Text.Printf (printf) import qualified Yaml as Y -escapeUnprintedChars :: String -> String -escapeUnprintedChars [] = [] -escapeUnprintedChars (ch : rest) = case ch of - '$' -> "\\char36{}" ++ escapeUnprintedChars rest - '@' -> "\\char64{}" ++ escapeUnprintedChars rest - '^' -> "\\char94{}" ++ escapeUnprintedChars rest - _ -> ch : escapeUnprintedChars rest +data LatexContext = LatexContext + { sugar :: SugarType, + line :: LineFormat + } -programToLaTeX :: Program -> PrintMode -> String -programToLaTeX prog mode = +renderToLatex :: Program -> LatexContext -> String +renderToLatex prog LatexContext {..} = render (toLaTeX $ withLineFormat line $ withEncoding ASCII $ withSugarType sugar $ programToCST prog) + +rewrittensToLatex :: [Rewritten] -> LatexContext -> String +rewrittensToLatex rewrittens ctx = + concat + [ "\\begin{phiquation}\n", + intercalate + "\n\\leadsto " + ( map + ( \Rewritten {..} -> + let prog = renderToLatex program ctx + unknown = "unknown" + maybeTo = case maybeRule of + Just (Y.Rule {..}) -> Just (map toLower (fromMaybe unknown name)) + _ -> Nothing + in case maybeTo of + Just name -> printf "%s \\leadsto_{\\nameref{r:%s}}" prog name + _ -> prog + ) + rewrittens + ), + "\n\\end{phiquation}" + ] + +programToLaTeX :: Program -> LatexContext -> String +programToLaTeX prog ctx = unlines - [ "\\documentclass{article}", - "\\usepackage{eolang}", - "\\begin{document}", - "\\begin{phiquation}", - escapeUnprintedChars (prettyProgram' prog mode ASCII), - "\\end{phiquation}", - "\\end{document}" + [ "\\begin{phiquation}", + renderToLatex prog ctx, + "\\end{phiquation}" ] + +class ToLaTeX a where + toLaTeX :: a -> a + +instance ToLaTeX PROGRAM where + toLaTeX PR_SWEET {..} = PR_SWEET (toLaTeX expr) + toLaTeX PR_SALTY {..} = PR_SALTY global arrow (toLaTeX expr) + +instance ToLaTeX EXPRESSION where + toLaTeX EX_ATTR {..} = EX_ATTR (toLaTeX attr) + toLaTeX EX_FORMATION {..} = EX_FORMATION lsb eol tab (toLaTeX binding) eol' tab' rsb + toLaTeX EX_APPLICATION {..} = EX_APPLICATION (toLaTeX expr) eol tab (toLaTeX bindings) eol' tab' + toLaTeX EX_APPLICATION' {..} = EX_APPLICATION' (toLaTeX expr) eol tab (toLaTeX args) eol' tab' + toLaTeX expr = expr + +instance ToLaTeX ATTRIBUTE where + toLaTeX AT_LABEL {..} = AT_LABEL (toLaTeX label) + toLaTeX attr = attr + +instance ToLaTeX BINDING where + toLaTeX BI_PAIR {..} = BI_PAIR (toLaTeX pair) (toLaTeX bindings) tab + toLaTeX bd = bd + +instance ToLaTeX BINDINGS where + toLaTeX BDS_PAIR {..} = BDS_PAIR eol tab (toLaTeX pair) (toLaTeX bindings) + toLaTeX bds = bds + +instance ToLaTeX PAIR where + toLaTeX PA_DELTA {..} = PA_DELTA' bytes + toLaTeX PA_LAMBDA {..} = PA_LAMBDA' func + toLaTeX PA_VOID {..} = PA_VOID (toLaTeX attr) arrow void + toLaTeX PA_TAU {..} = PA_TAU (toLaTeX attr) arrow (toLaTeX expr) + toLaTeX pair = pair + +instance ToLaTeX APP_ARG where + toLaTeX APP_ARG {..} = APP_ARG (toLaTeX expr) (toLaTeX args) + +instance ToLaTeX APP_ARGS where + toLaTeX AAS_EXPR {..} = AAS_EXPR eol tab (toLaTeX expr) (toLaTeX args) + toLaTeX args = args + +instance ToLaTeX String where + toLaTeX = escapeUnprintedChars + where + escapeUnprintedChars :: String -> String + escapeUnprintedChars [] = [] + escapeUnprintedChars (ch : rest) = case ch of + '$' -> "\\char36{}" <> escapeUnprintedChars rest + '@' -> "\\char64{}" <> escapeUnprintedChars rest + '^' -> "\\char94{}" <> escapeUnprintedChars rest + _ -> ch : escapeUnprintedChars rest -- @todo #114:30min Implement LaTeX conversion for rules. -- Convert Rule data structure to LaTeX inference rule format. diff --git a/src/Lining.hs b/src/Lining.hs new file mode 100644 --- /dev/null +++ b/src/Lining.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module Lining (toSingleLine, LineFormat (..), withLineFormat) where + +import CST + +withLineFormat :: (ToSingleLine a) => LineFormat -> a -> a +withLineFormat MULTILINE prog = prog +withLineFormat SINGLELINE prog = toSingleLine prog + +data LineFormat = SINGLELINE | MULTILINE + deriving (Show, Eq) + +class ToSingleLine a where + toSingleLine :: a -> a + +instance ToSingleLine PROGRAM where + toSingleLine PR_SALTY {..} = PR_SALTY global arrow (toSingleLine expr) + toSingleLine PR_SWEET {..} = PR_SWEET (toSingleLine expr) + +instance ToSingleLine EXPRESSION where + toSingleLine EX_FORMATION {lsb, binding = bd@BI_EMPTY {..}, rsb} = EX_FORMATION lsb NO_EOL NO_TAB bd NO_EOL NO_TAB rsb + toSingleLine EX_FORMATION {..} = EX_FORMATION lsb NO_EOL TAB' (toSingleLine binding) NO_EOL TAB' rsb + toSingleLine EX_DISPATCH {..} = EX_DISPATCH (toSingleLine expr) attr + toSingleLine EX_APPLICATION {..} = EX_APPLICATION (toSingleLine expr) NO_EOL TAB' (toSingleLine bindings) NO_EOL TAB' + toSingleLine EX_APPLICATION' {..} = EX_APPLICATION' (toSingleLine expr) NO_EOL TAB' (toSingleLine args) NO_EOL TAB' + toSingleLine expr = expr + +instance ToSingleLine BINDING where + toSingleLine BI_PAIR {..} = BI_PAIR (toSingleLine pair) (toSingleLine bindings) TAB' + toSingleLine bd = bd + +instance ToSingleLine BINDINGS where + toSingleLine BDS_PAIR {..} = BDS_PAIR NO_EOL TAB' (toSingleLine pair) (toSingleLine bindings) + toSingleLine bds = bds + +instance ToSingleLine PAIR where + toSingleLine PA_TAU {..} = PA_TAU attr arrow (toSingleLine expr) + toSingleLine pair = pair + +instance ToSingleLine APP_ARG where + toSingleLine APP_ARG {..} = APP_ARG (toSingleLine expr) (toSingleLine args) + +instance ToSingleLine APP_ARGS where + toSingleLine AAS_EXPR {..} = AAS_EXPR NO_EOL TAB' (toSingleLine expr) (toSingleLine args) + toSingleLine args = args diff --git a/src/Matcher.hs b/src/Matcher.hs --- a/src/Matcher.hs +++ b/src/Matcher.hs @@ -3,11 +3,11 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- The goal of the module is to traverse given Ast and build substitutions +-- The goal of the module is to traverse given AST and build substitutions -- from meta variables to appropriate meta values module Matcher where -import Ast +import AST import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes) diff --git a/src/Misc.hs b/src/Misc.hs --- a/src/Misc.hs +++ b/src/Misc.hs @@ -30,7 +30,7 @@ ) where -import Ast +import AST import Control.Exception import Control.Monad import Data.Binary.IEEE754 @@ -193,6 +193,7 @@ -- >>> toDouble 5 -- 5.0 toDouble :: Integer -> Double + toDouble = fromIntegral -- >>> btsToWord8 BtEmpty @@ -276,6 +277,8 @@ -- BtMany ["68","22"] -- >>> strToBts "\x01\x01" -- BtMany ["01","01"] +-- >>> strToBts "Hey" +-- BtMany ["48","65","79"] strToBts :: String -> Bytes strToBts "" = BtEmpty strToBts [ch] = word8ToBytes (unpack (U.fromString [ch])) diff --git a/src/Parser.hs b/src/Parser.hs --- a/src/Parser.hs +++ b/src/Parser.hs @@ -4,7 +4,7 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- The goal of the module is to parse given phi program to Ast +-- The goal of the module is to parse given phi program to AST module Parser ( parseProgram, parseProgramThrows, @@ -19,7 +19,7 @@ ) where -import Ast +import AST import Control.Exception (Exception, throwIO) import Control.Monad (guard) import Data.Char (isAsciiLower, isDigit) diff --git a/src/Pretty.hs b/src/Pretty.hs deleted file mode 100644 --- a/src/Pretty.hs +++ /dev/null @@ -1,264 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} - --- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com --- SPDX-License-Identifier: MIT - -module Pretty - ( prettyExpression, - prettyExpression', - prettyProgram, - prettyProgram', - prettyAttribute, - prettySubsts, - prettySubsts', - prettySubst, - prettyBinding, - prettyBytes, - prettyExtraArg, - PrintMode (SWEET, SALTY), - Encoding (ASCII, UNICODE), - ) -where - -import Ast -import Data.List (intercalate) -import qualified Data.Map.Strict as Map -import Matcher -import Misc -import Prettyprinter -import Prettyprinter.Render.String (renderString) -import Yaml (ExtraArgument (..)) - -data PrintMode = SWEET | SALTY - deriving (Eq) - -instance Show PrintMode where - show SWEET = "sweet" - show SALTY = "salty" - -data Encoding = ASCII | UNICODE - -newtype Formatted a = Formatted {unFormatted :: (PrintMode, Encoding, a)} - -formatted :: a -> Formatted a -formatted x = Formatted (SALTY, UNICODE, x) - -prettyMeta :: String -> Doc ann -prettyMeta meta = pretty "!" <> pretty meta - -prettyArrow :: Encoding -> Doc ann -prettyArrow UNICODE = pretty "↦" -prettyArrow ASCII = pretty "->" - -prettyLsb :: Encoding -> Doc ann -prettyLsb UNICODE = pretty "⟦" -prettyLsb ASCII = pretty "[[" - -prettyRsb :: Encoding -> Doc ann -prettyRsb UNICODE = pretty "⟧" -prettyRsb ASCII = pretty "]]" - -prettyDashedArrow :: Doc ann -prettyDashedArrow = pretty "⤍" - -prettyLambda :: Encoding -> Doc ann -prettyLambda UNICODE = pretty "λ" <+> prettyDashedArrow -prettyLambda ASCII = pretty "L>" - -prettyDelta :: Encoding -> Doc ann -prettyDelta UNICODE = pretty "Δ" <+> prettyDashedArrow -prettyDelta ASCII = pretty "D>" - -instance Pretty ExtraArgument where - pretty (ArgExpression expr) = pretty (Formatted (SWEET, UNICODE, expr)) - pretty (ArgBinding bd) = pretty (Formatted (SWEET, UNICODE, bd)) - pretty (ArgAttribute attr) = pretty (formatted attr) - pretty (ArgBytes bytes) = pretty bytes - -instance Pretty Bytes where - pretty BtEmpty = pretty "--" - pretty (BtOne bt) = pretty bt <> pretty "-" - pretty (BtMany bts) = pretty (intercalate "-" bts) - pretty (BtMeta meta) = prettyMeta meta - -instance Pretty (Formatted Attribute) where - pretty (Formatted (_, _, AtMeta meta)) = prettyMeta meta - pretty (Formatted (_, ASCII, AtAlpha idx)) = pretty "~" <> pretty idx - pretty (Formatted (_, ASCII, AtPhi)) = pretty "@" - pretty (Formatted (_, ASCII, AtRho)) = pretty "^" - pretty (Formatted (_, _, attr)) = pretty (show attr) - -instance Pretty (Formatted Binding) where - pretty (Formatted (SWEET, encoding, BiTau attr (ExFormation bindings))) = - let voids' = voids bindings - in if null voids' - then pretty (Formatted (SWEET, encoding, attr)) <+> prettyArrow encoding <+> pretty (Formatted (SWEET, encoding, ExFormation bindings)) - else - if length voids' == length bindings && last voids' == AtRho - then inlineVoids (init voids') <+> prettyLsb encoding <> prettyRsb encoding - else inlineVoids voids' <+> pretty (Formatted (SWEET, encoding, ExFormation (drop (length voids') bindings))) - where - voids :: [Binding] -> [Attribute] - voids [] = [] - voids (bd : bds) = case bd of - BiVoid attr -> attr : voids bds - _ -> [] - inlineVoids :: [Attribute] -> Doc ann - inlineVoids [] = pretty (Formatted (SWEET, encoding, attr)) <+> prettyArrow encoding - inlineVoids voids' = - pretty (Formatted (SWEET, encoding, attr)) - <> lparen - <> hsep (punctuate comma (map (\attr -> pretty (Formatted (SWEET, encoding, attr))) voids')) - <> rparen - <+> prettyArrow encoding - pretty (Formatted (mode, encoding, BiTau attr expr)) = pretty (Formatted (mode, encoding, attr)) <+> prettyArrow encoding <+> pretty (Formatted (mode, encoding, expr)) - pretty (Formatted (_, _, BiMeta meta)) = prettyMeta meta - pretty (Formatted (_, encoding, BiDelta bytes)) = prettyDelta encoding <+> pretty bytes - pretty (Formatted (_, encoding, BiLambda func)) = prettyLambda encoding <+> pretty func - pretty (Formatted (_, encoding, BiMetaLambda meta)) = prettyLambda encoding <+> prettyMeta meta - pretty (Formatted (mode, UNICODE, BiVoid attr)) = pretty (Formatted (mode, UNICODE, attr)) <+> prettyArrow UNICODE <+> pretty "∅" - pretty (Formatted (mode, ASCII, BiVoid attr)) = pretty (Formatted (mode, ASCII, attr)) <+> prettyArrow ASCII <+> pretty "?" - --- >>> render (Formatted (SWEET, UNICODE, [BiVoid AtRho])) --- "" --- >>> render (Formatted (SWEET, UNICODE, [BiTau (AtLabel "x") ExGlobal, BiVoid AtPhi])) --- "x \8614 \934,\n\966 \8614 \8709" -instance {-# OVERLAPPING #-} Pretty (Formatted [Binding]) where - pretty (Formatted (SWEET, encoding, bds)) = vsep (punctuate comma (excludeVoidRho (\bd -> pretty (Formatted (SWEET, encoding, bd))) [] bds)) - where - excludeVoidRho :: (Binding -> Doc ann) -> [Doc ann] -> [Binding] -> [Doc ann] - excludeVoidRho func acc [bd] = case bd of - BiVoid AtRho -> reverse acc - _ -> reverse (func bd : acc) - excludeVoidRho func acc (x : xs) = excludeVoidRho func (func x : acc) xs - excludeVoidRho func acc [] = reverse acc - pretty (Formatted (SALTY, encoding, bds)) = vsep (punctuate comma (map (\bd -> pretty (Formatted (SALTY, encoding, bd))) bds)) - -complexApplication :: Expression -> (Expression, [Binding], [Expression]) -complexApplication (ExApplication (ExApplication expr tau) tau') = - let (before, taus, exprs) = complexApplication (ExApplication expr tau) - taus' = tau' : taus - in 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], []) - --- >>> render (Formatted (SWEET, UNICODE, ExFormation [BiVoid AtRho])) --- "\10214\10215" -instance Pretty (Formatted Expression) where - pretty (Formatted (SWEET, UNICODE, ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang"))) = pretty "Φ̇" - pretty (Formatted (SWEET, ASCII, ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang"))) = pretty "QQ" - pretty (Formatted (SWEET, _, DataString bytes)) = pretty "\"" <> pretty (btsToStr bytes) <> pretty "\"" - pretty (Formatted (SWEET, _, DataNumber bytes)) = either pretty pretty (btsToNum bytes) - pretty (Formatted (SWEET, encoding, DataObject other bytes)) = pretty (Formatted (SALTY, encoding, DataObject other bytes)) - pretty (Formatted (SWEET, UNICODE, ExFormation [BiVoid AtRho])) = pretty "⟦⟧" - pretty (Formatted (SWEET, ASCII, ExFormation [BiVoid AtRho])) = pretty "[[]]" - pretty (Formatted (mode, encoding, ExFormation [binding])) = case binding of - BiTau _ _ -> vsep [prettyLsb encoding, indent 2 (pretty (Formatted (mode, encoding, binding))), prettyRsb encoding] - _ -> prettyLsb encoding <+> pretty (Formatted (mode, encoding, binding)) <+> prettyRsb encoding - pretty (Formatted (_, UNICODE, ExFormation [])) = pretty "⟦⟧" - pretty (Formatted (_, ASCII, ExFormation [])) = pretty "[[]]" - pretty (Formatted (mode, encoding, ExFormation bindings)) = vsep [prettyLsb encoding, indent 2 (pretty (Formatted (mode, encoding, bindings))), prettyRsb encoding] - pretty (Formatted (_, UNICODE, ExThis)) = pretty "ξ" - pretty (Formatted (_, ASCII, ExThis)) = pretty "$" - pretty (Formatted (_, UNICODE, ExGlobal)) = pretty "Φ" - pretty (Formatted (_, ASCII, ExGlobal)) = pretty "Q" - pretty (Formatted (_, UNICODE, ExTermination)) = pretty "⊥" - pretty (Formatted (_, ASCII, ExTermination)) = pretty "T" - pretty (Formatted (_, _, ExMeta meta)) = prettyMeta meta - pretty (Formatted (SWEET, encoding, ExApplication (ExApplication expr tau) tau')) = - let (expr', taus, exprs) = complexApplication (ExApplication (ExApplication expr tau) tau') - args = - if null exprs - then pretty (Formatted (SWEET, encoding, reverse taus)) - else vsep (punctuate comma (map (\exp -> pretty (Formatted (SWEET, encoding, exp))) (reverse exprs))) - in pretty (Formatted (SWEET, encoding, expr')) <> vsep [lparen, indent 2 args, rparen] - pretty (Formatted (SWEET, encoding, ExApplication expr tau)) = - let arg = case tau of - BiTau (AtAlpha 0) expr' -> pretty (Formatted (SWEET, encoding, expr')) - _ -> pretty (Formatted (SWEET, encoding, tau)) - in pretty (Formatted (SWEET, encoding, expr)) <> vsep [lparen, indent 2 arg, rparen] - pretty (Formatted (mode, encoding, ExApplication expr tau)) = pretty (Formatted (mode, encoding, expr)) <> vsep [lparen, indent 2 (pretty (Formatted (mode, encoding, tau))), rparen] - pretty (Formatted (mode, encoding, ExDispatch expr attr)) = pretty (Formatted (mode, encoding, expr)) <> pretty "." <> pretty (Formatted (mode, encoding, attr)) - pretty (Formatted (mode, encoding, ExMetaTail expr meta)) = pretty (Formatted (mode, encoding, expr)) <+> pretty "*" <+> prettyMeta meta - -instance Pretty (Formatted Program) where - pretty (Formatted (SALTY, encoding, Program expr)) = pretty "Φ" <+> prettyArrow encoding <+> pretty (Formatted (SALTY, encoding, expr)) - pretty (Formatted (SWEET, encoding, Program expr)) = pretty "{" <> pretty (Formatted (SWEET, encoding, expr)) <> pretty "}" - -instance Pretty Tail where - pretty (TaApplication tau) = vsep [lparen, indent 2 (pretty (formatted tau)), rparen] - pretty (TaDispatch attr) = pretty "." <> pretty (formatted attr) - -instance Pretty MetaValue where - pretty (MvAttribute attr) = pretty (formatted attr) - pretty (MvBytes bytes) = pretty bytes - pretty (MvBindings []) = pretty "[]" - pretty (MvBindings bindings) = vsep [pretty "[", indent 2 (pretty (formatted bindings)), pretty "]"] - pretty (MvFunction func) = pretty func - pretty (MvExpression expr _) = pretty (formatted expr) - pretty (MvTail tails) = vsep (punctuate comma (map pretty tails)) - -instance Pretty Subst where - pretty (Subst mp) = - vsep - [ lparen, - indent - 2 - ( vsep - ( punctuate - comma - ( map - (\(key, value) -> prettyMeta key <+> pretty ">>" <+> pretty value) - (Map.toList mp) - ) - ) - ), - rparen - ] - -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 binding = render (formatted binding) - -prettyExtraArg :: ExtraArgument -> String -prettyExtraArg = render - -prettyBytes :: Bytes -> String -prettyBytes = render - -prettyAttribute :: Attribute -> String -prettyAttribute attr = render (formatted attr) - -prettySubst :: Subst -> String -prettySubst = render - -prettySubsts :: [Subst] -> String -prettySubsts = render - -prettySubsts' :: [Subst] -> PrintMode -> Encoding -> String -prettySubsts' substs mode encoding = render (Formatted (mode, encoding, substs)) - -prettyExpression :: Expression -> String -prettyExpression expr = render (formatted expr) - -prettyExpression' :: Expression -> String -prettyExpression' expr = render (Formatted (SWEET, UNICODE, expr)) - -prettyProgram :: Program -> String -prettyProgram prog = render (formatted prog) - -prettyProgram' :: Program -> PrintMode -> Encoding -> String -prettyProgram' prog mode encoding = render (Formatted (mode, encoding, prog)) diff --git a/src/Printer.hs b/src/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Printer.hs @@ -0,0 +1,98 @@ +{-# HLINT ignore "Avoid restricted module" #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module Printer + ( printProgram, + printProgram', + printExpression, + printAttribute, + printBinding, + printBytes, + printExtraArg, + printSubsts, + PrintConfig (..), + ) +where + +import AST +import CST +import Data.List (intercalate) +import qualified Data.Map.Strict as Map +import Encoding +import Lining +import Matcher +import Render +import Sugar +import Yaml (ExtraArgument (ArgAttribute, ArgBinding, ArgBytes, ArgExpression)) +import Prelude hiding (print) + +type PrintConfig = (SugarType, Encoding, LineFormat) + +defaultPrintConfig :: PrintConfig +defaultPrintConfig = (SWEET, UNICODE, MULTILINE) + +printProgram' :: Program -> PrintConfig -> String +printProgram' prog (sugar, encoding, line) = render (withLineFormat line $ withEncoding encoding $ withSugarType sugar $ programToCST prog) + +printProgram :: Program -> String +printProgram prog = printProgram' prog defaultPrintConfig + +printExpression' :: Expression -> PrintConfig -> String +printExpression' expr (sugar, encoding, line) = render (withLineFormat line $ withEncoding encoding $ withSugarType sugar $ expressionToCST expr) + +printExpression :: Expression -> String +printExpression expr = printExpression' expr defaultPrintConfig + +printAttribute' :: Attribute -> Encoding -> String +printAttribute' attr encoding = render (withEncoding encoding (toCST attr 0 :: ATTRIBUTE)) + +printAttribute :: Attribute -> String +printAttribute attr = + let (_, encoding, _) = defaultPrintConfig + in printAttribute' attr encoding + +printBinding' :: Binding -> PrintConfig -> String +printBinding' bd = printExpression' (ExFormation [bd]) + +printBinding :: Binding -> String +printBinding bd = printBinding' bd defaultPrintConfig + +printBytes :: Bytes -> String +printBytes bts = render (toCST bts 0 :: BYTES) + +printExtraArg' :: ExtraArgument -> PrintConfig -> String +printExtraArg' (ArgAttribute attr) (_, encoding, _) = printAttribute' attr encoding +printExtraArg' (ArgBinding bd) config = printBinding' bd config +printExtraArg' (ArgExpression expr) config = printExpression' expr config +printExtraArg' (ArgBytes bts) _ = printBytes bts + +printExtraArg :: ExtraArgument -> String +printExtraArg arg = printExtraArg' arg defaultPrintConfig + +printTail :: Tail -> PrintConfig -> String +printTail (TaApplication tau) config = "(" <> printBinding' tau config <> ")" +printTail (TaDispatch attr) (_, encoding, _) = "." <> printAttribute' attr encoding + +printMetaValue :: MetaValue -> PrintConfig -> String +printMetaValue (MvAttribute attr) (_, encoding, _) = printAttribute' attr encoding +printMetaValue (MvExpression expr _) config = printExpression' expr config +printMetaValue (MvBytes bts) _ = printBytes bts +printMetaValue (MvBindings bds) config = printExpression' (ExFormation bds) config +printMetaValue (MvFunction func) _ = func +printMetaValue (MvTail tails) config = intercalate "," (map (`printTail` config) tails) + +printSubst :: Subst -> PrintConfig -> String +printSubst (Subst mp) config = + " " + <> intercalate + "\n " + (map (\(key, value) -> key <> " >> " <> printMetaValue value config) (Map.toList mp)) + +printSubsts' :: [Subst] -> PrintConfig -> String +printSubsts' substs config = intercalate "\n---\n" (map (`printSubst` config) substs) + +printSubsts :: [Subst] -> String +printSubsts substs = printSubsts' substs defaultPrintConfig diff --git a/src/Render.hs b/src/Render.hs new file mode 100644 --- /dev/null +++ b/src/Render.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module Render where + +import AST +import CST +import Data.List + +class Render a where + render :: a -> String + +instance Render String where + render str = str + +instance Render Integer where + render = show + +instance Render Double where + render = show + +instance Render Char where + render ch = [ch] + +instance Render LSB where + render LSB = "⟦" + render LSB' = "[[" + +instance Render RSB where + render RSB = "⟧" + render RSB' = "]]" + +instance Render COMMA where + render COMMA = "," + render NO_COMMA = "" + +instance Render ARROW where + render ARROW = "↦" + render ARROW' = "->" + +instance Render DASHED_ARROW where + render DASHED_ARROW = "⤍" + +instance Render VOID where + render EMPTY = "∅" + render QUESTION = "?" + +instance Render PHI where + render PHI = "φ" + render AT = "@" + +instance Render RHO where + render RHO = "ρ" + render CARET = "^" + +instance Render DELTA where + render DELTA = "Δ" + +instance Render XI where + render XI = "ξ" + render DOLLAR = "$" + +instance Render LAMBDA where + render LAMBDA = "λ" + +instance Render GLOBAL where + render Φ = "Φ" + render Q = "Q" + +instance Render DEF_PACKAGE where + render Φ̇ = "Φ̇" + render QQ = "QQ" + +instance Render TERMINATION where + render DEAD = "⊥" + render T = "T" + +instance Render SPACE where + render SPACE = " " + +instance Render EOL where + render EOL = "\n" + render NO_EOL = "" + +instance Render BYTES where + render BT_EMPTY = "--" + render (BT_ONE bte) = render bte <> "-" + render (BT_MANY bts) = intercalate "-" bts + +instance Render ALPHA where + render ALPHA = "α" + render ALPHA' = "~" + +instance Render TAB where + render TAB {..} = intercalate "" (replicate (fromIntegral indent) " ") + render TAB' = " " + render NO_TAB = "" + +instance Render PROGRAM where + render PR_SWEET {..} = "{" <> render expr <> "}" + render PR_SALTY {..} = render global <> render SPACE <> render arrow <> render SPACE <> render expr + +instance Render PAIR where + render PA_TAU {..} = render attr <> render SPACE <> render arrow <> render SPACE <> render expr + render PA_LAMBDA {..} = render LAMBDA <> render SPACE <> render DASHED_ARROW <> render SPACE <> render func + render PA_LAMBDA' {..} = "L> " <> func + render PA_VOID {..} = render attr <> render SPACE <> render arrow <> render SPACE <> render void + render PA_DELTA {..} = render DELTA <> render SPACE <> render DASHED_ARROW <> render SPACE <> render bytes + render PA_DELTA' {..} = "D> " <> render bytes + +instance Render BINDINGS where + render BDS_EMPTY {..} = "" + render BDS_PAIR {..} = render COMMA <> render eol <> render tab <> render pair <> render bindings + +instance Render BINDING where + render BI_PAIR {..} = render pair <> render bindings + render BI_EMPTY {..} = "" + +instance Render APP_ARG where + render APP_ARG {..} = render expr <> render args + +instance Render APP_ARGS where + render AAS_EMPTY = "" + render AAS_EXPR {..} = render COMMA <> render eol <> render tab <> render expr <> render args + +-- @todo #163:30min Introduce node for formation with inlined voids. +-- We need to be able to print formation with inlined void attributes: +-- x(a, b) -> [[ y -> 1 ]] => x -> [[ a -> ?, b -> ?, y -> 1 ]] +-- Don't forget to extend toSalty instance so such sugar. +instance Render EXPRESSION where + render EX_GLOBAL {..} = render global + render EX_DEF_PACKAGE {..} = render pckg + render EX_XI {..} = render xi + render EX_ATTR {..} = render attr + render EX_TERMINATION {..} = render termination + render EX_FORMATION {..} = render lsb <> render eol <> render tab <> render binding <> render eol' <> render tab' <> render rsb + render EX_DISPATCH {..} = render expr <> "." <> render attr + render EX_APPLICATION {..} = render expr <> "(" <> render eol <> render tab <> render bindings <> render eol' <> render tab' <> ")" + render EX_APPLICATION' {..} = render expr <> "(" <> render eol <> render tab <> render args <> render eol' <> render tab' <> ")" + render EX_STRING {..} = '"' : render str <> "\"" + render EX_NUMBER {..} = either show show num + +instance Render ATTRIBUTE where + render AT_LABEL {..} = label + render AT_ALPHA {..} = render alpha <> render idx + render AT_RHO {..} = render rho + render AT_PHI {..} = render phi + render AT_LAMBDA {..} = render lambda + render AT_DELTA {..} = render delta diff --git a/src/Replacer.hs b/src/Replacer.hs --- a/src/Replacer.hs +++ b/src/Replacer.hs @@ -18,12 +18,12 @@ ) where -import Ast +import AST import Control.Exception (Exception, throwIO) import Matcher (Tail (TaApplication, TaDispatch)) -import Pretty (prettyExpression, prettyProgram) import Text.Printf (printf) import Data.List (isPrefixOf) +import Printer (printProgram) data ReplaceProgramContext = ReplaceProgramContext { _program :: Program, @@ -51,7 +51,7 @@ show CouldNotReplace {..} = printf "Couldn't replace expression in program, lists of patterns and targets has different lengths\nProgram: %s" - (prettyProgram prog) + (printProgram prog) replaceBindings :: [Binding] -> [Expression] -> [Expression] -> ReplaceExpressionContext -> ReplaceExpressionFunc -> ([Binding], [Expression], [Expression]) replaceBindings bds [] [] _ _ = (bds, [], []) diff --git a/src/Rewriter.hs b/src/Rewriter.hs --- a/src/Rewriter.hs +++ b/src/Rewriter.hs @@ -1,17 +1,19 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module Rewriter (rewrite, rewrite', RewriteContext (..)) where +module Rewriter (rewrite, rewrite', RewriteContext (..), Rewritten (..)) where -import Ast +import AST import Builder import Control.Exception (Exception, throwIO) import Data.Foldable (foldlM) +import Data.Functor ((<&>)) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe, isJust) import qualified Data.Set as Set @@ -21,7 +23,7 @@ import Misc (ensuredFile) import Must (Must (..), exceedsUpperBound, inRange) import Parser (parseProgram, parseProgramThrows) -import Pretty (Encoding (UNICODE), PrintMode (SWEET), prettyAttribute, prettyBytes, prettyExpression, prettyExpression', prettyProgram, prettyProgram', prettySubsts) +import Printer (printProgram) import Replacer (ReplaceProgramContext (ReplaceProgramContext), ReplaceProgramThrowsFunc, replaceProgramFastThrows, replaceProgramThrows) import Rule (RuleContext (RuleContext), matchProgramWithRule) import qualified Rule as R @@ -29,11 +31,20 @@ import Yaml (ExtraArgument (..)) import qualified Yaml as Y +data Rewritten = Rewritten + { program :: Program, + maybeRule :: Maybe Y.Rule + } + +instance Eq Rewritten where + left == right = program left == program right + data RewriteContext = RewriteContext { _program :: Program, _maxDepth :: Integer, _maxCycles :: Integer, _depthSensitive :: Bool, + _sequence :: Bool, _buildTerm :: BuildTermFunc, _must :: Must, _saveStep :: SaveStepFunc @@ -118,56 +129,72 @@ hasMetaBindings = foldl (\acc bd -> acc || isMetaBinding bd) False tryBuildAndReplaceFast ptn res substs ctx = buildAndReplace' ptn res substs replaceProgramThrows ctx -rewrite :: Program -> [Y.Rule] -> Set.Set Program -> Integer -> RewriteContext -> IO (Program, Set.Set Program) -rewrite program [] progs _ _ = pure (program, progs) -rewrite program (rule : rest) progs iteration ctx@RewriteContext {..} = do - (prog, _progs) <- _rewrite program 1 progs - rewrite prog rest _progs iteration ctx +-- The function returns tuple (X, Y) where +-- - X is sequence of programs; for more details about this sequence see description of rewrite' function +-- - Y is Set of unique programs after each rule application. It allows to stop the rewriting if we're getting +-- into loop and get back to program which we've already got before +rewrite :: [Rewritten] -> [Y.Rule] -> Set.Set Program -> Integer -> RewriteContext -> IO ([Rewritten], Set.Set Program) +rewrite rewrittens [] unique _ _ = pure (rewrittens, unique) +rewrite rewrittens (rule : rest) unique iteration ctx@RewriteContext {..} = do + (rewrittens', unique') <- _rewrite rewrittens 1 unique + rewrite rewrittens' rest unique' iteration ctx where - _rewrite :: Program -> Integer -> Set.Set Program -> IO (Program, Set.Set Program) - _rewrite prog count progs' = + _rewrite :: [Rewritten] -> Integer -> Set.Set Program -> IO ([Rewritten], Set.Set Program) + _rewrite _rewrittens _count _unique = let ruleName = fromMaybe "unknown" (Y.name rule) ptn = Y.pattern rule res = Y.result rule - in if count - 1 == _maxDepth + Rewritten {..} = head _rewrittens + in if _count - 1 == _maxDepth then do logDebug (printf "Max amount of rewriting cycles (%d) for rule '%s' has been reached, rewriting is stopped" _maxDepth ruleName) if _depthSensitive then throwIO (StoppedOnLimit "max-depth" _maxDepth) - else pure (prog, progs') + else pure (_rewrittens, _unique) else do - logDebug (printf "Starting rewriting cycle for rule '%s': %d out of %d" ruleName count _maxDepth) - matched <- R.matchProgramWithRule prog rule (RuleContext _program _buildTerm) + logDebug (printf "Starting rewriting cycle for rule '%s': %d out of %d" ruleName _count _maxDepth) + matched <- R.matchProgramWithRule program rule (RuleContext _program _buildTerm) if null matched then do logDebug (printf "Rule '%s' does not match, rewriting is stopped" ruleName) - pure (prog, progs') + pure (_rewrittens, _unique) else do logDebug (printf "Rule '%s' has been matched, applying..." ruleName) - prog' <- tryBuildAndReplaceFast ptn res matched (ReplaceProgramContext prog _maxDepth) - if prog == prog' + prog <- tryBuildAndReplaceFast ptn res matched (ReplaceProgramContext program _maxDepth) + if program == prog then do logDebug (printf "Applied '%s', no changes made" ruleName) - pure (prog, progs') + pure (_rewrittens, _unique) else - if Set.member prog' progs - then throwIO (LoopingRewriting (prettyProgram' prog' SWEET UNICODE) ruleName count) + if Set.member prog _unique + then throwIO (LoopingRewriting (printProgram prog) ruleName _count) else do logDebug ( printf "Applied '%s' (%d nodes -> %d nodes)" ruleName + (countNodes program) (countNodes prog) - (countNodes prog') ) - _saveStep prog' (((iteration - 1) * _maxDepth) + count) - _rewrite prog' (count + 1) (Set.insert prog' progs) + _saveStep prog (((iteration - 1) * _maxDepth) + _count) + _rewrite (rewriteSequence prog) (_count + 1) (Set.insert prog _unique) + where + rewriteSequence :: Program -> [Rewritten] + rewriteSequence _prog + | _sequence = + let Rewritten {..} : rest = _rewrittens + in Rewritten _prog Nothing : Rewritten program (Just rule) : rest + | otherwise = [Rewritten _prog Nothing] -rewrite' :: Program -> [Y.Rule] -> RewriteContext -> IO Program -rewrite' prog rules ctx = _rewrite prog 1 Set.empty +-- The function accepts single program but returns sequence of programs +-- If RewriteContext has _sequence == True - all the intermediate +-- programs after each rule application are included into sequence +-- Otherwise sequence contains only one program +rewrite' :: Program -> [Y.Rule] -> RewriteContext -> IO [Rewritten] +rewrite' prog rules ctx = _rewrite [Rewritten prog Nothing] 1 Set.empty <&> reverse where - _rewrite :: Program -> Integer -> Set.Set Program -> IO Program - _rewrite prog count progs = do + _rewrite :: [Rewritten] -> Integer -> Set.Set Program -> IO [Rewritten] + _rewrite rewrittens count unique = do let cycles = _maxCycles ctx must = _must ctx current = count - 1 @@ -179,14 +206,14 @@ logDebug (printf "Max amount of rewriting cycles for all rules (%d) has been reached, rewriting is stopped" cycles) if _depthSensitive ctx then throwIO (StoppedOnLimit "max-cycles" cycles) - else pure prog + else pure rewrittens else do logDebug (printf "Starting rewriting cycle for all rules: %d out of %d" count cycles) - (rewritten, progs') <- rewrite prog rules progs count ctx - if rewritten == prog + (rewrittens', unique') <- rewrite rewrittens rules unique count ctx + if head rewrittens' == head rewrittens then do logDebug "Rewriting is stopped since it has no effect" if not (inRange must current) then throwIO (MustBeGoing must current) - else pure rewritten - else _rewrite rewritten (count + 1) progs' + else pure rewrittens' + else _rewrite rewrittens' (count + 1) unique' diff --git a/src/Rule.hs b/src/Rule.hs --- a/src/Rule.hs +++ b/src/Rule.hs @@ -6,26 +6,26 @@ module Rule (RuleContext (..), isNF, matchProgramWithRule, meetCondition) where -import Ast +import AST import Builder (buildAttribute, buildBinding, buildBindingThrows, buildExpression, buildExpressionThrows) import Control.Exception (SomeException (SomeException), evaluate) import Control.Exception.Base (try) +import Control.Monad (when) import Data.Aeson (FromJSON) import qualified Data.ByteString.Char8 as B import Data.Foldable (foldlM) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe) +import Deps (BuildTermFunc, Term (..)) import GHC.IO (unsafePerformIO) import Logger (logDebug) import Matcher -import Misc (allPathsIn, btsToUnescapedStr) -import Pretty (prettyAttribute, prettyBytes, prettyExpression, prettyExpression', prettySubsts, prettyBinding) +import Misc (btsToUnescapedStr) +import Printer import Regexp (match) -import Deps (BuildTermFunc, Term (..)) import Text.Printf (printf) import Yaml (normalizationRules) import qualified Yaml as Y -import Control.Monad (when) data RuleContext = RuleContext { _program :: Program, @@ -119,7 +119,7 @@ (Just left_, Just right_) -> pure [subst | left_ == right_] (_, _) -> pure [] where - -- Convert Number to Integer + -- Convert Number to Integer numToInt :: Y.Number -> Subst -> Maybe Integer numToInt (Y.Ordinal (AtMeta meta)) (Subst mp) = case M.lookup meta mp of Just (MvAttribute (AtAlpha idx)) -> Just idx @@ -250,16 +250,16 @@ term <- _buildTerm func args subst' _program meta <- case term of TeExpression expr -> do - logDebug (printf "Function %s() returned expression:\n%s" func (prettyExpression' expr)) + logDebug (printf "Function %s() returned expression:\n%s" func (printExpression expr)) pure (MvExpression expr defaultScope) TeAttribute attr -> do - logDebug (printf "Function %s() returned attribute: %s" func (prettyAttribute attr)) + logDebug (printf "Function %s() returned attribute: %s" func (printAttribute attr)) pure (MvAttribute attr) TeBytes bytes -> do - logDebug (printf "Function %s() returned bytes: %s" func (prettyBytes bytes)) + logDebug (printf "Function %s() returned bytes: %s" func (printBytes bytes)) pure (MvBytes bytes) TeBindings bds -> do - logDebug (printf "Function %s return bindings: %s" func (prettyExpression' (ExFormation bds))) + logDebug (printf "Function %s return bindings: %s" func (printExpression (ExFormation bds))) pure (MvBindings bds) case maybeName of Just name -> pure (combine (substSingle name meta) subst') diff --git a/src/Sugar.hs b/src/Sugar.hs new file mode 100644 --- /dev/null +++ b/src/Sugar.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module Sugar (toSalty, withSugarType, SugarType (..)) where + +import AST +import CST +import Misc + +withSugarType :: (ToSalty a) => SugarType -> a -> a +withSugarType SWEET prog = prog +withSugarType SALTY prog = toSalty prog + +voidRho :: PAIR +voidRho = PA_VOID (AT_RHO RHO) ARROW EMPTY + +bdWithVoidRho :: BINDING -> BINDING +bdWithVoidRho BI_EMPTY {..} = BI_PAIR voidRho (BDS_EMPTY tab) tab +bdWithVoidRho bd@BI_PAIR {pair = PA_VOID {attr = AT_RHO _}} = bd +bdWithVoidRho bd@BI_PAIR {pair = PA_TAU {attr = AT_RHO _}} = bd +bdWithVoidRho BI_PAIR {..} = BI_PAIR pair (bdsWithVoidRho bindings) tab + where + bdsWithVoidRho :: BINDINGS -> BINDINGS + bdsWithVoidRho BDS_EMPTY {..} = BDS_PAIR EOL tab voidRho (BDS_EMPTY tab) + bdsWithVoidRho bds@BDS_PAIR {pair = PA_VOID {attr = AT_RHO _}} = bds + bdsWithVoidRho bds@BDS_PAIR {pair = PA_TAU {attr = AT_RHO _}} = bds + bdsWithVoidRho BDS_PAIR {..} = BDS_PAIR eol tab pair (bdsWithVoidRho bindings) + +data SugarType = SWEET | SALTY + deriving (Eq, Show) + +-- By default CST is generated with all possible syntax sugar +-- The main purpose of this class is to get rid of syntax sugar +-- |----------------------------|-------------------------------------------------------| +-- | sugar | verbose version | +-- |----------------------------|-------------------------------------------------------| +-- | {e} | Q -> e | +-- | QQ | Q.org.eolang | +-- | a1 -> a2 | a1 ↦ $.a2 | +-- | a -> 42 | QQ.number(QQ.bytes([[ D> 40-45-00-00-00-00-00-00 ]])) | +-- | a -> "Hey" | QQ.number(QQ.bytes([[ D> 48-65-79 ]])) | +-- | [[ B ]] | [[ B, ^ -> ? ]], if rho is absent in 'B' | +-- | a1(a2, a3, ...) -> [[ B ]] | a1 -> [[ a2 -> ?, a3 -> ?, ..., B ]] | +-- | e(e0, e1, ...) | e(~0 -> e0, ~1 -> e1, ...) | +-- | e(a1 -> e1, a2 -> e2, ...) | e(a1 -> e1)(a2 -> e2)... | +-- |----------------------------|-------------------------------------------------------| +class ToSalty a where + toSalty :: a -> a + +instance ToSalty PROGRAM where + toSalty PR_SWEET {..} = PR_SALTY Φ ARROW (toSalty expr) + toSalty prog = prog + +instance ToSalty EXPRESSION where + toSalty EX_DEF_PACKAGE {..} = EX_DISPATCH (EX_DISPATCH (EX_GLOBAL Φ) (AT_LABEL "org")) (AT_LABEL "eolang") + toSalty EX_ATTR {..} = EX_DISPATCH (EX_XI XI) attr + toSalty EX_DISPATCH {..} = EX_DISPATCH (toSalty expr) attr + toSalty EX_FORMATION {lsb, binding = bd@BI_EMPTY {..}, rsb} = EX_FORMATION lsb NO_EOL TAB' (toSalty (bdWithVoidRho bd)) NO_EOL TAB' rsb + toSalty EX_FORMATION {..} = EX_FORMATION lsb eol tab (toSalty (bdWithVoidRho binding)) eol' tab' rsb + toSalty EX_APPLICATION {..} = EX_APPLICATION (toSalty expr) eol tab (toSalty bindings) eol' tab' + toSalty EX_APPLICATION' {..} = EX_APPLICATION (toSalty expr) eol tab (toSalty (argToBinding args tab)) eol' tab' + where + argToBinding :: APP_ARG -> TAB -> BINDING + argToBinding APP_ARG {..} = + BI_PAIR + (PA_TAU (AT_ALPHA ALPHA 0) ARROW expr) + (argsToBindings args 1 tab) + argsToBindings :: APP_ARGS -> Integer -> TAB -> BINDINGS + argsToBindings AAS_EMPTY _ tab = BDS_EMPTY tab + argsToBindings AAS_EXPR {..} idx tb = BDS_PAIR eol tb (PA_TAU (AT_ALPHA ALPHA idx) ARROW expr) (argsToBindings args (idx + 1) tb) + toSalty EX_NUMBER {num, tab = tb@TAB {..}} = + let number = ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "number") + bytes = ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "bytes") + number' = toCST number (indent + 1) :: EXPRESSION + bytes' = toCST bytes (indent + 2) :: EXPRESSION + data' = toCST (ExFormation [BiDelta (numToBts (either toDouble id num))]) (indent + 2) :: EXPRESSION + in toSalty + ( EX_APPLICATION' + number' + EOL + (TAB (indent + 1)) + ( APP_ARG + ( EX_APPLICATION' + bytes' + EOL + (TAB (indent + 2)) + (APP_ARG data' AAS_EMPTY) + EOL + (TAB (indent + 1)) + ) + AAS_EMPTY + ) + EOL + tb + ) + toSalty EX_STRING {str, tab = tb@TAB {..}} = + let string = ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "string") + bytes = ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "bytes") + string' = toCST string (indent + 1) :: EXPRESSION + bytes' = toCST bytes (indent + 2) :: EXPRESSION + data' = toCST (ExFormation [BiDelta (strToBts str)]) (indent + 2) :: EXPRESSION + in toSalty + ( EX_APPLICATION' + string' + EOL + (TAB (indent + 1)) + ( APP_ARG + ( EX_APPLICATION' + bytes' + EOL + (TAB (indent + 2)) + (APP_ARG data' AAS_EMPTY) + EOL + (TAB (indent + 1)) + ) + AAS_EMPTY + ) + EOL + tb + ) + toSalty expr = expr + +instance ToSalty BINDING where + toSalty BI_PAIR {..} = BI_PAIR (toSalty pair) (toSalty bindings) tab + toSalty bd = bd + +instance ToSalty BINDINGS where + toSalty BDS_PAIR {..} = BDS_PAIR eol tab (toSalty pair) (toSalty bindings) + toSalty bds = bds + +instance ToSalty PAIR where + toSalty PA_TAU {..} = PA_TAU attr arrow (toSalty expr) + toSalty pair = pair diff --git a/src/XMIR.hs b/src/XMIR.hs --- a/src/XMIR.hs +++ b/src/XMIR.hs @@ -18,7 +18,7 @@ ) where -import Ast +import AST import Control.Exception (Exception (displayException), SomeException, throwIO) import Control.Exception.Base (Exception) import qualified Data.Bifunctor @@ -36,10 +36,9 @@ import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Data.Time.Format (defaultTimeLocale, formatTime) import Data.Version (showVersion) -import Debug.Trace import Misc import Paths_phino (version) -import Pretty (PrintMode (SWEET), prettyAttribute, prettyBinding, prettyBytes, prettyExpression, prettyProgram) +import Printer import Text.Printf (printf) import qualified Text.Read as TR import Text.XML @@ -63,9 +62,9 @@ deriving (Exception) instance Show XMIRException where - show UnsupportedProgram {..} = printf "XMIR does not support such program:\n%s" (prettyProgram prog) - show UnsupportedExpression {..} = printf "XMIR does not support such expression:\n%s" (prettyExpression expr) - show UnsupportedBinding {..} = printf "XMIR does not support such bindings: %s" (prettyBinding binding) + show UnsupportedProgram {..} = printf "XMIR does not support such program:\n%s" (printProgram prog) + show UnsupportedExpression {..} = printf "XMIR does not support such expression:\n%s" (printExpression expr) + show UnsupportedBinding {..} = printf "XMIR does not support such bindings: %s" (printBinding binding) show CouldNotParseXMIR {..} = printf "Couldn't parse given XMIR, cause: %s" message show InvalidXMIRFormat {..} = printf @@ -89,14 +88,14 @@ object attrs children = NodeElement (element "o" attrs children) expression :: Expression -> XmirContext -> IO (String, [Node]) -expression ExThis _ = pure (prettyExpression ExThis, []) -expression ExGlobal _ = pure (prettyExpression ExGlobal, []) +expression ExThis _ = pure (printExpression ExThis, []) +expression ExGlobal _ = pure (printExpression ExGlobal, []) expression (ExFormation bds) ctx = do nested <- nestedBindings bds ctx pure ("", nested) expression (ExDispatch expr attr) ctx = do (base, children) <- expression expr ctx - let attr' = prettyAttribute attr + let attr' = printAttribute attr if null base then pure ('.' : attr', [object [] children]) else @@ -106,8 +105,8 @@ expression (DataNumber bytes) XmirContext {..} = let bts = object - [("as", prettyAttribute (AtAlpha 0)), ("base", "Φ.org.eolang.bytes")] - [object [] [NodeContent (T.pack (prettyBytes bytes))]] + [("as", printAttribute (AtAlpha 0)), ("base", "Φ.org.eolang.bytes")] + [object [] [NodeContent (T.pack (printBytes bytes))]] in pure ( "Φ.org.eolang.number", if omitComments @@ -120,8 +119,8 @@ expression (DataString bytes) XmirContext {..} = let bts = object - [("as", prettyAttribute (AtAlpha 0)), ("base", "Φ.org.eolang.bytes")] - [object [] [NodeContent (T.pack (prettyBytes bytes))]] + [("as", printAttribute (AtAlpha 0)), ("base", "Φ.org.eolang.bytes")] + [object [] [NodeContent (T.pack (printBytes bytes))]] in pure ( "Φ.org.eolang.string", if omitComments @@ -134,7 +133,7 @@ expression (ExApplication expr (BiTau attr texpr)) ctx = do (base, children) <- expression expr ctx (base', children') <- expression texpr ctx - let as = prettyAttribute attr + let as = printAttribute attr attrs = if null base' then [("as", as)] @@ -154,7 +153,7 @@ (base, children) <- expression expr ctx pure (Just (object [("name", show AtPhi), ("base", base)] children)) formationBinding (BiTau AtRho _) _ = pure Nothing -formationBinding (BiDelta bytes) _ = pure (Just (NodeContent (T.pack (prettyBytes bytes)))) +formationBinding (BiDelta bytes) _ = pure (Just (NodeContent (T.pack (printBytes bytes)))) formationBinding (BiLambda func) _ = pure (Just (object [("name", show AtLambda)] [])) formationBinding (BiVoid AtRho) _ = pure Nothing formationBinding (BiVoid AtPhi) _ = pure (Just (object [("name", show AtPhi), ("base", "∅")] [])) @@ -216,7 +215,7 @@ pure (label : pckg, expr') getPackage (ExFormation [BiTau attr expr, BiLambda "Package", BiVoid AtRho]) = pure ([], ExFormation [BiTau attr expr, BiVoid AtRho]) 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))) + getPackage expr = throwIO (userError (printf "Can't extract package from given expression:\n %s" (printExpression expr))) -- Convert root Expression to Node rootExpression :: Expression -> XmirContext -> IO Node rootExpression (ExFormation [bd, BiVoid AtRho]) ctx = do diff --git a/src/Yaml.hs b/src/Yaml.hs --- a/src/Yaml.hs +++ b/src/Yaml.hs @@ -8,7 +8,7 @@ module Yaml where -import Ast +import AST import Control.Applicative (asum) import Data.Aeson import qualified Data.ByteString as BS diff --git a/test/BuilderSpec.hs b/test/BuilderSpec.hs --- a/test/BuilderSpec.hs +++ b/test/BuilderSpec.hs @@ -3,7 +3,7 @@ module BuilderSpec where -import Ast +import AST import Builder import Control.Monad import Data.Map.Strict qualified as Map diff --git a/test/CLISpec.hs b/test/CLISpec.hs --- a/test/CLISpec.hs +++ b/test/CLISpec.hs @@ -238,22 +238,18 @@ withStdin "Q -> [[ x -> QQ.z(y -> 5), q -> T, w -> $, ^ -> Q, @ -> 1, y -> \"H$@^M\"]]" $ testCLISucceeded ["rewrite", "--output=latex", "--sweet"] - [ "\\documentclass{article}", - "\\usepackage{eolang}", - "\\begin{document}", - "\\begin{phiquation}", + [ "\\begin{phiquation}", "{[[", " x -> QQ.z(", " y -> 5", " ),", " q -> T,", - " w -> \\char36{},", - " \\char94{} -> Q,", - " \\char64{} -> 1,", - " y -> \"H\\char36{}\\char64{}\\char94{}M\"", + " w -> $,", + " ^ -> Q,", + " @ -> 1,", + " y -> \"H$@^M\"", "]]}", - "\\end{phiquation}", - "\\end{document}" + "\\end{phiquation}" ] it "rewrites with XMIR as input" $ @@ -281,6 +277,47 @@ ["rewrite", "--rule=test-resources/cli/simple.yaml", "--must=1", "--sweet"] ["x ↦ \"bar\""] + it "prints many programs with --sequence" $ + withStdin "{[[ x -> \"foo\" ]]}" $ + testCLISucceeded + [ "rewrite", + "--rule=test-resources/cli/first.yaml", + "--rule=test-resources/cli/second.yaml", + "--max-depth=1", + "--max-cycles=2", + "--sequence", + "--sweet", + "--flat" + ] + [ unlines + [ "{⟦ x ↦ \"foo\" ⟧}", + "{Φ.x( y ↦ \"foo\" )}", + "{⟦ x ↦ \"foo\" ⟧}" + ] + ] + + it "prints only one latex preamble with --sequence" $ + withStdin "{[[ x -> \"foo\" ]]}" $ + testCLISucceeded + [ "rewrite", + "--rule=test-resources/cli/first.yaml", + "--rule=test-resources/cli/second.yaml", + "--max-depth=1", + "--max-cycles=2", + "--sequence", + "--sweet", + "--flat", + "--output=latex" + ] + [ unlines + [ "\\begin{phiquation}", + "{[[ x -> \"foo\" ]]} \\leadsto_{\\nameref{r:first}}", + "\\leadsto {Q.x( y -> \"foo\" )} \\leadsto_{\\nameref{r:second}}", + "\\leadsto {[[ x -> \"foo\" ]]}", + "\\end{phiquation}" + ] + ] + describe "must range tests" $ do describe "fails" $ do it "when cycles exceed range ..1" $ @@ -367,6 +404,12 @@ "⟧}" ] ] + + it "prints in line with --flat" $ + withStdin "Q -> [[ x -> 5, y -> \"hey\", z -> [[ w -> [[ ]] ]] ]]" $ + testCLISucceeded + ["rewrite", "--sweet", "--flat"] + ["{⟦ x ↦ 5, y ↦ \"hey\", z ↦ ⟦ w ↦ ⟦⟧ ⟧ ⟧}"] describe "dataize" $ do it "dataizes simple program" $ diff --git a/test/CSTSpec.hs b/test/CSTSpec.hs new file mode 100644 --- /dev/null +++ b/test/CSTSpec.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module CSTSpec (spec) where + +import CST +import Control.Monad (forM_) +import Data.Aeson +import Data.Yaml qualified as Yaml +import Encoding (Encoding (ASCII), withEncoding) +import GHC.Generics (Generic) +import Lining (LineFormat (SINGLELINE), withLineFormat) +import Misc +import Parser (parseProgramThrows) +import Render (Render (render)) +import Sugar +import System.FilePath +import Test.Hspec + +data CSTPack = CSTPack + { program :: String, + result :: String + } + deriving (Generic, Show, FromJSON) + +cstPack :: FilePath -> IO CSTPack +cstPack = Yaml.decodeFileThrow + +spec :: Spec +spec = do + describe "builds valid CST" $ + forM_ + [ ("Q -> Q", PR_SWEET (EX_GLOBAL Φ)), + ( "{[[ x -> Q.y ]]}", + PR_SWEET + ( EX_FORMATION + LSB + EOL + (TAB 1) + (BI_PAIR (PA_TAU (AT_LABEL "x") ARROW (EX_DISPATCH (EX_GLOBAL Φ) (AT_LABEL "y"))) (BDS_EMPTY (TAB 1)) (TAB 1)) + EOL + (TAB 0) + RSB + ) + ) + ] + ( \(prog, cst) -> it prog $ do + ast <- parseProgramThrows prog + programToCST ast `shouldBe` cst + ) + + describe "CST printing packs" $ do + let resources = "test-resources/cst/printing-packs" + packs <- runIO (allPathsIn resources) + forM_ + packs + ( \pth -> it (makeRelative resources pth) $ do + pack <- cstPack pth + prog <- parseProgramThrows (program pack) + render (programToCST prog) `shouldBe` result pack + ) + + describe "converts to salty CST" $ do + let resources = "test-resources/cst/to-salty-packs" + packs <- runIO (allPathsIn resources) + forM_ + packs + ( \pth -> it (makeRelative resources pth) $ do + pack <- cstPack pth + prog <- parseProgramThrows (program pack) + let cst = programToCST prog + salty = toSalty cst + render salty `shouldBe` result pack + ) + + describe "converts to ascii CST" $ do + let resources = "test-resources/cst/to-ascii-packs" + packs <- runIO (allPathsIn resources) + forM_ + packs + ( \pth -> it (makeRelative resources pth) $ do + pack <- cstPack pth + prog <- parseProgramThrows (program pack) + let cst = programToCST prog + ascii = withEncoding ASCII cst + render ascii `shouldBe` result pack + ) + + describe "converts to singleline CST" $ do + let resources = "test-resources/cst/to-singleline-packs" + packs <- runIO (allPathsIn resources) + forM_ + packs + ( \pth -> it (makeRelative resources pth) $ do + pack <- cstPack pth + prog <- parseProgramThrows (program pack) + let cst = programToCST prog + ascii = withLineFormat SINGLELINE cst + render ascii `shouldBe` result pack + ) diff --git a/test/DataizeSpec.hs b/test/DataizeSpec.hs --- a/test/DataizeSpec.hs +++ b/test/DataizeSpec.hs @@ -3,7 +3,7 @@ module DataizeSpec (spec) where -import Ast +import AST import Control.Monad import Dataize (DataizeContext (DataizeContext), dataize, dataize', morph) import Deps (dontSaveStep) diff --git a/test/FunctionsSpec.hs b/test/FunctionsSpec.hs --- a/test/FunctionsSpec.hs +++ b/test/FunctionsSpec.hs @@ -3,14 +3,14 @@ module FunctionsSpec where -import Ast +import AST import Data.Map.Strict qualified as Map +import Deps (Term (TeBindings)) import Functions (buildTerm) import Logger (logDebug) import Matcher (MetaValue (MvBindings), Subst (Subst)) import Misc (uniqueBindings') -import Pretty (prettyExpression') -import Deps (Term (TeBindings)) +import Printer (printExpression) import Test.Hspec (Spec, describe, it, shouldBe) import Text.Printf (printf) import Yaml (ExtraArgument (ArgBinding)) @@ -24,5 +24,5 @@ subst = Subst (Map.fromList [first, second, third]) TeBindings bds <- buildTerm "join" [ArgBinding (BiMeta "B1"), ArgBinding (BiMeta "B2"), ArgBinding (BiMeta "B3")] subst (Program ExGlobal) bds' <- uniqueBindings' bds - logDebug (printf "Joined bindings:\n%s" (prettyExpression' (ExFormation bds'))) + logDebug (printf "Joined bindings:\n%s" (printExpression (ExFormation bds'))) length bds' `shouldBe` 9 diff --git a/test/MatcherSpec.hs b/test/MatcherSpec.hs --- a/test/MatcherSpec.hs +++ b/test/MatcherSpec.hs @@ -7,7 +7,7 @@ module MatcherSpec where -import Ast +import AST import Control.Monad (forM_) import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) diff --git a/test/MiscSpec.hs b/test/MiscSpec.hs --- a/test/MiscSpec.hs +++ b/test/MiscSpec.hs @@ -6,7 +6,7 @@ import Control.Monad (forM_) import Misc (withVoidRho, uniqueBindings) import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, describe, it, shouldBe, shouldSatisfy) -import Ast +import AST import Data.Either (isLeft, isRight) testWithVoidRho :: [(String, [Binding], [Binding])] -> SpecWith (Arg Expectation) diff --git a/test/ParserSpec.hs b/test/ParserSpec.hs --- a/test/ParserSpec.hs +++ b/test/ParserSpec.hs @@ -6,7 +6,7 @@ module ParserSpec where -import Ast +import AST import Control.Monad (forM_) import Data.Either (isLeft, isRight) import Misc (allPathsIn) diff --git a/test/PrettySpec.hs b/test/PrettySpec.hs deleted file mode 100644 --- a/test/PrettySpec.hs +++ /dev/null @@ -1,70 +0,0 @@ --- 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, defaultScope) -import Parser (parseProgramThrows) -import Pretty -import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, describe, it, runIO, shouldBe) - -test :: (a -> PrintMode -> Encoding -> String) -> [(String, String, a, PrintMode)] -> SpecWith (Arg Expectation) -test function useCases = - forM_ useCases $ \(input, output, arg, mode) -> - it input $ function arg mode UNICODE `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⟧}"), - ("Q -> 5", "{5}"), - ("Q -> [[ x -> \"hello\"]]", "{⟦\n x ↦ \"hello\"\n⟧}"), - ("Q -> [[ x -> \"hello\", y -> 5]]", "{⟦\n x ↦ \"hello\",\n y ↦ 5\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)}"), - ("Q -> Φ.jeo.opcode.ldc(18, \"Reading \\\"\")", "{Φ.jeo.opcode.ldc(\n 18,\n \"Reading \\\"\"\n)}"), - ("Q -> [[ k -> [[]] ]]", "{⟦\n k ↦ ⟦⟧\n⟧}"), - ("Q -> [[ ]]", "{⟦⟧}") - ] - 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")) defaultScope)]), - ("[(!a >> x)]", "[\n (\n !a >> x\n )\n]", [substSingle "a" (MvAttribute (AtLabel "x"))]) - ] - test prettySubsts' useCases diff --git a/test/ReplacerSpec.hs b/test/ReplacerSpec.hs --- a/test/ReplacerSpec.hs +++ b/test/ReplacerSpec.hs @@ -3,7 +3,7 @@ module ReplacerSpec where -import Ast +import AST import Control.Monad (forM_) import Replacer import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, describe, it, shouldBe) diff --git a/test/RewriterSpec.hs b/test/RewriterSpec.hs --- a/test/RewriterSpec.hs +++ b/test/RewriterSpec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-orphans #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com @@ -18,8 +19,8 @@ import Misc (allPathsIn, ensuredFile) import Must (Must (..)) import Parser (parseProgramThrows) -import Pretty (Encoding (UNICODE), PrintMode (SWEET), prettyProgram') -import Rewriter (RewriteContext (RewriteContext), rewrite') +import Printer (printProgram) +import Rewriter (RewriteContext (RewriteContext), Rewritten (..), rewrite') import System.FilePath (makeRelative, replaceExtension, ()) import Test.Hspec (Spec, describe, expectationFailure, it, pending, runIO) import Yaml (normalizationRules) @@ -81,7 +82,7 @@ case skip pack of Just True -> pending _ -> do - program <- parseProgramThrows (input pack) + prog <- parseProgramThrows (input pack) rules' <- case rules pack of Just _rules -> case custom _rules of Just custom' -> pure custom' @@ -98,25 +99,26 @@ if normalize' then pure normalizationRules else pure [] - rewritten <- + [Rewritten {..}] <- rewrite' - program + prog rules' ( RewriteContext - program + prog repeat' repeat' False + False buildTerm must' dontSaveStep ) result' <- parseProgramThrows (output pack) - unless (rewritten == result') $ + unless (program == result') $ expectationFailure ( "Wrong rewritten program. Expected:\n" - ++ prettyProgram' result' SWEET UNICODE + ++ printProgram result' ++ "\nGot:\n" - ++ prettyProgram' rewritten SWEET UNICODE + ++ printProgram program ) ) diff --git a/test/RuleSpec.hs b/test/RuleSpec.hs --- a/test/RuleSpec.hs +++ b/test/RuleSpec.hs @@ -6,7 +6,7 @@ module RuleSpec where -import Ast (Expression, Program (Program)) +import AST (Expression, Program (Program)) import Control.Monad import Data.Aeson import Data.Yaml qualified as Y @@ -14,11 +14,11 @@ import GHC.Generics import Matcher import Misc -import Pretty import Rule (RuleContext (RuleContext), meetCondition) import System.FilePath import Test.Hspec (Spec, describe, expectationFailure, it, runIO) import Yaml qualified +import Printer (printSubsts) data ConditionPack = ConditionPack { failure :: Maybe Bool, @@ -46,13 +46,13 @@ (null met) ( expectationFailure $ "List of substitutions after condition check must be empty, but got:\n" - ++ prettySubsts matched + ++ printSubsts matched ) _ -> when (null met) ( expectationFailure $ "List of substitution after condition check must be not empty\nOriginal substitutions:\n" - ++ prettySubsts matched + ++ printSubsts matched ) ) diff --git a/test/XMIRSpec.hs b/test/XMIRSpec.hs --- a/test/XMIRSpec.hs +++ b/test/XMIRSpec.hs @@ -7,7 +7,7 @@ module XMIRSpec where -import Ast +import AST import Control.Exception (bracket) import Control.Monad (filterM, forM_, unless) import Data.Aeson