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

module Condition where

import Ast
import Builder (buildAttribute, buildBinding)
import Data.Aeson (FromJSON)
import qualified Data.Map.Strict as M
import GHC.IO (unsafePerformIO)
import Matcher
import Misc (allPathsIn)
import Pretty (prettyExpression, prettySubsts)
import Yaml (normalizationRules)
import qualified Yaml as Y

-- 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 String
_) = 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.Add Number
left Number
right) Subst
subst = 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_) -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer
left_ Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
right_)
  (Maybe Integer, Maybe Integer)
_ -> 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

meetCondition' :: Y.Condition -> Subst -> [Subst]
meetCondition' :: Condition -> Subst -> [Subst]
meetCondition' (Y.Or []) Subst
subst = [Subst
subst]
meetCondition' (Y.Or (Condition
cond : [Condition]
rest)) Subst
subst = do
  let met :: [Subst]
met = Condition -> Subst -> [Subst]
meetCondition' Condition
cond Subst
subst
  if [Subst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Subst]
met
    then Condition -> Subst -> [Subst]
meetCondition' ([Condition] -> Condition
Y.Or [Condition]
rest) Subst
subst
    else [Subst]
met
meetCondition' (Y.And []) Subst
subst = [Subst
subst]
meetCondition' (Y.And (Condition
cond : [Condition]
rest)) Subst
subst = do
  let met :: [Subst]
met = Condition -> Subst -> [Subst]
meetCondition' Condition
cond Subst
subst
  if [Subst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Subst]
met
    then []
    else Condition -> Subst -> [Subst]
meetCondition' ([Condition] -> Condition
Y.And [Condition]
rest) Subst
subst
meetCondition' (Y.Not Condition
cond) Subst
subst = do
  let met :: [Subst]
met = Condition -> Subst -> [Subst]
meetCondition' Condition
cond Subst
subst
  [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 =
  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
subst | Attribute -> [Binding] -> Bool
attrInBindings Attribute
attr [Binding]
bds] -- if attrInBindings attr bd then [subst] else []
    (Maybe Attribute
_, Maybe [Binding]
_) -> []
meetCondition' (Y.Alpha (AtAlpha Integer
_)) Subst
subst = [Subst
subst]
meetCondition' (Y.Alpha (AtMeta String
name)) (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
name Map String MetaValue
mp of
  Just (MvAttribute (AtAlpha Integer
_)) -> [Map String MetaValue -> Subst
Subst Map String MetaValue
mp]
  Maybe MetaValue
_ -> []
meetCondition' (Y.Alpha Attribute
_) Subst
_ = []
meetCondition' (Y.Eq (Y.CmpNum Number
left) (Y.CmpNum Number
right)) Subst
subst = 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
subst | Integer
left_ Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
right_]
  (Maybe Integer
_, Maybe Integer
_) -> []
meetCondition' (Y.Eq (Y.CmpAttr Attribute
left) (Y.CmpAttr Attribute
right)) Subst
subst = [Subst
subst | Attribute -> Attribute -> Subst -> Bool
compareAttrs Attribute
left Attribute
right Subst
subst]
meetCondition' (Y.Eq Comparable
_ Comparable
_) Subst
_ = []
-- @todo #89:30min Extend list of expressions. There are expressions where we can definitely say
--  if this expression in normal form or not. In common case the expression in normal form if
--  it does not match with any of normalization rules. But it's quite expensive operation comparing to
--  simple list filtering and pattern matching. For example if expression is formation where all bindings are
--  void, lambda, or delta - this expression in normal form and there's no need to try to match it with normalization
--  rules. So we need find more such cases and introduce them.
meetCondition' (Y.NF (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
expr) -> case Expression
expr of
    Expression
ExThis -> [Map String MetaValue -> Subst
Subst Map String MetaValue
mp]
    Expression
ExGlobal -> [Map String MetaValue -> Subst
Subst Map String MetaValue
mp]
    Expression
ExTermination -> [Map String MetaValue -> Subst
Subst Map String MetaValue
mp]
    ExDispatch Expression
ExThis Attribute
_ -> [Map String MetaValue -> Subst
Subst Map String MetaValue
mp]
    ExDispatch Expression
ExGlobal Attribute
_ -> [Map String MetaValue -> Subst
Subst Map String MetaValue
mp]
    ExDispatch Expression
ExTermination Attribute
_ -> [] -- dd rule
    ExApplication Expression
ExTermination Binding
_ -> [] -- dc rule
    ExFormation [] -> [Map String MetaValue -> Subst
Subst Map String MetaValue
mp]
    Expression
_ -> [Map String MetaValue -> Subst
Subst Map String MetaValue
mp | Bool -> Bool
not (Expression -> [Rule] -> Bool
matchesAnyNormalizationRule Expression
expr [Rule]
normalizationRules)]
  Maybe MetaValue
_ -> []
  where
    -- Returns True if given expression matches with any of given normalization rules
    matchesAnyNormalizationRule :: Expression -> [Y.Rule] -> Bool
    matchesAnyNormalizationRule :: Expression -> [Rule] -> Bool
matchesAnyNormalizationRule Expression
_ [] = Bool
False
    matchesAnyNormalizationRule Expression
expr (Rule
rule : [Rule]
rules) =
      case Expression -> Maybe Condition -> Program -> Maybe [Subst]
matchProgramWithCondition (Rule -> Expression
Y.pattern Rule
rule) (Rule -> Maybe Condition
Y.when Rule
rule) (Expression -> Program
Program Expression
expr) of
        Just [Subst]
matched -> 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] -> Bool
matchesAnyNormalizationRule Expression
expr [Rule]
rules
        Maybe [Subst]
Nothing -> Expression -> [Rule] -> Bool
matchesAnyNormalizationRule Expression
expr [Rule]
rules
meetCondition' (Y.NF Expression
_) Subst
_ = []
meetCondition' (Y.FN (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
expr) -> Condition -> Subst -> [Subst]
meetCondition' (Expression -> Condition
Y.FN Expression
expr) (Map String MetaValue -> Subst
Subst Map String MetaValue
mp)
  Maybe MetaValue
_ -> []
meetCondition' (Y.FN (ExFormation [Binding]
_)) Subst
subst = [Subst
subst]
meetCondition' (Y.FN Expression
ExThis) Subst
subst = []
meetCondition' (Y.FN Expression
ExGlobal) Subst
subst = [Subst
subst]
meetCondition' (Y.FN (ExApplication Expression
expr (BiTau Attribute
attr Expression
texpr))) Subst
subst = do
  let onExpr :: [Subst]
onExpr = Condition -> Subst -> [Subst]
meetCondition' (Expression -> Condition
Y.FN Expression
expr) Subst
subst
      onTau :: [Subst]
onTau = Condition -> Subst -> [Subst]
meetCondition' (Expression -> Condition
Y.FN Expression
texpr) Subst
subst
  [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.FN (ExDispatch Expression
expr Attribute
_)) Subst
subst = Condition -> Subst -> [Subst]
meetCondition' (Expression -> Condition
Y.FN Expression
expr) Subst
subst

-- 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] -> [Subst]
meetCondition :: Condition -> [Subst] -> [Subst]
meetCondition Condition
_ [] = []
meetCondition Condition
cond (Subst
subst : [Subst]
rest) = do
  let first :: [Subst]
first = Condition -> Subst -> [Subst]
meetCondition' Condition
cond Subst
subst
  let next :: [Subst]
next = Condition -> [Subst] -> [Subst]
meetCondition Condition
cond [Subst]
rest
  if [Subst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Subst]
first
    then [Subst]
next
    else [Subst] -> Subst
forall a. HasCallStack => [a] -> a
head [Subst]
first Subst -> [Subst] -> [Subst]
forall a. a -> [a] -> [a]
: [Subst]
next

-- Returns Just [...] if
-- 1. program matches pattern and
-- 2.1. condition is not present, or
-- 2.2. condition is present and met
-- Otherwise returns Nothing
matchProgramWithCondition :: Expression -> Maybe Y.Condition -> Program -> Maybe [Subst]
matchProgramWithCondition :: Expression -> Maybe Condition -> Program -> Maybe [Subst]
matchProgramWithCondition Expression
ptn Maybe Condition
condition Program
program = do
  let matched :: [Subst]
matched = Expression -> Program -> [Subst]
matchProgram Expression
ptn Program
program
  if [Subst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Subst]
matched
    then Maybe [Subst]
forall a. Maybe a
Nothing
    else case Maybe Condition
condition of
      Maybe Condition
Nothing -> [Subst] -> Maybe [Subst]
forall a. a -> Maybe a
Just [Subst]
matched
      Just Condition
cond -> do
        let met :: [Subst]
met = Condition -> [Subst] -> [Subst]
meetCondition Condition
cond [Subst]
matched
        if [Subst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Subst]
met
          then Maybe [Subst]
forall a. Maybe a
Nothing
          else [Subst] -> Maybe [Subst]
forall a. a -> Maybe a
Just [Subst]
met