diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -29,7 +29,7 @@ ```bash cabal update -cabal install --overwrite-policy=always phino-0.0.0.54 +cabal install --overwrite-policy=always phino-0.0.0.55 phino --version ``` @@ -366,7 +366,7 @@ To generate a local coverage report for development, run: ```bash -cabal test --enable-coverage +make coverage ``` You will need [GHC] and [Cabal ≥3.0][cabal] or [Stack ≥ 3.0][stack] installed. diff --git a/phino.cabal b/phino.cabal --- a/phino.cabal +++ b/phino.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: phino -version: 0.0.0.55 +version: 0.0.0.56 license: MIT synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions description: Please see the README on GitHub at @@ -32,6 +32,7 @@ -Wno-missing-export-lists library + import: warnings exposed-modules: AST Builder @@ -122,6 +123,7 @@ FilterSpec FunctionsSpec LaTeXSpec + LiningSpec MatcherSpec MergeSpec MiscSpec @@ -130,6 +132,7 @@ Paths_phino PrinterSpec RandomSpec + RegexpSpec ReplacerSpec RewriterSpec RuleSpec @@ -147,6 +150,7 @@ build-depends: aeson, base, + bytestring, containers, directory, filepath, diff --git a/src/AST.hs b/src/AST.hs --- a/src/AST.hs +++ b/src/AST.hs @@ -7,7 +7,6 @@ -- 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 @@ -68,7 +67,7 @@ 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' (ExApplication expr' (BiTau _ bexpr')) = 2 + countNodes' expr' + countNodes' bexpr' + countNodes' (ExDispatch expr' _) = 2 + countNodes' expr' + countNodes' (ExFormation bds) = 1 + sum (map (\case BiTau _ 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 @@ -29,7 +29,6 @@ import Misc (uniqueBindings) import Printer import Text.Printf (printf) -import Yaml (ExtraArgument (..)) data BuildException = CouldNotBuildExpression {_expr :: Expression, _msg :: String} @@ -67,14 +66,15 @@ contextualize :: Expression -> Expression -> Expression contextualize ExGlobal _ = ExGlobal -contextualize ExThis expr = expr +contextualize ExThis ex = ex contextualize ExTermination _ = ExTermination contextualize (ExFormation bds) _ = ExFormation bds -contextualize (ExDispatch expr attr) context = ExDispatch (contextualize expr context) attr -contextualize (ExApplication expr (BiTau attr bexpr)) context = - let expr' = contextualize expr context +contextualize (ExDispatch ex at) context = ExDispatch (contextualize ex context) at +contextualize (ExApplication ex (BiTau at bexpr)) context = + let ex' = contextualize ex context bexpr' = contextualize bexpr context - in ExApplication expr' (BiTau attr bexpr') + in ExApplication ex' (BiTau at bexpr') +contextualize ex _ = ex buildAttribute :: Attribute -> Subst -> Built Attribute buildAttribute (AtMeta meta) (Subst mp) = case Map.lookup meta mp of @@ -120,9 +120,9 @@ 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 +buildExpressionWithTails ex (tl : rest) subst = case tl of + TaApplication taus -> buildExpressionWithTails (ExApplication ex taus) rest subst + TaDispatch at -> buildExpressionWithTails (ExDispatch ex at) rest subst -- Build meta expression with given substitution -- It returns tuple (X, Y) @@ -130,10 +130,10 @@ -- If meta expression is built from MvExpression, is has -- context from original Program. It have default context otherwise buildExpression :: Expression -> Subst -> Built (Expression, Expression) -buildExpression (ExDispatch expr attr) subst = do - (dispatched, scope) <- buildExpression expr subst - attr <- buildAttribute attr subst - Right (ExDispatch dispatched attr, scope) +buildExpression (ExDispatch ex at) subst = do + (dispatched, scope) <- buildExpression ex subst + at' <- buildAttribute at subst + Right (ExDispatch dispatched at', scope) buildExpression (ExApplication expr (BiTau battr bexpr)) subst = do (applied, scope) <- buildExpression expr subst bds <- buildBinding (BiTau battr bexpr) subst diff --git a/src/CLI.hs b/src/CLI.hs --- a/src/CLI.hs +++ b/src/CLI.hs @@ -3,6 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT @@ -12,22 +13,19 @@ import AST import qualified Canonizer as C import Condition (parseConditionThrows) -import Control.Exception (Exception (displayException), SomeException, handle, throw, throwIO) -import Control.Exception.Base +import Control.Exception.Base (Exception (displayException), SomeException, catch, fromException, handle, throwIO) import Control.Monad (forM_, unless, when, (>=>)) import Data.Char (toLower, toUpper) import Data.Foldable (for_) -import qualified Data.Foldable import Data.Functor ((<&>)) import Data.List (intercalate) import Data.Maybe (fromJust, isJust, isNothing) import Data.Version (showVersion) import Dataize (DataizeContext (DataizeContext), dataize) import Deps (SaveStepFunc, saveStep) -import Encoding (Encoding (ASCII, UNICODE)) +import Encoding (Encoding (UNICODE)) import qualified Filter as F import Functions (buildTerm) -import qualified Functions import LaTeX (LatexContext (LatexContext), explainRules, programToLaTeX, rewrittensToLatex) import Lining (LineFormat (MULTILINE, SINGLELINE)) import Logger @@ -39,7 +37,7 @@ import Parser (parseExpressionThrows, parseProgramThrows) import Paths_phino (version) import qualified Printer as P -import Rewriter (RewriteContext (RewriteContext), Rewritten (..), rewrite') +import Rewriter (RewriteContext (RewriteContext), Rewritten, rewrite') import Rule (RuleContext (RuleContext), matchProgramWithRule) import Sugar import System.Exit (ExitCode (..), exitFailure) @@ -62,14 +60,14 @@ } data CmdException - = InvalidCLIArguments {message :: String} - | CouldNotReadFromStdin {message :: String} + = InvalidCLIArguments String + | CouldNotReadFromStdin String | CouldNotDataize deriving (Exception) instance Show CmdException where - show InvalidCLIArguments{..} = printf "Invalid set of arguments: %s" message - show CouldNotReadFromStdin{..} = printf "Could not read input from stdin\nReason: %s" message + show (InvalidCLIArguments msg) = printf "Invalid set of arguments: %s" msg + show (CouldNotReadFromStdin msg) = printf "Could not read input from stdin\nReason: %s" msg show CouldNotDataize = "Could not dataize given program" data Command @@ -98,6 +96,7 @@ , omitComments :: Bool , nonumber :: Bool , sequence :: Bool + , canonize :: Bool , depthSensitive :: Bool , quiet :: Bool , compress :: Bool @@ -105,6 +104,7 @@ , maxCycles :: Int , hide :: [String] , show' :: [String] + , locator :: String , expression :: Maybe String , label :: Maybe String , meetPrefix :: Maybe String @@ -251,6 +251,9 @@ optSequence :: Parser Bool optSequence = switch (long "sequence" <> help "Result output contains all intermediate 𝜑-programs concatenated with EOL") +optCanonize :: Parser Bool +optCanonize = switch (long "canonize" <> help "Rename all functions attached to λ binding with F1, F2, etc.") + optExpression :: Parser (Maybe String) optExpression = optional (strOption (long "expression" <> metavar "NAME" <> help "Name for 'phiExpression' element when rendering to LaTeX (see --output option)")) @@ -337,6 +340,7 @@ <*> optOmitComments <*> optNonumber <*> optSequence + <*> optCanonize <*> optDepthSensitive <*> switch (long "quiet" <> help "Don't print the result of dataization") <*> optCompress @@ -344,6 +348,7 @@ <*> optMaxCycles <*> optHide <*> optShow + <*> strOption (long "locator" <> metavar "FQN" <> help "Location of object to dataize. Must be a valid dispatch expression; e.g. Q.foo.bar" <> value "Q" <> showDefault) <*> optExpression <*> optLabel <*> optMeetPrefix @@ -377,7 +382,7 @@ <*> optNonumber <*> switch (long "in-place" <> help "Edit file in-place instead of printing to output") <*> optSequence - <*> switch (long "canonize" <> help "Rename all functions attached to λ binding with F1, F2, etc.") + <*> optCanonize <*> optCompress <*> optMaxDepth <*> optMaxCycles @@ -464,8 +469,8 @@ case cmd of CmdRewrite OptsRewrite{..} -> do validateOpts - excluded <- expressionsToFilter "hide" hide - included <- expressionsToFilter "show" show' + excluded <- validatedDispatches "hide" hide + included <- validatedDispatches "show" show' logDebug (printf "Amount of rewriting cycles across all the rules: %d, per rule: %d" maxCycles maxDepth) input <- readInput inputFile rules' <- getRules normalize shuffle rules @@ -505,6 +510,8 @@ logDebug (printf "The option '--in-place' is specified, writing back to '%s'..." file) writeFile file prog logDebug (printf "The file '%s' was modified in-place" file) + (True, _, Nothing) -> + error "The option --in-place requires an input file" (False, Just file, _) -> do logDebug (printf "The option '--target' is specified, printing to '%s'..." file) writeFile file prog @@ -523,15 +530,17 @@ (saveStepFunc stepsDir ctx) CmdDataize OptsDataize{..} -> do validateOpts - excluded <- expressionsToFilter "hide" hide - included <- expressionsToFilter "show" show' + excluded <- validatedDispatches "hide" hide + included <- validatedDispatches "show" show' + [loc] <- validatedDispatches "locator" [locator] input <- readInput inputFile prog <- parseProgram input inputFormat let printCtx = PrintProgCtx sugarType flat defaultXmirContext nonumber compress expression label meetPrefix outputFormat + _canonize = if canonize then C.canonize else id _hide = (`F.exclude` excluded) _show = (`F.include` included) - (maybeBytes, seq) <- dataize prog (context prog printCtx) - when sequence (printRewrittens printCtx (_hide (_show seq)) >>= putStrLn) + (maybeBytes, seq) <- dataize loc (context prog printCtx) + when sequence (printRewrittens printCtx (_canonize $ _hide $ _show seq) >>= putStrLn) unless quiet (putStrLn (maybe (P.printExpression ExTermination) P.printBytes maybeBytes)) where validateOpts :: IO () @@ -556,7 +565,6 @@ CmdExplain OptsExplain{..} -> do validateOpts rules' <- getRules normalize shuffle rules - let latex = explainRules rules' output targetFile (explainRules rules') where validateOpts :: IO () @@ -606,17 +614,17 @@ | outputFormat == LATEX = "tex" | otherwise = show outputFormat --- Get list of expressions which must be hidden in printed programs -expressionsToFilter :: String -> [String] -> IO [Expression] -expressionsToFilter opt = traverse (parseExpressionThrows >=> asFilter) +-- Validate given expressions as valid dispatches +validatedDispatches :: String -> [String] -> IO [Expression] +validatedDispatches opt = traverse (parseExpressionThrows >=> asDispatch) where - asFilter :: Expression -> IO Expression - asFilter expr = asFilter' expr + asDispatch :: Expression -> IO Expression + asDispatch expr = asDispatch' expr where - asFilter' :: Expression -> IO Expression - asFilter' exp@(ExDispatch ExGlobal _) = pure exp - asFilter' exp@(ExDispatch expr attr) = asFilter' expr >> pure exp - asFilter' _ = + asDispatch' :: Expression -> IO Expression + asDispatch' exp@ExGlobal = pure exp + asDispatch' exp@(ExDispatch ex _) = asDispatch' ex >> pure exp + asDispatch' _ = invalidCLIArguments ( printf "Only dispatch expression started with Φ (or Q) can be used in --%s, but given: %s" @@ -665,6 +673,7 @@ parseProgram xmir XMIR = do doc <- parseXMIRThrows xmir xmirToPhi doc +parseProgram _ LATEX = invalidCLIArguments "LaTeX cannot be used as input format" printRewrittens :: PrintProgramContext -> [Rewritten] -> IO String printRewrittens ctx@PrintProgCtx{..} rewrittens diff --git a/src/CST.hs b/src/CST.hs --- a/src/CST.hs +++ b/src/CST.hs @@ -2,6 +2,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wno-partial-fields -Wno-name-shadowing #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT @@ -9,9 +11,8 @@ module CST where import AST -import Data.List (intercalate) import Data.Maybe (isJust) -import Misc +import Misc (btsToNum, btsToStr, matchDataObject, pattern BaseObject, pattern DataNumber, pattern DataString) data LCB = LCB | BIG_LCB deriving (Eq, Show) @@ -173,7 +174,7 @@ programToCST prog = toCST prog 0 EOL expressionToCST :: Expression -> EXPRESSION -expressionToCST expr = toCST expr 0 EOL +expressionToCST ex = toCST ex 0 EOL -- This class is used to convert AST to CST -- CST is created with sugar and unicode @@ -226,33 +227,33 @@ -- If given application is not such primitive - we just convert it to one of the applications: -- 1. either with pure expression with arguments, which means there are incremented only alpha bindings -- 2. or with just bindings - toCST app@(ExApplication exp tau) tabs eol = - let (expr, taus, exprs) = complexApplication app - expr' = toCST expr tabs eol :: EXPRESSION + toCST app@(ExApplication _ _) tabs eol = + let (ex, ts, exs) = complexApplication app + ex' = toCST ex tabs eol :: EXPRESSION next = tabs + 1 - (taus', rhos) = withoutRhosInPrimitives expr taus - obj = ExApplication expr (head taus') - in if length taus' == 1 && isJust (matchDataObject obj) - then applicationToPrimitive obj tabs rhos + (ts', rs) = withoutRhosInPrimitives ex ts + obj = ExApplication ex (head ts') + in if length ts' == 1 && isJust (matchDataObject obj) + then applicationToPrimitive obj tabs rs else - if null exprs + if null exs then - let eol' = inlinedEOL (not (hasEOL taus)) + let eol' = inlinedEOL (not (hasEOL ts)) in EX_APPLICATION_TAUS - expr' + ex' eol' (tabOfEOL eol' next) - (toCST taus next eol' :: BINDING) + (toCST ts next eol' :: BINDING) eol' (tabOfEOL eol' tabs) next else - let eol' = inlinedEOL (not (hasEOL exprs)) + let eol' = inlinedEOL (not (hasEOL exs)) in EX_APPLICATION_EXPRS - expr' + ex' eol' (tabOfEOL eol' next) - (toCST exprs next eol') + (toCST exs next eol') eol' (tabOfEOL eol' tabs) next @@ -275,6 +276,7 @@ applicationToPrimitive :: Expression -> Int -> [Binding] -> EXPRESSION applicationToPrimitive (DataNumber bts) tabs = EX_NUMBER (btsToNum bts) (TAB tabs) applicationToPrimitive (DataString bts) tabs = EX_STRING (btsToStr bts) (TAB tabs) + applicationToPrimitive _ _ = error "applicationToPrimitive expects DataNumber or DataString" -- Here we unroll nested application sequence into flat structure -- The returned tuple consists of: -- 1. deepest start expression @@ -294,15 +296,17 @@ then (before, taus', []) else case tau' of BiTau (AtAlpha idx) expr' -> - if idx == fromIntegral (length exprs) + if idx == 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], []) + complexApplication' expr = (expr, [], []) instance ToCST [Expression] APP_ARG where toCST (expr : exprs) tabs eol = APP_ARG (toCST expr tabs eol) (toCST exprs tabs eol) + toCST [] _ _ = error "toCST APP_ARG requires non-empty expression list" instance ToCST [Expression] APP_ARGS where toCST [] _ _ = AAS_EMPTY @@ -342,9 +346,11 @@ toCST (BiDelta bts) tabs eol = PA_DELTA (toCST bts tabs eol) toCST (BiLambda func) _ _ = PA_LAMBDA func toCST (BiMetaLambda mt) _ _ = PA_META_LAMBDA (MT_FUNCTION (tail mt)) + toCST (BiMeta mt) _ _ = error $ "BiMeta binding " ++ mt ++ " cannot be converted to PAIR" instance ToCST Binding APP_BINDING where toCST bd@(BiTau _ _) tabs eol = APP_BINDING (toCST bd tabs eol :: PAIR) + toCST bd _ _ = error $ "Only BiTau binding can be converted to APP_BINDING, got: " ++ show bd instance ToCST Bytes BYTES where toCST BtEmpty _ _ = BT_EMPTY @@ -378,7 +384,7 @@ instance HasEOL Binding where hasEOL (BiTau _ expr) = hasEOL expr - hasEOL bd = False + hasEOL _ = False instance HasEOL [Expression] where hasEOL [] = False @@ -392,4 +398,4 @@ hasEOL (BaseObject _) = False hasEOL (ExDispatch expr _) = hasEOL expr hasEOL (ExApplication expr tau) = hasEOL expr || hasEOL tau - hasEOL expr = False + hasEOL _ = False diff --git a/src/Condition.hs b/src/Condition.hs --- a/src/Condition.hs +++ b/src/Condition.hs @@ -159,5 +159,5 @@ parseConditionThrows :: String -> IO Y.Condition parseConditionThrows cnd = case parseCondition cnd of - Right condition -> pure condition + Right cond -> pure cond Left err -> throwIO (CouldNotParseCondition err) diff --git a/src/Dataize.hs b/src/Dataize.hs --- a/src/Dataize.hs +++ b/src/Dataize.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT @@ -9,16 +12,15 @@ import AST import Builder (contextualize) -import Control.Exception (throwIO) -import Data.IntMap (restrictKeys) +import Control.Exception (Exception, throwIO) import Data.List (partition) import Deps (BuildTermFunc, SaveStepFunc) import Misc import Must (Must (..)) +import Printer (printExpression) import Rewriter (RewriteContext (RewriteContext), Rewritten, rewrite') import Rule (RuleContext (RuleContext), isNF) import Text.Printf (printf) -import XMIR (XmirContext (XmirContext)) import Yaml (normalizationRules) type Dataized = (Maybe Bytes, [Rewritten]) @@ -27,6 +29,19 @@ type Morphed = Dataizable +data LocatorException + = CanNotFindObjectByLocator {fqn :: Expression} + | InvalidLocatorProvided {fqn :: Expression} + deriving Exception + +instance Show LocatorException where + show CanNotFindObjectByLocator{..} = printf "Can't find object by locator: '%s'" (printExpression fqn) + show InvalidLocatorProvided{..} = + printf + "Can't dataize object by invalid locator. \ + \'Q' or dispatch started with 'Q' expected, but got: '%s'" + (printExpression fqn) + data DataizeContext = DataizeContext { _program :: Program , _maxDepth :: Int @@ -132,7 +147,7 @@ -- M(e) -> ⊥ otherwise morph :: Morphed -> DataizeContext -> IO Morphed morph (ExTermination, seq) _ = pure (ExTermination, leadsTo seq "Mprim" ExTermination) -- PRIM -morph (form@(ExFormation bds), seq) ctx = do +morph (form@(ExFormation _), seq) ctx = do resolved <- withTail form ctx case resolved of Just (expr, rule) -> morph (expr, leadsTo seq rule expr) ctx -- LAMBDA or PHI @@ -150,41 +165,64 @@ (Program expr') = fst (head _seq) morph (expr', _seq) ctx +dataize :: Expression -> DataizeContext -> IO Dataized +dataize locator ctx@DataizeContext{_program = Program expr} = do + fqn <- case fqnToAttrs locator of + Just attrs -> pure attrs + _ -> throwIO (InvalidLocatorProvided locator) + exp <- located expr fqn + (maybeBytes, seq) <- dataize' (exp, [(Program exp, Nothing)]) ctx + pure (maybeBytes, reverse seq) + where + located :: Expression -> [Attribute] -> IO Expression + located expr [] = pure expr + located (ExFormation bds) [attr] = case locatedInBindings attr bds of + Just expr -> pure expr + _ -> throwIO (CanNotFindObjectByLocator locator) + located (ExFormation bds) (attr : rest) = case locatedInBindings attr bds of + Just expr -> located expr rest + _ -> throwIO (CanNotFindObjectByLocator locator) + located _ _ = throwIO (CanNotFindObjectByLocator locator) + locatedInBindings :: Attribute -> [Binding] -> Maybe Expression + locatedInBindings _ [] = Nothing + locatedInBindings attr (BiTau attr' expr : rest) + | attr == attr' = Just expr + | otherwise = locatedInBindings attr rest + locatedInBindings attr (_ : rest) = locatedInBindings attr rest + -- The goal of 'dataize' function is retrieve bytes from given expression. -- -- DELTA: D(e) -> data if e = [B1, Δ -> data, B2] -- BOX: D([B1, 𝜑 -> e, B2]) -> D(С(e)) if [B1,B2] has no delta/lambda, where С(e) - contextualization -- NORM: D(e1) -> D(e2) if e2 := M(e1) and e1 is not primitive -- nothing otherwise -dataize :: Program -> DataizeContext -> IO Dataized -dataize (Program expr) ctx = do - (maybeBytes, seq) <- dataize' (expr, [(Program expr, Nothing)]) ctx - pure (maybeBytes, reverse seq) - dataize' :: Dataizable -> DataizeContext -> IO Dataized dataize' (ExTermination, seq) _ = pure (Nothing, seq) dataize' (ExFormation bds, seq) ctx = case maybeDelta bds of (Just (BiDelta bytes), _) -> pure (Just bytes, seq) + (Just _, _) -> pure (Nothing, seq) (Nothing, _) -> case maybePhi bds of (Just (BiTau AtPhi expr), bds') -> case maybeLambda bds' of (Just (BiLambda _), _) -> throwIO (userError "The 𝜑 and λ can't be present in formation at the same time") - (_, _) -> + (Just _, _) -> pure (Nothing, seq) + (Nothing, _) -> let expr' = contextualize expr (ExFormation bds) in dataize' (expr', leadsTo seq "contextualize" expr') ctx + (Just _, _) -> pure (Nothing, seq) (Nothing, _) -> case maybeLambda bds of (Just (BiLambda _), _) -> morph (ExFormation bds, seq) ctx >>= (`dataize'` ctx) + (Just _, _) -> pure (Nothing, seq) (Nothing, _) -> pure (Nothing, seq) dataize' dataizable ctx = morph dataizable ctx >>= (`dataize'` ctx) leadsTo :: [Rewritten] -> String -> Expression -> [Rewritten] -leadsTo seq rule expr = - let (prog, _) : rest = seq - in (Program expr, Nothing) : (prog, Just rule) : rest +leadsTo [] rule expr = [(Program expr, Just rule)] +leadsTo ((prog, _) : rest) rule expr = (Program expr, Nothing) : (prog, Just rule) : rest atom :: String -> Expression -> DataizeContext -> IO Expression atom "L_org_eolang_number_plus" self ctx = do - (left, _) <- dataize (Program (ExDispatch self (AtLabel "x"))) ctx - (right, _) <- dataize (Program (ExDispatch self AtRho)) ctx + (left, _) <- dataize' (ExDispatch self (AtLabel "x"), []) ctx + (right, _) <- dataize' (ExDispatch self AtRho, []) ctx case (left, right) of (Just left', Just right') -> do let first = either toDouble id (btsToNum left') @@ -193,8 +231,8 @@ pure (DataNumber (numToBts sum)) _ -> pure ExTermination atom "L_org_eolang_number_times" self ctx = do - (left, _) <- dataize (Program (ExDispatch self (AtLabel "x"))) ctx - (right, _) <- dataize (Program (ExDispatch self AtRho)) ctx + (left, _) <- dataize' (ExDispatch self (AtLabel "x"), []) ctx + (right, _) <- dataize' (ExDispatch self AtRho, []) ctx case (left, right) of (Just left', Just right') -> do let first = either toDouble id (btsToNum left') @@ -203,8 +241,8 @@ pure (DataNumber (numToBts sum)) _ -> pure ExTermination atom "L_org_eolang_number_eq" self ctx = do - (x, _) <- dataize (Program (ExDispatch self (AtLabel "x"))) ctx - (rho, _) <- dataize (Program (ExDispatch self AtRho)) ctx + (x, _) <- dataize' (ExDispatch self (AtLabel "x"), []) ctx + (rho, _) <- dataize' (ExDispatch self AtRho, []) ctx case (x, rho) of (Just x', Just rho') -> do let self' = either toDouble id (btsToNum rho') diff --git a/src/Deps.hs b/src/Deps.hs --- a/src/Deps.hs +++ b/src/Deps.hs @@ -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 render prog step = do createDirectoryIfMissing True dir let path = dir printf "%05d.%s" step ext - content <- print prog + content <- render prog writeFile path content logDebug (printf "Saved step '%d' to '%s'" step path) diff --git a/src/Encoding.hs b/src/Encoding.hs --- a/src/Encoding.hs +++ b/src/Encoding.hs @@ -22,11 +22,11 @@ toASCII PR_SWEET{..} = PR_SWEET lcb (toASCII expr) rcb 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_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_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 tau) eol' tab' indent @@ -70,7 +70,7 @@ instance ToASCII ATTRIBUTE where toASCII AT_ALPHA{..} = AT_ALPHA ALPHA' idx - toASCII AT_PHI{..} = AT_PHI AT - toASCII AT_RHO{..} = AT_RHO CARET + toASCII AT_PHI{} = AT_PHI AT + toASCII AT_RHO{} = AT_RHO CARET toASCII AT_META{..} = AT_META (MT_ATTRIBUTE' (rest meta)) toASCII attr = attr diff --git a/src/Filter.hs b/src/Filter.hs --- a/src/Filter.hs +++ b/src/Filter.hs @@ -4,35 +4,26 @@ module Filter (include, exclude) where import AST -import Logger (logDebug) import Misc -import Printer (logPrintConfig, printExpression, printExpression', printProgram) import Rewriter -import Text.Printf (printf) -fqnToAttrs :: Expression -> [Attribute] -fqnToAttrs = reverse . fqnToAttrs' - where - fqnToAttrs' :: Expression -> [Attribute] - fqnToAttrs' (ExDispatch ExGlobal attr) = [attr] - fqnToAttrs' (ExDispatch expr attr) = attr : fqnToAttrs' expr - fqnToAttrs' expr = [] - exclude' :: Program -> [Expression] -> Program exclude' prog [] = prog -exclude' (Program expr@(ExFormation _)) (fqn : rest) = exclude' (Program (excludedFormation expr (fqnToAttrs fqn))) rest +exclude' prog@(Program ex@(ExFormation _)) (fqn : remaining) = case fqnToAttrs fqn of + Just fqn' -> exclude' (Program (excludedFormation ex fqn')) remaining + _ -> prog where excludedFormation :: Expression -> [Attribute] -> Expression - excludedFormation (ExFormation bds) [attr] = ExFormation [bd | bd <- bds, attributeFromBinding bd /= Just attr] - excludedFormation (ExFormation bds) attrs = ExFormation (excludedBindings bds attrs) + excludedFormation (ExFormation bindings) [at] = ExFormation [bd | bd <- bindings, attributeFromBinding bd /= Just at] + excludedFormation (ExFormation bindings) atts = ExFormation (excludedBindings bindings atts) where excludedBindings :: [Binding] -> [Attribute] -> [Binding] excludedBindings [] _ = [] - excludedBindings (bd@(BiTau attr form@(ExFormation _)) : bds) attrs@(attr' : rest) - | attr == attr' = BiTau attr (excludedFormation form rest) : bds - | otherwise = bd : excludedBindings bds attrs - excludedBindings (bd : bds) attrs = bd : excludedBindings bds attrs - excludedFormation expr _ = expr + excludedBindings (bd@(BiTau at' form@(ExFormation _)) : bs) as@(at'' : rs) + | at' == at'' = BiTau at' (excludedFormation form rs) : bs + | otherwise = bd : excludedBindings bs as + excludedBindings (bd : bs) as = bd : excludedBindings bs as + excludedFormation e _ = e exclude' prog _ = prog exclude :: [Rewritten] -> [Expression] -> [Rewritten] @@ -41,20 +32,24 @@ exclude ((program, maybeRule) : rest) exprs = (exclude' program exprs, maybeRule) : exclude rest exprs include' :: Program -> Expression -> Program -include' prog@(Program expr@(ExFormation _)) fqn = case includedFormation expr (fqnToAttrs fqn) of - Just expr -> Program expr - _ -> Program (ExFormation [BiVoid AtRho]) +include' (Program ex@(ExFormation _)) fqn = + let def = Program (ExFormation [BiVoid AtRho]) + in case fqnToAttrs fqn of + Just fqn' -> case includedFormation ex fqn' of + Just e -> Program e + _ -> def + _ -> def where includedFormation :: Expression -> [Attribute] -> Maybe Expression - includedFormation (ExFormation bds) [attr] = - let bds' = [bd | bd <- bds, attributeFromBinding bd == Just attr] - in if null bds' then Nothing else Just (ExFormation (withVoidRho bds')) - includedFormation (ExFormation bds) attrs = includedBindings bds attrs >>= (Just . ExFormation . (: [BiVoid AtRho])) + includedFormation (ExFormation bindings) [at] = + let bs = [bd | bd <- bindings, attributeFromBinding bd == Just at] + in if null bs then Nothing else Just (ExFormation (withVoidRho bs)) + includedFormation (ExFormation bindings) atts = includedBindings bindings atts >>= (Just . ExFormation . (: [BiVoid AtRho])) where includedBindings :: [Binding] -> [Attribute] -> Maybe Binding - includedBindings (bd@(BiTau attr form@(ExFormation _)) : bds) attrs@(attr' : rest) - | attr == attr' = includedFormation form rest >>= Just . BiTau attr - | otherwise = includedBindings bds attrs + includedBindings ((BiTau at' form@(ExFormation _)) : bs) as@(at'' : rs) + | at' == at'' = includedFormation form rs >>= Just . BiTau at' + | otherwise = includedBindings bs as includedBindings _ _ = Nothing includedFormation _ _ = Nothing include' _ _ = Program (ExFormation [BiVoid AtRho]) diff --git a/src/Functions.hs b/src/Functions.hs --- a/src/Functions.hs +++ b/src/Functions.hs @@ -8,7 +8,7 @@ import AST import Builder import Control.Exception (throwIO) -import Control.Monad (replicateM, when) +import Control.Monad (when) import qualified Data.ByteString.Char8 as B import Data.Functor import qualified Data.Set as Set @@ -140,9 +140,9 @@ Just body -> let (pat, rest) = nextUntilSlash body B.empty False (rep, flag) = nextUntilSlash rest B.empty True - in case [pat, rep, flag] of - [pat, rep, "g"] -> pure (pat, rep, True) - [pat, rep, ""] -> pure (pat, rep, False) + in case flag of + "g" -> pure (pat, rep, True) + "" -> pure (pat, rep, False) _ -> throwIO (userError "sed pattern must be in format s/pat/rep/[g]") _ -> throwIO (userError "sed pattern must start with s/") -- Cut part from given string until regular slash. @@ -182,12 +182,12 @@ str <- case expr' of DataNumber bts -> pure (DataString (strToBts (either show show (btsToNum bts)))) DataString bts -> pure (DataString bts) - exp -> + ex -> throwIO ( userError ( printf "Couldn't convert given expression to 'Φ̇.string' object, only 'Φ̇.number' or 'Φ̇.string' are allowed\n%s" - (printExpression exp) + (printExpression ex) ) ) pure (TeExpression str) @@ -227,21 +227,25 @@ join' :: [Binding] -> Set.Set Attribute -> [Binding] join' [] _ = [] join' (bd : bds) attrs = - let [attr] = attributesFromBindings [bd] - in if Set.member attr attrs + case attributesFromBindings [bd] of + [attr] -> + if Set.member attr attrs then if attr == AtRho || attr == AtDelta || attr == AtLambda then join' bds attrs else let new = case bd of - BiTau attr expr -> BiTau (updated attr attrs) expr - BiVoid attr -> BiVoid (updated attr attrs) + BiTau at ex -> BiTau (updated at attrs) ex + BiVoid at -> BiVoid (updated at attrs) + other -> other in new : join' bds attrs else bd : join' bds (Set.insert attr attrs) + _ -> bd : join' bds attrs updated :: Attribute -> Set.Set Attribute -> Attribute - updated attr attrs = - let (TeAttribute attr') = unsafePerformIO (_randomTau (map Y.ArgAttribute (Set.toList attrs)) subst) - in attr' + updated _ attrs = + case unsafePerformIO (_randomTau (map Y.ArgAttribute (Set.toList attrs)) subst) of + TeAttribute attr' -> attr' + _ -> AtLabel "unknown" _unsupported :: BuildTermFunc _unsupported func _ _ = throwIO (userError (printf "Function %s() is not supported or does not exist" func)) diff --git a/src/LaTeX.hs b/src/LaTeX.hs --- a/src/LaTeX.hs +++ b/src/LaTeX.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT @@ -19,12 +20,12 @@ import Data.List (intercalate, nub) import Data.Maybe (fromMaybe) import Encoding (Encoding (ASCII), withEncoding) -import Lining (LineFormat (MULTILINE, SINGLELINE), withLineFormat) +import Lining (LineFormat (MULTILINE), withLineFormat) import Matcher import Misc import Render (Render (render)) -import Replacer (ReplaceContext (ReplaceCtx), replaceProgram) -import Rewriter (Rewritten (..)) +import Replacer (replaceProgram) +import Rewriter (Rewritten) import Sugar (SugarType (SWEET), withSugarType) import Text.Printf (printf) import qualified Yaml as Y @@ -80,8 +81,9 @@ meetInPrograms prefix = meetInPrograms' 1 where meetInPrograms' :: Int -> [Program] -> [Program] + meetInPrograms' _ [] = [] meetInPrograms' _ [prog] = [prog] - meetInPrograms' idx progs@(first : rest) = + meetInPrograms' idx (first : rest) = let met = map (meetInProgram first) rest unique = nub (concat met) (frequent, _) = @@ -97,15 +99,17 @@ next = first : meetInPrograms' idx rest in case frequent of Just expr -> - let met' = map (filter (== expr)) met - (subst : substs) = matchProgram expr first - prog = replaceProgram (first, [expr], [ExPhiMeet prefix idx]) - prog' = replaceProgram (prog, map (const expr) substs, map (const (ExPhiAgain prefix idx)) substs) - rest' = zipWith (\prgm exprs -> replaceProgram (prgm, exprs, map (const (ExPhiAgain prefix idx)) exprs)) rest met' - found = filter (not . null) met' - in if length met' > 1 && toDouble (length found) / toDouble (length met') >= 0.5 - then prog' : meetInPrograms' (idx + 1) rest' - else next + case matchProgram expr first of + (_ : substs) -> + let met' = map (filter (== expr)) met + prog = replaceProgram (first, [expr], [ExPhiMeet prefix idx]) + prog' = replaceProgram (prog, map (const expr) substs, map (const (ExPhiAgain prefix idx)) substs) + rest' = zipWith (\prgm exprs -> replaceProgram (prgm, exprs, map (const (ExPhiAgain prefix idx)) exprs)) rest met' + found = filter (not . null) met' + in if length met' > 1 && toDouble (length found) / toDouble (length met') >= 0.5 + then prog' : meetInPrograms' (idx + 1) rest' + else next + [] -> next _ -> next renderToLatex :: Program -> LatexContext -> String diff --git a/src/Lining.hs b/src/Lining.hs --- a/src/Lining.hs +++ b/src/Lining.hs @@ -23,7 +23,7 @@ toSingleLine PR_SWEET{..} = PR_SWEET lcb (toSingleLine expr) rcb 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{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 tau) NO_EOL TAB' indent diff --git a/src/Logger.hs b/src/Logger.hs --- a/src/Logger.hs +++ b/src/Logger.hs @@ -22,25 +22,25 @@ data LogLevel = DEBUG | INFO | WARNING | ERROR | NONE deriving (Show, Ord, Eq, Bounded, Enum, Read) -data Logger = Logger {level :: LogLevel, lines :: Int} +data Logger = Logger {level :: LogLevel, lns :: Int} logger :: IORef Logger {-# NOINLINE logger #-} logger = unsafePerformIO (newIORef (Logger INFO 25)) setLogConfig :: LogLevel -> Int -> IO () -setLogConfig lvl lines = writeIORef logger (Logger lvl (fromIntegral lines)) +setLogConfig lvl cnt = writeIORef logger (Logger lvl cnt) logMessage :: LogLevel -> String -> IO () logMessage lvl message = do Logger{..} <- readIORef logger when - (lvl >= level && lines /= 0) - ( let lines' = DL.lines message - toPrint = take lines lines' + (lvl >= level && lns /= 0) + ( let split = DL.lines message + toPrint = take lns split msg - | lines == -1 = [message] - | length lines' > lines = toPrint ++ ["---| log is limited by --log-lines=" ++ show lines ++ " option |---"] + | lns == -1 = [message] + | length split > lns = toPrint ++ ["---| log is limited by --log-lines=" ++ show lns ++ " option |---"] | otherwise = toPrint in hPutStrLn stderr ("[" ++ show lvl ++ "]: " ++ DL.intercalate "\n" msg) ) diff --git a/src/Matcher.hs b/src/Matcher.hs --- a/src/Matcher.hs +++ b/src/Matcher.hs @@ -54,9 +54,10 @@ combine' :: [(String, MetaValue)] -> Map String MetaValue -> Maybe Subst combine' [] acc = Just (Subst acc) combine' ((key, MvExpression tgt scope) : rest) acc = case Map.lookup key acc of - Just (MvExpression expr _) - | expr == tgt -> combine' rest acc + Just (MvExpression expr' _) + | expr' == tgt -> combine' rest acc | otherwise -> Nothing + Just _ -> Nothing Nothing -> combine' rest (Map.insert key (MvExpression tgt scope) acc) combine' ((key, value) : rest) acc = case Map.lookup key acc of Just found @@ -136,7 +137,7 @@ matchExpression (ExFormation pbs) (ExFormation tbs) _ = matchBindings pbs tbs (ExFormation tbs) matchExpression (ExDispatch pexp pattr) (ExDispatch texp tattr) scope = combineMany (matchAttribute pattr tattr) (matchExpression pexp texp scope) matchExpression (ExApplication pexp pbd) (ExApplication texp tbd) scope = combineMany (matchExpression pexp texp scope) (matchBinding pbd tbd scope) -matchExpression (ExMetaTail exp meta) tgt scope = case tailExpressions exp tgt scope of +matchExpression (ExMetaTail expr meta) tgt scope = case tailExpressions expr tgt scope of ([], _) -> [] (substs, tails) -> combineMany substs [substSingle meta (MvTail tails)] matchExpression (ExPhiAgain prefix idx expr) (ExPhiAgain prefix' idx' expr') scope @@ -149,7 +150,7 @@ -- Deep match pattern to expression inside binding matchBindingExpression :: Binding -> Expression -> Expression -> [Subst] -matchBindingExpression (BiTau _ exp) ptn scope = matchExpressionDeep ptn exp scope +matchBindingExpression (BiTau _ expr) ptn scope = matchExpressionDeep ptn expr scope matchBindingExpression _ _ _ = [] -- Match expression with deep nested expression(s) matching @@ -158,10 +159,10 @@ let matched = matchExpression ptn tgt scope deep = case tgt of ExFormation bds -> concatMap (\bd -> matchBindingExpression bd ptn tgt) bds - ExDispatch exp _ -> matchExpressionDeep ptn exp scope - ExApplication exp tau -> matchExpressionDeep ptn exp scope ++ matchBindingExpression tau ptn scope + ExDispatch expr _ -> matchExpressionDeep ptn expr scope + ExApplication expr tau -> matchExpressionDeep ptn expr scope ++ matchBindingExpression tau ptn scope _ -> [] in matched ++ deep matchProgram :: Expression -> Program -> [Subst] -matchProgram ptn (Program exp) = matchExpressionDeep ptn exp defaultScope +matchProgram ptn (Program expr) = matchExpressionDeep ptn expr defaultScope diff --git a/src/Merge.hs b/src/Merge.hs --- a/src/Merge.hs +++ b/src/Merge.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE RecordWildCards #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT @@ -7,28 +6,24 @@ module Merge (merge) where import AST -import Control.Exception (throwIO) -import Control.Exception.Base +import Control.Exception.Base (Exception, throwIO) import Data.Functor ((<&>)) -import Deps (BuildTermFunc, Term (TeBindings)) -import Matcher (substEmpty) import Misc -import Printer (printBinding, printExpression, printProgram) +import Printer (printExpression, printProgram) import Text.Printf (printf) -import qualified Yaml as Y data MergeException - = WrongProgramFormat {program :: Program} - | CanNotMergeBinding {first :: Binding, second :: Binding} + = WrongProgramFormat Program + | CanNotMergeBinding Binding Binding | EmptyProgramList deriving (Exception) instance Show MergeException where - show WrongProgramFormat{..} = + show (WrongProgramFormat prog) = printf "Invalid program format, only programs with top level formations are supported for 'merge' command, given:\n%s" - (printProgram program) - show CanNotMergeBinding{..} = + (printProgram prog) + show (CanNotMergeBinding first second) = printf "Can't merge two bindings, conflict found:\n%s" (printExpression (ExFormation [first, second])) @@ -54,10 +49,10 @@ merge' :: [Program] -> IO Program merge' [] = throwIO EmptyProgramList -merge' [prog@(Program (ExFormation bds))] = pure prog -merge' (prog@(Program (ExFormation bds)) : rest) = do +merge' [p@(Program (ExFormation _))] = pure p +merge' (Program (ExFormation bindings) : rest) = do Program (ExFormation bds') <- merge' rest - merged <- mergeBindings bds' bds + merged <- mergeBindings bds' bindings pure (Program (ExFormation merged)) merge' (prog : _) = throwIO (WrongProgramFormat prog) diff --git a/src/Misc.hs b/src/Misc.hs --- a/src/Misc.hs +++ b/src/Misc.hs @@ -20,6 +20,7 @@ , shuffle , toDouble , btsToUnescapedStr + , fqnToAttrs , attributesFromBindings , attributesFromBindings' , attributeFromBinding @@ -42,12 +43,11 @@ import qualified Data.Aeson.KeyMap as KeyMap import Data.Binary.IEEE754 import Data.Bits (Bits (shiftL), (.|.)) -import qualified Data.Bits as IOArray import qualified Data.ByteString as B -import Data.ByteString.Builder (toLazyByteString, word64BE, word8) +import Data.ByteString.Builder (toLazyByteString, word64BE) import Data.ByteString.Lazy (unpack) import qualified Data.ByteString.Lazy.UTF8 as U -import Data.Char (chr, isPrint, ord) +import Data.Char (isPrint, ord) import Data.List (intercalate) import Data.Maybe (catMaybes) import qualified Data.Set as Set @@ -57,19 +57,23 @@ import qualified Data.Vector.Mutable as M import Data.Word (Word64, Word8) import Numeric (readHex) + +-- import Printer (printExpression) + +import Data.Functor ((<&>)) import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) import System.FilePath (()) import System.Random.Stateful import Text.Printf (printf) data FsException - = FileDoesNotExist {file :: FilePath} - | DirectoryDoesNotExist {dir :: FilePath} + = 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 + show FileDoesNotExist{..} = printf "File '%s' does not exist" _file + show DirectoryDoesNotExist{..} = printf "Directory '%s' does not exist" _dir matchBaseObject :: Expression -> Maybe String matchBaseObject (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel label)) = Just label @@ -175,15 +179,30 @@ where withVoidRho' :: [Binding] -> Bool -> [Binding] withVoidRho' [] hasRho = [BiVoid AtRho | not hasRho] - withVoidRho' (bd : bds) hasRho = + withVoidRho' (bd : rest) hasRho = case bd of - BiMeta _ -> bd : bds - BiVoid (AtMeta _) -> bd : bds - BiTau (AtMeta _) _ -> bd : bds - BiVoid AtRho -> bd : withVoidRho' bds True - BiTau AtRho _ -> bd : withVoidRho' bds True - _ -> bd : withVoidRho' bds hasRho + BiMeta _ -> bd : rest + BiVoid (AtMeta _) -> bd : rest + BiTau (AtMeta _) _ -> bd : rest + BiVoid AtRho -> bd : withVoidRho' rest True + BiTau AtRho _ -> bd : withVoidRho' rest True + _ -> bd : withVoidRho' rest hasRho +-- Transform dispatch to list of attributes +-- >>> fqnToAttrs (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang")) (AtLabel "number")) +-- Just [org,eolang,number] +-- >>> fqnToAttrs (ExFormation []) +-- Nothing +-- >>> fqnToAttrs ExGlobal +-- Just [] +fqnToAttrs :: Expression -> Maybe [Attribute] +fqnToAttrs expr = fqnToAttrs' expr <&> reverse + where + fqnToAttrs' :: Expression -> Maybe [Attribute] + fqnToAttrs' ExGlobal = Just [] + fqnToAttrs' (ExDispatch ex at) = fqnToAttrs' ex <&> (:) at + fqnToAttrs' _ = Nothing + ensuredFile :: FilePath -> IO FilePath ensuredFile pth = do exists <- doesFileExist pth @@ -222,12 +241,14 @@ btsToWord8 :: Bytes -> [Word8] btsToWord8 BtEmpty = [] btsToWord8 (BtOne bt) = case readHex bt of - [(hex, "")] -> [fromIntegral hex] + [(hex, "")] -> [fromIntegral (hex :: Integer)] _ -> error $ "Invalid hex byte; " ++ bt btsToWord8 (BtMany []) = [] btsToWord8 (BtMany (bt : bts)) = - let [next] = btsToWord8 (BtOne bt) - in next : btsToWord8 (BtMany bts) + case btsToWord8 (BtOne bt) of + [byte] -> byte : btsToWord8 (BtMany bts) + _ -> error $ "Invalid hex byte; " ++ bt +btsToWord8 (BtMeta mt) = error $ "Cannot convert meta bytes to Word8; " ++ mt -- >>> word8ToBytes [64, 20, 0] -- BtMany ["40","14","00"] @@ -368,7 +389,7 @@ M.swap v i j V.toList <$> V.freeze v -validateYamlObject :: (Applicative a, MonadFail a) => Object -> [String] -> a () +validateYamlObject :: (MonadFail a) => Object -> [String] -> a () validateYamlObject v keys = do let present = filter (`KeyMap.member` v) (map Key.fromString keys) current = KeyMap.keys v diff --git a/src/Must.hs b/src/Must.hs --- a/src/Must.hs +++ b/src/Must.hs @@ -17,9 +17,9 @@ show MtDisabled = "0" show (MtExact n) = show n show (MtRange Nothing Nothing) = ".." - show (MtRange Nothing (Just max)) = ".." ++ show max - show (MtRange (Just min) Nothing) = show min ++ ".." - show (MtRange (Just min) (Just max)) = show min ++ ".." ++ show max + show (MtRange Nothing (Just hi)) = ".." ++ show hi + show (MtRange (Just lo) Nothing) = show lo ++ ".." + show (MtRange (Just lo) (Just hi)) = show lo ++ ".." ++ show hi instance Read Must where readsPrec _ "0" = [(MtDisabled, "")] @@ -29,18 +29,18 @@ where parseRange :: String -> [(Must, String)] parseRange str = case break (== '.') str of - (minStr, '.' : '.' : maxStr) -> - let minPart = if null minStr then Nothing else readMaybe minStr - maxPart = if null maxStr then Nothing else readMaybe maxStr - in case (minPart, maxPart, null minStr, null maxStr) of + (loStr, '.' : '.' : hiStr) -> + let loPart = if null loStr then Nothing else readMaybe loStr + hiPart = if null hiStr then Nothing else readMaybe hiStr + in case (loPart, hiPart, null loStr, null hiStr) of (Nothing, Nothing, False, False) -> [] -- Invalid range: non-numeric values (Nothing, Nothing, True, True) -> [] -- Invalid range: empty range '..' - (Nothing, Just max, True, False) -> - [(MtRange Nothing (Just max), "") | max >= 0] - (Just min, Nothing, False, True) -> - [(MtRange (Just min) Nothing, "") | min >= 0] - (Just min, Just max, False, False) -> - [(MtRange (Just min) (Just max), "") | min >= 0 && max >= 0 && min <= max] + (Nothing, Just hi, True, False) -> + [(MtRange Nothing (Just hi), "") | hi >= 0] + (Just lo, Nothing, False, True) -> + [(MtRange (Just lo) Nothing, "") | lo >= 0] + (Just lo, Just hi, False, False) -> + [(MtRange (Just lo) (Just hi), "") | lo >= 0 && hi >= 0 && lo <= hi] _ -> [] -- Invalid range format _ -> [] -- Invalid range: expected format like '3..5', '3..', or '..5' parseExact :: String -> [(Must, String)] @@ -62,17 +62,17 @@ exceedsUpperBound :: Must -> Int -> Bool exceedsUpperBound MtDisabled _ = False exceedsUpperBound (MtExact n) current = current > n -exceedsUpperBound (MtRange _ (Just max)) current = current > max +exceedsUpperBound (MtRange _ (Just hi)) current = current > hi exceedsUpperBound (MtRange _ Nothing) _ = False validateMust :: Must -> Maybe String validateMust MtDisabled = Nothing validateMust (MtExact n) | n <= 0 = Just "--must exact value must be positive" -validateMust (MtRange (Just minVal) _) | minVal < 0 = Just "--must minimum must be non-negative" -validateMust (MtRange _ (Just maxVal)) | maxVal < 0 = Just "--must maximum must be non-negative" +validateMust (MtRange (Just lo) _) | lo < 0 = Just "--must minimum must be non-negative" +validateMust (MtRange _ (Just hi)) | hi < 0 = Just "--must maximum must be non-negative" validateMust (MtRange Nothing _) = Nothing validateMust (MtRange _ Nothing) = Nothing -validateMust (MtRange (Just min) (Just max)) - | min > max = Just (printf "--must range invalid: minimum (%d) is greater than maximum (%d)" min max) +validateMust (MtRange (Just lo) (Just hi)) + | lo > hi = Just (printf "--must range invalid: minimum (%d) is greater than maximum (%d)" lo hi) | otherwise = Nothing validateMust _ = Nothing diff --git a/src/Parser.hs b/src/Parser.hs --- a/src/Parser.hs +++ b/src/Parser.hs @@ -227,6 +227,7 @@ if n >= 0 && n <= 0x10FFFF then return (chr n) else fail ("Invalid Unicode code point: \\u" ++ hexDigits) + _ -> fail ("Invalid Unicode escape: \\u" ++ hexDigits) hexEscape :: Parser Char hexEscape = do digits <- count 2 hexDigitChar @@ -498,7 +499,7 @@ parseExpression = parse' "expression" expression parseExpressionThrows :: String -> IO Expression -parseExpressionThrows expression = case parseExpression expression of +parseExpressionThrows ex = case parseExpression ex of Right expr -> pure expr Left err -> throwIO (CouldNotParseExpression err) @@ -506,6 +507,6 @@ parseProgram = parse' "program" program parseProgramThrows :: String -> IO Program -parseProgramThrows program = case parseProgram program of +parseProgramThrows prg = case parseProgram prg of Right prog -> pure prog Left err -> throwIO (CouldNotParseProgram err) diff --git a/src/Printer.hs b/src/Printer.hs --- a/src/Printer.hs +++ b/src/Printer.hs @@ -15,7 +15,7 @@ , printExtraArg , printSubsts , printSubsts' - , PrintConfig (..) + , PrintConfig , logPrintConfig ) where @@ -47,18 +47,18 @@ printProgram prog = printProgram' prog defaultPrintConfig printExpression' :: Expression -> PrintConfig -> String -printExpression' expr (sugar, encoding, line) = render (withLineFormat line $ withEncoding encoding $ withSugarType sugar $ expressionToCST expr) +printExpression' ex (sugar, encoding, line) = render (withLineFormat line $ withEncoding encoding $ withSugarType sugar $ expressionToCST ex) printExpression :: Expression -> String -printExpression expr = printExpression' expr defaultPrintConfig +printExpression ex = printExpression' ex defaultPrintConfig printAttribute' :: Attribute -> Encoding -> String -printAttribute' attr encoding = render (withEncoding encoding (toCST attr 0 NO_EOL :: ATTRIBUTE)) +printAttribute' att encoding = render (withEncoding encoding (toCST att 0 NO_EOL :: ATTRIBUTE)) printAttribute :: Attribute -> String -printAttribute attr = +printAttribute att = let (_, encoding, _) = defaultPrintConfig - in printAttribute' attr encoding + in printAttribute' att encoding printBinding' :: Binding -> PrintConfig -> String printBinding' bd = printExpression' (ExFormation [bd]) @@ -70,24 +70,24 @@ printBytes bts = render (toCST bts 0 NO_EOL :: BYTES) printExtraArg' :: ExtraArgument -> PrintConfig -> String -printExtraArg' (ArgAttribute attr) (_, encoding, _) = printAttribute' attr encoding +printExtraArg' (ArgAttribute att) (_, encoding, _) = printAttribute' att encoding printExtraArg' (ArgBinding bd) config = printBinding' bd config -printExtraArg' (ArgExpression expr) config = printExpression' expr config +printExtraArg' (ArgExpression ex) config = printExpression' ex 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 +printTail (TaApplication bd) config = "(" <> printBinding' bd config <> ")" +printTail (TaDispatch att) (_, encoding, _) = "." <> printAttribute' att encoding printMetaValue :: MetaValue -> PrintConfig -> String -printMetaValue (MvAttribute attr) (_, encoding, _) = printAttribute' attr encoding -printMetaValue (MvExpression expr _) config = printExpression' expr config +printMetaValue (MvAttribute att) (_, encoding, _) = printAttribute' att encoding +printMetaValue (MvExpression ex _) config = printExpression' ex config printMetaValue (MvBytes bts) _ = printBytes bts printMetaValue (MvBindings bds) config = printExpression' (ExFormation bds) config -printMetaValue (MvFunction func) _ = func +printMetaValue (MvFunction fun) _ = fun printMetaValue (MvTail tails) config = intercalate "," (map (`printTail` config) tails) printSubst :: Subst -> PrintConfig -> String diff --git a/src/Render.hs b/src/Render.hs --- a/src/Render.hs +++ b/src/Render.hs @@ -7,10 +7,8 @@ module Render where -import AST import CST -import Data.List -import Data.Maybe (fromMaybe) +import Data.List (intercalate) class Render a where render :: a -> String @@ -102,6 +100,7 @@ render BT_EMPTY = "--" render (BT_ONE bte) = render bte <> "-" render (BT_MANY bts) = intercalate "-" bts + render (BT_META mt) = render mt instance Render META where render MT_EXPRESSION{..} = '𝑒' : rest @@ -120,7 +119,7 @@ render ALPHA' = "~" instance Render TAB where - render TAB{..} = intercalate "" (replicate (fromIntegral indent) " ") + render TAB{..} = intercalate "" (replicate indent " ") render TAB' = " " render NO_TAB = "" @@ -143,7 +142,7 @@ render PA_META_DELTA'{..} = render "D> " <> render meta instance Render BINDINGS where - render BDS_EMPTY{..} = "" + render BDS_EMPTY{} = "" render BDS_PAIR{..} = render COMMA <> render eol <> render tab <> render pair <> render bindings render BDS_META{..} = render COMMA <> render eol <> render tab <> render meta <> render bindings @@ -151,7 +150,7 @@ render APP_BINDING{..} = render pair instance Render BINDING where - render BI_EMPTY{..} = "" + render BI_EMPTY{} = "" render BI_PAIR{..} = render pair <> render bindings render BI_META{..} = render meta <> render bindings @@ -177,7 +176,7 @@ render EX_NUMBER{..} = either show show num render EX_META{..} = render meta render EX_META_TAIL{..} = render expr <> " * " <> render meta - render EX_PHI_MEET{..} = "\\phiMeet{" <> maybe "" (++ ":") prefix <> render idx <> "}{" <> render expr <> "}" + render EX_PHI_MEET{..} = "\\phiMeet{" <> maybe "" (++ ":") prefix <> render idx <> "}{ " <> render expr <> " }" render EX_PHI_AGAIN{..} = "\\phiAgain{" <> maybe "" (++ ":") prefix <> render idx <> "}" instance Render ATTRIBUTE where diff --git a/src/Replacer.hs b/src/Replacer.hs --- a/src/Replacer.hs +++ b/src/Replacer.hs @@ -15,11 +15,7 @@ where import AST -import Control.Exception (Exception, throwIO) import Data.List (isPrefixOf) -import Matcher (Tail (TaApplication, TaDispatch)) -import Printer (printProgram) -import Text.Printf (printf) type ReplaceState a = (a, [Expression], [Expression -> Expression]) @@ -30,9 +26,9 @@ newtype ReplaceContext = ReplaceCtx {_maxDepth :: Int} replaceBindings :: ReplaceState [Binding] -> ReplaceContext -> ReplaceExpressionFunc -> ReplaceState [Binding] -replaceBindings state@(bds, [], _) _ _ = state -replaceBindings state@(bds, _, []) _ _ = state -replaceBindings state@([], ptns, repls) _ _ = state +replaceBindings state@(_, [], _) _ _ = state +replaceBindings state@(_, _, []) _ _ = state +replaceBindings state@([], _, _) _ _ = state replaceBindings (BiTau attr expr : bds, ptns, repls) ctx func = let (expr', ptns', repls') = func (expr, ptns, repls) ctx (bds', ptns'', repls'') = replaceBindings (bds, ptns', repls') ctx func @@ -51,8 +47,9 @@ in (ExDispatch expr' attr, ptns', repls') ExApplication inner tau -> let (expr', ptns', repls') = replaceExpression (inner, ptns, repls) ctx - ([tau'], ptns'', repls'') = replaceBindings ([tau], ptns', repls') ctx replaceExpression - in (ExApplication expr' tau', ptns'', repls'') + in case replaceBindings ([tau], ptns', repls') ctx replaceExpression of + ([tau'], ptns'', repls'') -> (ExApplication expr' tau', ptns'', repls'') + (bds', _, _) -> error $ "Expected single binding, got " ++ show (length bds') ExFormation bds -> let (bds', ptns', repls') = replaceBindings (bds, ptns, repls) ctx replaceExpression in (ExFormation bds', ptns', repls') @@ -76,8 +73,8 @@ replaceExpressionFast = replaceExpressionFast' 0 where replaceExpressionFast' :: Int -> ReplaceExpressionFunc - replaceExpressionFast' _ state@(expr, [], _) _ = state - replaceExpressionFast' _ state@(expr, _, []) _ = state + replaceExpressionFast' _ state@(_, [], _) _ = state + replaceExpressionFast' _ state@(_, _, []) _ = state replaceExpressionFast' depth state@(expr, ptns, repls) ctx@ReplaceCtx{..} = if depth == _maxDepth then (expr, [], []) diff --git a/src/Rewriter.hs b/src/Rewriter.hs --- a/src/Rewriter.hs +++ b/src/Rewriter.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT @@ -13,23 +14,18 @@ import Builder import Control.Exception (Exception, throwIO) import Data.Char (toLower) -import Data.Foldable (foldlM) import Data.Functor ((<&>)) -import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes, fromMaybe, isJust) +import Data.Maybe (fromMaybe) import qualified Data.Set as Set import Deps import Logger (logDebug) -import Matcher (MetaValue (MvAttribute, MvBindings, MvBytes, MvExpression), Subst (Subst), combine, combineMany, defaultScope, matchProgram, substEmpty, substSingle) -import Misc (ensuredFile) +import Matcher (Subst) import Must (Must (..), exceedsUpperBound, inRange) -import Parser (parseProgram, parseProgramThrows) import Printer (printProgram) import Replacer (ReplaceContext (ReplaceCtx), ReplaceProgramFunc, replaceProgram, replaceProgramFast) -import Rule (RuleContext (RuleContext), matchProgramWithRule) +import Rule (RuleContext (RuleContext)) import qualified Rule as R -import Text.Printf -import Yaml (ExtraArgument (..)) +import Text.Printf (printf) import qualified Yaml as Y type RewriteState = ([Rewritten], Set.Set Program) @@ -48,36 +44,36 @@ } data RewriteException - = MustBeGoing {must :: Must, count :: Int} - | MustStopBefore {must :: Must, count :: Int} - | StoppedOnLimit {flag :: String, limit :: Int} - | LoopingRewriting {prog :: String, rule :: String, step :: Int} + = MustBeGoing Must Int + | MustStopBefore Must Int + | StoppedOnLimit String Int + | LoopingRewriting String String Int deriving (Exception) instance Show RewriteException where - show MustBeGoing{..} = + show (MustBeGoing mst cnt) = printf "With option --must=%s it's expected rewriting cycles to be in range [%s], but rewriting stopped after %d cycles" - (show must) - (show must) - count - show MustStopBefore{..} = + (show mst) + (show mst) + cnt + show (MustStopBefore mst cnt) = printf "With option --must=%s it's expected rewriting cycles to be in range [%s], but rewriting has already reached %d cycles and is still going" - (show must) - (show must) - count - show StoppedOnLimit{..} = + (show mst) + (show mst) + cnt + show (StoppedOnLimit flg lim) = printf "With option --depth-sensitive it's expected rewriting iterations amount does not reach the limit: --%s=%d" - flag - limit - show LoopingRewriting{..} = + flg + lim + show (LoopingRewriting prg rul stp) = printf "On rewriting step '%d' of rule '%s' we got the same program as we got at one of the previous step, it seems rewriting is looping\nProgram: %s" - step - rule - prog + stp + rul + prg -- Build pattern and result expression and replace patterns to results in given program buildAndReplace' :: ToReplace -> ReplaceProgramFunc -> IO Program @@ -178,16 +174,16 @@ _rewrite (leadsTo prog, Set.insert prog _unique) (_count + 1) where leadsTo :: Program -> [Rewritten] - leadsTo _prog = - let (program, _) : rest = _rewrittens - in (_prog, Nothing) : (program, Just (map toLower (fromMaybe "unknown" (Y.name rule)))) : rest + leadsTo _prog = case _rewrittens of + (program, _) : rest -> (_prog, Nothing) : (program, Just (map toLower (fromMaybe "unknown" (Y.name rule)))) : rest + [] -> [(_prog, Nothing)] -- The function accepts single program but returns sequence of programs rewrite' :: Program -> [Y.Rule] -> RewriteContext -> IO [Rewritten] rewrite' prog rules ctx = _rewrite ([(prog, Nothing)], Set.empty) 1 ctx <&> reverse where _rewrite :: RewriteState -> Int -> RewriteContext -> IO [Rewritten] - _rewrite state@(rewrittens, unique) count ctx@RewriteContext{..} = do + _rewrite state@(rewrittens, _) count ctx@RewriteContext{..} = do let cycles = _maxCycles must = _must current = count - 1 @@ -202,7 +198,7 @@ else pure rewrittens else do logDebug (printf "Starting rewriting cycle for all rules: %d out of %d" count cycles) - state'@(rewrittens', unique') <- rewrite state rules count ctx + state'@(rewrittens', _) <- rewrite state rules count ctx let (program', _) = head rewrittens' (program, _) = head rewrittens if program' == program diff --git a/src/Rule.hs b/src/Rule.hs --- a/src/Rule.hs +++ b/src/Rule.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT @@ -11,16 +12,10 @@ ( buildAttribute , buildBinding , buildBindingThrows - , buildExpression , buildExpressionThrows ) -import Control.Exception - ( SomeException (SomeException) - , evaluate - ) -import Control.Exception.Base (try) +import Control.Exception.Base (SomeException, 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 @@ -132,11 +127,11 @@ numToInt (Y.Ordinal (AtMeta meta)) (Subst mp) = case M.lookup meta mp of Just (MvAttribute (AtAlpha idx)) -> Just idx _ -> Nothing - numToInt (Y.Ordinal (AtAlpha idx)) subst = Just idx + numToInt (Y.Ordinal (AtAlpha idx)) _ = Just idx numToInt (Y.Length (BiMeta meta)) (Subst mp) = case M.lookup meta mp of Just (MvBindings bds) -> Just (length bds) _ -> Nothing - numToInt (Y.Literal num) subst = Just num + numToInt (Y.Literal num) _ = Just num numToInt _ _ = Nothing _eq (Y.CmpAttr left) (Y.CmpAttr right) subst _ = pure [subst | compareAttrs left right subst] where @@ -177,13 +172,14 @@ Just (MvExpression expr _) -> _xi expr (Subst mp) ctx _ -> pure [] _xi (ExFormation _) subst _ = pure [subst] -_xi ExThis subst _ = pure [] +_xi ExThis _ _ = pure [] _xi ExGlobal subst _ = pure [subst] -_xi (ExApplication expr (BiTau attr texpr)) subst ctx = do +_xi (ExApplication expr (BiTau _ texpr)) subst ctx = do onExpr <- _xi expr subst ctx onTau <- _xi texpr subst ctx pure [subst | not (null onExpr) && not (null onTau)] _xi (ExDispatch expr _) subst ctx = _xi expr subst ctx +_xi _ _ _ = pure [] _matches :: String -> Expression -> Subst -> RuleContext -> IO [Subst] _matches pat (ExMeta meta) (Subst mp) ctx = case M.lookup meta mp of @@ -201,10 +197,10 @@ pure [subst | partOf exp' bds] where partOf :: Expression -> [Binding] -> Bool - partOf expr [] = False + partOf _ [] = False partOf expr (BiTau _ (ExFormation bds) : rest) = expr == ExFormation bds || partOf expr bds || partOf expr rest partOf expr (BiTau _ expr' : rest) = expr == expr' || partOf expr rest - partOf expr (bd : rest) = partOf expr rest + partOf expr (_ : rest) = partOf expr rest meetCondition' :: Y.Condition -> Subst -> RuleContext -> IO [Subst] meetCondition' (Y.Or conds) = _or conds @@ -246,32 +242,34 @@ res <- sequence [ foldlM - ( \(Just subst') extra -> do - let maybeName = case Y.meta extra of - Y.ArgExpression (ExMeta name) -> Just name - Y.ArgAttribute (AtMeta name) -> Just name - Y.ArgBinding (BiMeta name) -> Just name - Y.ArgBytes (BtMeta name) -> Just name - _ -> Nothing - func = Y.function extra - args = Y.args extra - term <- _buildTerm func args subst' - meta <- case term of - TeExpression expr -> do - 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 (printAttribute attr)) - pure (MvAttribute attr) - TeBytes bytes -> do - logDebug (printf "Function %s() returned bytes: %s" func (printBytes bytes)) - pure (MvBytes bytes) - TeBindings bds -> do - 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') - _ -> pure Nothing + ( \maybeSubst extra -> case maybeSubst of + Nothing -> pure Nothing + Just subst' -> do + let maybeName = case Y.meta extra of + Y.ArgExpression (ExMeta name) -> Just name + Y.ArgAttribute (AtMeta name) -> Just name + Y.ArgBinding (BiMeta name) -> Just name + Y.ArgBytes (BtMeta name) -> Just name + _ -> Nothing + func = Y.function extra + args = Y.args extra + term <- _buildTerm func args subst' + meta <- case term of + TeExpression expr -> do + 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 (printAttribute attr)) + pure (MvAttribute attr) + TeBytes bytes -> do + logDebug (printf "Function %s() returned bytes: %s" func (printBytes bytes)) + pure (MvBytes bytes) + TeBindings bds -> do + 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') + _ -> pure Nothing ) (Just subst) extras' diff --git a/src/Sugar.hs b/src/Sugar.hs --- a/src/Sugar.hs +++ b/src/Sugar.hs @@ -1,6 +1,8 @@ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT @@ -9,7 +11,7 @@ import AST import CST -import Misc +import Misc (numToBts, strToBts, toDouble, pattern BaseObject) withSugarType :: (ToSalty a) => SugarType -> a -> a withSugarType SWEET prog = prog @@ -29,6 +31,8 @@ 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) + bdsWithVoidRho bds@BDS_META{} = bds +bdWithVoidRho bd@BI_META{} = bd data SugarType = SWEET | SALTY deriving (Eq, Show) @@ -56,10 +60,10 @@ 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_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{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 indent) (toSalty tau) EOL (TAB (indent - 1)) indent toSalty EX_APPLICATION_TAUS{..} = @@ -73,9 +77,12 @@ EX_APPLICATION (toSalty exp) EOL (TAB indent) (APP_BINDING (toSalty pair)) EOL (TAB (indent - 1)) indent tauToPairs :: BINDING -> [PAIR] tauToPairs BI_PAIR{..} = pair : tausToPairs bindings + tauToPairs BI_EMPTY{} = [] + tauToPairs (BI_META mt _ _) = error $ "BI_META " ++ show mt ++ " unexpected in tauToPairs" tausToPairs :: BINDINGS -> [PAIR] - tausToPairs BDS_EMPTY{..} = [] + tausToPairs BDS_EMPTY{} = [] tausToPairs BDS_PAIR{..} = pair : tausToPairs bindings + tausToPairs (BDS_META _ _ mt _) = error $ "BDS_META " ++ show mt ++ " unexpected in tausToPairs" toSalty EX_APPLICATION_EXPRS{..} = toSalty (EX_APPLICATION_TAUS expr EOL (TAB indent) (argToBinding args tab) EOL (TAB (indent - 1)) indent) where argToBinding :: APP_ARG -> TAB -> BINDING @@ -133,6 +140,8 @@ tb (indent + 1) ) +saltifyPrimitive _ _ _ TAB' _ = error "saltifyPrimitive requires TAB with indent, got TAB'" +saltifyPrimitive _ _ _ NO_TAB _ = error "saltifyPrimitive requires TAB with indent, got NO_TAB" instance ToSalty BINDING where toSalty BI_PAIR{..} = BI_PAIR (toSalty pair) (toSalty bindings) tab @@ -147,7 +156,7 @@ instance ToSalty PAIR where toSalty PA_TAU{..} = PA_TAU attr arrow (toSalty expr) - toSalty PA_FORMATION{voids, attr, arrow, expr = expr@EX_FORMATION{..}} = + toSalty PA_FORMATION{voids, attr, arrow, expr = EX_FORMATION{..}} = PA_TAU attr arrow (toSalty (EX_FORMATION lsb eol tab (joinToBinding voids binding) eol' tab' rsb)) where joinToBinding :: [ATTRIBUTE] -> BINDING -> BINDING @@ -156,5 +165,6 @@ joinToBindings :: [ATTRIBUTE] -> BINDING -> BINDINGS joinToBindings [] BI_EMPTY{..} = BDS_EMPTY tab joinToBindings [] BI_PAIR{..} = BDS_PAIR eol tab pair bindings + joinToBindings [] BI_META{} = error "BI_META unexpected in joinToBindings" joinToBindings (attr : rest) bd = BDS_PAIR eol tab (PA_VOID attr arrow EMPTY) (joinToBindings rest bd) toSalty pair = pair diff --git a/src/XMIR.hs b/src/XMIR.hs --- a/src/XMIR.hs +++ b/src/XMIR.hs @@ -19,20 +19,16 @@ where import AST -import Control.Exception (Exception (displayException), SomeException, throwIO) -import Control.Exception.Base (Exception) +import Control.Exception (Exception (displayException), throwIO) import qualified Data.Bifunctor import Data.Foldable (foldlM) import Data.List (intercalate) -import qualified Data.List -import Data.Map (Map) import qualified Data.Map as M -import Data.Maybe (catMaybes, mapMaybe) -import Data.Text (Text) +import Data.Maybe (catMaybes) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TB -import Data.Time +import Data.Time (UTCTime, getCurrentTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Data.Time.Format (defaultTimeLocale, formatTime) import Data.Version (showVersion) @@ -54,23 +50,23 @@ defaultXmirContext = XmirContext True True (const "") data XMIRException - = UnsupportedProgram {prog :: Program} - | UnsupportedExpression {expr :: Expression} - | UnsupportedBinding {binding :: Binding} - | CouldNotParseXMIR {message :: String} - | InvalidXMIRFormat {message :: String, cursor :: C.Cursor} + = UnsupportedProgram Program + | UnsupportedExpression Expression + | UnsupportedBinding Binding + | CouldNotParseXMIR String + | InvalidXMIRFormat String C.Cursor deriving (Exception) instance Show XMIRException where - 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{..} = + show (UnsupportedProgram prog) = printf "XMIR does not support such program:\n%s" (printProgram prog) + show (UnsupportedExpression expr) = printf "XMIR does not support such expression:\n%s" (printExpression expr) + show (UnsupportedBinding bd) = printf "XMIR does not support such bindings: %s" (printBinding bd) + show (CouldNotParseXMIR msg) = printf "Couldn't parse given XMIR, cause: %s" msg + show (InvalidXMIRFormat msg cur) = printf "Couldn't traverse though given XMIR, cause: %s\nXMIR:\n%s" - message - ( case C.node cursor of + msg + ( case C.node cur of NodeElement el -> printXMIR (Document (Prologue [] Nothing []) el []) _ -> "Unknown" ) @@ -154,7 +150,7 @@ pure (Just (object [("name", show AtPhi), ("base", base)] children)) formationBinding (BiTau AtRho _) _ = pure Nothing formationBinding (BiDelta bytes) _ = pure (Just (NodeContent (T.pack (printBytes bytes)))) -formationBinding (BiLambda func) _ = pure (Just (object [("name", show AtLambda)] [])) +formationBinding (BiLambda _) _ = pure (Just (object [("name", show AtLambda)] [])) formationBinding (BiVoid AtRho) _ = pure Nothing formationBinding (BiVoid AtPhi) _ = pure (Just (object [("name", show AtPhi), ("base", "∅")] [])) formationBinding (BiVoid (AtLabel label)) _ = pure (Just (object [("name", label), ("base", "∅")] [])) @@ -214,15 +210,15 @@ getPackage (ExFormation [BiTau (AtLabel label) (ExFormation [bd, BiLambda "Package", BiVoid AtRho]), BiLambda "Package", BiVoid AtRho]) = do (pckg, expr') <- getPackage (ExFormation [bd, BiLambda "Package", BiVoid AtRho]) pure (label : pckg, expr') - getPackage (ExFormation [BiTau attr expr, BiLambda "Package", BiVoid AtRho]) = pure ([], ExFormation [BiTau attr expr, BiVoid AtRho]) + getPackage (ExFormation [BiTau at ex, BiLambda "Package", BiVoid AtRho]) = pure ([], ExFormation [BiTau at ex, 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" (printExpression expr))) + getPackage ex = throwIO (userError (printf "Can't extract package from given expression:\n %s" (printExpression ex))) -- Convert root Expression to Node rootExpression :: Expression -> XmirContext -> IO Node - rootExpression (ExFormation [bd, BiVoid AtRho]) ctx = do - [bd'] <- nestedBindings [bd] ctx + rootExpression (ExFormation [bd, BiVoid AtRho]) c = do + [bd'] <- nestedBindings [bd] c pure bd' - rootExpression expr _ = throwIO (UnsupportedExpression expr) + rootExpression ex _ = throwIO (UnsupportedExpression ex) -- Returns metas Node with package: -- -- @@ -432,16 +428,16 @@ pure (ExFormation (withVoidRho bds)) where xmirToExpression' :: Expression -> String -> String -> C.Cursor -> [String] -> IO Expression - xmirToExpression' start symbol rest cur fqn = - if null rest - then throwIO (InvalidXMIRFormat (printf "The @base='%s.' is illegal in XMIR" symbol) cur) + xmirToExpression' start symbol rst c names = + if null rst + then throwIO (InvalidXMIRFormat (printf "The @base='%s.' is illegal in XMIR" symbol) c) else do head' <- foldlM - (\acc part -> ExDispatch acc <$> toAttr (T.unpack part) cur) + (\acc part -> ExDispatch acc <$> toAttr (T.unpack part) c) start - (T.splitOn "." (T.pack rest)) - xmirToApplication head' (cur C.$/ C.element (toName "o")) fqn + (T.splitOn "." (T.pack rst)) + xmirToApplication head' (c C.$/ C.element (toName "o")) names xmirToApplication :: Expression -> [C.Cursor] -> [String] -> IO Expression xmirToApplication = xmirToApplication' 0 diff --git a/src/Yaml.hs b/src/Yaml.hs --- a/src/Yaml.hs +++ b/src/Yaml.hs @@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT @@ -16,14 +17,14 @@ import Data.Text (unpack) import Data.Yaml (Parser) import qualified Data.Yaml as Yaml -import GHC.Generics -import Misc (allPathsIn, validateYamlObject) +import GHC.Generics (Generic) +import Misc (validateYamlObject) import Parser parseJSON' :: String -> (String -> Either String a) -> Value -> Parser a -parseJSON' name func = +parseJSON' nm func = withText - name + nm ( \txt -> case func (unpack txt) of Left err -> fail err Right parsed -> pure parsed @@ -99,12 +100,12 @@ , do vals <- v .: "matches" case vals of - [pat, exp] -> Matches <$> parseJSON pat <*> parseJSON exp + [pat, ex] -> Matches <$> parseJSON pat <*> parseJSON ex _ -> fail "'matches' expects exactly two arguments" , do vals <- v .: "part-of" case vals of - [exp, bd] -> PartOf <$> parseJSON exp <*> parseJSON bd + [ex, bd] -> PartOf <$> parseJSON ex <*> parseJSON bd _ -> fail "'part-of' expects exactly two arguments" ] ) diff --git a/test/CLISpec.hs b/test/CLISpec.hs --- a/test/CLISpec.hs +++ b/test/CLISpec.hs @@ -238,6 +238,11 @@ ["rewrite", "--show=Q.x(Q.y)"] ["[ERROR]:", "Only dispatch expression started with Φ (or Q) can be used in --show"] + it "prints help" $ + testCLISucceeded + ["rewrite", "--help"] + ["Rewrite the 𝜑-program"] + it "saves steps to dir with --steps-dir" $ do let dir = "test-steps-temp" dirExists <- doesDirectoryExist dir @@ -426,7 +431,7 @@ [ unlines [ "\\begin{phiquation}" , "\\Big\\{[[ |x| -> ?, |y| -> |x| ]]( |x| -> [[ D> 42- ]] ).|y|\\Big\\} \\leadsto_{\\nameref{r:copy}}" - , " \\leadsto \\Big\\{\\phiMeet{foo:1}{[[ |x| -> [[ D> 42- ]], |y| -> |x| ]]}.|y|\\Big\\} \\leadsto_{\\nameref{r:dot}}" + , " \\leadsto \\Big\\{\\phiMeet{foo:1}{ [[ |x| -> [[ D> 42- ]], |y| -> |x| ]] }.|y|\\Big\\} \\leadsto_{\\nameref{r:dot}}" , " \\leadsto \\Big\\{\\phiAgain{foo:1}.|x|( ^ -> \\phiAgain{foo:1} )\\Big\\} \\leadsto_{\\nameref{r:dot}}" , " \\leadsto \\Big\\{[[ D> 42- ]]( ^ -> \\phiAgain{foo:1}, ^ -> \\phiAgain{foo:1} )\\Big\\} \\leadsto_{\\nameref{r:copy}}" , " \\leadsto \\Big\\{[[ D> 42-, ^ -> \\phiAgain{foo:1} ]]( ^ -> \\phiAgain{foo:1} )\\Big\\} \\leadsto_{\\nameref{r:stay}}" @@ -442,7 +447,7 @@ [ unlines [ "\\begin{phiquation}" , "\\Big\\{[[ |x| -> ?, |y| -> |x| ]]( |x| -> [[ D> 42- ]] ).|y|\\Big\\} \\leadsto_{\\nameref{r:copy}}" - , " \\leadsto \\Big\\{\\phiMeet{1}{[[ |x| -> [[ D> 42- ]], |y| -> |x| ]]}.|y|\\Big\\} \\leadsto_{\\nameref{r:dot}}" + , " \\leadsto \\Big\\{\\phiMeet{1}{ [[ |x| -> [[ D> 42- ]], |y| -> |x| ]] }.|y|\\Big\\} \\leadsto_{\\nameref{r:dot}}" , " \\leadsto \\Big\\{\\phiAgain{1}.|x|( ^ -> \\phiAgain{1} )\\Big\\} \\leadsto_{\\nameref{r:dot}}" , " \\leadsto \\Big\\{[[ D> 42- ]]( ^ -> \\phiAgain{1}, ^ -> \\phiAgain{1} )\\Big\\} \\leadsto_{\\nameref{r:copy}}" , " \\leadsto \\Big\\{[[ D> 42-, ^ -> \\phiAgain{1} ]]( ^ -> \\phiAgain{1} )\\Big\\} \\leadsto_{\\nameref{r:stay}}" @@ -457,7 +462,7 @@ ["rewrite", "--normalize", "--sequence", "--flat", "--compress", "--output=latex", "--sweet"] [ unlines [ "\\begin{phiquation}" - , "\\Big\\{[[ |ex| -> [[ |x| -> [[ |y| -> ?, |k| -> \\phiMeet{1}{[[ |t| -> 42 ]]} ]]( |y| -> \\phiAgain{1} ) ]].|i| ]]\\Big\\} \\leadsto_{\\nameref{r:copy}}" + , "\\Big\\{[[ |ex| -> [[ |x| -> [[ |y| -> ?, |k| -> \\phiMeet{1}{ [[ |t| -> 42 ]] } ]]( |y| -> \\phiAgain{1} ) ]].|i| ]]\\Big\\} \\leadsto_{\\nameref{r:copy}}" , " \\leadsto \\Big\\{[[ |ex| -> [[ |x| -> [[ |y| -> \\phiAgain{1}, |k| -> \\phiAgain{1} ]] ]].|i| ]]\\Big\\} \\leadsto_{\\nameref{r:stop}}" , " \\leadsto \\Big\\{[[ |ex| -> T ]]\\Big\\}." , "\\end{phiquation}" @@ -618,6 +623,9 @@ ["{⟦ x ↦ ⟦ y ↦ ⟦ λ ⤍ F1 ⟧.q, z ↦ Φ.x( a ↦ ⟦ w ↦ ⟦ λ ⤍ F2 ⟧, λ ⤍ F3 ⟧ ) ⟧, λ ⤍ F4 ⟧}"] describe "dataize" $ do + it "prints help" $ + testCLISucceeded ["dataize", "--help"] ["Dataize the 𝜑-program"] + it "dataizes simple program" $ withStdin "Q -> [[ D> 01- ]]" $ testCLISucceeded ["dataize"] ["01-"] @@ -643,6 +651,10 @@ , "01-" ] ] + + it "dataizes with --locator" $ + withStdin "{[[ ex -> [[ @ -> Q.x ]], x -> [[ D> 42- ]] ]]}" $ + testCLISucceeded ["dataize", "--locator=Q.ex"] ["42-"] it "does not print bytes with --quiet" $ withStdin "Q -> [[ D> 01- ]]" $ diff --git a/test/DataizeSpec.hs b/test/DataizeSpec.hs --- a/test/DataizeSpec.hs +++ b/test/DataizeSpec.hs @@ -8,7 +8,7 @@ import Dataize (DataizeContext (DataizeContext), dataize, dataize', morph) import Deps (dontSaveStep) import Functions (buildTerm) -import Parser (parseProgramThrows) +import Parser (parseExpressionThrows, parseProgramThrows) import Printer (printProgram) import Rewriter (Rewritten) import Test.Hspec @@ -30,13 +30,14 @@ (res, _) <- func (input, [(Program prog, Nothing)]) (defaultDataizeContext (Program prog)) res `shouldBe` output -testDataize :: [(String, String, Bytes)] -> Spec +testDataize :: [(String, String, String, Bytes)] -> Spec testDataize useCases = - forM_ useCases $ \(name, prog, res) -> + forM_ useCases $ \(name, loc, prog, res) -> it name $ do prog' <- parseProgramThrows prog + loc' <- parseExpressionThrows loc putStrLn (printProgram prog') - (value, _) <- dataize prog' (defaultDataizeContext prog') + (value, _) <- dataize loc' (defaultDataizeContext prog') value `shouldBe` Just res spec :: Spec @@ -104,6 +105,7 @@ testDataize [ ( "5.plus(5)" + , "Q" , unlines [ "Q -> [[" , " org -> [[" @@ -126,6 +128,7 @@ ) , ( "Fahrenheit" + , "Q" , unlines [ "Q -> [[" , " org -> [[" @@ -150,6 +153,7 @@ ) , ( "Factorial" + , "Q" , unlines [ "Q -> [[" , " org -> [[" @@ -178,5 +182,20 @@ , "]]" ] , BtMany ["40", "18", "00", "00", "00", "00", "00", "00"] + ) + , + ( "Located" + , "Q.foo.bar" + , unlines + [ "Q -> [[" + , " foo -> [[" + , " bar -> [[" + , " @ -> Q.x" + , " ]]" + , " ]]," + , " x -> [[ D> 42- ]]" + , "]]" + ] + , BtOne "42" ) ] diff --git a/test/LiningSpec.hs b/test/LiningSpec.hs new file mode 100644 --- /dev/null +++ b/test/LiningSpec.hs @@ -0,0 +1,194 @@ +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +{- | Tests for the Lining module that converts CST to single-line format. +The module provides functions to remove line breaks and indentation from +phi-calculus concrete syntax trees while preserving structural semantics. +-} +module LiningSpec (spec) where + +import CST +import Control.Monad (forM_) +import Lining (LineFormat (..), toSingleLine, withLineFormat) +import Test.Hspec (Spec, describe, it, shouldBe, shouldNotBe) + +spec :: Spec +spec = do + describe "withLineFormat preserves multiline programs" $ + it "returns program unchanged" $ + let prog = PR_SWEET LCB (EX_GLOBAL Φ) RCB + in withLineFormat MULTILINE prog `shouldBe` prog + + describe "withLineFormat converts to singleline" $ + it "applies toSingleLine transformation" $ + let prog = PR_SWEET LCB (EX_FORMATION LSB EOL (TAB 1) (BI_EMPTY (TAB 1)) EOL (TAB 0) RSB) RCB + result = withLineFormat SINGLELINE prog + in result `shouldBe` PR_SWEET LCB (EX_FORMATION LSB NO_EOL NO_TAB (BI_EMPTY (TAB 1)) NO_EOL NO_TAB RSB) RCB + + describe "LineFormat Eq instance" $ + forM_ + [ ("SINGLELINE equals SINGLELINE", SINGLELINE, SINGLELINE, True) + , ("MULTILINE equals MULTILINE", MULTILINE, MULTILINE, True) + , ("SINGLELINE differs from MULTILINE", SINGLELINE, MULTILINE, False) + ] + ( \(desc, fmt1, fmt2, expected) -> + it desc $ + if expected + then fmt1 `shouldBe` fmt2 + else fmt1 `shouldNotBe` fmt2 + ) + + describe "LineFormat Show instance" $ + forM_ + [ ("SINGLELINE shows correctly", SINGLELINE, "SINGLELINE") + , ("MULTILINE shows correctly", MULTILINE, "MULTILINE") + ] + ( \(desc, fmt, expected) -> + it desc (show fmt `shouldBe` expected) + ) + + describe "toSingleLine PROGRAM for PR_SWEET" $ + it "removes newlines from expression" $ + let prog = PR_SWEET LCB (EX_FORMATION LSB EOL (TAB 1) (BI_EMPTY (TAB 1)) EOL (TAB 0) RSB) RCB + in toSingleLine prog `shouldBe` PR_SWEET LCB (EX_FORMATION LSB NO_EOL NO_TAB (BI_EMPTY (TAB 1)) NO_EOL NO_TAB RSB) RCB + + describe "toSingleLine PROGRAM for PR_SALTY" $ + it "converts salty program to singleline" $ + let prog = PR_SALTY Φ ARROW (EX_FORMATION LSB EOL (TAB 1) (BI_EMPTY (TAB 1)) EOL (TAB 0) RSB) + in toSingleLine prog `shouldBe` PR_SALTY Φ ARROW (EX_FORMATION LSB NO_EOL NO_TAB (BI_EMPTY (TAB 1)) NO_EOL NO_TAB RSB) + + describe "toSingleLine EXPRESSION for EX_FORMATION with empty binding" $ + it "removes tabs and newlines" $ + let ex = EX_FORMATION LSB EOL (TAB 1) (BI_EMPTY (TAB 1)) EOL (TAB 0) RSB + in toSingleLine ex `shouldBe` EX_FORMATION LSB NO_EOL NO_TAB (BI_EMPTY (TAB 1)) NO_EOL NO_TAB RSB + + describe "toSingleLine EXPRESSION for EX_FORMATION with bindings" $ + it "converts to singleline with TAB markers" $ + let bd = BI_PAIR (PA_TAU (AT_LABEL "x") ARROW (EX_GLOBAL Φ)) (BDS_EMPTY (TAB 1)) (TAB 1) + ex = EX_FORMATION LSB EOL (TAB 1) bd EOL (TAB 0) RSB + result = toSingleLine ex + in result `shouldBe` EX_FORMATION LSB NO_EOL TAB' (BI_PAIR (PA_TAU (AT_LABEL "x") ARROW (EX_GLOBAL Φ)) (BDS_EMPTY (TAB 1)) TAB') NO_EOL TAB' RSB + + describe "toSingleLine EXPRESSION for EX_DISPATCH" $ + it "converts nested expression" $ + let ex = EX_DISPATCH (EX_FORMATION LSB EOL (TAB 1) (BI_EMPTY (TAB 1)) EOL (TAB 0) RSB) (AT_LABEL "attr") + in toSingleLine ex `shouldBe` EX_DISPATCH (EX_FORMATION LSB NO_EOL NO_TAB (BI_EMPTY (TAB 1)) NO_EOL NO_TAB RSB) (AT_LABEL "attr") + + describe "toSingleLine EXPRESSION for EX_APPLICATION" $ + it "converts with proper spacing" $ + let t = APP_BINDING (PA_TAU (AT_LABEL "y") ARROW (EX_GLOBAL Φ)) + ex = EX_APPLICATION (EX_GLOBAL Φ) EOL (TAB 1) t EOL (TAB 0) 1 + in toSingleLine ex `shouldBe` EX_APPLICATION (EX_GLOBAL Φ) NO_EOL TAB' (APP_BINDING (PA_TAU (AT_LABEL "y") ARROW (EX_GLOBAL Φ))) NO_EOL TAB' 1 + + describe "toSingleLine EXPRESSION for EX_APPLICATION_TAUS" $ + it "converts taus application" $ + let ts = BI_PAIR (PA_TAU (AT_LABEL "z") ARROW (EX_GLOBAL Φ)) (BDS_EMPTY (TAB 1)) (TAB 1) + ex = EX_APPLICATION_TAUS (EX_GLOBAL Φ) EOL (TAB 1) ts EOL (TAB 0) 1 + in toSingleLine ex `shouldBe` EX_APPLICATION_TAUS (EX_GLOBAL Φ) NO_EOL TAB' (BI_PAIR (PA_TAU (AT_LABEL "z") ARROW (EX_GLOBAL Φ)) (BDS_EMPTY (TAB 1)) TAB') NO_EOL TAB' 1 + + describe "toSingleLine EXPRESSION for EX_APPLICATION_EXPRS" $ + it "converts expressions application" $ + let as = APP_ARG (EX_GLOBAL Φ) AAS_EMPTY + ex = EX_APPLICATION_EXPRS (EX_GLOBAL Φ) EOL (TAB 1) as EOL (TAB 0) 1 + in toSingleLine ex `shouldBe` EX_APPLICATION_EXPRS (EX_GLOBAL Φ) NO_EOL TAB' (APP_ARG (EX_GLOBAL Φ) AAS_EMPTY) NO_EOL TAB' 1 + + describe "toSingleLine EXPRESSION for EX_PHI_MEET" $ + it "converts meet expression" $ + let ex = EX_PHI_MEET Nothing 0 (EX_FORMATION LSB EOL (TAB 1) (BI_EMPTY (TAB 1)) EOL (TAB 0) RSB) + in toSingleLine ex `shouldBe` EX_PHI_MEET Nothing 0 (EX_FORMATION LSB NO_EOL NO_TAB (BI_EMPTY (TAB 1)) NO_EOL NO_TAB RSB) + + describe "toSingleLine EXPRESSION for EX_PHI_AGAIN" $ + it "converts again expression" $ + let ex = EX_PHI_AGAIN Nothing 1 (EX_FORMATION LSB EOL (TAB 1) (BI_EMPTY (TAB 1)) EOL (TAB 0) RSB) + in toSingleLine ex `shouldBe` EX_PHI_AGAIN Nothing 1 (EX_FORMATION LSB NO_EOL NO_TAB (BI_EMPTY (TAB 1)) NO_EOL NO_TAB RSB) + + describe "toSingleLine EXPRESSION leaves primitives unchanged" $ + forM_ + [ ("EX_GLOBAL", EX_GLOBAL Φ) + , ("EX_DEF_PACKAGE", EX_DEF_PACKAGE Φ̇) + , ("EX_XI", EX_XI XI) + , ("EX_ATTR", EX_ATTR (AT_LABEL "attr")) + , ("EX_TERMINATION", EX_TERMINATION DEAD) + , ("EX_STRING", EX_STRING "тест" (TAB 0) []) + , ("EX_NUMBER", EX_NUMBER (Left 42) (TAB 0) []) + , ("EX_META", EX_META (MT_EXPRESSION "e")) + , ("EX_META_TAIL", EX_META_TAIL (EX_GLOBAL Φ) (MT_TAIL "t")) + ] + ( \(desc, ex) -> + it desc (toSingleLine ex `shouldBe` ex) + ) + + describe "toSingleLine APP_BINDING" $ + it "converts nested pair expression" $ + let bd = APP_BINDING (PA_TAU (AT_LABEL "x") ARROW (EX_FORMATION LSB EOL (TAB 1) (BI_EMPTY (TAB 1)) EOL (TAB 0) RSB)) + in toSingleLine bd `shouldBe` APP_BINDING (PA_TAU (AT_LABEL "x") ARROW (EX_FORMATION LSB NO_EOL NO_TAB (BI_EMPTY (TAB 1)) NO_EOL NO_TAB RSB)) + + describe "toSingleLine BINDING for BI_PAIR" $ + it "converts to singleline" $ + let bd = BI_PAIR (PA_TAU (AT_LABEL "x") ARROW (EX_GLOBAL Φ)) (BDS_EMPTY (TAB 1)) (TAB 1) + in toSingleLine bd `shouldBe` BI_PAIR (PA_TAU (AT_LABEL "x") ARROW (EX_GLOBAL Φ)) (BDS_EMPTY (TAB 1)) TAB' + + describe "toSingleLine BINDING for BI_META" $ + it "converts meta binding" $ + let bd = BI_META (MT_BINDING "B") (BDS_EMPTY (TAB 1)) (TAB 1) + in toSingleLine bd `shouldBe` BI_META (MT_BINDING "B") (BDS_EMPTY (TAB 1)) TAB' + + describe "toSingleLine BINDING for BI_EMPTY" $ + it "returns binding unchanged" $ + let bd = BI_EMPTY (TAB 1) + in toSingleLine bd `shouldBe` bd + + describe "toSingleLine BINDINGS for BDS_PAIR" $ + it "converts to singleline" $ + let bds = BDS_PAIR EOL (TAB 1) (PA_TAU (AT_LABEL "y") ARROW (EX_GLOBAL Φ)) (BDS_EMPTY (TAB 1)) + in toSingleLine bds `shouldBe` BDS_PAIR NO_EOL TAB' (PA_TAU (AT_LABEL "y") ARROW (EX_GLOBAL Φ)) (BDS_EMPTY (TAB 1)) + + describe "toSingleLine BINDINGS for BDS_META" $ + it "converts meta bindings" $ + let bds = BDS_META EOL (TAB 1) (MT_BINDING "B") (BDS_EMPTY (TAB 1)) + in toSingleLine bds `shouldBe` BDS_META NO_EOL TAB' (MT_BINDING "B") (BDS_EMPTY (TAB 1)) + + describe "toSingleLine BINDINGS for BDS_EMPTY" $ + it "returns bindings unchanged" $ + let bds = BDS_EMPTY (TAB 1) + in toSingleLine bds `shouldBe` bds + + describe "toSingleLine PAIR for PA_TAU" $ + it "converts expression" $ + let pr = PA_TAU (AT_LABEL "x") ARROW (EX_FORMATION LSB EOL (TAB 1) (BI_EMPTY (TAB 1)) EOL (TAB 0) RSB) + in toSingleLine pr `shouldBe` PA_TAU (AT_LABEL "x") ARROW (EX_FORMATION LSB NO_EOL NO_TAB (BI_EMPTY (TAB 1)) NO_EOL NO_TAB RSB) + + describe "toSingleLine PAIR for PA_FORMATION" $ + it "converts formation pair" $ + let pr = PA_FORMATION (AT_LABEL "f") [AT_LABEL "v"] ARROW (EX_FORMATION LSB EOL (TAB 1) (BI_EMPTY (TAB 1)) EOL (TAB 0) RSB) + in toSingleLine pr `shouldBe` PA_FORMATION (AT_LABEL "f") [AT_LABEL "v"] ARROW (EX_FORMATION LSB NO_EOL NO_TAB (BI_EMPTY (TAB 1)) NO_EOL NO_TAB RSB) + + describe "toSingleLine PAIR leaves non-expression pairs unchanged" $ + forM_ + [ ("PA_VOID", PA_VOID (AT_LABEL "v") ARROW EMPTY) + , ("PA_LAMBDA", PA_LAMBDA "λфункция") + , ("PA_LAMBDA'", PA_LAMBDA' "Function") + , ("PA_META_LAMBDA", PA_META_LAMBDA (MT_FUNCTION "F")) + , ("PA_META_LAMBDA'", PA_META_LAMBDA' (MT_FUNCTION "F")) + , ("PA_DELTA", PA_DELTA (BT_ONE "FF")) + , ("PA_DELTA'", PA_DELTA' (BT_MANY ["00", "01"])) + , ("PA_META_DELTA", PA_META_DELTA (MT_BYTES "d")) + , ("PA_META_DELTA'", PA_META_DELTA' (MT_BYTES "d")) + ] + ( \(desc, pr) -> + it desc (toSingleLine pr `shouldBe` pr) + ) + + describe "toSingleLine APP_ARG" $ + it "converts expression and args" $ + let arg = APP_ARG (EX_FORMATION LSB EOL (TAB 1) (BI_EMPTY (TAB 1)) EOL (TAB 0) RSB) AAS_EMPTY + in toSingleLine arg `shouldBe` APP_ARG (EX_FORMATION LSB NO_EOL NO_TAB (BI_EMPTY (TAB 1)) NO_EOL NO_TAB RSB) AAS_EMPTY + + describe "toSingleLine APP_ARGS for AAS_EXPR" $ + it "converts nested expression" $ + let as = AAS_EXPR EOL (TAB 1) (EX_FORMATION LSB EOL (TAB 1) (BI_EMPTY (TAB 1)) EOL (TAB 0) RSB) AAS_EMPTY + in toSingleLine as `shouldBe` AAS_EXPR NO_EOL TAB' (EX_FORMATION LSB NO_EOL NO_TAB (BI_EMPTY (TAB 1)) NO_EOL NO_TAB RSB) AAS_EMPTY + + describe "toSingleLine APP_ARGS for AAS_EMPTY" $ + it "returns unchanged" $ + toSingleLine AAS_EMPTY `shouldBe` AAS_EMPTY diff --git a/test/ParserSpec.hs b/test/ParserSpec.hs --- a/test/ParserSpec.hs +++ b/test/ParserSpec.hs @@ -12,7 +12,7 @@ import Misc import Parser import System.FilePath (takeBaseName) -import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, describe, it, runIO, shouldBe, shouldSatisfy) +import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, anyException, describe, it, runIO, shouldBe, shouldReturn, shouldSatisfy, shouldThrow) test :: (Eq a, Show a) => @@ -261,3 +261,232 @@ content <- runIO (readFile pack) it (takeBaseName pack) (parseProgram content `shouldSatisfy` isLeft) ) + + describe "parse bytes" $ + test + parseBytes + [ ("--", Just BtEmpty) + , ("00-", Just (BtOne "00")) + , ("FF-", Just (BtOne "FF")) + , ("AB-", Just (BtOne "AB")) + , ("1F-2A-00", Just (BtMany ["1F", "2A", "00"])) + , ("01-02-03-04-05", Just (BtMany ["01", "02", "03", "04", "05"])) + , ("!d", Just (BtMeta "d")) + , ("!d0", Just (BtMeta "d0")) + , ("!d_test", Just (BtMeta "d_test")) + , ("δ", Just (BtMeta "d")) + , ("δ0", Just (BtMeta "d0")) + , ("GG-", Nothing) + , ("0-", Nothing) + , ("000-", Nothing) + , ("zz-", Nothing) + ] + + describe "parse binding" $ + test + parseBinding + [ ("x -> $", Just (BiTau (AtLabel "x") ExThis)) + , ("y -> Q", Just (BiTau (AtLabel "y") ExGlobal)) + , ("z -> ?", Just (BiVoid (AtLabel "z"))) + , ("w -> ∅", Just (BiVoid (AtLabel "w"))) + , ("^ -> T", Just (BiTau AtRho ExTermination)) + , ("@ -> $", Just (BiTau AtPhi ExThis)) + , ("ρ -> Q", Just (BiTau AtRho ExGlobal)) + , ("φ -> T", Just (BiTau AtPhi ExTermination)) + , ("!a -> $", Just (BiTau (AtMeta "a") ExThis)) + , ("!a0 -> Q", Just (BiTau (AtMeta "a0") ExGlobal)) + , ("D> --", Just (BiDelta BtEmpty)) + , ("D> 42-", Just (BiDelta (BtOne "42"))) + , ("D> 01-02-03", Just (BiDelta (BtMany ["01", "02", "03"]))) + , ("D> !d", Just (BiDelta (BtMeta "d"))) + , ("Δ ⤍ FF-", Just (BiDelta (BtOne "FF"))) + , ("Δ ⤍ --", Just (BiDelta BtEmpty)) + , ("L> Func", Just (BiLambda "Func")) + , ("L> Function_name", Just (BiLambda "Function_name")) + , ("L> Aφ", Just (BiLambda "Aφ")) + , ("λ ⤍ Test", Just (BiLambda "Test")) + , ("L> !F", Just (BiMetaLambda "F")) + , ("L> !F0", Just (BiMetaLambda "F0")) + , ("!B", Just (BiMeta "B")) + , ("!B0", Just (BiMeta "B0")) + , ("!B_test", Just (BiMeta "B_test")) + , ("𝐵", Just (BiMeta "B")) + , ("𝐵1", Just (BiMeta "B1")) + , ("x() -> [[]]", Just (BiTau (AtLabel "x") (ExFormation [BiVoid AtRho]))) + , ("y(^) -> [[]]", Just (BiTau (AtLabel "y") (ExFormation [BiVoid AtRho]))) + , ("z(^, @) -> [[]]", Just (BiTau (AtLabel "z") (ExFormation [BiVoid AtRho, BiVoid AtPhi]))) + , ("x -> [[y -> $]]", Just (BiTau (AtLabel "x") (ExFormation [BiTau (AtLabel "y") ExThis, BiVoid AtRho]))) + , ("x ↦ ξ", Just (BiTau (AtLabel "x") ExThis)) + , ("x -> ", Nothing) + , ("-> Q", Nothing) + , ("L>", Nothing) + , ("D>", Nothing) + ] + + describe "parse attribute" $ + test + parseAttribute + [ ("x", Just (AtLabel "x")) + , ("foo", Just (AtLabel "foo")) + , ("camelCase", Just (AtLabel "camelCase")) + , ("with_underscore", Just (AtLabel "with_underscore")) + , ("with-dash", Just (AtLabel "with-dash")) + , ("^", Just AtRho) + , ("ρ", Just AtRho) + , ("@", Just AtPhi) + , ("φ", Just AtPhi) + , ("!a", Just (AtMeta "a")) + , ("!a0", Just (AtMeta "a0")) + , ("!a_test", Just (AtMeta "a_test")) + , ("𝜏", Just (AtMeta "a")) + , ("𝜏0", Just (AtMeta "a0")) + , ("~0", Just (AtAlpha 0)) + , ("~1", Just (AtAlpha 1)) + , ("~123", Just (AtAlpha 123)) + , ("α0", Just (AtAlpha 0)) + , ("α42", Just (AtAlpha 42)) + , ("X", Nothing) + , ("123", Nothing) + , ("", Nothing) + ] + + describe "parse number" $ + test + parseNumber + [ ("0", Just (DataNumber (BtMany ["00", "00", "00", "00", "00", "00", "00", "00"]))) + , ("1", Just (DataNumber (BtMany ["3F", "F0", "00", "00", "00", "00", "00", "00"]))) + , ("-1", Just (DataNumber (BtMany ["BF", "F0", "00", "00", "00", "00", "00", "00"]))) + , ("+1", Just (DataNumber (BtMany ["3F", "F0", "00", "00", "00", "00", "00", "00"]))) + , ("42", Just (DataNumber (BtMany ["40", "45", "00", "00", "00", "00", "00", "00"]))) + , ("-42", Just (DataNumber (BtMany ["C0", "45", "00", "00", "00", "00", "00", "00"]))) + , ("3.14", Just (DataNumber (BtMany ["40", "09", "1E", "B8", "51", "EB", "85", "1F"]))) + , ("1.5", Just (DataNumber (BtMany ["3F", "F8", "00", "00", "00", "00", "00", "00"]))) + , ("-0.5", Just (DataNumber (BtMany ["BF", "E0", "00", "00", "00", "00", "00", "00"]))) + , ("1e3", Just (DataNumber (BtMany ["40", "8F", "40", "00", "00", "00", "00", "00"]))) + , ("1E3", Just (DataNumber (BtMany ["40", "8F", "40", "00", "00", "00", "00", "00"]))) + , ("1.5e2", Just (DataNumber (BtMany ["40", "62", "C0", "00", "00", "00", "00", "00"]))) + , ("2e-3", Just (DataNumber (BtMany ["3F", "60", "62", "4D", "D2", "F1", "A9", "FC"]))) + , ("-1e10", Just (DataNumber (BtMany ["C2", "02", "A0", "5F", "20", "00", "00", "00"]))) + , ("abc", Nothing) + , ("", Nothing) + ] + + describe "parseProgramThrows" $ do + it "returns program on valid input" $ + parseProgramThrows "Q -> T" `shouldReturn` Program ExTermination + it "throws on invalid input" $ + parseProgramThrows "invalid program ]][[" `shouldThrow` anyException + + describe "parseExpressionThrows" $ do + it "returns expression on valid input" $ + parseExpressionThrows "Q.x" `shouldReturn` ExDispatch ExGlobal (AtLabel "x") + it "throws on invalid input" $ + parseExpressionThrows "[[invalid" `shouldThrow` anyException + + describe "parseAttributeThrows" $ do + it "returns attribute on valid input" $ + parseAttributeThrows "foo" `shouldReturn` AtLabel "foo" + it "throws on invalid input" $ + parseAttributeThrows "123invalid" `shouldThrow` anyException + + describe "parseNumberThrows" $ do + it "returns number on valid input" $ do + result <- parseNumberThrows "42" + case result of + DataNumber _ -> return () + _ -> fail "expected DataNumber" + it "throws on invalid input" $ + parseNumberThrows "notanumber" `shouldThrow` anyException + + describe "parse string escapes" $ + test + parseExpression + [ ("\"hello\"", Just (DataString (BtMany ["68", "65", "6C", "6C", "6F"]))) + , ("\"\"", Just (DataString BtEmpty)) + , ("\"a\"", Just (DataString (BtOne "61"))) + , ("\"\\n\"", Just (DataString (BtOne "0A"))) + , ("\"\\r\"", Just (DataString (BtOne "0D"))) + , ("\"\\t\"", Just (DataString (BtOne "09"))) + , ("\"\\\\\"", Just (DataString (BtOne "5C"))) + , ("\"\\\"\"", Just (DataString (BtOne "22"))) + , ("\"\\b\"", Just (DataString (BtOne "08"))) + , ("\"\\f\"", Just (DataString (BtOne "0C"))) + , ("\"\\x41\"", Just (DataString (BtOne "41"))) + , ("\"\\x00\"", Just (DataString (BtOne "00"))) + , ("\"\\u0041\"", Just (DataString (BtOne "41"))) + , ("\"\\u0000\"", Just (DataString (BtOne "00"))) + , ("\"line1\\nline2\"", Just (DataString (BtMany ["6C", "69", "6E", "65", "31", "0A", "6C", "69", "6E", "65", "32"]))) + ] + + describe "parse unicode syntax" $ + test + parseExpression + [ ("ξ", Just ExThis) + , ("Φ", Just ExGlobal) + , ("⊥", Just ExTermination) + , ("Φ̇", Just (ExDispatch (ExDispatch ExGlobal (AtLabel "org")) (AtLabel "eolang"))) + , ("⟦⟧", Just (ExFormation [BiVoid AtRho])) + , ("⟦ x ↦ ξ ⟧", Just (ExFormation [BiTau (AtLabel "x") ExThis, BiVoid AtRho])) + , ("ξ.ρ", Just (ExDispatch ExThis AtRho)) + , ("ξ.φ", Just (ExDispatch ExThis AtPhi)) + ] + + describe "parse labels with special characters" $ + test + parseExpression + [ ("foo123", Just (ExDispatch ExThis (AtLabel "foo123"))) + , ("with-dash", Just (ExDispatch ExThis (AtLabel "with-dash"))) + , ("with_underscore", Just (ExDispatch ExThis (AtLabel "with_underscore"))) + , ("aкирилиця", Just (ExDispatch ExThis (AtLabel "aкирилиця"))) + , ("a日本語", Just (ExDispatch ExThis (AtLabel "a日本語"))) + , ("name123_test", Just (ExDispatch ExThis (AtLabel "name123_test"))) + ] + + describe "parse complex formations" $ + test + parseExpression + [ ("[[^ -> ?]]", Just (ExFormation [BiVoid AtRho])) + , ("[[@ -> ?]]", Just (ExFormation [BiVoid AtPhi, BiVoid AtRho])) + , ("[[^ -> ?, @ -> ?]]", Just (ExFormation [BiVoid AtRho, BiVoid AtPhi])) + , ("[[^ -> Q, @ -> $]]", Just (ExFormation [BiTau AtRho ExGlobal, BiTau AtPhi ExThis])) + ] + + describe "parse applications with mixed bindings" $ + test + parseExpression + [ ("[[]](Q)", Just (ExApplication (ExFormation [BiVoid AtRho]) (BiTau (AtAlpha 0) ExGlobal))) + , ("[[]](Q, T)", Just (ExApplication (ExApplication (ExFormation [BiVoid AtRho]) (BiTau (AtAlpha 0) ExGlobal)) (BiTau (AtAlpha 1) ExTermination))) + , ("Q.x(y -> $)", Just (ExApplication (ExDispatch ExGlobal (AtLabel "x")) (BiTau (AtLabel "y") ExThis))) + , ("[[x -> ?]].x(Q)", Just (ExApplication (ExDispatch (ExFormation [BiVoid (AtLabel "x"), BiVoid AtRho]) (AtLabel "x")) (BiTau (AtAlpha 0) ExGlobal))) + ] + + describe "parse meta expressions" $ + test + parseExpression + [ ("!e", Just (ExMeta "e")) + , ("!e0", Just (ExMeta "e0")) + , ("!e_test", Just (ExMeta "e_test")) + , ("𝑒", Just (ExMeta "e")) + , ("𝑒0", Just (ExMeta "e0")) + , ("!e.x", Just (ExDispatch (ExMeta "e") (AtLabel "x"))) + , ("!e(Q)", Just (ExApplication (ExMeta "e") (BiTau (AtAlpha 0) ExGlobal))) + ] + + describe "parse meta tails" $ + test + parseExpression + [ ("Q * !t", Just (ExMetaTail ExGlobal "t")) + , ("Q.x * !t", Just (ExMetaTail (ExDispatch ExGlobal (AtLabel "x")) "t")) + , ("[[]].y * !t0", Just (ExMetaTail (ExDispatch (ExFormation [BiVoid AtRho]) (AtLabel "y")) "t0")) + , ("Q * !t * !t2", Nothing) + ] + + describe "parse whitespace handling" $ + forM_ + [ "[[ x -> Q ]]" + , "[[\n\tx\n\t->\n\tQ\n\t]]" + , " Q . x " + , "Q.x( y -> $ )" + , " [[ x -> Q ]] " + ] + (\expr -> it expr (parseExpression expr `shouldSatisfy` isRight)) diff --git a/test/RegexpSpec.hs b/test/RegexpSpec.hs new file mode 100644 --- /dev/null +++ b/test/RegexpSpec.hs @@ -0,0 +1,250 @@ +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +{- | Tests for the Regexp module that provides regular expression +matching and replacement using PCRE. +-} +module RegexpSpec where + +import Data.ByteString.Char8 qualified as B +import Regexp qualified as R +import Test.Hspec (Spec, anyException, describe, it, shouldBe, shouldReturn, shouldThrow) + +spec :: Spec +spec = do + describe "compile" $ do + it "compiles a valid pattern" $ do + _ <- R.compile (B.pack "foo") + matched <- R.match (B.pack "foo") (B.pack "foobar") + matched `shouldBe` True + + it "throws on invalid pattern" $ + R.compile (B.pack "[invalid") `shouldThrow` anyException + + it "compiles pattern with groups" $ do + _ <- R.compile (B.pack "(a)(b)(c)") + matched <- R.match (B.pack "(a)(b)(c)") (B.pack "abc") + matched `shouldBe` True + + it "compiles pattern with unicode" $ do + _ <- R.compile (B.pack "кирилиця") + matched <- R.match (B.pack "кирилиця") (B.pack "текст кирилиця тут") + matched `shouldBe` True + + it "compiles empty pattern" $ do + _ <- R.compile B.empty + matched <- R.match B.empty (B.pack "anything") + matched `shouldBe` True + + describe "match" $ do + it "returns true when pattern matches" $ + R.match (B.pack "hello") (B.pack "hello world") `shouldReturn` True + + it "returns false when pattern does not match" $ + R.match (B.pack "goodbye") (B.pack "hello world") `shouldReturn` False + + it "returns true for partial match" $ + R.match (B.pack "wor") (B.pack "hello world") `shouldReturn` True + + it "returns true for match at start" $ + R.match (B.pack "^hello") (B.pack "hello world") `shouldReturn` True + + it "returns false for anchored pattern not at start" $ + R.match (B.pack "^world") (B.pack "hello world") `shouldReturn` False + + it "returns true for match at end" $ + R.match (B.pack "world$") (B.pack "hello world") `shouldReturn` True + + it "returns true with empty input and empty pattern" $ + R.match B.empty B.empty `shouldReturn` True + + it "returns true with non-empty input and empty pattern" $ + R.match B.empty (B.pack "text") `shouldReturn` True + + it "returns false with empty input and non-empty pattern" $ + R.match (B.pack "text") B.empty `shouldReturn` False + + it "handles special regex characters" $ + R.match (B.pack "a\\.b") (B.pack "a.b") `shouldReturn` True + + it "handles character class" $ + R.match (B.pack "[0-9]+") (B.pack "abc123def") `shouldReturn` True + + it "handles alternation" $ + R.match (B.pack "cat|dog") (B.pack "I have a dog") `shouldReturn` True + + it "handles unicode input" $ + R.match (B.pack "日本語") (B.pack "これは日本語です") `shouldReturn` True + + it "handles case sensitive match" $ + R.match (B.pack "Hello") (B.pack "hello") `shouldReturn` False + + describe "extractGroups" $ do + it "extracts groups from pattern with capturing groups" $ do + regex <- R.compile (B.pack "(\\w+)@(\\w+)") + groups <- R.extractGroups regex (B.pack "user@domain") + groups `shouldBe` [B.pack "user@domain", B.pack "user", B.pack "domain"] + + it "returns empty list when no match" $ do + regex <- R.compile (B.pack "(foo)") + groups <- R.extractGroups regex (B.pack "bar") + groups `shouldBe` [] + + it "extracts nested groups" $ do + regex <- R.compile (B.pack "((a)(b))") + groups <- R.extractGroups regex (B.pack "ab") + groups `shouldBe` [B.pack "ab", B.pack "ab", B.pack "a", B.pack "b"] + + it "handles optional group that did not match" $ do + regex <- R.compile (B.pack "(a)(b)?") + groups <- R.extractGroups regex (B.pack "a") + length groups `shouldBe` 3 + + it "extracts multiple groups" $ do + regex <- R.compile (B.pack "(x)(y)(z)") + groups <- R.extractGroups regex (B.pack "prefix xyz suffix") + groups `shouldBe` [B.pack "xyz", B.pack "x", B.pack "y", B.pack "z"] + + it "handles pattern without groups" $ do + regex <- R.compile (B.pack "test") + groups <- R.extractGroups regex (B.pack "this is a test") + groups `shouldBe` [B.pack "test"] + + describe "substituteGroups" $ do + it "substitutes group zero" $ + R.substituteGroups (B.pack "[$0]") [B.pack "match"] `shouldBe` B.pack "[match]" + + it "substitutes multiple groups" $ + R.substituteGroups (B.pack "$1-$2") [B.pack "full", B.pack "a", B.pack "b"] + `shouldBe` B.pack "a-b" + + it "keeps dollar sign when no digits follow" $ + R.substituteGroups (B.pack "$ test") [B.pack "x"] `shouldBe` B.pack "$ test" + + it "keeps original reference for out of bounds index" $ + R.substituteGroups (B.pack "$9") [B.pack "only"] `shouldBe` B.pack "$9" + + it "handles replacement without group references" $ + R.substituteGroups (B.pack "plain") [B.pack "x"] `shouldBe` B.pack "plain" + + it "handles empty replacement" $ + R.substituteGroups B.empty [B.pack "x"] `shouldBe` B.empty + + it "handles empty groups list with reference" $ + R.substituteGroups (B.pack "$0") [] `shouldBe` B.pack "$0" + + it "handles multi-digit group reference" $ + R.substituteGroups (B.pack "$12") (replicate 13 (B.pack "x")) + `shouldBe` B.pack "x" + + it "handles consecutive group references" $ + R.substituteGroups (B.pack "$0$1$2") [B.pack "a", B.pack "b", B.pack "c"] + `shouldBe` B.pack "abc" + + it "handles unicode in replacement" $ + R.substituteGroups (B.pack "結果: $1") [B.pack "all", B.pack "データ"] + `shouldBe` B.pack "結果: データ" + + it "handles dollar at end of string" $ + R.substituteGroups (B.pack "test$") [B.pack "x"] `shouldBe` B.pack "test$" + + it "handles double dollar" $ + R.substituteGroups (B.pack "$$1") [B.pack "x", B.pack "y"] + `shouldBe` B.pack "$y" + + describe "replaceFirst" $ do + it "replaces first occurrence" $ do + regex <- R.compile (B.pack "cat") + result <- R.replaceFirst regex (B.pack "dog") (B.pack "cat and cat") + result `shouldBe` B.pack "dog and cat" + + it "returns input when no match" $ do + regex <- R.compile (B.pack "xyz") + result <- R.replaceFirst regex (B.pack "abc") (B.pack "hello world") + result `shouldBe` B.pack "hello world" + + it "replaces with empty string" $ do + regex <- R.compile (B.pack "remove") + result <- R.replaceFirst regex B.empty (B.pack "please remove this") + result `shouldBe` B.pack "please this" + + it "replaces at start of string" $ do + regex <- R.compile (B.pack "^start") + result <- R.replaceFirst regex (B.pack "begin") (B.pack "start here") + result `shouldBe` B.pack "begin here" + + it "replaces at end of string" $ do + regex <- R.compile (B.pack "end$") + result <- R.replaceFirst regex (B.pack "finish") (B.pack "the end") + result `shouldBe` B.pack "the finish" + + it "uses captured groups in replacement" $ do + regex <- R.compile (B.pack "(\\w+)@(\\w+)") + result <- R.replaceFirst regex (B.pack "[$1 AT $2]") (B.pack "email: test@example here") + result `shouldBe` B.pack "email: [test AT example] here" + + it "handles unicode pattern and replacement" $ do + regex <- R.compile (B.pack "古い") + result <- R.replaceFirst regex (B.pack "新しい") (B.pack "これは古いです") + result `shouldBe` B.pack "これは新しいです" + + it "handles empty input" $ do + regex <- R.compile (B.pack "x") + result <- R.replaceFirst regex (B.pack "y") B.empty + result `shouldBe` B.empty + + it "replaces entire string when pattern matches all" $ do + regex <- R.compile (B.pack "^.*$") + result <- R.replaceFirst regex (B.pack "replaced") (B.pack "original") + result `shouldBe` B.pack "replaced" + + describe "replaceAll" $ do + it "replaces all occurrences" $ do + regex <- R.compile (B.pack "a") + result <- R.replaceAll regex (B.pack "X") (B.pack "banana") + result `shouldBe` B.pack "bXnXnX" + + it "returns input when no match" $ do + regex <- R.compile (B.pack "xyz") + result <- R.replaceAll regex (B.pack "abc") (B.pack "hello world") + result `shouldBe` B.pack "hello world" + + it "replaces consecutive matches" $ do + regex <- R.compile (B.pack "o") + result <- R.replaceAll regex (B.pack "0") (B.pack "oooo") + result `shouldBe` B.pack "0000" + + it "replaces with captured groups" $ do + regex <- R.compile (B.pack "(\\d+)") + result <- R.replaceAll regex (B.pack "[$1]") (B.pack "a1b2c3") + result `shouldBe` B.pack "a[1]b[2]c[3]" + + it "handles empty replacement" $ do + regex <- R.compile (B.pack "x") + result <- R.replaceAll regex B.empty (B.pack "axbxcx") + result `shouldBe` B.pack "abc" + + it "handles empty input" $ do + regex <- R.compile (B.pack "x") + result <- R.replaceAll regex (B.pack "y") B.empty + result `shouldBe` B.empty + + it "handles unicode input and pattern" $ do + regex <- R.compile (B.pack "кіт") + result <- R.replaceAll regex (B.pack "пес") (B.pack "кіт і кіт") + result `shouldBe` B.pack "пес і пес" + + it "replaces overlapping potential matches correctly" $ do + regex <- R.compile (B.pack "aa") + result <- R.replaceAll regex (B.pack "X") (B.pack "aaaa") + result `shouldBe` B.pack "XX" + + it "handles single character replacement" $ do + regex <- R.compile (B.pack ".") + result <- R.replaceAll regex (B.pack "*") (B.pack "abc") + result `shouldBe` B.pack "***" + + it "handles word boundary" $ do + regex <- R.compile (B.pack "\\bword\\b") + result <- R.replaceAll regex (B.pack "WORD") (B.pack "word in a word") + result `shouldBe` B.pack "WORD in a WORD" diff --git a/test/ReplacerSpec.hs b/test/ReplacerSpec.hs --- a/test/ReplacerSpec.hs +++ b/test/ReplacerSpec.hs @@ -101,6 +101,87 @@ ) ) ) + , + ( "Q -> T => ([], []) => Q -> T" + , Program ExTermination + , [] + , [] + , Program ExTermination + ) + , + ( "Q -> $ => ([$], [Q]) => Q -> Q" + , Program ExThis + , [ExThis] + , [ExGlobal] + , Program ExGlobal + ) + , + ( "Q -> Q.α0 => ([Q.α0], [$.α1]) => Q -> $.α1" + , Program (ExDispatch ExGlobal (AtAlpha 0)) + , [ExDispatch ExGlobal (AtAlpha 0)] + , [ExDispatch ExThis (AtAlpha 1)] + , Program (ExDispatch ExThis (AtAlpha 1)) + ) + , + ( "Q -> [[D> --]] => ([[D> --]], [[[L> Функція]]]) => Q -> [[L> Функція]]" + , Program (ExFormation [BiDelta BtEmpty]) + , [ExFormation [BiDelta BtEmpty]] + , [ExFormation [BiLambda "Функція"]] + , Program (ExFormation [BiLambda "Функція"]) + ) + , + ( "Q -> Q.プログラム => ([Q.プログラム], [$.コード]) => Q -> $.コード" + , Program (ExDispatch ExGlobal (AtLabel "プログラム")) + , [ExDispatch ExGlobal (AtLabel "プログラム")] + , [ExDispatch ExThis (AtLabel "コード")] + , Program (ExDispatch ExThis (AtLabel "コード")) + ) + , + ( "Q -> [[^ -> T, @ -> T]] => ([T, T], [Q, $]) => Q -> [[^ -> Q, @ -> $]]" + , Program (ExFormation [BiTau AtRho ExTermination, BiTau AtPhi ExTermination]) + , [ExTermination, ExTermination] + , [ExGlobal, ExThis] + , Program (ExFormation [BiTau AtRho ExGlobal, BiTau AtPhi ExThis]) + ) + , + ( "Q -> [[x -> [[y -> Q]]]].x => ([[y -> Q]], [[[z -> $]]]) => Q -> [[x -> [[z -> $]]]].x" + , Program (ExDispatch (ExFormation [BiTau (AtLabel "x") (ExFormation [BiTau (AtLabel "y") ExGlobal])]) (AtLabel "x")) + , [ExFormation [BiTau (AtLabel "y") ExGlobal]] + , [ExFormation [BiTau (AtLabel "z") ExThis]] + , Program (ExDispatch (ExFormation [BiTau (AtLabel "x") (ExFormation [BiTau (AtLabel "z") ExThis])]) (AtLabel "x")) + ) + , + ( "Q -> Q.a(b -> Q.c) => ([Q.a, Q.c], [$, T]) => Q -> $(b -> T)" + , Program (ExApplication (ExDispatch ExGlobal (AtLabel "a")) (BiTau (AtLabel "b") (ExDispatch ExGlobal (AtLabel "c")))) + , [ExDispatch ExGlobal (AtLabel "a"), ExDispatch ExGlobal (AtLabel "c")] + , [ExThis, ExTermination] + , Program (ExApplication ExThis (BiTau (AtLabel "b") ExTermination)) + ) + , + ( "Q -> [[D> 00-01-02-]] => ([[D> 00-01-02-]], [[[D> FF-]]]) => Q -> [[D> FF-]]" + , Program (ExFormation [BiDelta (BtMany ["00", "01", "02"])]) + , [ExFormation [BiDelta (BtMany ["00", "01", "02"])]] + , [ExFormation [BiDelta (BtOne "FF")]] + , Program (ExFormation [BiDelta (BtOne "FF")]) + ) + , + ( "Q -> [[@ -> $.x, ^ -> $.y]] => ([$.x, $.y], [T, Q]) => Q -> [[@ -> T, ^ -> Q]]" + , Program (ExFormation [BiTau AtPhi (ExDispatch ExThis (AtLabel "x")), BiTau AtRho (ExDispatch ExThis (AtLabel "y"))]) + , [ExDispatch ExThis (AtLabel "x"), ExDispatch ExThis (AtLabel "y")] + , [ExTermination, ExGlobal] + , Program (ExFormation [BiTau AtPhi ExTermination, BiTau AtRho ExGlobal]) + ) + , + ( "Q -> Q.a.b.c => ([Q.a.b.c, Q.a.b, Q.a], [$, T, Q]) => Q -> $" + , Program (ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "a")) (AtLabel "b")) (AtLabel "c")) + , + [ ExDispatch (ExDispatch (ExDispatch ExGlobal (AtLabel "a")) (AtLabel "b")) (AtLabel "c") + , ExDispatch (ExDispatch ExGlobal (AtLabel "a")) (AtLabel "b") + , ExDispatch ExGlobal (AtLabel "a") + ] + , [ExThis, ExTermination, ExGlobal] + , Program ExThis + ) ] describe "replace program fast: Program => ([Expression], [Expression]) => Program" $ @@ -126,5 +207,92 @@ , [ExFormation [BiTau AtRho ExTermination], ExFormation [BiTau AtRho ExThis]] , [ExFormation [BiTau AtRho ExGlobal], ExFormation [BiVoid AtPhi]] , Program (ExDispatch (ExApplication (ExFormation [BiTau AtRho ExGlobal]) (BiTau AtRho (ExFormation [BiVoid AtPhi]))) AtPhi) + ) + , + ( "Q -> [[ ]] => ([], []) => Q -> [[ ]]" + , Program (ExFormation []) + , [] + , [] + , Program (ExFormation []) + ) + , + ( "Q -> $ => ([$], [T]) => Q -> $" + , Program ExThis + , [ExThis] + , [ExTermination] + , Program ExThis + ) + , + ( "Q -> [[ a -> ?, b -> ?, c -> ? ]] => ([[a -> ?]], [[a -> Q]]) => Q -> [[a -> Q, b -> ?, c -> ?]]" + , Program (ExFormation [BiVoid (AtLabel "a"), BiVoid (AtLabel "b"), BiVoid (AtLabel "c")]) + , [ExFormation [BiVoid (AtLabel "a")]] + , [ExFormation [BiTau (AtLabel "a") ExGlobal]] + , Program (ExFormation [BiTau (AtLabel "a") ExGlobal, BiVoid (AtLabel "b"), BiVoid (AtLabel "c")]) + ) + , + ( "Q -> [[ λ -> ?, D> 00- ]] => ([[λ -> ?]], [[λ -> $]]) => Q -> [[λ -> $, D> 00-]]" + , Program (ExFormation [BiVoid AtLambda, BiDelta (BtOne "00")]) + , [ExFormation [BiVoid AtLambda]] + , [ExFormation [BiTau AtLambda ExThis]] + , Program (ExFormation [BiTau AtLambda ExThis, BiDelta (BtOne "00")]) + ) + , + ( "Q -> [[x -> [[y -> ?]]]].x => ([[y -> ?]], [[y -> Q]]) => Q -> [[x -> [[y -> Q]]]].x" + , Program (ExDispatch (ExFormation [BiTau (AtLabel "x") (ExFormation [BiVoid (AtLabel "y")])]) (AtLabel "x")) + , [ExFormation [BiVoid (AtLabel "y")]] + , [ExFormation [BiTau (AtLabel "y") ExGlobal]] + , Program (ExDispatch (ExFormation [BiTau (AtLabel "x") (ExFormation [BiTau (AtLabel "y") ExGlobal])]) (AtLabel "x")) + ) + , + ( "Q -> [[アイテム -> ?]] => ([[アイテム -> ?]], [[アイテム -> $]]) => Q -> [[アイテム -> $]]" + , Program (ExFormation [BiVoid (AtLabel "アイテム")]) + , [ExFormation [BiVoid (AtLabel "アイテム")]] + , [ExFormation [BiTau (AtLabel "アイテム") ExThis]] + , Program (ExFormation [BiTau (AtLabel "アイテム") ExThis]) + ) + , + ( "Q -> [[a -> ?, a -> ?]] => ([[a -> ?]], [[a -> Q]]) => Q -> [[a -> Q, a -> Q]]" + , Program (ExFormation [BiVoid (AtLabel "a"), BiVoid (AtLabel "a")]) + , [ExFormation [BiVoid (AtLabel "a")]] + , [ExFormation [BiTau (AtLabel "a") ExGlobal]] + , Program (ExFormation [BiTau (AtLabel "a") ExGlobal, BiTau (AtLabel "a") ExGlobal]) + ) + , + ( "Q -> Q.a(b -> [[c -> ?]]) => ([[c -> ?]], [[c -> T]]) => Q -> Q.a(b -> [[c -> T]])" + , Program (ExApplication (ExDispatch ExGlobal (AtLabel "a")) (BiTau (AtLabel "b") (ExFormation [BiVoid (AtLabel "c")]))) + , [ExFormation [BiVoid (AtLabel "c")]] + , [ExFormation [BiTau (AtLabel "c") ExTermination]] + , Program (ExApplication (ExDispatch ExGlobal (AtLabel "a")) (BiTau (AtLabel "b") (ExFormation [BiTau (AtLabel "c") ExTermination]))) + ) + , + ( "Q -> [[ L> Функція ]] => ([[ L> Функція ]], [[ L> Код ]]) => Q -> [[ L> Код ]]" + , Program (ExFormation [BiLambda "Функція"]) + , [ExFormation [BiLambda "Функція"]] + , [ExFormation [BiLambda "Код"]] + , Program (ExFormation [BiLambda "Код"]) + ) + ] + + describe "replace program fast with depth 0" $ + test + (replaceProgramFast (ReplaceCtx 0)) + [ + ( "Q -> [[a -> ?]] => ([[a -> ?]], [[a -> $]]) => Q -> [[a -> ?]]" + , Program (ExFormation [BiVoid (AtLabel "a")]) + , [ExFormation [BiVoid (AtLabel "a")]] + , [ExFormation [BiTau (AtLabel "a") ExThis]] + , Program (ExFormation [BiVoid (AtLabel "a")]) + ) + ] + + describe "replace program fast with depth 1" $ + test + (replaceProgramFast (ReplaceCtx 1)) + [ + ( "Q -> [[ ^ -> ? ]] => [[ ^ -> ? ]] => [[ ^ -> [[ ^ -> ? ]] ]] => Q -> [[ ^ -> [[ ^ -> ? ]] ]]" + , Program (ExFormation [BiVoid AtRho]) + , [ExFormation [BiVoid AtRho]] + , [ExFormation [BiTau AtRho (ExFormation [BiVoid AtRho])]] + , Program (ExFormation [BiTau AtRho (ExFormation [BiVoid AtRho])]) ) ] 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 (Attribute (..), Binding (..), Bytes (..), Expression (..), Program (Program)) import Control.Monad import Data.Aeson import Data.Yaml qualified as Y @@ -15,9 +15,9 @@ import Matcher import Misc import Printer (printSubsts) -import Rule (RuleContext (RuleContext), meetCondition) +import Rule (RuleContext (RuleContext), isNF, meetCondition) import System.FilePath -import Test.Hspec (Spec, describe, expectationFailure, it, runIO) +import Test.Hspec (Spec, describe, expectationFailure, it, runIO, shouldBe) import Yaml qualified data ConditionPack = ConditionPack @@ -29,30 +29,48 @@ deriving (Generic, FromJSON, Show) spec :: Spec -spec = describe "check conditions" $ do - let resources = "test-resources/condition-packs" - packs <- runIO (allPathsIn resources) - forM_ - packs - ( \pth -> it (makeRelative resources pth) $ do - pack <- Y.decodeFileThrow pth :: IO ConditionPack - let prog = Program (expression pack) - let matched = matchProgram (pattern pack) prog - unless (matched /= []) (expectationFailure "List of matched substitutions is empty which is not expected") - met <- meetCondition (condition pack) matched (RuleContext buildTerm) - case failure pack of - Just True -> - unless - (null met) - ( expectationFailure $ - "List of substitutions after condition check must be empty, but got:\n" - ++ printSubsts matched - ) - _ -> - when - (null met) - ( expectationFailure $ - "List of substitution after condition check must be not empty\nOriginal substitutions:\n" - ++ printSubsts matched - ) - ) +spec = do + describe "check conditions" $ do + let resources = "test-resources/condition-packs" + packs <- runIO (allPathsIn resources) + forM_ + packs + ( \pth -> it (makeRelative resources pth) $ do + pack <- Y.decodeFileThrow pth :: IO ConditionPack + let prog = Program (expression pack) + let matched = matchProgram (pattern pack) prog + unless (matched /= []) (expectationFailure "List of matched substitutions is empty which is not expected") + met <- meetCondition (condition pack) matched (RuleContext buildTerm) + case failure pack of + Just True -> + unless + (null met) + ( expectationFailure $ + "List of substitutions after condition check must be empty, but got:\n" + ++ printSubsts matched + ) + _ -> + when + (null met) + ( expectationFailure $ + "List of substitution after condition check must be not empty\nOriginal substitutions:\n" + ++ printSubsts matched + ) + ) + describe "isNF determines normal form" $ do + let ctx = RuleContext buildTerm + forM_ + [ ("returns true for ExThis", ExThis, True) + , ("returns true for ExGlobal", ExGlobal, True) + , ("returns true for ExTermination", ExTermination, True) + , ("returns true for dispatch on ExThis", ExDispatch ExThis (AtLabel "foo"), True) + , ("returns true for dispatch on ExGlobal", ExDispatch ExGlobal (AtLabel "bar"), True) + , ("returns false for dispatch on ExTermination", ExDispatch ExTermination (AtLabel "x"), False) + , ("returns false for application on ExTermination", ExApplication ExTermination (BiTau (AtLabel "y") ExGlobal), False) + , ("returns true for empty formation", ExFormation [], True) + , ("returns true for formation with only delta binding", ExFormation [BiDelta (BtMany ["00", "01"])], True) + , ("returns true for formation with only void binding", ExFormation [BiVoid (AtLabel "x")], True) + , ("returns true for formation with only lambda binding", ExFormation [BiLambda "Func"], True) + , ("returns true for formation with delta void and lambda", ExFormation [BiDelta (BtOne "FF"), BiVoid (AtLabel "y"), BiLambda "G"], True) + ] + (\(desc, expr, expected) -> it desc $ isNF expr ctx `shouldBe` expected) diff --git a/test/SugarSpec.hs b/test/SugarSpec.hs --- a/test/SugarSpec.hs +++ b/test/SugarSpec.hs @@ -287,3 +287,150 @@ salty = toSalty cst rendered = render salty rendered `shouldContain` "α2" + + describe "toSalty EXPRESSION converts EX_PHI_MEET" $ + it "recursively processes inner expression" $ do + let inner = EX_DEF_PACKAGE Φ̇ + expr' = EX_PHI_MEET (Just "x") 1 inner + salty = toSalty expr' + isDispatch EX_DISPATCH{} = True + isDispatch _ = False + case salty of + EX_PHI_MEET pref ix innerSalty -> do + pref `shouldBe` Just "x" + ix `shouldBe` 1 + innerSalty `shouldSatisfy` isDispatch + _ -> fail "Expected EX_PHI_MEET but got different constructor" + + describe "toSalty EXPRESSION converts EX_PHI_AGAIN" $ + it "recursively processes inner expression" $ do + let inner = EX_DEF_PACKAGE Φ̇ + expr' = EX_PHI_AGAIN Nothing 5 inner + salty = toSalty expr' + isDispatch EX_DISPATCH{} = True + isDispatch _ = False + case salty of + EX_PHI_AGAIN pref ix innerSalty -> do + pref `shouldBe` Nothing + ix `shouldBe` 5 + innerSalty `shouldSatisfy` isDispatch + _ -> fail "Expected EX_PHI_AGAIN but got different constructor" + + describe "toSalty handles BI_META binding" $ + it "preserves meta binding in formation" $ do + prog <- parseProgramThrows "{[[ !B ]]}" + let cst = programToCST prog + salty = toSalty cst + render salty `shouldContain` "𝐵" + + describe "toSalty handles BDS_META in nested bindings" $ + it "preserves meta bindings in sequence" $ do + prog <- parseProgramThrows "{[[ x -> Q, !B ]]}" + let cst = programToCST prog + salty = toSalty cst + rendered = render salty + rendered `shouldContain` "𝐵" + + describe "toSalty preserves rho tau in nested bindings" $ + it "keeps tau rho as first binding in sequence" $ do + prog <- parseProgramThrows "{[[ ^ -> $, x -> Q, y -> $ ]]}" + let cst = programToCST prog + salty = toSalty cst + rendered = render salty + count = length (filter (== 'ρ') rendered) + count `shouldBe` 1 + + describe "toSalty PAIR converts formation with empty inner binding" $ + it "expands void parameters into empty formation" $ do + prog <- parseProgramThrows "{[[ f(a) -> [[]] ]]}" + let cst = programToCST prog + salty = toSalty cst + rendered = render salty + rendered `shouldContain` "a" + + describe "toSalty handles floating point number" $ + it "expands float to bytes" $ do + prog <- parseProgramThrows "{[[ x -> 3.14 ]]}" + let cst = programToCST prog + salty = toSalty cst + render salty `shouldContain` "number" + + describe "toSalty handles negative number" $ + it "expands negative integer to bytes" $ do + prog <- parseProgramThrows "{[[ x -> -42 ]]}" + let cst = programToCST prog + salty = toSalty cst + render salty `shouldContain` "number" + + describe "toSalty handles single named application argument" $ + it "processes single tau binding correctly" $ do + prog <- parseProgramThrows "{Q.x(y -> $)}" + let cst = programToCST prog + salty = toSalty cst + rendered = render salty + rendered `shouldContain` "y" + + describe "toSalty preserves rho tau as non-first binding" $ + it "keeps tau rho binding in sequence" $ do + prog <- parseProgramThrows "{[[ x -> Q, ^ -> $ ]]}" + let cst = programToCST prog + salty = toSalty cst + rendered = render salty + count = length (filter (== 'ρ') rendered) + count `shouldBe` 1 + + describe "toSalty handles single positional argument" $ + it "converts single arg to alpha binding" $ do + prog <- parseProgramThrows "{Q.f($)}" + let cst = programToCST prog + salty = toSalty cst + rendered = render salty + rendered `shouldContain` "α0" + + describe "toSalty PAIR handles formation with multiple voids and empty body" $ + it "expands multiple void parameters into empty formation" $ do + prog <- parseProgramThrows "{[[ g(a, b, c) -> [[]] ]]}" + let cst = programToCST prog + salty = toSalty cst + rendered = render salty + rendered `shouldContain` "a" + + describe "toSalty handles unicode attribute in dispatch" $ + it "processes dispatch with decorated name" $ do + prog <- parseProgramThrows "{Q.größe}" + let cst = programToCST prog + salty = toSalty cst + rendered = render salty + rendered `shouldContain` "größe" + + describe "toSalty handles empty string literal" $ + it "expands empty string to bytes" $ do + prog <- parseProgramThrows "{[[ x -> \"\" ]]}" + let cst = programToCST prog + salty = toSalty cst + render salty `shouldContain` "string" + + describe "toSalty handles scientific notation number" $ + it "expands scientific number to bytes" $ do + prog <- parseProgramThrows "{[[ x -> 1e10 ]]}" + let cst = programToCST prog + salty = toSalty cst + render salty `shouldContain` "number" + + describe "toSalty handles deeply nested formations" $ + it "adds rho to all nested levels" $ do + prog <- parseProgramThrows "{[[ x -> [[ y -> [[ z -> Q ]] ]] ]]}" + let cst = programToCST prog + salty = toSalty cst + rendered = render salty + count = length (filter (== 'ρ') rendered) + count `shouldBe` 3 + + describe "toSalty handles formation with only rho void" $ + it "preserves single rho void binding" $ do + prog <- parseProgramThrows "{[[ ^ -> ? ]]}" + let cst = programToCST prog + salty = toSalty cst + rendered = render salty + count = length (filter (== 'ρ') rendered) + count `shouldBe` 1