{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com
-- SPDX-License-Identifier: MIT

module Rule where

import Ast
import Builder (buildAttribute, buildBinding, buildBindingThrows, buildExpression, buildExpressionThrows)
import Control.Exception (SomeException (SomeException), evaluate)
import Control.Exception.Base (try)
import Data.Aeson (FromJSON)
import qualified Data.ByteString.Char8 as B
import Data.Foldable (foldlM)
import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes, fromMaybe)
import GHC.IO (unsafePerformIO)
import Logger (logDebug)
import Matcher
import Misc (allPathsIn, btsToUnescapedStr)
import Pretty (prettyAttribute, prettyBytes, prettyExpression, prettyExpression', prettySubsts)
import Regexp (match)
import Term (BuildTermFunc, Term (..))
import Text.Printf (printf)
import Yaml (normalizationRules)
import qualified Yaml as Y

data RuleContext = RuleContext
  { RuleContext -> Program
_program :: Program,
    RuleContext -> BuildTermFunc
_buildTerm :: BuildTermFunc
  }

-- Check if given attribute is present in given binding
attrInBindings :: Attribute -> [Binding] -> Bool
attrInBindings :: Attribute -> [Binding] -> Bool
attrInBindings Attribute
attr (Binding
bd : [Binding]
bds) = Attribute -> Binding -> Bool
attrInBinding Attribute
attr Binding
bd Bool -> Bool -> Bool
|| Attribute -> [Binding] -> Bool
attrInBindings Attribute
attr [Binding]
bds
  where
    attrInBinding :: Attribute -> Binding -> Bool
    attrInBinding :: Attribute -> Binding -> Bool
attrInBinding Attribute
attr (BiTau Attribute
battr Expression
_) = Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
battr
    attrInBinding Attribute
attr (BiVoid Attribute
battr) = Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
battr
    attrInBinding Attribute
AtLambda (BiLambda String
_) = Bool
True
    attrInBinding Attribute
AtDelta (BiDelta Bytes
_) = Bool
True
    attrInBinding Attribute
_ Binding
_ = Bool
False
attrInBindings Attribute
_ [Binding]
_ = Bool
False

-- Apply 'eq' yaml condition to attributes
compareAttrs :: Attribute -> Attribute -> Subst -> Bool
compareAttrs :: Attribute -> Attribute -> Subst -> Bool
compareAttrs (AtMeta String
left) (AtMeta String
right) Subst
_ = String
left String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
right
compareAttrs Attribute
attr (AtMeta String
meta) (Subst Map String MetaValue
mp) = case String -> Map String MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
meta Map String MetaValue
mp of
  Just (MvAttribute Attribute
found) -> Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
found
  Maybe MetaValue
_ -> Bool
False
compareAttrs (AtMeta String
meta) Attribute
attr (Subst Map String MetaValue
mp) = case String -> Map String MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
meta Map String MetaValue
mp of
  Just (MvAttribute Attribute
found) -> Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
found
  Maybe MetaValue
_ -> Bool
False
compareAttrs Attribute
left Attribute
right Subst
subst = Attribute
right Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
left

-- Convert Number to Integer
numToInt :: Y.Number -> Subst -> Maybe Integer
numToInt :: Number -> Subst -> Maybe Integer
numToInt (Y.Ordinal (AtMeta String
meta)) (Subst Map String MetaValue
mp) = case String -> Map String MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
meta Map String MetaValue
mp of
  Just (MvAttribute (AtAlpha Integer
idx)) -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
idx
  Maybe MetaValue
_ -> Maybe Integer
forall a. Maybe a
Nothing
numToInt (Y.Ordinal (AtAlpha Integer
idx)) Subst
subst = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
idx
numToInt (Y.Length (BiMeta String
meta)) (Subst Map String MetaValue
mp) = case String -> Map String MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
meta Map String MetaValue
mp of
  Just (MvBindings [Binding]
bds) -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Int -> Integer
forall a. Integral a => a -> Integer
toInteger ([Binding] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Binding]
bds))
  Maybe MetaValue
_ -> Maybe Integer
forall a. Maybe a
Nothing
numToInt (Y.Literal Integer
num) Subst
subst = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
num
numToInt Number
_ Subst
_ = Maybe Integer
forall a. Maybe a
Nothing

-- Returns True if given expression matches with any of given normalization rules
-- Here we use unsafePerformIO because we're sure that conditions which are used
-- in normalization rules doesn't throw an exception.
matchesAnyNormalizationRule :: Expression -> RuleContext -> Bool
matchesAnyNormalizationRule :: Expression -> RuleContext -> Bool
matchesAnyNormalizationRule Expression
expr RuleContext
ctx = Expression -> [Rule] -> RuleContext -> Bool
matchesAnyNormalizationRule' Expression
expr [Rule]
normalizationRules RuleContext
ctx
  where
    matchesAnyNormalizationRule' :: Expression -> [Y.Rule] -> RuleContext -> Bool
    matchesAnyNormalizationRule' :: Expression -> [Rule] -> RuleContext -> Bool
matchesAnyNormalizationRule' Expression
_ [] RuleContext
_ = Bool
False
    matchesAnyNormalizationRule' Expression
expr (Rule
rule : [Rule]
rules) RuleContext
ctx =
      let matched :: [Subst]
matched = IO [Subst] -> [Subst]
forall a. IO a -> a
unsafePerformIO (Program -> Rule -> RuleContext -> IO [Subst]
matchProgramWithRule (Expression -> Program
Program Expression
expr) Rule
rule RuleContext
ctx)
       in Bool -> Bool
not ([Subst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Subst]
matched) Bool -> Bool -> Bool
|| Expression -> [Rule] -> RuleContext -> Bool
matchesAnyNormalizationRule' Expression
expr [Rule]
rules RuleContext
ctx

-- Returns True if given expression is in the normal form
isNF :: Expression -> RuleContext -> Bool
isNF :: Expression -> RuleContext -> Bool
isNF Expression
ExThis RuleContext
_ = Bool
True
isNF Expression
ExGlobal RuleContext
_ = Bool
True
isNF Expression
ExTermination RuleContext
_ = Bool
True
isNF (ExDispatch Expression
ExThis Attribute
_) RuleContext
_ = Bool
True
isNF (ExDispatch Expression
ExGlobal Attribute
_) RuleContext
_ = Bool
True
isNF (ExDispatch Expression
ExTermination Attribute
_) RuleContext
_ = Bool
False -- dd rule
isNF (ExApplication Expression
ExTermination Binding
_) RuleContext
_ = Bool
False -- dc rule
isNF (ExFormation []) RuleContext
_ = Bool
True
isNF (ExFormation [Binding]
bds) RuleContext
ctx = [Binding] -> Bool
normalBindings [Binding]
bds Bool -> Bool -> Bool
|| Bool -> Bool
not (Expression -> RuleContext -> Bool
matchesAnyNormalizationRule ([Binding] -> Expression
ExFormation [Binding]
bds) RuleContext
ctx)
  where
    -- Returns True if all given bindings are 100% in normal form
    normalBindings :: [Binding] -> Bool
    normalBindings :: [Binding] -> Bool
normalBindings [] = Bool
True
    normalBindings (Binding
bd : [Binding]
bds) =
      let next :: Bool
next = [Binding] -> Bool
normalBindings [Binding]
bds
       in case Binding
bd of
            BiDelta Bytes
_ -> Bool
next
            BiVoid Attribute
_ -> Bool
next
            BiLambda String
_ -> Bool
next
            Binding
_ -> Bool
False
isNF Expression
expr RuleContext
ctx = Bool -> Bool
not (Expression -> RuleContext -> Bool
matchesAnyNormalizationRule Expression
expr RuleContext
ctx)

meetCondition' :: Y.Condition -> Subst -> RuleContext -> IO [Subst]
meetCondition' :: Condition -> Subst -> RuleContext -> IO [Subst]
meetCondition' (Y.Or []) Subst
subst RuleContext
_ = [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Subst
subst]
meetCondition' (Y.Or (Condition
cond : [Condition]
rest)) Subst
subst RuleContext
ctx = do
  [Subst]
met <- Condition -> Subst -> RuleContext -> IO [Subst]
meetCondition' Condition
cond Subst
subst RuleContext
ctx
  if [Subst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Subst]
met
    then Condition -> Subst -> RuleContext -> IO [Subst]
meetCondition' ([Condition] -> Condition
Y.Or [Condition]
rest) Subst
subst RuleContext
ctx
    else [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Subst]
met
meetCondition' (Y.And []) Subst
subst RuleContext
_ = [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Subst
subst]
meetCondition' (Y.And (Condition
cond : [Condition]
rest)) Subst
subst RuleContext
ctx = do
  [Subst]
met <- Condition -> Subst -> RuleContext -> IO [Subst]
meetCondition' Condition
cond Subst
subst RuleContext
ctx
  if [Subst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Subst]
met
    then [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    else Condition -> Subst -> RuleContext -> IO [Subst]
meetCondition' ([Condition] -> Condition
Y.And [Condition]
rest) Subst
subst RuleContext
ctx
meetCondition' (Y.Not Condition
cond) Subst
subst RuleContext
ctx = do
  [Subst]
met <- Condition -> Subst -> RuleContext -> IO [Subst]
meetCondition' Condition
cond Subst
subst RuleContext
ctx
  [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Subst
subst | [Subst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Subst]
met]
meetCondition' (Y.In Attribute
attr Binding
binding) Subst
subst RuleContext
_ =
  case (Attribute -> Subst -> Maybe Attribute
buildAttribute Attribute
attr Subst
subst, Binding -> Subst -> Maybe [Binding]
buildBinding Binding
binding Subst
subst) of
    (Just Attribute
attr, Just [Binding]
bds) -> [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Subst
subst | Attribute -> [Binding] -> Bool
attrInBindings Attribute
attr [Binding]
bds] -- if attrInBindings attr bd then [subst] else []
    (Maybe Attribute
_, Maybe [Binding]
_) -> [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
meetCondition' (Y.Alpha (AtAlpha Integer
_)) Subst
subst RuleContext
_ = [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Subst
subst]
meetCondition' (Y.Alpha (AtMeta String
name)) (Subst Map String MetaValue
mp) RuleContext
_ = case String -> Map String MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
name Map String MetaValue
mp of
  Just (MvAttribute (AtAlpha Integer
_)) -> [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Map String MetaValue -> Subst
Subst Map String MetaValue
mp]
  Maybe MetaValue
_ -> [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
meetCondition' (Y.Alpha Attribute
_) Subst
_ RuleContext
_ = [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
meetCondition' (Y.Eq (Y.CmpNum Number
left) (Y.CmpNum Number
right)) Subst
subst RuleContext
_ = case (Number -> Subst -> Maybe Integer
numToInt Number
left Subst
subst, Number -> Subst -> Maybe Integer
numToInt Number
right Subst
subst) of
  (Just Integer
left_, Just Integer
right_) -> [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Subst
subst | Integer
left_ Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
right_]
  (Maybe Integer
_, Maybe Integer
_) -> [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
meetCondition' (Y.Eq (Y.CmpAttr Attribute
left) (Y.CmpAttr Attribute
right)) Subst
subst RuleContext
_ = [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Subst
subst | Attribute -> Attribute -> Subst -> Bool
compareAttrs Attribute
left Attribute
right Subst
subst]
meetCondition' (Y.Eq Comparable
_ Comparable
_) Subst
_ RuleContext
_ = [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
meetCondition' (Y.NF (ExMeta String
meta)) (Subst Map String MetaValue
mp) RuleContext
ctx = case String -> Map String MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
meta Map String MetaValue
mp of
  Just (MvExpression Expression
expr Expression
_) -> [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Map String MetaValue -> Subst
Subst Map String MetaValue
mp | Expression -> RuleContext -> Bool
isNF Expression
expr RuleContext
ctx]
  Maybe MetaValue
_ -> [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
meetCondition' (Y.NF Expression
expr) (Subst Map String MetaValue
mp) RuleContext
ctx = [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Map String MetaValue -> Subst
Subst Map String MetaValue
mp | Expression -> RuleContext -> Bool
isNF Expression
expr RuleContext
ctx]
meetCondition' (Y.XI (ExMeta String
meta)) (Subst Map String MetaValue
mp) RuleContext
ctx = case String -> Map String MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
meta Map String MetaValue
mp of
  Just (MvExpression Expression
expr Expression
_) -> Condition -> Subst -> RuleContext -> IO [Subst]
meetCondition' (Expression -> Condition
Y.XI Expression
expr) (Map String MetaValue -> Subst
Subst Map String MetaValue
mp) RuleContext
ctx
  Maybe MetaValue
_ -> [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
meetCondition' (Y.XI (ExFormation [Binding]
_)) Subst
subst RuleContext
_ = [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Subst
subst]
meetCondition' (Y.XI Expression
ExThis) Subst
subst RuleContext
_ = [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
meetCondition' (Y.XI Expression
ExGlobal) Subst
subst RuleContext
_ = [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Subst
subst]
meetCondition' (Y.XI (ExApplication Expression
expr (BiTau Attribute
attr Expression
texpr))) Subst
subst RuleContext
ctx = do
  [Subst]
onExpr <- Condition -> Subst -> RuleContext -> IO [Subst]
meetCondition' (Expression -> Condition
Y.XI Expression
expr) Subst
subst RuleContext
ctx
  [Subst]
onTau <- Condition -> Subst -> RuleContext -> IO [Subst]
meetCondition' (Expression -> Condition
Y.XI Expression
texpr) Subst
subst RuleContext
ctx
  [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Subst
subst | Bool -> Bool
not ([Subst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Subst]
onExpr) Bool -> Bool -> Bool
&& Bool -> Bool
not ([Subst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Subst]
onTau)]
meetCondition' (Y.XI (ExDispatch Expression
expr Attribute
_)) Subst
subst RuleContext
ctx = Condition -> Subst -> RuleContext -> IO [Subst]
meetCondition' (Expression -> Condition
Y.XI Expression
expr) Subst
subst RuleContext
ctx
meetCondition' (Y.Matches String
pat (ExMeta String
meta)) (Subst Map String MetaValue
mp) RuleContext
ctx = case String -> Map String MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
meta Map String MetaValue
mp of
  Just (MvExpression Expression
expr Expression
_) -> Condition -> Subst -> RuleContext -> IO [Subst]
meetCondition' (String -> Expression -> Condition
Y.Matches String
pat Expression
expr) (Map String MetaValue -> Subst
Subst Map String MetaValue
mp) RuleContext
ctx
  Maybe MetaValue
_ -> [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
meetCondition' (Y.Matches String
pat Expression
expr) Subst
subst RuleContext
ctx = do
  (TeBytes Bytes
tgt) <- RuleContext -> BuildTermFunc
_buildTerm RuleContext
ctx String
"dataize" [Expression -> ExtraArgument
Y.ArgExpression Expression
expr] Subst
subst (Expression -> Program
Program Expression
expr)
  Bool
matched <- ByteString -> ByteString -> IO Bool
match (String -> ByteString
B.pack String
pat) (String -> ByteString
B.pack (Bytes -> String
btsToUnescapedStr Bytes
tgt))
  [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Subst
subst | Bool
matched]
meetCondition' (Y.PartOf Expression
exp Binding
bd) Subst
subst RuleContext
_ = do
  (Expression
exp', Expression
_) <- Expression -> Subst -> IO (Expression, Expression)
buildExpressionThrows Expression
exp Subst
subst
  [Binding]
bds <- Binding -> Subst -> IO [Binding]
buildBindingThrows Binding
bd Subst
subst
  [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Subst
subst | Expression -> [Binding] -> Bool
partOf Expression
exp' [Binding]
bds]
  where
    partOf :: Expression -> [Binding] -> Bool
    partOf :: Expression -> [Binding] -> Bool
partOf Expression
expr [] = Bool
False
    partOf Expression
expr (BiTau Attribute
_ (ExFormation [Binding]
bds) : [Binding]
rest) = Expression
expr Expression -> Expression -> Bool
forall a. Eq a => a -> a -> Bool
== [Binding] -> Expression
ExFormation [Binding]
bds Bool -> Bool -> Bool
|| Expression -> [Binding] -> Bool
partOf Expression
expr [Binding]
bds Bool -> Bool -> Bool
|| Expression -> [Binding] -> Bool
partOf Expression
expr [Binding]
rest
    partOf Expression
expr (BiTau Attribute
_ Expression
expr' : [Binding]
rest) = Expression
expr Expression -> Expression -> Bool
forall a. Eq a => a -> a -> Bool
== Expression
expr' Bool -> Bool -> Bool
|| Expression -> [Binding] -> Bool
partOf Expression
expr [Binding]
rest
    partOf Expression
expr (Binding
bd : [Binding]
rest) = Expression -> [Binding] -> Bool
partOf Expression
expr [Binding]
rest

-- For each substitution check if it meetCondition to given condition
-- If substitution does not meet the condition - it's thrown out
-- and is not used in replacement
meetCondition :: Y.Condition -> [Subst] -> RuleContext -> IO [Subst]
meetCondition :: Condition -> [Subst] -> RuleContext -> IO [Subst]
meetCondition Condition
_ [] RuleContext
_ = [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
meetCondition Condition
cond (Subst
subst : [Subst]
rest) RuleContext
ctx = do
  Either SomeException [Subst]
met <- IO [Subst] -> IO (Either SomeException [Subst])
forall e a. Exception e => IO a -> IO (Either e a)
try (Condition -> Subst -> RuleContext -> IO [Subst]
meetCondition' Condition
cond Subst
subst RuleContext
ctx) :: IO (Either SomeException [Subst])
  case Either SomeException [Subst]
met of
    Right [Subst]
first -> do
      [Subst]
next <- Condition -> [Subst] -> RuleContext -> IO [Subst]
meetCondition Condition
cond [Subst]
rest RuleContext
ctx
      if [Subst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Subst]
first
        then [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Subst]
next
        else [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Subst] -> Subst
forall a. HasCallStack => [a] -> a
head [Subst]
first Subst -> [Subst] -> [Subst]
forall a. a -> [a] -> [a]
: [Subst]
next)
    Left SomeException
_ -> Condition -> [Subst] -> RuleContext -> IO [Subst]
meetCondition Condition
cond [Subst]
rest RuleContext
ctx

meetMaybeCondition :: Maybe Y.Condition -> [Subst] -> RuleContext -> IO [Subst]
meetMaybeCondition :: Maybe Condition -> [Subst] -> RuleContext -> IO [Subst]
meetMaybeCondition Maybe Condition
Nothing [Subst]
substs RuleContext
_ = [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Subst]
substs
meetMaybeCondition (Just Condition
cond) [Subst]
substs RuleContext
ctx = Condition -> [Subst] -> RuleContext -> IO [Subst]
meetCondition Condition
cond [Subst]
substs RuleContext
ctx

-- Extend list of given substitutions with extra substitutions from 'where' yaml rule section
extraSubstitutions :: [Subst] -> Maybe [Y.Extra] -> RuleContext -> IO [Subst]
extraSubstitutions :: [Subst] -> Maybe [Extra] -> RuleContext -> IO [Subst]
extraSubstitutions [Subst]
substs Maybe [Extra]
extras RuleContext {Program
BuildTermFunc
_program :: RuleContext -> Program
_buildTerm :: RuleContext -> BuildTermFunc
_program :: Program
_buildTerm :: BuildTermFunc
..} = case Maybe [Extra]
extras of
  Maybe [Extra]
Nothing -> [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Subst]
substs
  Just [Extra]
extras' -> do
    [Maybe Subst]
res <-
      [IO (Maybe Subst)] -> IO [Maybe Subst]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
        [ (Maybe Subst -> Extra -> IO (Maybe Subst))
-> Maybe Subst -> [Extra] -> IO (Maybe Subst)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
            ( \(Just Subst
subst') Extra
extra -> do
                let maybeName :: Maybe String
maybeName = case Extra -> ExtraArgument
Y.meta Extra
extra of
                      Y.ArgExpression (ExMeta String
name) -> String -> Maybe String
forall a. a -> Maybe a
Just String
name
                      Y.ArgAttribute (AtMeta String
name) -> String -> Maybe String
forall a. a -> Maybe a
Just String
name
                      Y.ArgBinding (BiMeta String
name) -> String -> Maybe String
forall a. a -> Maybe a
Just String
name
                      Y.ArgBytes (BtMeta String
name) -> String -> Maybe String
forall a. a -> Maybe a
Just String
name
                      ExtraArgument
_ -> Maybe String
forall a. Maybe a
Nothing
                    func :: String
func = Extra -> String
Y.function Extra
extra
                    args :: [ExtraArgument]
args = Extra -> [ExtraArgument]
Y.args Extra
extra
                Term
term <- BuildTermFunc
_buildTerm String
func [ExtraArgument]
args Subst
subst' Program
_program
                MetaValue
meta <- case Term
term of
                  TeExpression Expression
expr -> do
                    String -> IO ()
logDebug (String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Function %s() returned expression:\n%s" String
func (Expression -> String
prettyExpression' Expression
expr))
                    MetaValue -> IO MetaValue
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Expression -> MetaValue
MvExpression Expression
expr Expression
defaultScope)
                  TeAttribute Attribute
attr -> do
                    String -> IO ()
logDebug (String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Function %s() returned attribute:\n%s" String
func (Attribute -> String
prettyAttribute Attribute
attr))
                    MetaValue -> IO MetaValue
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attribute -> MetaValue
MvAttribute Attribute
attr)
                  TeBytes Bytes
bytes -> do
                    String -> IO ()
logDebug (String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Function %s() returned bytes: %s" String
func (Bytes -> String
prettyBytes Bytes
bytes))
                    MetaValue -> IO MetaValue
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> MetaValue
MvBytes Bytes
bytes)
                case Maybe String
maybeName of
                  Just String
name -> Maybe Subst -> IO (Maybe Subst)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Subst -> Subst -> Maybe Subst
combine (String -> MetaValue -> Subst
substSingle String
name MetaValue
meta) Subst
subst')
                  Maybe String
_ -> Maybe Subst -> IO (Maybe Subst)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Subst
forall a. Maybe a
Nothing
            )
            (Subst -> Maybe Subst
forall a. a -> Maybe a
Just Subst
subst)
            [Extra]
extras'
          | Subst
subst <- [Subst]
substs
        ]
    [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Maybe Subst] -> [Subst]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Subst]
res)

matchProgramWithRule :: Program -> Y.Rule -> RuleContext -> IO [Subst]
matchProgramWithRule :: Program -> Rule -> RuleContext -> IO [Subst]
matchProgramWithRule Program
program Rule
rule RuleContext
ctx =
  let ptn :: Expression
ptn = Rule -> Expression
Y.pattern Rule
rule
      matched :: [Subst]
matched = Expression -> Program -> [Subst]
matchProgram Expression
ptn Program
program
   in if [Subst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Subst]
matched
        then [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        else do
          [Subst]
when <- Maybe Condition -> [Subst] -> RuleContext -> IO [Subst]
meetMaybeCondition (Rule -> Maybe Condition
Y.when Rule
rule) [Subst]
matched RuleContext
ctx
          if [Subst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Subst]
when
            then [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
            else do
              [Subst]
extended <- [Subst] -> Maybe [Extra] -> RuleContext -> IO [Subst]
extraSubstitutions [Subst]
when (Rule -> Maybe [Extra]
Y.where_ Rule
rule) RuleContext
ctx
              Maybe Condition -> [Subst] -> RuleContext -> IO [Subst]
meetMaybeCondition (Rule -> Maybe Condition
Y.having Rule
rule) [Subst]
extended RuleContext
ctx