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

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

module Rule (RuleContext (..), isNF, matchProgramWithRule, meetCondition) 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, prettyBinding)
import Regexp (match)
import Term (BuildTermFunc, Term (..))
import Text.Printf (printf)
import Yaml (normalizationRules)
import qualified Yaml as Y
import Control.Monad (when)

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

-- 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)

_or :: [Y.Condition] -> Subst -> RuleContext -> IO [Subst]
_or :: [Condition] -> Subst -> RuleContext -> IO [Subst]
_or [] Subst
_ RuleContext
_ = [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
_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]
_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

_and :: [Y.Condition] -> Subst -> RuleContext -> IO [Subst]
_and :: [Condition] -> Subst -> RuleContext -> IO [Subst]
_and [] Subst
subst RuleContext
_ = [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Subst
subst]
_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]
_and [Condition]
rest Subst
subst RuleContext
ctx

_not :: Y.Condition -> Subst -> RuleContext -> IO [Subst]
_not :: Condition -> Subst -> RuleContext -> IO [Subst]
_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]

_in :: Attribute -> Binding -> Subst -> RuleContext -> IO [Subst]
_in :: Attribute -> Binding -> Subst -> RuleContext -> IO [Subst]
_in Attribute
attr Binding
binding Subst
subst RuleContext
_ =
  case (Attribute -> Subst -> Built Attribute
buildAttribute Attribute
attr Subst
subst, Binding -> Subst -> Built [Binding]
buildBinding Binding
binding Subst
subst) of
    (Right Attribute
attr, Right [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 []
    (Built Attribute
_, Built [Binding]
_) -> [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  where
    -- 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

_alpha :: Attribute -> Subst -> RuleContext -> IO [Subst]
_alpha :: Attribute -> Subst -> RuleContext -> IO [Subst]
_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]
_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 []
_alpha Attribute
_ Subst
_ RuleContext
_ = [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

_eq :: Y.Comparable -> Y.Comparable -> Subst -> RuleContext -> IO [Subst]
_eq :: Comparable -> Comparable -> Subst -> RuleContext -> IO [Subst]
_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 []
  where
      -- 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
_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]
  where
    compareAttrs :: Attribute -> Attribute -> Subst -> Bool
    compareAttrs :: Attribute -> Attribute -> Subst -> Bool
compareAttrs (AtMeta String
left) (AtMeta String
right) (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
left Map String MetaValue
mp, String -> Map String MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
right Map String MetaValue
mp) of
      (Just (MvAttribute Attribute
left'), Just (MvAttribute Attribute
right')) -> Attribute -> Attribute -> Subst -> Bool
compareAttrs Attribute
left' Attribute
right' (Map String MetaValue -> Subst
Subst Map String MetaValue
mp)
      (Maybe MetaValue, Maybe MetaValue)
_ -> Bool
False
    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
_ = Attribute
right Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
left
_eq (Y.CmpExpr Expression
left) (Y.CmpExpr Expression
right) Subst
subst RuleContext
_ = [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Subst
subst | Expression -> Expression -> Subst -> Bool
compareExprs Expression
left Expression
right Subst
subst]
  where
    compareExprs :: Expression -> Expression -> Subst -> Bool
    compareExprs :: Expression -> Expression -> Subst -> Bool
compareExprs (ExMeta String
left) (ExMeta String
right) (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
left Map String MetaValue
mp, String -> Map String MetaValue -> Maybe MetaValue
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
right Map String MetaValue
mp) of
      (Just (MvExpression Expression
left' Expression
_), Just (MvExpression Expression
right' Expression
_)) -> Expression -> Expression -> Subst -> Bool
compareExprs Expression
left' Expression
right' (Map String MetaValue -> Subst
Subst Map String MetaValue
mp)
      (Maybe MetaValue, Maybe MetaValue)
_ -> Bool
False
    compareExprs Expression
expr (ExMeta 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 (MvExpression Expression
found Expression
_) -> Expression
expr Expression -> Expression -> Bool
forall a. Eq a => a -> a -> Bool
== Expression
found
      Maybe MetaValue
_ -> Bool
False
    compareExprs (ExMeta String
meta) Expression
expr (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 (MvExpression Expression
found Expression
_) -> Expression
expr Expression -> Expression -> Bool
forall a. Eq a => a -> a -> Bool
== Expression
found
      Maybe MetaValue
_ -> Bool
False
    compareExprs Expression
left Expression
right Subst
_ = Expression
left Expression -> Expression -> Bool
forall a. Eq a => a -> a -> Bool
== Expression
right
_eq Comparable
_ Comparable
_ Subst
_ RuleContext
_ = [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

_nf :: Expression -> Subst -> RuleContext -> IO [Subst]
_nf :: Expression -> Subst -> RuleContext -> IO [Subst]
_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
_) -> Expression -> Subst -> RuleContext -> IO [Subst]
_nf 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 []
_nf Expression
expr Subst
subst RuleContext
ctx = [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Subst
subst | Expression -> RuleContext -> Bool
isNF Expression
expr RuleContext
ctx]

_xi :: Expression -> Subst -> RuleContext -> IO [Subst]
_xi :: Expression -> Subst -> RuleContext -> IO [Subst]
_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
_) -> Expression -> Subst -> RuleContext -> IO [Subst]
_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 []
_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]
_xi Expression
ExThis Subst
subst RuleContext
_ = [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
_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]
_xi (ExApplication Expression
expr (BiTau Attribute
attr Expression
texpr)) Subst
subst RuleContext
ctx = do
  [Subst]
onExpr <- Expression -> Subst -> RuleContext -> IO [Subst]
_xi Expression
expr Subst
subst RuleContext
ctx
  [Subst]
onTau <- Expression -> Subst -> RuleContext -> IO [Subst]
_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)]
_xi (ExDispatch Expression
expr Attribute
_) Subst
subst RuleContext
ctx = Expression -> Subst -> RuleContext -> IO [Subst]
_xi Expression
expr Subst
subst RuleContext
ctx

_matches :: String -> Expression -> Subst -> RuleContext -> IO [Subst]
_matches :: String -> Expression -> Subst -> RuleContext -> IO [Subst]
_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
_) -> String -> Expression -> Subst -> RuleContext -> IO [Subst]
_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 []
_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]

_partOf :: Expression -> Binding -> Subst -> RuleContext -> IO [Subst]
_partOf :: Expression -> Binding -> Subst -> RuleContext -> IO [Subst]
_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

meetCondition' :: Y.Condition -> Subst -> RuleContext -> IO [Subst]
meetCondition' :: Condition -> Subst -> RuleContext -> IO [Subst]
meetCondition' (Y.Or [Condition]
conds) = [Condition] -> Subst -> RuleContext -> IO [Subst]
_or [Condition]
conds
meetCondition' (Y.And [Condition]
conds) = [Condition] -> Subst -> RuleContext -> IO [Subst]
_and [Condition]
conds
meetCondition' (Y.Not Condition
cond) = Condition -> Subst -> RuleContext -> IO [Subst]
_not Condition
cond
meetCondition' (Y.In Attribute
attr Binding
binding) = Attribute -> Binding -> Subst -> RuleContext -> IO [Subst]
_in Attribute
attr Binding
binding
meetCondition' (Y.Alpha Attribute
attr) = Attribute -> Subst -> RuleContext -> IO [Subst]
_alpha Attribute
attr
meetCondition' (Y.Eq Comparable
left Comparable
right) = Comparable -> Comparable -> Subst -> RuleContext -> IO [Subst]
_eq Comparable
left Comparable
right
meetCondition' (Y.NF Expression
expr) = Expression -> Subst -> RuleContext -> IO [Subst]
_nf Expression
expr
meetCondition' (Y.XI Expression
expr) = Expression -> Subst -> RuleContext -> IO [Subst]
_xi Expression
expr
meetCondition' (Y.Matches String
pat Expression
expr) = String -> Expression -> Subst -> RuleContext -> IO [Subst]
_matches String
pat Expression
expr
meetCondition' (Y.PartOf Expression
expr Binding
bd) = Expression -> Binding -> Subst -> RuleContext -> IO [Subst]
_partOf Expression
expr Binding
bd

-- 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
    String -> IO ()
logDebug String
"Building extra substitutions..."
    [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: %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)
                  TeBindings [Binding]
bds -> do
                    String -> IO ()
logDebug (String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Function %s return bindings: %s" String
func (Expression -> String
prettyExpression' ([Binding] -> Expression
ExFormation [Binding]
bds)))
                    MetaValue -> IO MetaValue
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Binding] -> MetaValue
MvBindings [Binding]
bds)
                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 do
          String -> IO ()
logDebug String
"Pattern was not matched"
          [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 do
              String -> IO ()
logDebug String
"The 'when' condition wasn't met"
              [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
              if [Subst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Subst]
extended
                then do
                  String -> IO ()
logDebug String
"Substitution is empty after enxtending, maybe some metas are duplicated"
                  [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                else do
                  [Subst]
met <- Maybe Condition -> [Subst] -> RuleContext -> IO [Subst]
meetMaybeCondition (Rule -> Maybe Condition
Y.having Rule
rule) [Subst]
extended RuleContext
ctx
                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Subst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Subst]
met) (String -> IO ()
logDebug String
"The 'having' condition wan't met")
                  [Subst] -> IO [Subst]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Subst]
met