diff --git a/LICENSES/MIT.txt b/LICENSES/MIT.txt new file mode 100644 --- /dev/null +++ b/LICENSES/MIT.txt @@ -0,0 +1,19 @@ +Copyright (c) 2025 Objectionary.com + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NON-INFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,10 @@ +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module Main where + +import CLI (runCLI) +import System.Environment (getArgs) + +main :: IO () +main = getArgs >>= runCLI diff --git a/phino.cabal b/phino.cabal new file mode 100644 --- /dev/null +++ b/phino.cabal @@ -0,0 +1,94 @@ +cabal-version: 3.0 + +name: phino +version: 0.0.0.1 +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 + +source-repository head + type: git + location: https://github.com/objectionary/phino + +common warnings + ghc-options: -Wall + +library + exposed-modules: + CLI, Ast, Parser, Matcher, Builder, Replacer, Printer, Rewriter, Yaml, Misc + hs-source-dirs: src + other-modules: + Paths_phino + autogen-modules: + Paths_phino + build-depends: + base ^>=4.18.3.0, + containers, + megaparsec >= 9.0, + text, + aeson, + yaml, + directory, + filepath, + scientific, + binary-ieee754, + bytestring, + utf8-string, + prettyprinter, + optparse-applicative + default-language: Haskell2010 + +-- Executable using the library +executable phino + import: warnings + main-is: Main.hs + hs-source-dirs: app + build-depends: + 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 + other-modules: + Spec, + CLISpec, + ParserSpec, + MatcherSpec, + BuilderSpec, + ReplacerSpec, + PrinterSpec, + RewriterSpec + default-extensions: + ImportQualifiedPost + ghc-options: -Wall + build-depends: + optparse-applicative, + base, + megaparsec, + phino, + containers, + hspec, + hspec-core, + filepath, + prettyprinter, + aeson, + yaml, + text, + silently, + directory + build-tool-depends: + hspec-discover:hspec-discover + default-language: Haskell2010 diff --git a/src/Ast.hs b/src/Ast.hs new file mode 100644 --- /dev/null +++ b/src/Ast.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DeriveGeneric #-} + +-- 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, 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, Show, Generic) + +data Binding + = BiTau Attribute Expression -- attr -> expr + | BiMeta String -- !B + | BiDelta String -- D> 1F-2A + | BiMetaDelta String -- D> !b + | BiVoid Attribute -- attr -> ? + | BiLambda String -- L> Function + | BiMetaLambda String -- L> !F + deriving (Eq, Show, Generic) + +data Attribute + = AtLabel String -- attr + | AtAlpha Integer -- ~1 + | AtPhi -- @ + | AtRho -- ^ + | AtMeta String -- !a + deriving (Eq, Show, Generic) diff --git a/src/Builder.hs b/src/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Builder.hs @@ -0,0 +1,93 @@ +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +-- The goal of the module is to build phi expression based on +-- pattern expression and set of substitutions by replacing +-- meta variables with appropriate meta values +module Builder where + +import Ast +import Misc +import Matcher +import qualified Data.Map.Strict as Map +import Data.List (findIndex) + +buildAttribute :: Attribute -> Subst -> Maybe Attribute +buildAttribute (AtMeta meta) (Subst mp) = case Map.lookup meta mp of + Just (MvAttribute attr) -> Just attr + _ -> Nothing +buildAttribute attr _ = Just attr + +-- Build binding +-- The function returns [Binding] because the BiMeta is always attached +-- to the list of bindings +buildBinding :: Binding -> Subst -> Maybe [Binding] +buildBinding (BiTau attr expr) subst = do + attribute <- buildAttribute attr subst + expression <- buildExpression expr subst + Just [BiTau attribute expression] +buildBinding (BiVoid attr) subst = do + attribute <- buildAttribute attr subst + Just [BiVoid attribute] +buildBinding (BiMeta meta) (Subst mp) = case Map.lookup meta mp of + Just (MvBindings bds) -> Just bds + _ -> Nothing +buildBinding (BiMetaDelta meta) (Subst mp) = case Map.lookup meta mp of + Just (MvBytes bytes) -> Just [BiDelta bytes] + _ -> Nothing +buildBinding (BiMetaLambda meta) (Subst mp) = case Map.lookup meta mp of + Just (MvFunction func) -> Just [BiLambda func] + _ -> Nothing +buildBinding binding _ = Just [binding] + +-- Build bindings which don't contain meta binding (BiMeta) +buildExactBindings :: [Binding] -> Subst -> Maybe [Binding] +buildExactBindings [] _ = Just [] +buildExactBindings (bd:rest) subst = do + first <- buildBinding bd subst + bds <- buildExactBindings rest subst + Just (head first : bds) + +-- Build bindings that may contain meta binding (BiMeta) +buildBindings :: [Binding] -> Subst -> Maybe [Binding] +buildBindings [] _ = Just [] +buildBindings bindings subst = case findIndex isMetaBinding bindings of + Just idx -> do + exact <- buildExactBindings (withoutAt idx bindings) subst + meta <- buildBinding (bindings !! idx) subst + Just (exact ++ meta) + _ -> buildExactBindings bindings subst + +buildExpressionWithTails :: Expression -> [Tail] -> Subst -> Expression +buildExpressionWithTails expr [] _ = expr +buildExpressionWithTails expr (tail:rest) subst = case tail of + TaApplication taus -> buildExpressionWithTails (ExApplication expr taus) rest subst + TaDispatch attr -> buildExpressionWithTails (ExDispatch expr attr) rest subst + +buildExpression :: Expression -> Subst -> Maybe Expression +buildExpression (ExDispatch expr attr) subst = do + dispatched <- buildExpression expr subst + attr <- buildAttribute attr subst + return (ExDispatch dispatched attr) +buildExpression (ExApplication expr taus) subst = do + applied <- buildExpression expr subst + bindings <- buildBindings taus subst + Just (ExApplication applied bindings) +buildExpression (ExFormation bds) subst = buildBindings bds subst >>= (Just . ExFormation) +-- buildExpression (ExFormation bds) subst = do +-- bindings <- buildBindings bds subst +-- Just (ExFormation bindings) +buildExpression (ExMeta meta) (Subst mp) = case Map.lookup meta mp of + Just (MvExpression expr) -> Just expr + _ -> Nothing +buildExpression (ExMetaTail expr meta) subst = do + let (Subst mp) = subst + expression <- buildExpression expr subst + case Map.lookup meta mp of + Just (MvTail tails) -> Just (buildExpressionWithTails expression tails subst) + _ -> Nothing +buildExpression expr _ = Just expr + +-- Build a several expression from one expression and several substitutions +buildExpressions :: Expression -> [Subst] -> Maybe [Expression] +buildExpressions expr = traverse (buildExpression expr) diff --git a/src/CLI.hs b/src/CLI.hs new file mode 100644 --- /dev/null +++ b/src/CLI.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module CLI (runCLI) where + +import Data.Version (showVersion) +import Options.Applicative +import Paths_phino (version) +import Rewriter (rewrite) +import Misc (ensuredFile) +import qualified Yaml as Y +import System.IO (hPutStrLn, stderr, getContents') +import System.Exit (exitFailure) +import Control.Exception (handle, SomeException, Exception (displayException), throwIO) +import Control.Exception.Base +import Text.Printf (printf) + +data CmdException + = InvalidRewriteArguments + | NormalizationIsNotSupported + | CouldNotReadFromStdin { message :: String } + deriving (Exception) + +instance Show CmdException where + show InvalidRewriteArguments = "Invalid set of arguments for 'rewrite' command: no --rules, no --normalize, no --nothing are provided" + show NormalizationIsNotSupported = "Normalization is not supported yet..." + show CouldNotReadFromStdin{..} = printf "Could not read 𝜑-expression from stdin\nReason: %s" message + +newtype Command = CmdRewrite OptsRewrite + +data OptsRewrite = OptsRewrite + { rules :: Maybe FilePath, + phiInput :: Maybe FilePath, + normalize :: Bool, + nothing :: Bool + } + +rewriteParser :: Parser Command +rewriteParser = + CmdRewrite + <$> ( OptsRewrite + <$> optional (strOption (long "rules" <> metavar "FILENAME" <> help "Path to custom rules")) + <*> optional (strOption (long "phi-input" <> metavar "FILENAME" <> help "Path .phi file with 𝜑-expression")) + <*> switch (long "normalize" <> help "Use built-in normalization rules") + <*> switch (long "nothing" <> help "Desugar provided 𝜑-expression") + ) + +commandParser :: Parser Command +commandParser = hsubparser (command "rewrite" (info rewriteParser (progDesc "Rewrite the expression"))) + +parserInfo :: ParserInfo Command +parserInfo = + info + (commandParser <**> helper <**> simpleVersioner (showVersion version)) + (fullDesc <> header "Phino - CLI Manipulator of 𝜑-Calculus Expressions") + +handler :: SomeException -> IO () +handler e = do + hPutStrLn stderr ("[error] " ++ displayException e) + exitFailure + +runCLI :: [String] -> IO () +runCLI args = handle handler $ do + cmd <- handleParseResult (execParserPure defaultPrefs parserInfo args) + case cmd of + CmdRewrite OptsRewrite{..} -> do + prog <- case phiInput of + Just pth -> readFile =<< ensuredFile pth + Nothing -> getContents' `catch` (\(e :: SomeException) -> throwIO (CouldNotReadFromStdin (show e))) + rules' <- if nothing + then pure Nothing + else do + path <- case rules of + Nothing -> + if normalize + then throwIO NormalizationIsNotSupported + else throwIO InvalidRewriteArguments + Just pth -> ensuredFile pth + ruleSet <- Y.yamlRuleSet path + pure (Just ruleSet) + rewritten <- rewrite prog rules' + putStrLn rewritten diff --git a/src/Matcher.hs b/src/Matcher.hs new file mode 100644 --- /dev/null +++ b/src/Matcher.hs @@ -0,0 +1,240 @@ +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +-- 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 Misc +import Data.List (findIndex, partition) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, isJust, maybeToList) +import Data.Sequence (foldlWithIndex) + +-- Meta value +-- The right part of substitution +data MetaValue + = MvAttribute Attribute -- !a + | MvBytes String -- !b + | MvBindings [Binding] -- !B + | MvFunction String -- !F + | MvExpression Expression -- !e + | MvTail [Tail] -- !t + deriving (Eq, Show) + +-- Tail operation after expression +-- Dispatch or application +data Tail + = TaApplication [Binding] -- BiTau only + | TaDispatch Attribute + deriving (Eq, Show) + +-- Substitution +-- Shows the match of meta name to meta value +newtype Subst = Subst (Map String MetaValue) + deriving (Eq, Show) + +-- Empty substitution +substEmpty :: Subst +substEmpty = Subst Map.empty + +-- Singleton substitution with one (key -> value) pair +substSingle :: String -> MetaValue -> Subst +substSingle key value = Subst (Map.singleton key value) + +-- Returns True if given binding contains meta attribute on the left: +-- !a -> ... +-- !a -> ? +isBindingWithMetaAttr :: Binding -> Bool +isBindingWithMetaAttr (BiTau (AtMeta _) _) = True +isBindingWithMetaAttr (BiVoid (AtMeta _)) = True +isBindingWithMetaAttr _ = False + +-- Combine two substitutions into a single one +-- Fails if values by the same keys are not equal +combine :: Subst -> Subst -> Maybe Subst +combine (Subst a) (Subst b) = combine' (Map.toList b) a + where + combine' :: [(String, MetaValue)] -> Map String MetaValue -> Maybe Subst + combine' [] acc = Just (Subst acc) + combine' ((key, value) : rest) acc = case Map.lookup key acc of + Just found + | found == value -> combine' rest acc + | otherwise -> Nothing + Nothing -> combine' rest (Map.insert key value acc) + +matchAttribute :: Attribute -> Attribute -> Maybe Subst +matchAttribute (AtMeta meta) tgt = Just (substSingle meta (MvAttribute tgt)) +matchAttribute ptn tgt + | ptn == tgt = Just substEmpty + | otherwise = Nothing + +matchBinding :: Binding -> Binding -> Maybe Subst +matchBinding (BiVoid pattr) (BiVoid tattr) = matchAttribute pattr tattr +matchBinding (BiDelta pbts) (BiDelta tbts) + | pbts == tbts = Just substEmpty + | otherwise = Nothing +matchBinding (BiMetaDelta meta) (BiDelta tBts) = Just (substSingle meta (MvBytes tBts)) +matchBinding (BiLambda pFunc) (BiLambda tFunc) + | pFunc == tFunc = Just substEmpty + | otherwise = Nothing +matchBinding (BiMetaLambda meta) (BiLambda tFunc) = Just (substSingle meta (MvFunction tFunc)) +matchBinding (BiTau pattr pexp) (BiTau tattr texp) = do + mattr <- matchAttribute pattr tattr + mexp <- matchExpression pexp texp + combine mattr mexp +matchBinding _ _ = Nothing + +-- Returns a tuple (X, Y) if given binding B is matched to any of bindings L +-- X is an index of matched B in L +-- Y is substiturion for matched B +-- (-1, Nothing) is returned in case of no binding is matched in L +matchAnyBinding :: Binding -> [Binding] -> (Int, Maybe Subst) +matchAnyBinding pb [] = (-1, Nothing) +matchAnyBinding pb tbs = matchAnyBindingWithIndex 0 tbs + where + matchAnyBindingWithIndex :: Integer -> [Binding] -> (Int, Maybe Subst) + matchAnyBindingWithIndex idx [] = (-1, Nothing) + matchAnyBindingWithIndex idx (tb : rest) = case matchBinding pb tb of + Nothing -> matchAnyBindingWithIndex (idx + 1) rest + subst -> (fromInteger idx, subst) + +-- Match bindings with filtering target bindings +-- !! Bindings may be placed in random order +-- +-- Returns a tuple (B, S) where: +-- B is a list of rest target bindings excluding matched ones +-- S is a substitution for matched bindings +-- In case of not matching - S as Nothing is returned +matchBindingsWithFiltering :: [Binding] -> [Binding] -> ([Binding], Maybe Subst) +matchBindingsWithFiltering [] [] = ([], Just substEmpty) +matchBindingsWithFiltering [] tbs = (tbs, Just substEmpty) +matchBindingsWithFiltering (pb : rest) tbs = case matchAnyBinding pb tbs of + (-1, Nothing) -> (tbs, Nothing) + (idx, Just subst) -> case matchBindingsWithFiltering rest (withoutAt idx tbs) of + (bs, Just next) -> (bs, combine subst next) + _ -> (tbs, Nothing) + +-- Match non meta bindings +-- !! Pattern bindings don't contain BiMeta +-- !! Target and pattern bindings may be placed in random order +-- !! Lengths of pattern and target bindings must be the same +-- +-- First it filters pattern bindings, only bindings without meta attributes are left (B) +-- If B are not empty, it means we have bindings B with exact attributes, like "attr", "foo", etc. +-- Since all the attributes in phi calculus are unique in the scope of formation or application +-- we try to match these exact bindings first. While matching them we drop target bindings which +-- we found a match for. When we're done with exact bindings, we have a list of target +-- unmatched bindings (L). Now we're entering a new circle and trying to match rest "not exact" +-- pattern bindings with left unmatched bindings L. If matching is succeeded - we just merge +-- result substitutions. +matchNonMetaExactBindings :: [Binding] -> [Binding] -> Maybe Subst +matchNonMetaExactBindings [] [] = Just substEmpty +matchNonMetaExactBindings pbs tbs + | length tbs /= length pbs = Nothing + | otherwise = case partition isBindingWithMetaAttr pbs of + (with, []) -> case matchBindingsWithFiltering with tbs of + ([], Just subst) -> Just subst + (_, _) -> Nothing + (with, without) -> case matchBindingsWithFiltering without tbs of + (rest, Just subst) -> case matchNonMetaExactBindings with rest of + Just next -> combine subst next + Nothing -> Nothing + (_, Nothing) -> Nothing + +-- The same as `matchNonMetaExactBindings` but without the "same length" requirement +matchNonMetaBindingsWithFiltering :: [Binding] -> [Binding] -> ([Binding], Maybe Subst) +matchNonMetaBindingsWithFiltering [] [] = ([], Just substEmpty) +matchNonMetaBindingsWithFiltering [] tbs = (tbs, Just substEmpty) +matchNonMetaBindingsWithFiltering pbs [] = ([], Nothing) +matchNonMetaBindingsWithFiltering pbs tbs + | length pbs > length tbs = ([], Nothing) + | otherwise = case partition isBindingWithMetaAttr pbs of + (with, []) -> case matchBindingsWithFiltering with tbs of + (rest, Just subst) -> (rest, Just subst) + (_, Nothing) -> ([], Nothing) + (with, without) -> case matchBindingsWithFiltering without tbs of + (rest, Just subst) -> case matchNonMetaBindingsWithFiltering with rest of + (rest', Just next) -> (rest', combine subst next) + (_, Nothing) -> ([], Nothing) + (_, Nothing) -> ([], Nothing) + +-- Match pattern bindings to target bindings +-- !! Pattern bindings list may contain only one BiMeta binding +-- !! Pattern and target bindings may be placed in random order +-- +-- If pattern bindings contains only BiMeta binding - all the target bindings are matched +matchBindings :: [Binding] -> [Binding] -> Maybe Subst +matchBindings [] [] = Just substEmpty +matchBindings pbs tbs = case findIndex isMetaBinding pbs of + Just idx -> do + let (BiMeta name) = pbs !! idx + if length pbs == 1 + then Just (substSingle name (MvBindings tbs)) + else case matchNonMetaBindingsWithFiltering (withoutAt idx pbs) tbs of + (rest, Just subst) -> combine subst (substSingle name (MvBindings rest)) + (_, Nothing) -> Nothing + _ -> matchNonMetaExactBindings pbs tbs + +-- Recursively go through given target expression and try to find +-- the head expression which matches to given pattern. +-- If there's one - build the list of all the tail operations after head expression. +-- The tail operations may be only dispatches or applications +tailExpressions :: Expression -> Expression -> Maybe (Subst, [Tail]) +tailExpressions ptn tgt = do + (subst, tails) <- tailExpressionsReversed ptn tgt + return (subst, reverse tails) + where + tailExpressionsReversed :: Expression -> Expression -> Maybe (Subst, [Tail]) + tailExpressionsReversed ptn' tgt' = case matchExpression ptn' tgt' of + Just subst -> Just (subst, []) + Nothing -> case tgt' of + ExDispatch expr attr -> do + (subst, tails) <- tailExpressionsReversed ptn' expr + return (subst, TaDispatch attr : tails) + ExApplication expr bds -> do + (subst, tails) <- tailExpressionsReversed ptn' expr + return (subst, TaApplication bds : tails) + _ -> Nothing + +matchExpression :: Expression -> Expression -> Maybe Subst +matchExpression (ExMeta meta) tgt = Just (substSingle meta (MvExpression tgt)) +matchExpression ExThis ExThis = Just substEmpty +matchExpression ExGlobal ExGlobal = Just substEmpty +matchExpression ExTermination ExTermination = Just substEmpty +matchExpression (ExFormation pbs) (ExFormation tbs) = matchBindings pbs tbs +matchExpression (ExDispatch pexp pattr) (ExDispatch texp tattr) = do + mexp <- matchExpression pexp texp + mattr <- matchAttribute pattr tattr + combine mexp mattr +matchExpression (ExApplication pexp pbs) (ExApplication texp tbs) = do + mexp <- matchExpression pexp texp + mbs <- matchBindings pbs tbs + combine mexp mbs +matchExpression (ExMetaTail exp meta) tgt = do + (subst, tails) <- tailExpressions exp tgt + combine subst (substSingle meta (MvTail tails)) +matchExpression _ _ = Nothing + +-- Match expression with deep nested expression(s) matching +matchExpressionDeep :: Expression -> Expression -> [Subst] +matchExpressionDeep ptn tgt = do + let here = maybeToList (matchExpression ptn tgt) + deep = case tgt of + ExFormation bds -> concatMap matchBindingExpression bds + ExDispatch dexp _ -> matchExpressionDeep ptn dexp + ExApplication aexp taus -> matchExpressionDeep ptn aexp ++ concatMap matchBindingExpression taus + _ -> [] + where + -- Deep match pattern to expression inside binding + matchBindingExpression :: Binding -> [Subst] + matchBindingExpression (BiTau _ texp) = matchExpressionDeep ptn texp + matchBindingExpression _ = [] + case here of + [] -> deep + found : _ -> found : deep + +matchProgram :: Expression -> Program -> [Subst] +matchProgram ptn (Program exp) = matchExpressionDeep ptn exp diff --git a/src/Misc.hs b/src/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Misc.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE RecordWildCards #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +-- This module provides commonly used helper functions for other modules +module Misc where + +import Ast +import Control.Exception +import Control.Monad +import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) +import System.FilePath (()) +import Text.Printf (printf) +import Data.Binary.IEEE754 +import Data.ByteString.Builder (word64BE, toLazyByteString) +import Data.List (intercalate) +import Data.ByteString.Lazy (unpack) +import qualified Data.ByteString.Lazy.UTF8 as U +import Data.Word (Word8) + +data FsException + = FileDoesNotExist {file :: FilePath} + | DirectoryDoesNotExist {dir :: FilePath} + deriving (Exception) + +instance Show FsException where + show FileDoesNotExist {..} = printf "File '%s' does not exist" file + show DirectoryDoesNotExist {..} = printf "Directory '%s' does not exist" dir + +-- List without element by given index +withoutAt :: Int -> [a] -> [a] +withoutAt i xs = take i xs ++ drop (i + 1) xs + +-- Returns True if given binding is BiMeta (!B) +isMetaBinding :: Binding -> Bool +isMetaBinding (BiMeta _) = True +isMetaBinding _ = False + +ensuredFile :: FilePath -> IO FilePath +ensuredFile pth = do + exists <- doesFileExist pth + if exists then pure pth else throwIO (FileDoesNotExist pth) + +-- Recursively collect all file paths in provided directory +allPathsIn :: FilePath -> IO [FilePath] +allPathsIn dir = do + exists <- doesDirectoryExist dir + names <- if exists then listDirectory dir else throwIO (DirectoryDoesNotExist dir) + let nested = map (dir ) names + paths <- + forM + nested + ( \path -> do + isDir <- doesDirectoryExist path + if isDir + then allPathsIn path + else return [path] + ) + return (concat paths) + +btsToHex :: [Word8] -> String +btsToHex bts = intercalate "-" (map (printf "%02X") bts) + +-- >>> numToHex 0.0 +-- "00-00-00-00-00-00-00-00" +-- >>> numToHex 42 +-- "40-45-00-00-00-00-00-00" +-- >>> numToHex (-0.25) +-- "BF-D0-00-00-00-00-00-00" +-- >>> numToHex 5 +-- "40-14-00-00-00-00-00-00" +numToHex :: Double -> String +numToHex num = btsToHex (unpack (toLazyByteString (word64BE (doubleToWord num)))) + +-- >>> strToHex "hello" +-- "68-65-6C-6C-6F" +-- >>> strToHex "world" +-- "77-6F-72-6C-64" +strToHex :: String -> String +strToHex str = btsToHex (unpack (U.fromString str)) diff --git a/src/Parser.hs b/src/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Parser.hs @@ -0,0 +1,380 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE RecordWildCards #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +-- The goal of the module is to parse given phi program to Ast +module Parser (parseProgram, parseProgramThrows, parseExpression, parseExpressionThrows) where + +import Ast +import Control.Exception (Exception, throwIO) +import Control.Monad (guard) +import Data.Char (isDigit, isLower) +import Data.Scientific (toRealFloat) +import Data.Sequence (mapWithIndex) +import Data.Text.Internal.Fusion.Size (lowerBound) +import Data.Void +import Misc (numToHex, strToHex) +import Text.Megaparsec +import Text.Megaparsec.Char (alphaNumChar, char, digitChar, hexDigitChar, letterChar, lowerChar, space1, string, upperChar) +import qualified Text.Megaparsec.Char.Lexer as L +import Text.Printf (printf) + +type Parser = Parsec Void String + +data ParserException + = CouldNotParseProgram {message :: String} + | CouldNotParseExpression {message :: String} + deriving (Exception) + +instance Show ParserException where + show CouldNotParseProgram {..} = printf "Couldn't parse given phi program, cause: %s" message + show CouldNotParseExpression {..} = printf "Couldn't parse given phi program, cause: %s" message + +dataExpression :: String -> String -> Expression +dataExpression obj bts = + ExApplication + (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel obj)) + [ BiTau + (AtAlpha 0) + ( ExApplication + (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "bytes")) + [ BiTau + (AtAlpha 0) + (ExFormation [BiDelta bts]) + ] + ) + ] + +-- White space consumer +whiteSpace :: Parser () +whiteSpace = L.space space1 empty empty + +-- Lexeme that ignores white spaces after +lexeme :: Parser a -> Parser a +lexeme = L.lexeme whiteSpace + +-- Strict symbol (or sequence of symbols) with ignored white spaces after +symbol :: String -> Parser String +symbol = L.symbol whiteSpace + +label' :: Parser String +label' = lexeme $ do + first <- lowerChar + rest <- many (satisfy (`notElem` " \r\n\t,.|':;!?][}{)(⟧⟦") "allowed character") + return (first : rest) + +function :: Parser String +function = lexeme $ do + first <- upperChar + rest <- + many + ( satisfy + (\ch -> isDigit ch || isLower ch || ch == '_' || ch == 'φ') + "allowed character in function name" + ) + return (first : rest) + +delta :: Parser String +delta = + choice + [ symbol "D>", + symbol "Δ" >> dashedArrow + ] + +lambda :: Parser String +lambda = + choice + [ symbol "L>", + symbol "λ" >> dashedArrow + ] + +dashedArrow :: Parser String +dashedArrow = symbol "⤍" + +arrow :: Parser String +arrow = choice [symbol "->", symbol "↦"] + +global :: Parser String +global = choice [symbol "Q", symbol "Φ"] + +meta :: Char -> Parser String +meta ch = do + _ <- char '!' + c <- char ch + ds <- lexeme (many digitChar) + return (c : ds) + +byte :: Parser String +byte = do + f <- hexDigitChar >>= upperHex + s <- hexDigitChar >>= upperHex + return [f, s] + where + upperHex ch + | isDigit ch || ('A' <= ch && ch <= 'F') = return ch + | otherwise = fail ("expected 0-9 or A-F, got " ++ show ch) + +-- bytes +-- 1. empty: -- +-- 2. one byte: 01- +-- 3. many bytes: 01-02-...-FF +bytes :: Parser String +bytes = lexeme $ do + choice + [ symbol "--", + try $ do + first <- byte + rest <- some $ do + dash <- char '-' + bte <- byte + return (dash : bte) + return (first ++ concat rest), + do + bte <- byte + dash <- char '-' + return (bte ++ [dash]) + ] + "bytes" + +tauBinding :: Parser Attribute -> Parser Binding +tauBinding attr = do + attr' <- attr + choice + [ try $ do + _ <- arrow + BiTau attr' <$> expression, + do + _ <- symbol "(" + voids <- map BiVoid <$> void' `sepBy` symbol "," + _ <- symbol ")" + _ <- arrow + ExFormation bs <- formation + return (BiTau attr' (ExFormation (voids ++ bs))) + ] + +-- binding +-- 1. tau +-- 2. void +-- 3. delta +-- 4. meta delta +-- 5. meta +-- 6. lambda +-- 7. meta lambda +binding :: Parser Binding +binding = + choice + [ try (tauBinding attribute), + try $ do + attr <- attribute + _ <- arrow + _ <- choice [symbol "?", symbol "∅"] + return (BiVoid attr), + try $ do + _ <- delta + BiDelta <$> bytes, + try $ do + _ <- delta + BiMetaDelta <$> meta 'b', + try (BiMeta <$> meta 'B'), + try $ do + _ <- lambda + BiLambda <$> function, + do + _ <- lambda + BiMetaLambda <$> meta 'F' + ] + "binding" + +-- inlined void attribute +-- 1. label +-- 2. rho +-- 3. phi +void' :: Parser Attribute +void' = + choice + [ AtLabel <$> label', + do + _ <- choice [symbol "^", symbol "ρ"] + return AtRho, + do + _ <- choice [symbol "@", symbol "φ"] + return AtPhi + ] + +-- attribute +-- 1. label +-- 2. meta +-- 3. rho +-- 4. phi +attribute :: Parser Attribute +attribute = + choice + [ void', + AtMeta <$> meta 'a' + ] + "attribute" + +-- full attribute +-- 1. label +-- 2. meta +-- 3. rho +-- 4. phi +-- 5. alpha +fullAttribute :: Parser Attribute +fullAttribute = + choice + [ attribute, + do + _ <- choice [symbol "~", symbol "α"] + AtAlpha <$> lexeme L.decimal + ] + "full attribute" + +-- formation +formation :: Parser Expression +formation = do + _ <- choice [symbol "[[", symbol "⟦"] + bs <- binding `sepBy` symbol "," + _ <- choice [symbol "]]", symbol "⟧"] + return (ExFormation bs) + +-- head part of expression +-- 1. formation +-- 2. this +-- 3. global +-- 4. termination +-- 5. meta expression +-- 6. full attribute -> sugar for $.attr +exHead :: Parser Expression +exHead = + choice + [ formation, + do + _ <- choice [symbol "$", symbol "ξ"] + return ExThis, + try $ do + _ <- choice [symbol "QQ", symbol "Φ̇"] + return (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")), + do + _ <- global + return ExGlobal, + do + _ <- choice [symbol "T", symbol "⊥"] + return ExTermination, + do + sign <- optional (choice [char '-', char '+']) + unsigned <- lexeme L.scientific + let num = + toRealFloat + ( case sign of + Just '-' -> negate unsigned + _ -> unsigned + ) + return (dataExpression "number" (numToHex num)), + lexeme $ do + _ <- char '"' + str <- manyTill L.charLiteral (char '"') + return (dataExpression "string" (strToHex str)), + try (ExMeta <$> meta 'e'), + ExDispatch ExThis <$> fullAttribute + ] + "expression head" + +-- tail optional part of application +-- 1. any head + dispatch +-- 2. any head except $ and Q + application +-- 3. any head except meta tail + meta tail +exTail :: Expression -> Parser Expression +exTail expr = + choice + [ do + next <- + choice + [ do + _ <- symbol "." + ExDispatch expr <$> fullAttribute, + do + guard + ( case expr of + ExThis -> False + ExGlobal -> False + _ -> True + ) + _ <- symbol "(" + bds <- + choice + [ try $ tauBinding fullAttribute `sepBy1` symbol ",", + do + exprs <- expression `sepBy1` symbol "," + return (zipWith (BiTau . AtAlpha) [0 ..] exprs) -- \idx expr -> BiTau (AtAlpha idx) expr + ] + _ <- symbol ")" + return (ExApplication expr bds), + do + guard + ( case expr of + ExMetaTail _ _ -> False + _ -> True + ) + _ <- symbol "*" + ExMetaTail expr <$> meta 't' + ] + "dispatch or application" + exTail next, + return expr + ] + +expression :: Parser Expression +expression = do + expr <- exHead + exTail expr + +program :: Parser Program +program = + choice + [ do + _ <- symbol "{" + prog <- Program <$> expression + _ <- symbol "}" + return prog, + do + _ <- global + _ <- arrow + Program <$> expression + ] + "program" + +-- Entry point +parse' :: String -> Parser a -> String -> Either String a +parse' name parser input = do + let parsed = + runParser + ( do + _ <- whiteSpace + p <- parser + _ <- eof + return p + ) + name + input + case parsed of + Right parsed' -> Right parsed' + Left err -> Left (errorBundlePretty err) + +parseExpression :: String -> Either String Expression +parseExpression = parse' "expression" expression + +parseExpressionThrows :: String -> IO Expression +parseExpressionThrows expression = case parseExpression expression of + Right expr -> pure expr + Left err -> throwIO (CouldNotParseExpression err) + +parseProgram :: String -> Either String Program +parseProgram = parse' "program" program + +parseProgramThrows :: String -> IO Program +parseProgramThrows program = case parseProgram program of + Right prog -> pure prog + Left err -> throwIO (CouldNotParseProgram err) diff --git a/src/Printer.hs b/src/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Printer.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module Printer (printExpression, printProgram, printSubstitutions) where + +import Ast +import qualified Data.Map.Strict as Map +import Matcher +import Prettyprinter +import Prettyprinter.Render.String (renderString) +import Text.Printf (vFmt) + +prettyMeta :: String -> Doc ann +prettyMeta meta = pretty "!" <> pretty meta + +prettyArrow :: Doc ann +prettyArrow = pretty "↦" + +prettyDashedArrow :: Doc ann +prettyDashedArrow = pretty "⤍" + +instance Pretty Attribute where + pretty (AtLabel name) = pretty name + pretty (AtAlpha index) = pretty "α" <> pretty index + pretty AtRho = pretty "ρ" + pretty AtPhi = pretty "φ" + pretty (AtMeta meta) = prettyMeta meta + +instance Pretty Binding where + pretty (BiTau attr expr) = pretty attr <+> prettyArrow <+> pretty expr + pretty (BiMeta meta) = prettyMeta meta + pretty (BiDelta bytes) = pretty "Δ" <+> prettyDashedArrow <+> pretty bytes + pretty (BiMetaDelta meta) = pretty "Δ" <+> prettyDashedArrow <+> prettyMeta meta + pretty (BiVoid attr) = pretty attr <+> prettyArrow <+> pretty "∅" + pretty (BiLambda func) = pretty "λ" <+> prettyDashedArrow <+> pretty func + pretty (BiMetaLambda meta) = pretty "λ" <+> prettyDashedArrow <+> prettyMeta meta + +instance {-# OVERLAPPING #-} Pretty [Binding] where + pretty bindings = vsep (punctuate comma (map pretty bindings)) + +instance Pretty Expression where + pretty (ExFormation []) = pretty "⟦⟧" + pretty (ExFormation [binding]) = case binding of + BiTau _ _ -> vsep [pretty "⟦", indent 2 (pretty binding), pretty "⟧"] + _ -> pretty "⟦" <+> pretty binding <+> pretty "⟧" + pretty (ExFormation bindings) = vsep [pretty "⟦", indent 2 (pretty bindings), pretty "⟧"] + pretty ExThis = pretty "ξ" + pretty ExGlobal = pretty "Φ" + pretty ExTermination = pretty "⊥" + pretty (ExMeta meta) = prettyMeta meta + pretty (ExApplication expr []) = pretty expr <> pretty "()" + pretty (ExApplication expr taus) = pretty expr <> vsep [lparen, indent 2 (pretty taus), rparen] + pretty (ExDispatch expr attr) = pretty expr <> pretty "." <> pretty attr + pretty (ExMetaTail expr meta) = pretty expr <+> pretty "*" <+> prettyMeta meta + +instance Pretty Program where + pretty (Program expr) = pretty "Φ" <+> prettyArrow <+> pretty expr + +instance Pretty Tail where + pretty (TaApplication []) = pretty "()" + pretty (TaApplication taus) = vsep [lparen, indent 2 (pretty taus), rparen] + pretty (TaDispatch attr) = pretty "." <> pretty attr + +instance Pretty MetaValue where + pretty (MvAttribute attr) = pretty attr + pretty (MvBytes bytes) = pretty bytes + pretty (MvBindings bindings) = pretty bindings + pretty (MvFunction func) = pretty func + pretty (MvExpression expr) = pretty 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 [Subst] where + pretty :: [Subst] -> Doc ann + pretty [] = pretty "[]" + pretty substs = vsep [pretty "[", indent 2 (vsep (punctuate comma (map pretty substs))), pretty "]"] + +prettyPrint :: (Pretty a) => a -> String +prettyPrint printable = renderString (layoutPretty defaultLayoutOptions (pretty printable)) + +printSubstitutions :: [Subst] -> String +printSubstitutions = prettyPrint + +printExpression :: Expression -> String +printExpression = prettyPrint + +printProgram :: Program -> String +printProgram = prettyPrint diff --git a/src/Replacer.hs b/src/Replacer.hs new file mode 100644 --- /dev/null +++ b/src/Replacer.hs @@ -0,0 +1,47 @@ +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +-- The goal of the module is to traverse though the Program with replacing +-- pattern sub expression with target expressions +module Replacer (replaceProgram) where + +import Ast +import Matcher (Tail (TaApplication, TaDispatch)) + +replaceBindings :: [Binding] -> [Expression] -> [Expression] -> ([Binding], [Expression], [Expression]) +replaceBindings bds [] [] = (bds, [], []) +replaceBindings [] ptns repls = ([], ptns, repls) +replaceBindings (BiTau attr expr : bds) ptns repls = do + let (expr', ptns', repls') = replaceExpression expr ptns repls + let (bds', ptns'', repls'') = replaceBindings bds ptns' repls' + (BiTau attr expr' : bds', ptns'', repls'') +replaceBindings (bd : bds) ptns repls = do + let (bds', ptns', repls') = replaceBindings bds ptns repls + (bd : bds', ptns', repls') + +replaceExpression :: Expression -> [Expression] -> [Expression] -> (Expression, [Expression], [Expression]) +replaceExpression expr [] [] = (expr, [], []) +replaceExpression expr ptns repls = do + let (ptn : ptnsRest) = ptns + let (repl : replsRest) = repls + if expr == ptn + then (repl, ptnsRest, replsRest) + else case expr of + ExDispatch inner attr -> do + let (expr', ptns', repls') = replaceExpression inner ptns repls + (ExDispatch expr' attr, ptns', repls') + ExApplication inner taus -> do + let (expr', ptns', repls') = replaceExpression inner ptns repls + let (taus', ptns'', repls'') = replaceBindings taus ptns' repls' + (ExApplication expr' taus', ptns'', repls'') + ExFormation bds -> do + let (bds', ptns', repls') = replaceBindings bds ptns repls + (ExFormation bds', ptns', repls') + _ -> (expr, ptns, repls) + +replaceProgram :: Program -> [Expression] -> [Expression] -> Maybe Program +replaceProgram (Program expr) ptns repls + | length ptns == length repls = do + let (expr', _, _) = replaceExpression expr ptns repls + Just (Program expr') + | otherwise = Nothing diff --git a/src/Rewriter.hs b/src/Rewriter.hs new file mode 100644 --- /dev/null +++ b/src/Rewriter.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module Rewriter (rewrite) where + +import Ast +import Builder (buildExpressions) +import Control.Exception +import Matcher (Subst, matchProgram) +import Misc (ensuredFile) +import Parser (parseProgram, parseProgramThrows) +import Printer (printExpression, printProgram, printSubstitutions) +import Replacer (replaceProgram) +import System.Directory +import Text.Printf +import qualified Yaml as Y +import Yaml (Rule) + +data RewriteException + = CouldNotMatch {pattern :: Expression, program :: Program} + | CouldNotBuild {expr :: Expression, substs :: [Subst]} + | CouldNotReplace {prog :: Program, ptn :: Expression, res :: Expression} + deriving (Exception) + +instance Show RewriteException where + show CouldNotMatch {..} = + printf + "Couldn't find given pattern in provided program\n--Pattern: %s\n--Program: %s" + (printExpression pattern) + (printProgram program) + show CouldNotBuild {..} = + printf + "Couldn't build given expression with provided substitutions\n--Expression: %s\n--Substitutions: %s" + (printExpression expr) + (printSubstitutions substs) + show CouldNotReplace {..} = + printf + "Couldn't replace expression in program by pattern\nProgram: %s\n--Pattern: %s\n--Result: %s" + (printProgram prog) + (printExpression ptn) + (printExpression res) + +applyRules :: Program -> [Y.Rule] -> IO Program +applyRules program [] = pure program +applyRules program [rule] = do + let ptn = Y.pattern rule + let res = Y.result rule + case matchProgram ptn program of + [] -> throwIO (CouldNotMatch ptn program) + substs -> case (buildExpressions ptn substs, buildExpressions res substs) of + (Just ptns, Just repls) -> case replaceProgram program ptns repls of + Just prog -> pure prog + _ -> throwIO (CouldNotReplace program ptn res) + (Nothing, _) -> throwIO (CouldNotBuild ptn substs) + (_, Nothing) -> throwIO (CouldNotBuild res substs) +applyRules program (rule : rest) = do + prog <- applyRules program [rule] + applyRules prog rest + +rewrite :: String -> Maybe Y.RuleSet -> IO String +rewrite prog rulesSet = do + program <- parseProgramThrows prog + rewritten <- case rulesSet of + Just set -> applyRules program (Y.rules set) + Nothing -> pure program + pure (printProgram rewritten) diff --git a/src/Yaml.hs b/src/Yaml.hs new file mode 100644 --- /dev/null +++ b/src/Yaml.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module Yaml where + +import Ast +import Data.Aeson +import Data.String (IsString (..)) +import Data.Text (unpack) +import qualified Data.Yaml as Yaml +import GHC.Generics +import Parser + +instance FromJSON Expression where + parseJSON = + withText + "Expression" + ( \txt -> case parseExpression (unpack txt) of + Left err -> fail err + Right expr -> pure expr + ) + +data RuleSet = RuleSet + { title :: String, + rules :: [Rule] + } + deriving (Generic, FromJSON, Show) + +data Rule = Rule + { name :: String, + pattern :: Expression, + result :: Expression + } + deriving (Generic, FromJSON, Show) + +yamlRuleSet :: FilePath -> IO RuleSet +yamlRuleSet = Yaml.decodeFileThrow diff --git a/test/BuilderSpec.hs b/test/BuilderSpec.hs new file mode 100644 --- /dev/null +++ b/test/BuilderSpec.hs @@ -0,0 +1,80 @@ +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module BuilderSpec where + +import Ast +import Builder +import Control.Monad +import Data.Map.Strict qualified as Map +import Matcher +import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, describe, it, shouldBe) + +test :: (Show a, Eq a) => (a -> Subst -> Maybe a) -> [(String, a, [(String, MetaValue)], Maybe a)] -> SpecWith (Arg Expectation) +test function useCases = + forM_ useCases $ \(desc, expr, mp, res) -> + it desc $ function expr (Subst (Map.fromList mp)) `shouldBe` res + +spec :: Spec +spec = do + describe "buildExpression" $ do + test + buildExpression + [ ( "Q.!a => (!a >> x) => Q.x", + ExDispatch ExGlobal (AtMeta "a"), + [("a", MvAttribute (AtLabel "x"))], + Just (ExDispatch ExGlobal (AtLabel "x")) + ), + ( "Q.c(!a -> !e) => (!a >> x, !e >> $.y.z) => Q.c(x -> $.y.z)", + ExApplication (ExDispatch ExGlobal (AtLabel "c")) [BiTau (AtMeta "a") (ExMeta "e")], + [("a", MvAttribute (AtLabel "x")), ("e", MvExpression (ExDispatch (ExDispatch ExThis (AtLabel "y")) (AtLabel "z")))], + Just (ExApplication (ExDispatch ExGlobal (AtLabel "c")) [BiTau (AtLabel "x") (ExDispatch (ExDispatch ExThis (AtLabel "y")) (AtLabel "z"))]) + ), + ( "[[!a -> $.x, !B]] => (!a >> y, !B >> [[b -> ?, L> Func]]) => [[y -> $.x, b -> ?, L> Func]]", + ExFormation [BiTau (AtMeta "a") (ExDispatch ExThis (AtLabel "x")), BiMeta "B"], + [("a", MvAttribute (AtLabel "y")), ("B", MvBindings [BiVoid (AtLabel "b"), BiLambda "Func"])], + Just + ( ExFormation + [ BiTau (AtLabel "y") (ExDispatch ExThis (AtLabel "x")), + BiVoid (AtLabel "b"), + BiLambda "Func" + ] + ) + ), + ( "Q * !t => (!t >> [.a, .b, (~1 -> $.x)]) => Q.a.b(~1 -> $.x)", + ExMetaTail ExGlobal "t", + [("t", MvTail [TaDispatch (AtLabel "a"), TaDispatch (AtLabel "b"), TaApplication [BiTau (AtAlpha 1) (ExDispatch ExThis (AtLabel "x"))]])], + Just (ExApplication (ExDispatch (ExDispatch ExGlobal (AtLabel "a")) (AtLabel "b")) [BiTau (AtAlpha 1) (ExDispatch ExThis (AtLabel "x"))]) + ), + ( "Q.!a => () => X", + ExDispatch ExGlobal (AtMeta "a"), + [], + Nothing + ), + ( "!e0(!a1 -> !e1, !a2 => !e2) => (!e0 >> [[]], !a1 >> x, !e1 >> Q, !a2 >> y, !e2 >> $) => [[]](x -> Q, y -> $)", + ExApplication (ExMeta "e0") [BiTau (AtMeta "a1") (ExMeta "e1"), BiTau (AtMeta "a2") (ExMeta "e2")], + [ ("e0", MvExpression (ExFormation [])), + ("a1", MvAttribute (AtLabel "x")), + ("e1", MvExpression ExGlobal), + ("a2", MvAttribute (AtLabel "y")), + ("e2", MvExpression ExThis) + ], + Just (ExApplication (ExFormation []) [BiTau (AtLabel "x") ExGlobal, BiTau (AtLabel "y") ExThis]) + ) + ] + + describe "buildExpressions" $ do + it "!e => [(!e >> Q.x), (!e >> $.y)] => [Q.x, $.y]" $ + do + buildExpressions + (ExMeta "e") + [ substSingle "e" (MvExpression (ExDispatch ExGlobal (AtLabel "x"))), + substSingle "e" (MvExpression (ExDispatch ExThis (AtLabel "y"))) + ] + `shouldBe` Just [ExDispatch ExGlobal (AtLabel "x"), ExDispatch ExThis (AtLabel "y")] + it "!e => [(!e1 >> Q.x)] => X" $ + do + buildExpressions + (ExMeta "e") + [substSingle "e1" (MvExpression (ExDispatch ExGlobal (AtLabel "x")))] + `shouldBe` Nothing diff --git a/test/CLISpec.hs b/test/CLISpec.hs new file mode 100644 --- /dev/null +++ b/test/CLISpec.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module CLISpec (spec) where + +import CLI (runCLI) +import System.IO.Silently (capture_) +import System.Directory (removeFile) +import Test.Hspec +import System.IO +import Control.Exception +import GHC.IO.Handle + +withRedirectedStdin :: String -> IO a -> IO a +withRedirectedStdin input action = do + bracket (openTempFile "." "stdin.tmp") cleanup $ \(filePath, h) -> do + hSetEncoding h utf8 + hPutStr h input + hFlush h + hSeek h AbsoluteSeek 0 + hClose h + withFile filePath ReadMode $ \hIn -> do + hSetEncoding hIn utf8 + bracket (hDuplicate stdin) restoreStdin $ \_ -> do + hDuplicateTo hIn stdin + hSetEncoding stdin utf8 + action + where + restoreStdin orig = hDuplicateTo orig stdin >> hClose orig + cleanup (fp, _) = removeFile fp + +spec :: Spec +spec = do + it "desugares with --nothing flag from file" $ do + let args = ["rewrite", "--nothing", "--phi-input=test/resources/cli/desugar.phi"] + output <- capture_ (runCLI args) + output `shouldContain` "Φ ↦ ⟦\n foo ↦ Φ.org.eolang\n⟧" + + it "desugares with --nothing flag from stdin" $ do + withRedirectedStdin "{[[foo ↦ QQ]]}" $ do + let args = ["rewrite", "--nothing"] + output <- capture_ (runCLI args) + output `shouldContain` "Φ ↦ ⟦\n foo ↦ Φ.org.eolang\n⟧" diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,10 @@ +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module Main where + +import Spec qualified +import Test.Hspec.Runner + +main :: IO () +main = hspecWith defaultConfig Spec.spec diff --git a/test/MatcherSpec.hs b/test/MatcherSpec.hs new file mode 100644 --- /dev/null +++ b/test/MatcherSpec.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module MatcherSpec where + +import Ast +import Control.Monad (forM_) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Matcher +import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, describe, it, shouldBe) + +class Expected e where + type ExpectedResult e + toExpected :: e -> ExpectedResult e + +instance Expected (Maybe [(String, MetaValue)]) where + type ExpectedResult (Maybe [(String, MetaValue)]) = Maybe Subst + toExpected = fmap (Subst . Map.fromList) + +instance Expected ([Binding], [(String, MetaValue)]) where + type ExpectedResult ([Binding], [(String, MetaValue)]) = ([Binding], Maybe Subst) + toExpected (rest, pairs) = (rest, Just (Subst (Map.fromList pairs))) + +instance Expected [[(String, MetaValue)]] where + type ExpectedResult [[(String, MetaValue)]] = [Subst] + toExpected = map (Subst . Map.fromList) + +maybeCombined :: Subst -> Subst -> Subst +maybeCombined first second = + fromMaybe + (error "combine returned Nothing") + (combine first second) + +test :: + (Expected e, ExpectedResult e ~ r, Eq r, Show r) => + (a -> a -> r) -> + [(String, a, a, e)] -> + SpecWith (Arg Expectation) +test function useCases = + forM_ useCases $ \(desc, ptn, tgt, mp) -> + it desc $ function ptn tgt `shouldBe` toExpected mp + +spec :: Spec +spec = do + describe "matchExpressionDeep: expression => expression => [substitution]" $ + test + matchExpressionDeep + [ ( "[[!a -> Q.org.!a]] => [[f -> [[x -> Q.org.x]], t -> [[y -> Q.org.y]] => [(!a >> x), (!a >> y)]", + ExFormation [BiTau (AtMeta "a") (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtMeta "a"))], + ExFormation + [ BiTau (AtLabel "f") (ExFormation [BiTau (AtLabel "x") (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "x"))]), + BiTau (AtLabel "t") (ExFormation [BiTau (AtLabel "y") (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "y"))]) + ], + [[("a", MvAttribute (AtLabel "x"))], [("a", MvAttribute (AtLabel "y"))]] + ), + ( "!e => [[x -> Q]] => [(!e >> [[x -> Q]]), (!e >> Q)]", + ExMeta "e", + ExFormation [BiTau (AtLabel "x") ExGlobal], + [[("e", MvExpression (ExFormation [BiTau (AtLabel "x") ExGlobal]))], [("e", MvExpression ExGlobal)]] + ), + ( "!e.!a => Q.org.eolang => [(!e >> Q.org, !a >> eolang), (!e >> Q, !a >> org)]", + ExDispatch (ExMeta "e") (AtMeta "a"), + ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang"), + [ [("e", MvExpression (ExDispatch ExGlobal (AtLabel "org"))), ("a", MvAttribute (AtLabel "eolang"))], + [("e", MvExpression ExGlobal), ("a", MvAttribute (AtLabel "org"))] + ] + ) + ] + + describe "matchAttribute: attribute => attribute => substitution" $ + test + matchAttribute + [ ("~1 => ~1 => ()", AtAlpha 1, AtAlpha 1, Just []), + ("!a => ^ => (!a >> ^)", AtMeta "a", AtRho, Just [("a", MvAttribute AtRho)]), + ("!a => @ => (!a >> @)", AtMeta "a", AtPhi, Just [("a", MvAttribute AtPhi)]), + ("~0 => x => X", AtAlpha 0, AtLabel "x", Nothing) + ] + + describe "matchNonMetaExactBindings" $ + test + matchNonMetaExactBindings + [ ( "[^ -> ?, !a -> ?] => [^ -> ?, x -> ?] => (!a >> x)", + [BiVoid AtRho, BiVoid (AtMeta "a")], + [BiVoid AtRho, BiVoid (AtLabel "x")], + Just [("a", MvAttribute (AtLabel "x"))] + ), + ( "[^ -> ?, !a -> ?] => [!x -> ?, ^ -> ?] => (!a >> x)", + [BiVoid AtRho, BiVoid (AtMeta "a")], + [BiVoid (AtLabel "x"), BiVoid AtRho], + Just [("a", MvAttribute (AtLabel "x"))] + ), + ( "[^ -> ?] => [^ -> ?] => ()", + [BiVoid AtRho], + [BiVoid AtRho], + Just [] + ) + ] + + describe "matchBindings: [binding] => [binding] => substitution" $ + test + matchBindings + [ ( "[] => [] => ()", + [], + [], + Just [] + ), + ( "[!B] => T:[x -> ?, D> 01-, L> Func] => (!B >> T)", + [BiMeta "B"], + [BiVoid (AtLabel "x"), BiDelta "01-", BiLambda "Func"], + Just [("B", MvBindings [BiVoid (AtLabel "x"), BiDelta "01-", BiLambda "Func"])] + ), + ( "[D> 00-] => [D> 00-, L> Func] => X", + [BiDelta "00-"], + [BiDelta "00-", BiLambda "Func"], + Nothing + ), + ( "[y -> ?, !a -> ?] => [x -> ?, y -> ?] => (!a >> x)", + [BiVoid (AtLabel "y"), BiVoid (AtMeta "a")], + [BiVoid (AtLabel "x"), BiVoid (AtLabel "y")], + Just [("a", MvAttribute (AtLabel "x"))] + ), + ( "[!B, x -> ?] => [x -> ?] => (!B >> [])", + [BiMeta "B", BiVoid (AtLabel "x")], + [BiVoid (AtLabel "x")], + Just [("B", MvBindings [])] + ), + ( "[!B, x -> ?] => [x -> ?, y -> ?] => (!B >> [y -> ?])", + [BiMeta "B", BiVoid (AtLabel "x")], + [BiVoid (AtLabel "x"), BiVoid (AtLabel "y")], + Just [("B", MvBindings [BiVoid (AtLabel "y")])] + ), + ( "[!B, !x -> ?] => [y -> ?, D> -> 00-, L> Func] => (!x >> y, !B >> [D> -> 00-, L> Func])", + [BiMeta "B", BiVoid (AtMeta "x")], + [BiVoid (AtLabel "y"), BiDelta "00-", BiLambda "Func"], + Just [("B", MvBindings [BiDelta "00-", BiLambda "Func"]), ("x", MvAttribute (AtLabel "y"))] + ), + ( "[!x -> ?, !y -> ?] => [a -> ?, b -> ?] => (!x >> a, !y >> b)", + [BiVoid (AtMeta "x"), BiVoid (AtMeta "y")], + [BiVoid (AtLabel "a"), BiVoid (AtLabel "b")], + Just [("x", MvAttribute (AtLabel "a")), ("y", MvAttribute (AtLabel "b"))] + ) + ] + + describe "matchExpression: expression => pattern => substitution" $ + test + matchExpression + [ ("$ => $ => ()", ExThis, ExThis, Just []), + ("Q => Q => ()", ExGlobal, ExGlobal, Just []), + ( "!e => Q => (!e >> Q)", + ExMeta "e", + ExGlobal, + Just [("e", MvExpression ExGlobal)] + ), + ( "!e => Q.org(x -> $) => (!e >> Q.org(x -> $))", + ExMeta "e", + ExApplication (ExDispatch ExGlobal (AtLabel "org")) [BiTau (AtLabel "x") ExThis], + Just [("e", MvExpression (ExApplication (ExDispatch ExGlobal (AtLabel "org")) [BiTau (AtLabel "x") ExThis]))] + ), + ( "!e1.x => Q.org.x => (!e1 >> Q.org)", + ExDispatch (ExMeta "e1") (AtLabel "x"), + ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "x"), + Just [("e1", MvExpression (ExDispatch ExGlobal (AtLabel "org")))] + ), + ( "!e.org.!a => $.org.x => (!e >> $, !a >> x)", + ExDispatch (ExDispatch (ExMeta "e") (AtLabel "org")) (AtMeta "a"), + ExDispatch (ExDispatch ExThis (AtLabel "org")) (AtLabel "x"), + Just [("e", MvExpression ExThis), ("a", MvAttribute (AtLabel "x"))] + ), + ( "[[!a -> !e, !B]].!a => [[x -> Q, y -> $]].x => (!a >> x, !e >> Q, !B >> [y -> $])", + ExDispatch (ExFormation [BiTau (AtMeta "a") (ExMeta "e"), BiMeta "B"]) (AtMeta "a"), + ExDispatch + ( ExFormation + [ BiTau (AtLabel "x") ExGlobal, + BiTau (AtLabel "y") ExThis + ] + ) + (AtLabel "x"), + Just + [ ("a", MvAttribute (AtLabel "x")), + ("e", MvExpression ExGlobal), + ("B", MvBindings [BiTau (AtLabel "y") ExThis]) + ] + ), + ( "Q * !t => Q.org => (!t >> [.org])", + ExMetaTail ExGlobal "t", + ExDispatch ExGlobal (AtLabel "x"), + Just [("t", MvTail [TaDispatch (AtLabel "x")])] + ), + ( "Q * !t => Q.org(x -> [[]]) => (!t >> [.org, (x -> [[]])])", + ExMetaTail ExGlobal "t", + ExApplication (ExDispatch ExGlobal (AtLabel "org")) [BiTau (AtLabel "x") (ExFormation [])], + Just [("t", MvTail [TaDispatch (AtLabel "org"), TaApplication [BiTau (AtLabel "x") (ExFormation [])]])] + ), + ( "Q.!a * !t => Q.org(x -> [[]]) => (!a >> org, !t >> [(x -> [[]])])", + ExMetaTail (ExDispatch ExGlobal (AtMeta "a")) "t", + ExApplication (ExDispatch ExGlobal (AtLabel "org")) [BiTau (AtLabel "x") (ExFormation [])], + Just [("a", MvAttribute (AtLabel "org")), ("t", MvTail [TaApplication [BiTau (AtLabel "x") (ExFormation [])]])] + ), + ( "Q.x(y -> $ * !t1) * !t2 => Q.x(y -> $.q).p => (!t1 >> [.q], !t2 >> [.p])", + ExMetaTail (ExApplication (ExDispatch ExGlobal (AtLabel "x")) [BiTau (AtLabel "y") (ExMetaTail ExThis "t1")]) "t2", + ExDispatch (ExApplication (ExDispatch ExGlobal (AtLabel "x")) [BiTau (AtLabel "y") (ExDispatch ExThis (AtLabel "q"))]) (AtLabel "p"), + Just [("t1", MvTail [TaDispatch (AtLabel "q")]), ("t2", MvTail [TaDispatch (AtLabel "p")])] + ) + ] + + describe "matchBindingsWithFiltering: [binding] => [binding] => ([binding], substitution)" $ + test + matchBindingsWithFiltering + [ ( "[^ -> ?] => [^ -> ?] => ([], ())", + [BiVoid AtRho], + [BiVoid AtRho], + ([], []) + ), + ( "[x -> ?] => [x -> ?] => ([], ())", + [BiVoid (AtLabel "x")], + [BiVoid (AtLabel "x")], + ([], []) + ), + ( "[x -> ?] => [x -> ?, ^ -> ?] => ([^ -> ?], ())", + [BiVoid (AtLabel "x")], + [BiVoid (AtLabel "x"), BiVoid AtRho], + ([BiVoid AtRho], []) + ), + ( "[!a -> ?] => [x -> ?] => ([], (!a -> x))", + [BiVoid (AtMeta "a")], + [BiVoid (AtLabel "x")], + ([], [("a", MvAttribute (AtLabel "x"))]) + ) + ] + + describe "combine" $ do + it "combines empty substitutions" $ do + combine substEmpty substEmpty `shouldBe` Just substEmpty + it "combines two empty substs from list" $ do + combine (Subst Map.empty) (Subst Map.empty) `shouldBe` Just substEmpty + it "combines empty subst with single one" $ do + let Subst joined = maybeCombined substEmpty (Subst (Map.singleton "at" (MvAttribute AtPhi))) + Map.lookup "at" joined `shouldBe` Just (MvAttribute AtPhi) + it "combines two different subst" $ do + let Subst joined = + maybeCombined + (Subst (Map.singleton "first" (MvAttribute AtPhi))) + (Subst (Map.singleton "second" (MvBytes "00-"))) + Map.lookup "first" joined `shouldBe` Just (MvAttribute AtPhi) + Map.lookup "second" joined `shouldBe` Just (MvBytes "00-") + it "leave values in the same substs" $ do + let rho = MvAttribute AtRho + first = + Subst + ( Map.fromList + [ ("first", rho), + ("second", MvAttribute AtPhi) + ] + ) + second = Subst (Map.singleton "first" rho) + Subst joined = maybeCombined first second + Map.lookup "first" joined `shouldBe` Just (MvAttribute AtRho) + it "returns Nothing if values are different" $ do + combine (Subst (Map.singleton "x" (MvAttribute AtPhi))) (Subst (Map.singleton "x" (MvAttribute AtRho))) `shouldBe` Nothing + it "clears all the values" $ do + let first = + Subst + ( Map.fromList + [ ("x", MvAttribute AtRho), + ("y", MvBytes "1F-") + ] + ) + second = Subst (Map.singleton "x" (MvAttribute AtPhi)) + combine first second `shouldBe` Nothing + + describe "isBindingWithMetaAttr" $ do + it "does not touch simple attr" $ do + isBindingWithMetaAttr (BiVoid (AtLabel "x")) `shouldBe` False + it "recognizes void meta attr" $ do + isBindingWithMetaAttr (BiVoid (AtMeta "x")) `shouldBe` True diff --git a/test/ParserSpec.hs b/test/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/ParserSpec.hs @@ -0,0 +1,260 @@ +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use tuple-section" #-} + +module ParserSpec where + +import Ast +import Control.Monad (forM_) +import Data.Either (isLeft, isRight) +import Misc (allPathsIn) +import Parser +import System.FilePath (takeBaseName) +import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, describe, it, runIO, shouldBe, shouldSatisfy) + +test :: + (Eq a, Show a) => + (String -> Either String a) -> + [(String, Maybe a)] -> + SpecWith (Arg Expectation) +test function useCases = + forM_ useCases $ \(ipt, res) -> + it ipt $ case res of + Just right -> function ipt `shouldBe` Right right + _ -> function ipt `shouldSatisfy` isLeft + +spec :: Spec +spec = do + describe "parse program" $ + test + parseProgram + [ ("Q -> [[]]", Just (Program (ExFormation []))), + ("Q -> T(x -> Q)", Just (Program (ExApplication ExTermination [BiTau (AtLabel "x") ExGlobal]))), + ("Q -> Q.org.eolang", Just (Program (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")))), + ("Q -> [[x -> $, y -> ?]]", Just (Program (ExFormation [BiTau (AtLabel "x") ExThis, BiVoid (AtLabel "y")]))), + ("{[[foo ↦ QQ]]}", Just (Program (ExFormation [BiTau (AtLabel "foo") (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang"))]))) + ] + + describe "parse expression" $ + test + parseExpression + [ ("Q.!a", Just (ExDispatch ExGlobal (AtMeta "a"))), + ("[[]](!a1 -> $)", Just (ExApplication (ExFormation []) [BiTau (AtMeta "a1") ExThis])), + ( "[[]](~0 -> $)(~11 -> Q)", + Just + ( ExApplication + ( ExApplication + (ExFormation []) + [BiTau (AtAlpha 0) ExThis] + ) + [BiTau (AtAlpha 11) ExGlobal] + ) + ), + ("[[]](x -> $, y -> Q)", Just (ExApplication (ExFormation []) [BiTau (AtLabel "x") ExThis, BiTau (AtLabel "y") ExGlobal])), + ("[[!B, !B1]]", Just (ExFormation [BiMeta "B", BiMeta "B1"])), + ("[[!B2, !a2 -> $]]", Just (ExFormation [BiMeta "B2", BiTau (AtMeta "a2") ExThis])), + ("!e0", Just (ExMeta "e0")), + ("[[x -> !e]]", Just (ExFormation [BiTau (AtLabel "x") (ExMeta "e")])), + ("[[!a -> !e1]]", Just (ExFormation [BiTau (AtMeta "a") (ExMeta "e1")])), + ("Q * !t", Just (ExMetaTail ExGlobal "t")), + ("[[]](x -> $) * !t1", Just (ExMetaTail (ExApplication (ExFormation []) [BiTau (AtLabel "x") ExThis]) "t1")), + ("[[D> --]]", Just (ExFormation [BiDelta "--"])), + ("[[D> 1F-]]", Just (ExFormation [BiDelta "1F-"])), + ("[[\n L> Func,\n D> 00-\n]]", Just (ExFormation [BiLambda "Func", BiDelta "00-"])), + ("[[D> 1F-2A-00]]", Just (ExFormation [BiDelta "1F-2A-00"])), + ("[[D> !b0]]", Just (ExFormation [BiMetaDelta "b0"])), + ("[[L> Function]]", Just (ExFormation [BiLambda "Function"])), + ("[[L> !F3]]", Just (ExFormation [BiMetaLambda "F3"])), + ("[[x() -> [[]] ]]", Just (ExFormation [BiTau (AtLabel "x") (ExFormation [])])), + ( "[[y(^,@,z) -> [[q -> Q.a]] ]]", + Just + ( ExFormation + [ BiTau + (AtLabel "y") + ( ExFormation + [ BiVoid AtRho, + BiVoid AtPhi, + BiVoid (AtLabel "z"), + BiTau (AtLabel "q") (ExDispatch ExGlobal (AtLabel "a")) + ] + ) + ] + ) + ), + ( "!e(x(^,@) -> [[w -> !e1]])", + Just + ( ExApplication + (ExMeta "e") + [ BiTau + (AtLabel "x") + ( ExFormation + [ BiVoid AtRho, + BiVoid AtPhi, + BiTau (AtLabel "w") (ExMeta "e1") + ] + ) + ] + ) + ), + ( "[[x -> y.z, a -> ~1, w -> ^, u -> @, p -> !a, q -> !e]]", + Just + ( ExFormation + [ BiTau + (AtLabel "x") + (ExDispatch (ExDispatch ExThis (AtLabel "y")) (AtLabel "z")), + BiTau + (AtLabel "a") + (ExDispatch ExThis (AtAlpha 1)), + BiTau + (AtLabel "w") + (ExDispatch ExThis AtRho), + BiTau + (AtLabel "u") + (ExDispatch ExThis AtPhi), + BiTau + (AtLabel "p") + (ExDispatch ExThis (AtMeta "a")), + BiTau + (AtLabel "q") + (ExMeta "e") + ] + ) + ), + ( "Q.x(~1, y, [[]].z, Q.y(^,@))", + Just + ( ExApplication + (ExDispatch ExGlobal (AtLabel "x")) + [ BiTau (AtAlpha 0) (ExDispatch ExThis (AtAlpha 1)), + BiTau (AtAlpha 1) (ExDispatch ExThis (AtLabel "y")), + BiTau (AtAlpha 2) (ExDispatch (ExFormation []) (AtLabel "z")), + BiTau + (AtAlpha 3) + ( ExApplication + (ExDispatch ExGlobal (AtLabel "y")) + [ BiTau (AtAlpha 0) (ExDispatch ExThis AtRho), + BiTau (AtAlpha 1) (ExDispatch ExThis AtPhi) + ] + ) + ] + ) + ), + ( "5.plus(5.q(\"hello\".length))", + Just + ( ExApplication + ( ExDispatch + ( ExApplication + (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "number")) + [ BiTau + (AtAlpha 0) + ( ExApplication + (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "bytes")) + [ BiTau + (AtAlpha 0) + (ExFormation [BiDelta "40-14-00-00-00-00-00-00"]) + ] + ) + ] + ) + (AtLabel "plus") + ) + [ BiTau + (AtAlpha 0) + ( ExApplication + ( ExDispatch + ( ExApplication + (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "number")) + [ BiTau + (AtAlpha 0) + ( ExApplication + (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "bytes")) + [ BiTau + (AtAlpha 0) + (ExFormation [BiDelta "40-14-00-00-00-00-00-00"]) + ] + ) + ] + ) + (AtLabel "q") + ) + [ BiTau + (AtAlpha 0) + ( ExDispatch + ( ExApplication + (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "string")) + [ BiTau + (AtAlpha 0) + ( ExApplication + (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "bytes")) + [ BiTau + (AtAlpha 0) + (ExFormation [BiDelta "68-65-6C-6C-6F"]) + ] + ) + ] + ) + (AtLabel "length") + ) + ] + ) + ] + ) + ) + ] + + describe "just parses" $ + forM_ + [ "[[x -> $, y -> ?]]", + "[[x() -> [[]] ]]", + "[[x(^, @, y) -> [[q -> QQ]] ]]", + "Q.x(y() -> [[]])", + "Q.x(y(q) -> [[w -> !e]])", + "Q.x(~1(^,@) -> [[]])", + "Q.x.~1.^.@.!a0", + "[[x -> y.z]]", + "[[x -> ~1]]", + "[[x -> ^, y -> @, z -> !a]]", + "Q.x(a.b.c, Q.a(b), [[]])", + "Q.x(~1, y, [[]].z, Q.y(^,@))", + "[[x -> 5.plus(5), y -> \"hello\", z -> 42.5]]", + "[[w -> x(~1)]]", + "[[\n x -> \"Hi\",\n y -> 42\n]]", + "[[x -> -42, y -> +34]]", + "⟦x ↦ Φ.org.eolang(z ↦ ξ.f, x ↦ α0, φ ↦ ρ, t ↦ φ, first ↦ ⟦ λ ⤍ Function_name, Δ ⤍ 42- ⟧)⟧", + "[[x -> 1.00e+3, y -> 2.32e-4]]" + ] + (\expr -> it expr (parseExpression expr `shouldSatisfy` isRight)) + + describe "prohibits" $ + test + parseExpression + ( map + (\input -> (input, Nothing)) + [ "Q.x()", + "Q * !t1 * !t2", + "Q(x -> [[]])", + "$(x -> [[]])", + "Q.x(x -> ?)", + "Q.x(L> Func)", + "Q.x(D> --)", + "Q.x(!B)", + "Q.x(~1 -> ?)", + "Q.x(L> !F)", + "Q.x(D> !b)", + "[[~0 -> Q.x]]", + "[[x(~1) -> [[]] ]]", + "[[y(!e) -> [[]] ]]", + "[[z(w) -> Q.x]]", + "Q.x(y(~1) -> [[]])" + ] + ) + + describe "parse packs" $ do + packs <- runIO (allPathsIn "test/resources/parser-packs") + forM_ + packs + ( \pack -> do + content <- runIO (readFile pack) + it (takeBaseName pack) (parseProgram content `shouldSatisfy` isRight) + ) diff --git a/test/PrinterSpec.hs b/test/PrinterSpec.hs new file mode 100644 --- /dev/null +++ b/test/PrinterSpec.hs @@ -0,0 +1,46 @@ +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module PrinterSpec where + +import Ast +import Control.Monad (forM_) +import Matcher (MetaValue (MvAttribute, MvExpression), substEmpty, substSingle) +import Parser (parseProgramThrows) +import Prettyprinter +import Printer +import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, describe, it, runIO, shouldBe) + +test :: (Pretty a) => (a -> String) -> [(String, String, a)] -> SpecWith (Arg Expectation) +test function useCases = + forM_ useCases $ \(input, output, arg) -> + it input $ function arg `shouldBe` output + +spec :: Spec +spec = do + describe "print program" $ do + useCases <- + runIO $ + mapM + ( \(input, output) -> do + prog <- parseProgramThrows input + return (input, output, prog) + ) + [ ("Q -> $", "Φ ↦ ξ"), + ("Q -> Q.org.x", "Φ ↦ Φ.org.x"), + ("Q -> [[]]", "Φ ↦ ⟦⟧"), + ("Q -> [[@ -> ?]](~1 -> Q.x)", "Φ ↦ ⟦ φ ↦ ∅ ⟧(\n α1 ↦ Φ.x\n)"), + ("Q -> !e * !t", "Φ ↦ !e * !t"), + ( "Q -> [[D> 00-,L> F,^ -> ?,!B,@ -> [[y -> ?]]]]", + "Φ ↦ ⟦\n Δ ⤍ 00-,\n λ ⤍ F,\n ρ ↦ ∅,\n !B,\n φ ↦ ⟦ y ↦ ∅ ⟧\n⟧" + ) + ] + test printProgram useCases + + describe "print substitution" $ + test + printSubstitutions + [ ("[()]", "[\n (\n \n )\n]", [substEmpty]), + ("[(!e >> Q.x)]", "[\n (\n !e >> Φ.x\n )\n]", [substSingle "e" (MvExpression (ExDispatch ExGlobal (AtLabel "x")))]), + ("[(!a >> x)]", "[\n (\n !a >> x\n )\n]", [substSingle "a" (MvAttribute (AtLabel "x"))]) + ] diff --git a/test/ReplacerSpec.hs b/test/ReplacerSpec.hs new file mode 100644 --- /dev/null +++ b/test/ReplacerSpec.hs @@ -0,0 +1,55 @@ +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module ReplacerSpec where + +import Ast +import Control.Monad (forM_) +import Replacer +import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, describe, it, shouldBe) + +test :: + (Program -> [Expression] -> [Expression] -> Maybe Program) -> + [(String, Program, [Expression], [Expression], Maybe Program)] -> + SpecWith (Arg Expectation) +test function useCases = + forM_ useCases $ \(desc, prog, ptns, repls, res) -> + it desc $ function prog ptns repls `shouldBe` res + +spec :: Spec +spec = do + describe "replaceProgram: program => ([expression], [expression]) => program" $ do + test + replaceProgram + [ ( "Q -> Q.y.x() => ([Q.y], [$]) => Q -> $.x()", + Program (ExApplication (ExDispatch (ExDispatch ExGlobal (AtLabel "y")) (AtLabel "x")) []), + [ExDispatch ExGlobal (AtLabel "y")], + [ExThis], + Just (Program (ExApplication (ExDispatch ExThis (AtLabel "x")) [])) + ), + ( "Q -> [[x -> [[y -> $]], z -> [[w -> $]] ]] => ([[y -> $], [w -> $]], [Q.y, Q.w]) => Q -> [[x -> Q.y, z -> Q.w]]", + Program + ( ExFormation + [ BiTau (AtLabel "x") (ExFormation [BiTau (AtLabel "y") ExThis]), + BiTau (AtLabel "z") (ExFormation [BiTau (AtLabel "w") ExThis]) + ] + ), + [ExFormation [BiTau (AtLabel "y") ExThis], ExFormation [BiTau (AtLabel "w") ExThis]], + [ExDispatch ExGlobal (AtLabel "y"), ExDispatch ExGlobal (AtLabel "w")], + Just + ( Program + ( ExFormation + [ BiTau (AtLabel "x") (ExDispatch ExGlobal (AtLabel "y")), + BiTau (AtLabel "z") (ExDispatch ExGlobal (AtLabel "w")) + ] + ) + ) + ), + ("Q -> [[]] => ([], [$]) => X", Program (ExFormation []), [], [ExThis], Nothing), + ( "Q -> [[L> Func, D> 00-]] => ([ [[L> Func, D> 00-]] ], [Q]) => Q -> Q", + Program (ExFormation [BiLambda "Func", BiDelta "00-"]), + [ExFormation [BiLambda "Func", BiDelta "00-"]], + [ExGlobal], + Just (Program ExGlobal) + ) + ] diff --git a/test/RewriterSpec.hs b/test/RewriterSpec.hs new file mode 100644 --- /dev/null +++ b/test/RewriterSpec.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module RewriterSpec where + +import Control.Monad (forM_) +import Data.Aeson +import Data.Yaml qualified as Yaml +import GHC.Generics +import Misc (allPathsIn) +import Rewriter (rewrite) +import Test.Hspec (Spec, describe, runIO, shouldBe, it) +import qualified Yaml +import System.FilePath (takeBaseName) + +data YamlPack = YamlPack + { input :: String, + output :: String, + ruleSet :: Maybe Yaml.RuleSet + } + deriving (Generic, FromJSON, Show) + +yamlPack :: FilePath -> IO YamlPack +yamlPack = Yaml.decodeFileThrow + +spec :: Spec +spec = do + describe "rewrite packs" $ do + packs <- runIO (allPathsIn "test/resources/rewriter-packs") + forM_ + packs + ( \pth -> do + pack <- runIO $ yamlPack pth + let output' = output pack + input' = input pack + ruleSet' = ruleSet pack + rewritten <- runIO $ rewrite input' ruleSet' + it (takeBaseName pth) (rewritten `shouldBe` output') + ) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,7 @@ +-- This pragma runs `hspec-discover` preprocessor at compile time. +-- This preprocessor scans for *Spec.hs modules and gathers them into +-- one big spec :: Spec module which is run by test/Main.hs +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT