-- 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.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
matchesAnyNormalizationRule :: Expression -> Bool
matchesAnyNormalizationRule :: Expression -> Bool
matchesAnyNormalizationRule Expression
expr = Expression -> [Rule] -> Bool
matchesAnyNormalizationRule' Expression
expr [Rule]
normalizationRules
  where
    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

-- Returns True if given expression is in the normal form
isNF :: Expression -> Bool
isNF :: Expression -> Bool
isNF Expression
ExThis = Bool
True
isNF Expression
ExGlobal = Bool
True
isNF Expression
ExTermination = Bool
True
isNF (ExDispatch Expression
ExThis Attribute
_) = Bool
True
isNF (ExDispatch Expression
ExGlobal Attribute
_) = Bool
True
isNF (ExDispatch Expression
ExTermination Attribute
_) = Bool
False -- dd rule
isNF (ExApplication Expression
ExTermination Binding
_) = Bool
False -- dc rule
isNF (ExFormation []) = Bool
True
isNF (ExFormation [Binding]
bds) = [Binding] -> Bool
normalBindings [Binding]
bds Bool -> Bool -> Bool
|| Bool -> Bool
not (Expression -> Bool
matchesAnyNormalizationRule ([Binding] -> Expression
ExFormation [Binding]
bds))
  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 String
_ -> Bool
next
            BiVoid Attribute
_ -> Bool
next
            BiLambda String
_ -> Bool
next
            Binding
_ -> Bool
False
isNF Expression
expr = Bool -> Bool
not (Expression -> Bool
matchesAnyNormalizationRule Expression
expr)

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 =
  let met :: [Subst]
met = Condition -> Subst -> [Subst]
meetCondition' Condition
cond Subst
subst
   in 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 =
  let met :: [Subst]
met = Condition -> Subst -> [Subst]
meetCondition' Condition
cond Subst
subst
   in 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 =
  let met :: [Subst]
met = Condition -> Subst -> [Subst]
meetCondition' Condition
cond Subst
subst
   in [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
_ = []
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 Expression
_) -> [Map String MetaValue -> Subst
Subst Map String MetaValue
mp | Expression -> Bool
isNF Expression
expr]
  Maybe MetaValue
_ -> []
meetCondition' (Y.NF Expression
expr) (Subst Map String MetaValue
mp) = [Map String MetaValue -> Subst
Subst Map String MetaValue
mp | Expression -> Bool
isNF Expression
expr]
meetCondition' (Y.XI (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 Expression
_) -> Condition -> Subst -> [Subst]
meetCondition' (Expression -> Condition
Y.XI Expression
expr) (Map String MetaValue -> Subst
Subst Map String MetaValue
mp)
  Maybe MetaValue
_ -> []
meetCondition' (Y.XI (ExFormation [Binding]
_)) Subst
subst = [Subst
subst]
meetCondition' (Y.XI Expression
ExThis) Subst
subst = []
meetCondition' (Y.XI Expression
ExGlobal) Subst
subst = [Subst
subst]
meetCondition' (Y.XI (ExApplication Expression
expr (BiTau Attribute
attr Expression
texpr))) Subst
subst =
  let onExpr :: [Subst]
onExpr = Condition -> Subst -> [Subst]
meetCondition' (Expression -> Condition
Y.XI Expression
expr) Subst
subst
      onTau :: [Subst]
onTau = Condition -> Subst -> [Subst]
meetCondition' (Expression -> Condition
Y.XI Expression
texpr) Subst
subst
   in [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 = Condition -> Subst -> [Subst]
meetCondition' (Expression -> Condition
Y.XI 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) =
  let first :: [Subst]
first = Condition -> Subst -> [Subst]
meetCondition' Condition
cond Subst
subst
      next :: [Subst]
next = Condition -> [Subst] -> [Subst]
meetCondition Condition
cond [Subst]
rest
   in 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 =
  let 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 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 ->
            let met :: [Subst]
met = Condition -> [Subst] -> [Subst]
meetCondition Condition
cond [Subst]
matched
             in 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