phino-0.0.100: src/Rewriter.hs
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com
-- SPDX-License-Identifier: MIT
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 qualified Data.Map.Strict as Map
import Deps
import Locator (locatedExpression, withLocatedExpression)
import Logger (logDebug)
import Matcher (Subst)
import Misc (recoverFormations)
import Must (Must (..), exceedsUpperBound, inRange)
import Printer (printExpression)
import Replacer (ReplaceContext (ReplaceCtx), ReplaceExpressionFunc, replaceExpression, replaceExpressionFast)
import Rule (RuleContext (RuleContext))
import qualified Rule as R
import Text.Printf (printf)
import qualified Yaml as Y
type RewriteState = (NonEmpty Rewritten, Seen, Bool)
-- Loop-detection store. It maps a cheap fixed-size digest of an expression (see
-- 'hashExpression') to the full expressions that produced that digest. A
-- digest collision is resolved by a slow, exact structural (==) comparison,
-- so loops are still detected soundly while the common (no collision) case
-- stays O(1) on the digest instead of O(expressionSize) per lookup/insert.
type Seen = Map.Map Int [Expression]
-- Has this exact expression been seen before? The digest lookup is fast; the
-- (==) check runs only on a digest match, guarding against hash collisions.
seenMember :: Int -> Expression -> Seen -> Bool
seenMember digest expr seen = maybe False (elem expr) (Map.lookup digest seen)
-- Remember an expression under its digest, keeping any earlier collisions.
seenInsert :: Int -> Expression -> Seen -> Seen
seenInsert digest expr = Map.insertWith (++) digest [expr]
type Rewritten = (Expression, Maybe String)
type Rewrittens = (NonEmpty Rewritten, Bool)
type Rewrittens' = ([Rewritten], Bool)
type ToReplace = (Expression, Expression, Expression, [Subst])
data RewriteContext = RewriteContext
{ _locator :: Expression
, _maxDepth :: Int
, _maxCycles :: Int
, _depthSensitive :: Bool
, _buildTerm :: BuildTermFunc
, _must :: Must
, _breakpoint :: Maybe String
, _saveStep :: SaveStepFunc
}
data RewriteException
= MustBeGoing Must Int
| MustStopBefore Must Int
| StoppedOnLimit String Int
| LoopingRewriting String String Int
deriving (Exception)
instance Show RewriteException where
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 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 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"
flg
lim
show (LoopingRewriting expr rul stp) =
printf
"On rewriting step '%d' of rule '%s' we got the same expression as we got at one of the previous step, it seems rewriting is looping\nExpression: %s"
stp
rul
expr
-- Build pattern and result expression and replace patterns to results in given expression
buildAndReplace' :: ToReplace -> ReplaceExpressionFunc -> IO Expression
buildAndReplace' (expr, ptn, res, substs) func = do
ptns <- buildExpressionsThrows ptn substs
repls <- buildExpressionsThrows res substs
pure (func (expr, ptns, map const repls))
-- If pattern and replacement are appropriate for fast replacing - does it.
-- Pattern and replacement expressions can be used in fast replacing only if
-- 1. they are both formations
-- 2. they start and end with the same meta bindings, e.g. [!B1, ..., !B2]
-- 3. the does not have meta bindings between first and last meta bindings
-- In such case we can just replace bindings one by one without building whole expression.
-- 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@(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')
then do
logDebug "Applying fast replacing since 'pattern' and 'result' are suitable for this..."
buildAndReplace' (expr, ExFormation pbds', ExFormation rbds', substs) (replaceExpressionFast ctx)
else do
logDebug "Applying regular replacing..."
buildAndReplace' state replaceExpression
where
startsAndEndsWithMeta :: [Binding] -> Bool
startsAndEndsWithMeta [] = False
startsAndEndsWithMeta bds@(bd : _) =
length bds > 1
&& isMetaBinding bd
&& isMetaBinding (last bds)
hasMetaBindings :: [Binding] -> Bool
isMetaBinding :: Binding -> Bool
isMetaBinding = \case
BiMeta _ -> True
_ -> False
hasMetaBindings = foldl (\acc bd -> acc || isMetaBinding bd) False
tryBuildAndReplaceFast state _ = buildAndReplace' state replaceExpression
-- The function returns tuple (X, Y, Z) where
-- - X is sequence of expressions;
-- - Y is Set of unique expressions after each rule application. It allows to stop the rewriting if we're getting
-- into loop and get back to an expression which we've already got before
-- - Z is boolean flag which tells us if we reach breakpoint. If unmatched rule is equal to breakpoint rule - entire
-- rewriting must be stopped and original expression must be returned
rewrite' :: RewriteState -> [Y.Rule] -> Int -> RewriteContext -> IO RewriteState
rewrite' state [] _ _ = pure state
rewrite' state (rule : rest) iteration ctx@RewriteContext{..} = do
state' <- _rewrite state 1
case state' of
(_, _, True) -> pure state'
_ -> rewrite' state' rest iteration ctx
where
_rewrite :: RewriteState -> Int -> IO RewriteState
_rewrite (_rewrittens@((current, _) :| _), _unique, _) _count =
let ruleName = rule.name
ptn = rule.pattern
res = rule.result
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)
if _depthSensitive
then throwIO (StoppedOnLimit "max-depth" _maxDepth)
else pure (_rewrittens, _unique, False)
else do
logDebug (printf "Starting rewriting cycle for rule '%s': %d out of %d" ruleName _count _maxDepth)
expression <- locatedExpression _locator current
R.matchExpressionWithRule expression rule (RuleContext _buildTerm) >>= \case
[] -> do
logDebug (printf "Rule '%s' does not match, rewriting is stopped" ruleName)
if _breakpoint == Just ruleName
then do
logDebug (printf "Rule '%s' is a breakpoint, dropping down all the previous rewritings..." ruleName)
pure (_rewrittens, _unique, True)
else pure (_rewrittens, _unique, False)
matched -> do
logDebug (printf "Rule '%s' has been matched, applying..." ruleName)
expr <- recoverFormations <$> tryBuildAndReplaceFast (expression, ptn, res, matched) (ReplaceCtx _maxDepth)
if expression == expr
then do
logDebug (printf "Applied '%s', no changes made" ruleName)
pure (_rewrittens, _unique, False)
else
let digest = hashExpression expr
in if seenMember digest expr _unique
then throwIO (LoopingRewriting (printExpression expr) ruleName _count)
else do
logDebug
( printf
"Applied '%s' (%d nodes -> %d nodes)\n%s"
ruleName
(countNodes expression)
(countNodes expr)
(printExpression expr)
)
updated <- withLocatedExpression _locator expr current
_saveStep updated (((iteration - 1) * _maxDepth) + _count)
_rewrite (leadsTo updated, seenInsert digest expr _unique, False) (_count + 1)
where
leadsTo :: Expression -> NonEmpty Rewritten
leadsTo next =
let (head', _) :| rest = _rewrittens
in (next, Nothing) :| (head', Just rule.name) : rest
-- Rewrite the expression by provided locator from RewriteContext
rewrite :: Expression -> [Y.Rule] -> RewriteContext -> IO Rewrittens
rewrite expr rules ctx@RewriteContext{..} = do
(rewrittens, exceeded) <- _rewrite ((expr, Nothing) :| [], Map.empty, False) 0
pure (NE.reverse rewrittens, exceeded)
where
_rewrite :: RewriteState -> Int -> IO Rewrittens
_rewrite state@(rewrittens@((current, _) :| _), _, _) 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)
if _depthSensitive
then throwIO (StoppedOnLimit "max-cycles" _maxCycles)
else pure (rewrittens, True)
| otherwise = do
logDebug (printf "Starting rewriting cycle for all rules: %d out of %d" count _maxCycles)
rewrite' state rules count ctx >>= \case
(_, _, True) -> pure ((expr, Nothing) :| [], False) -- breakpoint, return original expression
state'@(rewrittens'@((current', _) :| _), _, False) ->
if current' == current
then do
logDebug "Rewriting is stopped since it has no effect"
if not (inRange _must count)
then throwIO (MustBeGoing _must count)
else pure (rewrittens', False)
else _rewrite state' (count + 1)