phino 0.0.0.64 → 0.0.0.65
raw patch · 19 files changed
+171/−147 lines, 19 filesdep −transformersdep ~aesondep ~arraydep ~binary-ieee754
Dependencies removed: transformers
Dependency ranges changed: aeson, array, binary-ieee754, bytestring, containers, directory, file-embed, filepath, hspec, hspec-core, megaparsec, optparse-applicative, process, random, regex-pcre-builtin, scientific, silently, text, time, utf8-string, vector, xml-conduit, yaml
Files
- README.md +5/−8
- app/Main.hs +2/−1
- phino.cabal +36/−38
- src/Builder.hs +7/−2
- src/CLI/Helpers.hs +2/−2
- src/CLI/Runners.hs +2/−1
- src/CST.hs +11/−2
- src/Dataize.hs +31/−27
- src/Functions.hs +2/−2
- src/LaTeX.hs +2/−2
- src/Matcher.hs +2/−2
- src/Render.hs +2/−2
- src/Rewriter.hs +25/−23
- src/Rule.hs +3/−3
- src/XMIR.hs +17/−16
- test/ASTSpec.hs +12/−10
- test/DataizeSpec.hs +5/−4
- test/RandomSpec.hs +3/−1
- test/RewriterSpec.hs +2/−1
README.md view
@@ -29,7 +29,7 @@ ```bash cabal update-cabal install --overwrite-policy=always phino-0.0.0.63+cabal install --overwrite-policy=always phino-0.0.0.64 phino --version ``` @@ -47,6 +47,7 @@ * Ubuntu: <http://phino.objectionary.com/releases/ubuntu-24.04/phino-latest> * MacOS (ARM): <http://phino.objectionary.com/releases/macos-15/phino-latest> * MacOS (Intel): <http://phino.objectionary.com/releases/macos-14-large/phino-latest>+* Windows: <http://phino.objectionary.com/releases/windows-2022/phino-latest.exe> ## Build @@ -72,7 +73,7 @@ Verify that `phino` is installed correctly: ```bash-phino --version+$ phino --version 0.0.0.0 ``` @@ -200,11 +201,6 @@ { [[ B_1, \tau_1 -> ?, B_2 ]] ( \tau_1 -> e ) } { if $ \indexof{ \tau_2 } = \vert B_1 \vert $ } { }-\trrule{copy}- { [[ B_1, \tau -> ?, B_2 ]] ( \tau -> e_1 ) }- { [[ B_1, \tau -> e_3, B_2 ]] }- { if $ \isnormal{ e_1 } $ }- { where $ e_2 \coloneqq \scopeof{ e_1 } $ and $ e_3 \coloneqq \ctx{ e_1 }{ e_2 } $ } \trrule{dc} { T ( \tau -> e ) } { T }@@ -359,7 +355,8 @@ make coverage ``` -You will need [GHC] and [Cabal ≥3.0][cabal] or [Stack ≥ 3.0][stack] installed.+You will need [GHC ≥ 9.6.7][GHC] and [Cabal ≥ 3.0 (recommended)][cabal]+or [Stack ≥ 3.0][stack] installed. [cabal]: https://www.haskell.org/cabal/ [stack]: https://docs.haskellstack.org/en/stable/install_and_upgrade/
app/Main.hs view
@@ -4,7 +4,8 @@ module Main where import CLI (runCLI)+import GHC.IO.Encoding (setLocaleEncoding, utf8) import System.Environment (getArgs) main :: IO ()-main = getArgs >>= runCLI+main = setLocaleEncoding utf8 >> getArgs >>= runCLI
phino.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: phino-version: 0.0.0.64+version: 0.0.0.65 license: MIT synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions description: Please see the README on GitHub at <https://github.com/objectionary/phino#readme>@@ -29,7 +29,6 @@ -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints- -Wno-missing-export-lists library import: warnings@@ -79,27 +78,26 @@ Paths_phino build-depends:- aeson ^>=2.2.3.0,- array ^>=0.5.8.0,+ aeson >=2.2.3 && <2.3,+ array >=0.5.4 && <0.6, base >=4.18.3.0 && <5,- binary-ieee754 ^>=0.1.0.0,- bytestring ^>=0.11.5.4,- containers ^>=0.6.7,- directory ^>=1.3.8.5,- file-embed ^>=0.0.16.0,- filepath ^>=1.4.301.0,- megaparsec ^>=9.7.0,- optparse-applicative ^>=0.19.0.0,- random >=1.2 && <1.4,- regex-pcre-builtin ^>=0.95.2.3.8.44,- scientific ^>=0.3.8.0,- text ^>=2.0.2,- time ^>=1.12,- transformers ^>=0.6.1.0,- utf8-string ^>=1.0.2,- vector ^>=0.13.2.0,- xml-conduit ^>=1.10,- yaml ^>=0.11.11.2,+ binary-ieee754 >=0.1.0 && <0.2,+ bytestring >=0.11.4 && <0.13,+ containers >=0.6.5 && <0.8,+ directory >=1.3.7 && <1.4,+ file-embed >=0.0.15 && <0.0.17,+ filepath >=1.4.200 && <1.5,+ megaparsec >=9.5 && <9.8,+ optparse-applicative >=0.18 && <0.20,+ random >=1.2 && <1.3,+ regex-pcre-builtin >=0.95.2 && <0.96,+ scientific >=0.3.7 && <0.4,+ text >=2.0.2 && <2.2,+ time >=1.12 && <1.15,+ utf8-string >=1.0.2 && <1.1,+ vector >=0.13.0 && <0.14,+ xml-conduit >=1.9 && <1.10,+ yaml >=0.11.8 && <0.12, default-language: Haskell2010 @@ -154,25 +152,25 @@ ImportQualifiedPost build-depends:- aeson ^>=2.2.3.0,+ aeson >=2.2.3 && <2.3, base >=4.18.3.0 && <5,- bytestring ^>=0.11.5.4,- containers ^>=0.6.7,- directory ^>=1.3.8.5,- filepath ^>=1.4.301.0,- hspec ^>=2.11.16,- hspec-core ^>=2.11.16,- megaparsec ^>=9.7.0,- optparse-applicative ^>=0.19.0.0,+ bytestring >=0.11.4 && <0.13,+ containers >=0.6.5 && <0.8,+ directory >=1.3.7 && <1.4,+ filepath >=1.4.200 && <1.5,+ hspec >=2.11.0 && <2.12,+ hspec-core >=2.11.0 && <2.12,+ megaparsec >=9.5 && <9.8,+ optparse-applicative >=0.18 && <0.20, phino,- process ^>=1.6.19.0,- silently ^>=1.2.5.4,- text ^>=2.0.2,- time ^>=1.12,- xml-conduit ^>=1.10,- yaml ^>=0.11.11.2,+ process >=1.6.17 && <1.7,+ silently >=1.2.5 && <1.3,+ text >=2.0.2 && <2.2,+ time >=1.12 && <1.15,+ xml-conduit >=1.9 && <1.10,+ yaml >=0.11.8 && <0.12, build-tool-depends:- hspec-discover:hspec-discover+ hspec-discover:hspec-discover >=2.11.0 && <2.12 default-language: Haskell2010
src/Builder.hs view
@@ -24,6 +24,7 @@ import AST import Control.Exception (Exception, throwIO)+import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map.Strict as Map import Matcher import Misc (uniqueBindings)@@ -118,8 +119,12 @@ Right (ExDispatch dispatched at', scope) buildExpression (ExApplication expr (BiTau battr bexpr)) subst = do (applied, scope) <- buildExpression expr subst- bds <- buildBinding (BiTau battr bexpr) subst- Right (ExApplication applied (head bds), scope)+ bd :| _ <- nonEmpty' =<< buildBinding (BiTau battr bexpr) subst+ Right (ExApplication applied bd, scope)+ where+ nonEmpty' :: [a] -> Built (NonEmpty a)+ nonEmpty' [] = Left ""+ nonEmpty' (x : xs) = Right (x :| xs) buildExpression (ExFormation bds) subst = do bds' <- buildBindings bds subst >>= uniqueBindings Right (ExFormation bds', defaultScope)
src/CLI/Helpers.hs view
@@ -20,7 +20,7 @@ import qualified Misc as M import Parser (parseProgramThrows) import qualified Printer as P-import Rewriter (Rewrittens)+import Rewriter (Rewrittens') import System.IO (getContents') import Text.Printf (printf) import XMIR (parseXMIRThrows, printXMIR, programToXMIR, xmirToPhi)@@ -58,7 +58,7 @@ parseProgram xmir XMIR = parseXMIRThrows xmir >>= xmirToPhi parseProgram _ LATEX = invalidCLIArguments "LaTeX cannot be used as input format" -printRewrittens :: PrintProgramContext -> Rewrittens -> IO String+printRewrittens :: PrintProgramContext -> Rewrittens' -> IO String printRewrittens ctx@PrintProgCtx{..} rewrittens@(chain, _) | _outputFormat == LATEX && _sequence = rewrittensToLatex rewrittens (printCtxToLatexCtx ctx) | _focus == ExGlobal = mapM (printProgram ctx . fst) chain <&> intercalate "\n"
src/CLI/Runners.hs view
@@ -14,6 +14,7 @@ import Condition (parseConditionThrows) import Control.Exception import Control.Monad (unless, when)+import qualified Data.List.NonEmpty as NE import Data.Maybe (fromJust, isJust, isNothing) import Dataize import Encoding@@ -49,7 +50,7 @@ exclude = (`F.exclude` excluded) include = (`F.include` included) (rewrittens, exceeded) <- rewrite program rules (context loc printCtx)- let rewrittens' = canonize $ exclude $ include (if _sequence then rewrittens else [last rewrittens])+ let rewrittens' = canonize $ exclude $ include (if _sequence then NE.toList rewrittens else [NE.last rewrittens]) logDebug (printf "Printing rewritten 𝜑-program as %s" (show _outputFormat)) progs <- printRewrittens printCtx (rewrittens', exceeded) output _targetFile progs
src/CST.hs view
@@ -258,7 +258,7 @@ toCST' = (`toCST` (0, EOL)) metaTail :: String -> String-metaTail = tail+metaTail = drop 1 -- This class is used to convert AST to CST -- CST is created with sugar and unicode@@ -314,7 +314,7 @@ ex' = toCST ex ctx :: EXPRESSION next = tabs + 1 (ts', rs) = withoutRhosInPrimitives ex ts- obj = ExApplication ex (head ts')+ obj = ExApplication ex (head' ts') in if length ts' == 1 && isJust (matchDataObject obj) then applicationToPrimitive obj tabs rs else@@ -385,6 +385,15 @@ complexApplication' (ExApplication expr (BiTau (AtAlpha 0) expr')) = (expr, [BiTau (AtAlpha 0) expr'], [expr']) complexApplication' (ExApplication expr tau) = (expr, [tau], []) complexApplication' expr = (expr, [], [])+ -- This head' works the same as head from Prelude but doesn't throw an error+ -- It's used to bypass the x-partial error in ghc 9.8.*+ -- This approach is just simpler that switching to NonEmpty for complexApplication or withoutRhosInPrimitives functions+ -- but not a brightest design+ -- There never be an empty list because application always has binding, which means complex application+ -- always has non empty list of bindings+ head' :: [a] -> a+ head' [] = error "Should never be called"+ head' (x : _) = x instance ToCST [Expression] APP_ARG where toCST (expr : exprs) ctx = APP_ARG (toCST expr ctx) (toCST exprs ctx)
src/Dataize.hs view
@@ -13,6 +13,8 @@ import Builder (contextualize) import Control.Exception (throwIO) import Data.List (partition)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE import Deps (BuildTermFunc, SaveStepFunc, Term (TeAttribute)) import Locator (locatedExpression, withLocatedExpression) import Matcher (substEmpty)@@ -25,7 +27,7 @@ type Dataized = (Maybe Bytes, [Rewritten]) -type Dataizable = (Expression, [Rewritten])+type Dataizable = (Expression, NonEmpty Rewritten) type Morphed = Dataizable @@ -154,15 +156,16 @@ then morph (ExTermination, seq) ctx -- PRIM else do prog' <- withLocatedExpression _locator expr _program- (rewrittens', _) <- rewrite prog' normalizationRules (switchContext ctx) -- NMZ- let seq' = reverse rewrittens' <> tail seq- expr' <- locatedExpression _locator (fst (head seq'))+ (rewrittens, _) <- rewrite prog' normalizationRules (switchContext ctx) -- NMZ+ let (rw :| rws) = NE.reverse rewrittens+ seq' = rw :| rws <> NE.tail seq+ expr' <- locatedExpression _locator (fst rw) morph (expr', seq') ctx dataize :: DataizeContext -> IO Dataized dataize ctx@DataizeContext{..} = do expr <- locatedExpression _locator _program- (maybeBytes, seq) <- dataize' (expr, [(_program, Nothing)]) ctx+ (maybeBytes, seq) <- dataize' (expr, (_program, Nothing) :| []) ctx pure (maybeBytes, reverse seq) -- The goal of 'dataize' function is retrieve bytes from given expression.@@ -172,30 +175,31 @@ -- NORM: D(e1) -> D(e2) if e2 := M(e1) and e1 is not primitive -- nothing otherwise dataize' :: Dataizable -> DataizeContext -> IO Dataized-dataize' (ExTermination, seq) _ = pure (Nothing, seq)-dataize' (form@(ExFormation bds), seq) ctx@DataizeContext{..} = 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, _) -> do- let expr' = contextualize expr form- seq' <- leadsTo seq "contextualize" expr' ctx- dataize' (expr', seq') ctx- (Just _, _) -> pure (Nothing, seq)- (Nothing, _) -> case maybeLambda bds of- (Just (BiLambda _), _) -> morph (form, seq) ctx >>= (`dataize'` ctx)- (Just _, _) -> pure (Nothing, seq)- (Nothing, _) -> pure (Nothing, seq)+dataize' (ExTermination, seq) _ = pure (Nothing, NE.toList seq)+dataize' (form@(ExFormation bds), seq) ctx@DataizeContext{..} =+ let _seq = NE.toList seq+ in 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, _) -> do+ let expr' = contextualize expr form+ seq' <- leadsTo seq "contextualize" expr' ctx+ dataize' (expr', seq') ctx+ (Just _, _) -> pure (Nothing, _seq)+ (Nothing, _) -> case maybeLambda bds of+ (Just (BiLambda _), _) -> morph (form, seq) ctx >>= (`dataize'` ctx)+ (Just _, _) -> pure (Nothing, _seq)+ (Nothing, _) -> pure (Nothing, _seq) dataize' dataizable ctx = morph dataizable ctx >>= (`dataize'` ctx) -leadsTo :: [Rewritten] -> String -> Expression -> DataizeContext -> IO [Rewritten]-leadsTo [] _ _ _ = throwIO (userError "Empty rewritten sequence should never met during dataization process")-leadsTo ((prog, _) : rest) rule expr DataizeContext{..} = do+leadsTo :: NonEmpty Rewritten -> String -> Expression -> DataizeContext -> IO (NonEmpty Rewritten)+leadsTo ((prog, _) :| rest) rule expr DataizeContext{..} = do prog' <- withLocatedExpression _locator expr prog- pure ((prog', Nothing) : (prog, Just rule) : rest)+ pure ((prog', Nothing) :| (prog, Just rule) : rest) -- Synthetic dataize function for internal usage inside atoms -- Here we modify original program from context by adding new binding@@ -204,7 +208,7 @@ _dataize expr ctx@DataizeContext{_buildTerm = buildTerm, _program = Program (ExFormation bds)} = do (TeAttribute attr) <- buildTerm "random-tau" (map ArgAttribute (attributesFromBindings bds)) substEmpty let prog = Program (ExFormation (BiTau attr expr : bds))- (bts, _) <- dataize' (expr, [(prog, Nothing)]) ctx{_program = prog}+ (bts, _) <- dataize' (expr, (prog, Nothing) :| []) ctx{_program = prog} pure bts _dataize _ _ = throwIO (userError "Can't call _dataize from atoms with non-formation program")
src/Functions.hs view
@@ -114,14 +114,14 @@ _sed :: BuildTermMethod _sed args subst = do when (length args < 2) (throwIO (userError "Function sed() requires at least two arguments"))- args' <-+ first : rest <- traverse ( \arg -> do bts <- argToString arg subst pure (B.pack bts) ) args- res <- sed (head args') (tail args')+ res <- sed first rest pure (TeExpression (DataString (strToBts (B.unpack res)))) where sed :: B.ByteString -> [B.ByteString] -> IO B.ByteString
src/LaTeX.hs view
@@ -31,7 +31,7 @@ import Misc import Render (Render (render)) import Replacer (replaceProgram)-import Rewriter (Rewritten, Rewrittens)+import Rewriter (Rewritten, Rewrittens') import Sugar (SugarType (SWEET), ToSalty, withSugarType) import Text.Printf (printf) import Text.Read (readMaybe)@@ -159,7 +159,7 @@ let (progs, rules) = unzip rewrittens in if _compress then zip (meetInPrograms progs ctx) rules else rewrittens -rewrittensToLatex :: Rewrittens -> LatexContext -> IO String+rewrittensToLatex :: Rewrittens' -> LatexContext -> IO String rewrittensToLatex (rewrittens, exceeded) ctx@LatexContext{_focus = ExGlobal} = pure ( concat
src/Matcher.hs view
@@ -117,8 +117,8 @@ (substs, tails) <- tailExpressionsReversed ptn' expr Just (substs, TaDispatch attr : tails) ExApplication expr tau -> do- (substs, tails) <- tailExpressionsReversed ptn' expr- if not (null tails) && isDispatch (head tails)+ (substs, tails@(t : _)) <- tailExpressionsReversed ptn' expr+ if not (null tails) && isDispatch t then Just (substs, TaApplication tau : tails) else Nothing where
src/Render.hs view
@@ -254,6 +254,6 @@ render ARG_BYTES{..} = render bytes instance Render EXTRA where- render EXTRA{func = "contextualize", ..} = printf "$ %s \\coloneqq \\ctx{ %s }{ %s } $" (render meta) (render (head args)) (intercalate ", " (map render (tail args)))- render EXTRA{func = "scope", ..} = printf "$ %s \\coloneqq \\scopeof{ %s } $" (render meta) (render (head args))+ render EXTRA{func = "contextualize", args = arg : rest, ..} = printf "$ %s \\coloneqq \\ctx{ %s }{ %s } $" (render meta) (render arg) (intercalate ", " (map render rest))+ render EXTRA{func = "scope", args = arg : _, ..} = printf "$ %s \\coloneqq \\scopeof{ %s } $" (render meta) (render arg) render EXTRA{..} = printf "$ %s \\coloneqq %s( %s ) $" (render meta) func (intercalate ", " (map render args))
src/Rewriter.hs view
@@ -8,11 +8,13 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module Rewriter (rewrite, RewriteContext (..), Rewritten, Rewrittens) where+module Rewriter (rewrite, RewriteContext (..), Rewritten, Rewrittens, Rewrittens') where import AST import Builder import Control.Exception (Exception, throwIO)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE import Data.Maybe (fromMaybe) import qualified Data.Set as Set import Deps@@ -27,12 +29,14 @@ import Text.Printf (printf) import qualified Yaml as Y -type RewriteState = ([Rewritten], Set.Set Expression)+type RewriteState = (NonEmpty Rewritten, Set.Set Expression) type Rewritten = (Program, Maybe String) -type Rewrittens = ([Rewritten], Bool)+type Rewrittens = (NonEmpty Rewritten, Bool) +type Rewrittens' = ([Rewritten], Bool)+ type ToReplace = (Expression, Expression, Expression, [Subst]) data RewriteContext = RewriteContext@@ -95,12 +99,12 @@ -- You can find more details in this ticket: https://github.com/objectionary/phino/issues/321 -- If we don't meet the conditions above - just do a regular replacing tryBuildAndReplaceFast :: ToReplace -> ReplaceContext -> IO Expression-tryBuildAndReplaceFast state@(expr, ExFormation pbds, ExFormation rbds, substs) ctx =- let pbds' = init (tail pbds)- rbds' = init (tail rbds)- in if startsAndEndsWithMeta pbds- && startsAndEndsWithMeta rbds- && head pbds == head rbds+tryBuildAndReplaceFast state@(expr, ExFormation _pbds@(pbd : pbds), ExFormation _rbds@(rbd : rbds), substs) ctx =+ let pbds' = init pbds+ rbds' = init rbds+ in if startsAndEndsWithMeta _pbds+ && startsAndEndsWithMeta _rbds+ && pbd == rbd && last pbds == last rbds && not (hasMetaBindings pbds') && not (hasMetaBindings rbds')@@ -112,9 +116,10 @@ buildAndReplace' state replaceExpression where startsAndEndsWithMeta :: [Binding] -> Bool- startsAndEndsWithMeta bds =+ startsAndEndsWithMeta [] = False+ startsAndEndsWithMeta bds@(bd : _) = length bds > 1- && isMetaBinding (head bds)+ && isMetaBinding bd && isMetaBinding (last bds) hasMetaBindings :: [Binding] -> Bool isMetaBinding :: Binding -> Bool@@ -135,11 +140,10 @@ rewrite' state' rest iteration ctx where _rewrite :: RewriteState -> Int -> IO RewriteState- _rewrite (_rewrittens, _unique) _count =+ _rewrite (_rewrittens@((program, _) :| _), _unique) _count = let ruleName = fromMaybe "unknown" (Y.name rule) ptn = Y.pattern rule res = Y.result rule- (program, _) = head _rewrittens in if _count - 1 == _maxDepth then do logDebug (printf "Max amount of rewriting cycles (%d) for rule '%s' has been reached, rewriting is stopped" _maxDepth ruleName)@@ -177,19 +181,19 @@ _saveStep prog (((iteration - 1) * _maxDepth) + _count) _rewrite (leadsTo prog, Set.insert expr _unique) (_count + 1) where- leadsTo :: Program -> [Rewritten]- leadsTo _prog = case _rewrittens of- (program, _) : rest -> (_prog, Nothing) : (program, Just (fromMaybe "unknown" (Y.name rule))) : rest- [] -> [(_prog, Nothing)]+ leadsTo :: Program -> NonEmpty Rewritten+ leadsTo _prog =+ let (program, _) :| rest = _rewrittens+ in (_prog, Nothing) :| (program, Just (fromMaybe "unknown" (Y.name rule))) : rest -- Rewrite program by provided locator from RewriteContext rewrite :: Program -> [Y.Rule] -> RewriteContext -> IO Rewrittens rewrite prog rules ctx@RewriteContext{..} = do- (rewrittens, exceeded) <- _rewrite ([(prog, Nothing)], Set.empty) 0- pure (reverse rewrittens, exceeded)+ (rewrittens, exceeded) <- _rewrite ((prog, Nothing) :| [], Set.empty) 0+ pure (NE.reverse rewrittens, exceeded) where _rewrite :: RewriteState -> Int -> IO Rewrittens- _rewrite state@(rewrittens, _) count+ _rewrite state@(rewrittens@((program, _) :| _), _) count | not (inRange _must count) && count > 0 && exceedsUpperBound _must count = throwIO (MustStopBefore _must count) | count == _maxCycles = do logDebug (printf "Max amount of rewriting cycles for all rules (%d) has been reached, rewriting is stopped" _maxCycles)@@ -198,9 +202,7 @@ else pure (rewrittens, True) | otherwise = do logDebug (printf "Starting rewriting cycle for all rules: %d out of %d" count _maxCycles)- state'@(rewrittens', _) <- rewrite' state rules count ctx- let (program', _) = head rewrittens'- (program, _) = head rewrittens+ state'@(rewrittens'@((program', _) :| _), _) <- rewrite' state rules count ctx if program' == program then do logDebug "Rewriting is stopped since it has no effect"
src/Rule.hs view
@@ -222,9 +222,9 @@ case met of Right first -> do next <- meetCondition cond rest ctx- if null first- then pure next- else pure (head first : next)+ case first of+ [] -> pure next+ sbt : _ -> pure (sbt : next) Left _ -> meetCondition cond rest ctx meetMaybeCondition :: Maybe Y.Condition -> [Subst] -> RuleContext -> IO [Subst]
src/XMIR.hs view
@@ -92,10 +92,10 @@ expression (ExDispatch expr attr) ctx = do (base, children) <- expression expr ctx let attr' = printAttribute attr- if null base- then pure ('.' : attr', [object [] children])- else- if head base == '.' || not (null children)+ case base of+ [] -> pure ('.' : attr', [object [] children])+ ch : _ ->+ if ch == '.' || not (null children) then pure ('.' : attr', [object [("base", base)] children]) else pure (base ++ ('.' : attr'), children) expression (DataNumber bytes) XmirContext{..} =@@ -405,13 +405,13 @@ then throwIO (InvalidXMIRFormat "The @base attribute can't be just '.'" cur) else let args = cur C.$/ C.element (toName "o")- in if null args- then throwIO (InvalidXMIRFormat (printf "Element with @base='%s' must have at least one child" base) cur)- else do- expr <- xmirToExpression (head args) fqn+ in case args of+ [] -> throwIO (InvalidXMIRFormat (printf "Element with @base='%s' must have at least one child" base) cur)+ arg : args' -> do+ expr <- xmirToExpression arg fqn attr <- toAttr rest cur let disp = ExDispatch expr attr- xmirToApplication disp (tail args) fqn+ xmirToApplication disp args' fqn "ξ" -> if null (cur C.$/ C.element (toName "o")) then pure ExThis@@ -470,7 +470,7 @@ attr <- toAttr as cur case attr of AtRho -> throwIO (InvalidXMIRFormat "The 'ρ' in @as attribute is illegal in XMIR" cur)- other -> pure other+ _ -> pure attr | otherwise = pure (AtAlpha idx) toAttr :: String -> C.Cursor -> IO Attribute@@ -481,10 +481,11 @@ Nothing -> throwIO (InvalidXMIRFormat "The attribute started with 'α' must be followed by integer" cur) "φ" -> pure AtPhi "ρ" -> pure AtRho- _- | head attr `notElem` ['a' .. 'z'] -> throwIO (InvalidXMIRFormat (printf "The attribute '%s' must start with ['a'..'z']" attr) cur)+ ch : _+ | ch `notElem` ['a' .. 'z'] -> throwIO (InvalidXMIRFormat (printf "The attribute '%s' must start with ['a'..'z']" attr) cur) | '.' `elem` attr -> throwIO (InvalidXMIRFormat "Attribute can't contain dots" cur) | otherwise -> pure (AtLabel attr)+ _ -> throwIO (InvalidXMIRFormat (printf "Invalid attribute given: %s" attr) cur) hasAttr :: String -> C.Cursor -> Bool hasAttr key cur = not (null (C.attribute (toName key) cur))@@ -492,10 +493,10 @@ getAttr :: String -> C.Cursor -> IO String getAttr key cur = let attrs = C.attribute (toName key) cur- in if null attrs- then throwIO (InvalidXMIRFormat (printf "Couldn't find attribute '%s'" key) cur)- else- let attr = (T.unpack . head) attrs+ in case attrs of+ [] -> throwIO (InvalidXMIRFormat (printf "Couldn't find attribute '%s'" key) cur)+ at : _ ->+ let attr = T.unpack at in if null attr then throwIO (InvalidXMIRFormat (printf "The attribute '%s' is not expected to be empty" attr) cur) else pure attr
test/ASTSpec.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT @@ -86,10 +88,10 @@ describe "Attribute Ord instance orders correctly" $ it "sorts attributes by constructor order" $ let attrs = [AtMeta "z", AtDelta, AtLambda, AtRho, AtPhi, AtAlpha 1, AtLabel "a"]- sorted = sort attrs+ first : _ = sort attrs isLabel (AtLabel _) = True isLabel _ = False- in head sorted `shouldSatisfy` isLabel+ in first `shouldSatisfy` isLabel describe "Bytes Eq instance compares same constructors" $ forM_@@ -118,8 +120,8 @@ describe "Bytes Ord instance orders correctly" $ it "sorts bytes by constructor order" $ let bytes = [BtMeta "z", BtMany ["00"], BtOne "FF", BtEmpty]- sorted = sort bytes- in head sorted `shouldBe` BtEmpty+ first : _ = sort bytes+ in first `shouldBe` BtEmpty describe "Binding Eq instance compares same constructors" $ forM_@@ -154,10 +156,10 @@ describe "Binding Ord instance orders correctly" $ it "sorts bindings by constructor order" $ let bindings = [BiMetaLambda "Z", BiLambda "A", BiVoid AtRho, BiDelta BtEmpty, BiMeta "B", BiTau AtRho ExGlobal]- sorted = sort bindings+ first : _ = sort bindings isTau (BiTau _ _) = True isTau _ = False- in head sorted `shouldSatisfy` isTau+ in first `shouldSatisfy` isTau describe "Expression Eq instance compares same constructors" $ forM_@@ -191,8 +193,8 @@ describe "Expression Ord instance orders correctly" $ it "sorts expressions by constructor order" $ let exprs = [ExMetaTail ExGlobal "t", ExDispatch ExGlobal AtRho, ExApplication ExGlobal (BiVoid AtRho), ExMeta "e", ExTermination, ExGlobal, ExThis, ExFormation []]- sorted = sort exprs- in head sorted `shouldBe` ExFormation []+ first : _ = sort exprs+ in first `shouldBe` ExFormation [] describe "Program Eq instance compares programs" $ forM_@@ -206,8 +208,8 @@ describe "Program Ord instance orders correctly" $ it "orders programs by expression" $ let progs = [Program ExThis, Program ExGlobal, Program (ExFormation [])]- sorted = sort progs- in head sorted `shouldBe` Program (ExFormation [])+ first : _ = sort progs+ in first `shouldBe` Program (ExFormation []) describe "Program Show instance renders programs" $ it "shows program wrapper" $
test/DataizeSpec.hs view
@@ -5,6 +5,7 @@ import AST import Control.Monad+import Data.List.NonEmpty (NonEmpty (..)) import Dataize (DataizeContext (DataizeContext), dataize, dataize', morph) import Deps (dontSaveStep) import Functions (buildTerm)@@ -15,20 +16,20 @@ defaultDataizeContext :: Expression -> Program -> DataizeContext defaultDataizeContext loc prog = DataizeContext loc prog 25 25 False buildTerm dontSaveStep -test :: (Eq a, Show a) => ((Expression, [Rewritten]) -> DataizeContext -> IO (Maybe a, [Rewritten])) -> [(String, Expression, Expression, Maybe a)] -> Spec+test :: (Eq a, Show a) => ((Expression, NonEmpty Rewritten) -> DataizeContext -> IO (Maybe a, [Rewritten])) -> [(String, Expression, Expression, Maybe a)] -> Spec test func useCases = forM_ useCases $ \(desc, input, expr, output) -> it desc $ do let prog = Program expr- (res, _) <- func (input, [(prog, Nothing)]) (defaultDataizeContext ExGlobal prog)+ (res, _) <- func (input, (prog, Nothing) :| []) (defaultDataizeContext ExGlobal prog) res `shouldBe` output -test' :: (Eq a, Show a) => ((Expression, [Rewritten]) -> DataizeContext -> IO (a, [Rewritten])) -> [(String, Expression, Expression, a)] -> Spec+test' :: (Eq a, Show a) => ((Expression, NonEmpty Rewritten) -> DataizeContext -> IO (a, NonEmpty Rewritten)) -> [(String, Expression, Expression, a)] -> Spec test' func useCases = forM_ useCases $ \(desc, input, expr, output) -> it desc $ do let prog = Program expr- (res, _) <- func (input, [(prog, Nothing)]) (defaultDataizeContext ExGlobal prog)+ (res, _) <- func (input, (prog, Nothing) :| []) (defaultDataizeContext ExGlobal prog) res `shouldBe` output testDataize :: [(String, String, String, Bytes)] -> Spec
test/RandomSpec.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT @@ -94,7 +96,7 @@ describe "randomString with mixed patterns" $ it "handles %d and %x together" $ do result <- randomString "a%db%xc"- result `shouldSatisfy` (\s -> head s == 'a')+ result `shouldSatisfy` (\case [] -> False; ch : _ -> ch == 'a') describe "randomString generates unique strings" $ it "produces different results on repeated calls" $ do
test/RewriterSpec.hs view
@@ -12,6 +12,7 @@ import Control.Monad (forM_, unless) import Data.Aeson import Data.Char (isSpace)+import Data.List.NonEmpty qualified as NE import Data.Yaml qualified as Yaml import Deps (dontSaveStep) import Functions (buildTerm)@@ -112,7 +113,7 @@ must' dontSaveStep )- let (program, _) = last rewrittens+ let (program, _) = NE.last rewrittens result' <- parseProgramThrows (output pack) unless (program == result') $ expectationFailure