phino 0.0.0.55 → 0.0.0.56
raw patch · 36 files changed
+1512/−401 lines, 36 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ Dataize: instance GHC.Exception.Type.Exception Dataize.LocatorException
+ Dataize: instance GHC.Show.Show Dataize.LocatorException
+ Misc: fqnToAttrs :: Expression -> Maybe [Attribute]
- Dataize: dataize :: Program -> DataizeContext -> IO Dataized
+ Dataize: dataize :: Expression -> DataizeContext -> IO Dataized
- Misc: validateYamlObject :: (Applicative a, MonadFail a) => Object -> [String] -> a ()
+ Misc: validateYamlObject :: MonadFail a => Object -> [String] -> a ()
Files
- README.md +2/−2
- phino.cabal +5/−1
- src/AST.hs +3/−4
- src/Builder.hs +13/−13
- src/CLI.hs +36/−27
- src/CST.hs +26/−20
- src/Condition.hs +1/−1
- src/Dataize.hs +57/−19
- src/Deps.hs +2/−2
- src/Encoding.hs +6/−6
- src/Filter.hs +24/−29
- src/Functions.hs +17/−13
- src/LaTeX.hs +17/−13
- src/Lining.hs +1/−1
- src/Logger.hs +7/−7
- src/Matcher.hs +8/−7
- src/Merge.hs +10/−15
- src/Misc.hs +39/−18
- src/Must.hs +18/−18
- src/Parser.hs +3/−2
- src/Printer.hs +13/−13
- src/Render.hs +6/−7
- src/Replacer.hs +8/−11
- src/Rewriter.hs +29/−33
- src/Rule.hs +37/−39
- src/Sugar.hs +15/−5
- src/XMIR.hs +27/−31
- src/Yaml.hs +7/−6
- test/CLISpec.hs +15/−3
- test/DataizeSpec.hs +23/−4
- test/LiningSpec.hs +194/−0
- test/ParserSpec.hs +230/−1
- test/RegexpSpec.hs +250/−0
- test/ReplacerSpec.hs +168/−0
- test/RuleSpec.hs +48/−30
- test/SugarSpec.hs +147/−0
README.md view
@@ -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.
phino.cabal view
@@ -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 <https://github.com/objectionary/phino#readme>@@ -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,
src/AST.hs view
@@ -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
src/Builder.hs view
@@ -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
src/CLI.hs view
@@ -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
src/CST.hs view
@@ -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
src/Condition.hs view
@@ -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)
src/Dataize.hs view
@@ -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')
src/Deps.hs view
@@ -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)
src/Encoding.hs view
@@ -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
src/Filter.hs view
@@ -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])
src/Functions.hs view
@@ -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))
src/LaTeX.hs view
@@ -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
src/Lining.hs view
@@ -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
src/Logger.hs view
@@ -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) )
src/Matcher.hs view
@@ -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
src/Merge.hs view
@@ -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)
src/Misc.hs view
@@ -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
src/Must.hs view
@@ -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
src/Parser.hs view
@@ -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)
src/Printer.hs view
@@ -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
src/Render.hs view
@@ -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
src/Replacer.hs view
@@ -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, [], [])
src/Rewriter.hs view
@@ -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
src/Rule.hs view
@@ -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'
src/Sugar.hs view
@@ -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
src/XMIR.hs view
@@ -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: -- <metas> -- <meta>@@ -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
src/Yaml.hs view
@@ -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" ] )
test/CLISpec.hs view
@@ -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- ]]" $
test/DataizeSpec.hs view
@@ -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" ) ]
+ test/LiningSpec.hs view
@@ -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
test/ParserSpec.hs view
@@ -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))
+ test/RegexpSpec.hs view
@@ -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"
test/ReplacerSpec.hs view
@@ -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])]) ) ]
test/RuleSpec.hs view
@@ -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)
test/SugarSpec.hs view
@@ -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