{-# LANGUAGE TupleSections #-}

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

module Filter (include, include', exclude, exclude') where

import AST
import Control.Exception (throwIO)
import Data.Maybe (fromMaybe)
import Locator (LocatorException (CanNotFindObjectByLocator, CanNotHideWholeProgram, InvalidLocatorProvided))
import Misc
import Rewriter

exclude' :: Expression -> [Expression] -> IO Expression
exclude' :: Expression -> [Expression] -> IO Expression
exclude' Expression
expr [Expression]
fqns = (Expression -> [Attribute] -> Expression)
-> Expression -> [[Attribute]] -> Expression
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Expression -> [Attribute] -> Expression
hidden Expression
expr ([[Attribute]] -> Expression) -> IO [[Attribute]] -> IO Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expression -> IO [Attribute]) -> [Expression] -> IO [[Attribute]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Expression -> IO [Attribute]
located [Expression]
fqns
  where
    located :: Expression -> IO [Attribute]
    located :: Expression -> IO [Attribute]
located Expression
ExRoot = LocatorException -> IO [Attribute]
forall e a. Exception e => e -> IO a
throwIO (Expression -> LocatorException
CanNotHideWholeProgram Expression
ExRoot)
    located Expression
fqn = case Expression -> Maybe [Attribute]
fqnToAttrs Expression
fqn of
      Just attrs :: [Attribute]
attrs@(Attribute
_ : [Attribute]
_) -> IO [Attribute]
-> (Expression -> IO [Attribute])
-> Maybe Expression
-> IO [Attribute]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (LocatorException -> IO [Attribute]
forall e a. Exception e => e -> IO a
throwIO (Expression -> LocatorException
CanNotFindObjectByLocator Expression
fqn)) (IO [Attribute] -> Expression -> IO [Attribute]
forall a b. a -> b -> a
const ([Attribute] -> IO [Attribute]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Attribute]
attrs)) (Expression -> [Attribute] -> Maybe Expression
excludedFormation Expression
expr [Attribute]
attrs)
      Maybe [Attribute]
_ -> LocatorException -> IO [Attribute]
forall e a. Exception e => e -> IO a
throwIO (Expression -> LocatorException
InvalidLocatorProvided Expression
fqn)
    hidden :: Expression -> [Attribute] -> Expression
    hidden :: Expression -> [Attribute] -> Expression
hidden Expression
current [Attribute]
attrs = Expression -> Maybe Expression -> Expression
forall a. a -> Maybe a -> a
fromMaybe Expression
current (Expression -> [Attribute] -> Maybe Expression
excludedFormation Expression
current [Attribute]
attrs)
    excludedFormation :: Expression -> [Attribute] -> Maybe Expression
    excludedFormation :: Expression -> [Attribute] -> Maybe Expression
excludedFormation (ExFormation [Binding]
bindings) [Attribute
at]
      | (Binding -> Bool) -> [Binding] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Maybe Attribute -> Maybe Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute -> Maybe Attribute
forall a. a -> Maybe a
Just Attribute
at) (Maybe Attribute -> Bool)
-> (Binding -> Maybe Attribute) -> Binding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binding -> Maybe Attribute
attributeFromBinding) [Binding]
bindings = Expression -> Maybe Expression
forall a. a -> Maybe a
Just ([Binding] -> Expression
ExFormation [Binding
bd | Binding
bd <- [Binding]
bindings, Binding -> Maybe Attribute
attributeFromBinding Binding
bd Maybe Attribute -> Maybe Attribute -> Bool
forall a. Eq a => a -> a -> Bool
/= Attribute -> Maybe Attribute
forall a. a -> Maybe a
Just Attribute
at])
    excludedFormation (ExFormation [Binding]
bindings) (Attribute
at : [Attribute]
rest) = case (Binding -> Bool) -> [Binding] -> ([Binding], [Binding])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Attribute -> Binding -> Bool
nested Attribute
at) [Binding]
bindings of
      ([Binding]
before, BiTau Attribute
at' Expression
form : [Binding]
after) -> (\Expression
form' -> [Binding] -> Expression
ExFormation ([Binding]
before [Binding] -> [Binding] -> [Binding]
forall a. [a] -> [a] -> [a]
++ Attribute -> Expression -> Binding
BiTau Attribute
at' Expression
form' Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding]
after)) (Expression -> Expression) -> Maybe Expression -> Maybe Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> [Attribute] -> Maybe Expression
excludedFormation Expression
form [Attribute]
rest
      ([Binding], [Binding])
_ -> Maybe Expression
forall a. Maybe a
Nothing
    excludedFormation Expression
_ [Attribute]
_ = Maybe Expression
forall a. Maybe a
Nothing
    nested :: Attribute -> Binding -> Bool
    nested :: Attribute -> Binding -> Bool
nested Attribute
at (BiTau Attribute
at' (ExFormation [Binding]
_)) = Attribute
at Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
at'
    nested Attribute
_ Binding
_ = Bool
False

exclude :: [Rewritten] -> [Expression] -> IO [Rewritten]
exclude :: [Rewritten] -> [Expression] -> IO [Rewritten]
exclude [Rewritten]
rs [Expression]
exprs = (Rewritten -> IO Rewritten) -> [Rewritten] -> IO [Rewritten]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\(Expression
expr, Maybe (Judgment, String)
maybeRule) -> (,Maybe (Judgment, String)
maybeRule) (Expression -> Rewritten) -> IO Expression -> IO Rewritten
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> [Expression] -> IO Expression
exclude' Expression
expr [Expression]
exprs) [Rewritten]
rs

include' :: Expression -> [Expression] -> IO Expression
include' :: Expression -> [Expression] -> IO Expression
include' Expression
expr [] = Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression
expr
include' Expression
expr [Expression]
fqns
  | Expression
ExRoot Expression -> [Expression] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Expression]
fqns = Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression
expr
  | Bool
otherwise = [Expression] -> Expression
mergeForms ([Expression] -> Expression) -> IO [Expression] -> IO Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expression -> IO Expression) -> [Expression] -> IO [Expression]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Expression -> IO Expression
pick [Expression]
fqns
  where
    pick :: Expression -> IO Expression
    pick :: Expression -> IO Expression
pick Expression
fqn = case Expression -> Maybe [Attribute]
fqnToAttrs Expression
fqn of
      Just [Attribute]
attrs -> IO Expression
-> (Expression -> IO Expression)
-> Maybe Expression
-> IO Expression
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (LocatorException -> IO Expression
forall e a. Exception e => e -> IO a
throwIO (Expression -> LocatorException
CanNotFindObjectByLocator Expression
fqn)) Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> [Attribute] -> Maybe Expression
includedFormation Expression
expr [Attribute]
attrs)
      Maybe [Attribute]
_ -> LocatorException -> IO Expression
forall e a. Exception e => e -> IO a
throwIO (Expression -> LocatorException
InvalidLocatorProvided Expression
fqn)
    mergeForms :: [Expression] -> Expression
    mergeForms :: [Expression] -> Expression
mergeForms [Expression]
forms = [Binding] -> Expression
ExFormation (([Binding] -> Binding -> [Binding])
-> [Binding] -> [Binding] -> [Binding]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Binding] -> Binding -> [Binding]
merged [] ([[Binding]] -> [Binding]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Binding]
bs | ExFormation [Binding]
bs <- [Expression]
forms]))
    merged :: [Binding] -> Binding -> [Binding]
    merged :: [Binding] -> Binding -> [Binding]
merged [Binding]
acc Binding
bd = case (Binding -> Bool) -> [Binding] -> ([Binding], [Binding])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((Maybe Attribute -> Maybe Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Binding -> Maybe Attribute
attributeFromBinding Binding
bd) (Maybe Attribute -> Bool)
-> (Binding -> Maybe Attribute) -> Binding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binding -> Maybe Attribute
attributeFromBinding) [Binding]
acc of
      ([Binding]
before, BiTau Attribute
at (ExFormation [Binding]
old) : [Binding]
after) | BiTau Attribute
_ (ExFormation [Binding]
new) <- Binding
bd -> [Binding]
before [Binding] -> [Binding] -> [Binding]
forall a. [a] -> [a] -> [a]
++ Attribute -> Expression -> Binding
BiTau Attribute
at ([Expression] -> Expression
mergeForms [[Binding] -> Expression
ExFormation [Binding]
old, [Binding] -> Expression
ExFormation [Binding]
new]) Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding]
after
      ([Binding]
before, Binding
_ : [Binding]
after) -> [Binding]
before [Binding] -> [Binding] -> [Binding]
forall a. [a] -> [a] -> [a]
++ Binding
bd Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding]
after
      ([Binding], [Binding])
_ -> [Binding]
acc [Binding] -> [Binding] -> [Binding]
forall a. [a] -> [a] -> [a]
++ [Binding
bd]
    includedFormation :: Expression -> [Attribute] -> Maybe Expression
    includedFormation :: Expression -> [Attribute] -> Maybe Expression
includedFormation (ExFormation [Binding]
bindings) [Attribute
at] =
      let bs :: [Binding]
bs = [Binding
bd | Binding
bd <- [Binding]
bindings, Binding -> Maybe Attribute
attributeFromBinding Binding
bd Maybe Attribute -> Maybe Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute -> Maybe Attribute
forall a. a -> Maybe a
Just Attribute
at]
       in if [Binding] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Binding]
bs then Maybe Expression
forall a. Maybe a
Nothing else Expression -> Maybe Expression
forall a. a -> Maybe a
Just ([Binding] -> Expression
ExFormation [Binding]
bs)
    includedFormation (ExFormation [Binding]
bindings) [Attribute]
atts = [Binding] -> [Attribute] -> Maybe Binding
includedBindings [Binding]
bindings [Attribute]
atts Maybe Binding -> (Binding -> Maybe Expression) -> Maybe Expression
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Expression -> Maybe Expression
forall a. a -> Maybe a
Just (Expression -> Maybe Expression)
-> (Binding -> Expression) -> Binding -> Maybe Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Binding] -> Expression
ExFormation ([Binding] -> Expression)
-> (Binding -> [Binding]) -> Binding -> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binding -> [Binding]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
      where
        includedBindings :: [Binding] -> [Attribute] -> Maybe Binding
        includedBindings :: [Binding] -> [Attribute] -> Maybe Binding
includedBindings ((BiTau Attribute
at' form :: Expression
form@(ExFormation [Binding]
_)) : [Binding]
bs) as :: [Attribute]
as@(Attribute
at'' : [Attribute]
rs)
          | Attribute
at' Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
at'' = Expression -> [Attribute] -> Maybe Expression
includedFormation Expression
form [Attribute]
rs Maybe Expression -> (Expression -> Maybe Binding) -> Maybe Binding
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Binding -> Maybe Binding
forall a. a -> Maybe a
Just (Binding -> Maybe Binding)
-> (Expression -> Binding) -> Expression -> Maybe Binding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attribute -> Expression -> Binding
BiTau Attribute
at'
          | Bool
otherwise = [Binding] -> [Attribute] -> Maybe Binding
includedBindings [Binding]
bs [Attribute]
as
        includedBindings (Binding
_ : [Binding]
bs) [Attribute]
as = [Binding] -> [Attribute] -> Maybe Binding
includedBindings [Binding]
bs [Attribute]
as
        includedBindings [Binding]
_ [Attribute]
_ = Maybe Binding
forall a. Maybe a
Nothing
    includedFormation Expression
_ [Attribute]
_ = Maybe Expression
forall a. Maybe a
Nothing

include :: [Rewritten] -> [Expression] -> IO [Rewritten]
include :: [Rewritten] -> [Expression] -> IO [Rewritten]
include [Rewritten]
rs [Expression]
exprs = (Rewritten -> IO Rewritten) -> [Rewritten] -> IO [Rewritten]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\(Expression
expr, Maybe (Judgment, String)
maybeRule) -> (,Maybe (Judgment, String)
maybeRule) (Expression -> Rewritten) -> IO Expression -> IO Rewritten
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> [Expression] -> IO Expression
include' Expression
expr [Expression]
exprs) [Rewritten]
rs