diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -29,7 +29,7 @@ ```bash cabal update -cabal install --overwrite-policy=always phino-0.0.0.63 +cabal install --overwrite-policy=always phino-0.0.0.64 phino --version ``` @@ -47,6 +47,7 @@ * Ubuntu: * MacOS (ARM): * MacOS (Intel): +* Windows: ## 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/ diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/phino.cabal b/phino.cabal --- a/phino.cabal +++ b/phino.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: phino -version: 0.0.0.64 +version: 0.0.0.65 license: MIT synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions description: Please see the README on GitHub at @@ -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 diff --git a/src/Builder.hs b/src/Builder.hs --- a/src/Builder.hs +++ b/src/Builder.hs @@ -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) diff --git a/src/CLI/Helpers.hs b/src/CLI/Helpers.hs --- a/src/CLI/Helpers.hs +++ b/src/CLI/Helpers.hs @@ -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" diff --git a/src/CLI/Runners.hs b/src/CLI/Runners.hs --- a/src/CLI/Runners.hs +++ b/src/CLI/Runners.hs @@ -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 diff --git a/src/CST.hs b/src/CST.hs --- a/src/CST.hs +++ b/src/CST.hs @@ -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) diff --git a/src/Dataize.hs b/src/Dataize.hs --- a/src/Dataize.hs +++ b/src/Dataize.hs @@ -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") diff --git a/src/Functions.hs b/src/Functions.hs --- a/src/Functions.hs +++ b/src/Functions.hs @@ -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 diff --git a/src/LaTeX.hs b/src/LaTeX.hs --- a/src/LaTeX.hs +++ b/src/LaTeX.hs @@ -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 diff --git a/src/Matcher.hs b/src/Matcher.hs --- a/src/Matcher.hs +++ b/src/Matcher.hs @@ -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 diff --git a/src/Render.hs b/src/Render.hs --- a/src/Render.hs +++ b/src/Render.hs @@ -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)) diff --git a/src/Rewriter.hs b/src/Rewriter.hs --- a/src/Rewriter.hs +++ b/src/Rewriter.hs @@ -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" diff --git a/src/Rule.hs b/src/Rule.hs --- a/src/Rule.hs +++ b/src/Rule.hs @@ -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] diff --git a/src/XMIR.hs b/src/XMIR.hs --- a/src/XMIR.hs +++ b/src/XMIR.hs @@ -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 diff --git a/test/ASTSpec.hs b/test/ASTSpec.hs --- a/test/ASTSpec.hs +++ b/test/ASTSpec.hs @@ -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" $ diff --git a/test/DataizeSpec.hs b/test/DataizeSpec.hs --- a/test/DataizeSpec.hs +++ b/test/DataizeSpec.hs @@ -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 diff --git a/test/RandomSpec.hs b/test/RandomSpec.hs --- a/test/RandomSpec.hs +++ b/test/RandomSpec.hs @@ -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 diff --git a/test/RewriterSpec.hs b/test/RewriterSpec.hs --- a/test/RewriterSpec.hs +++ b/test/RewriterSpec.hs @@ -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