{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedStrings #-}

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

module Merge (merge) where

import AST
import Control.Exception.Base (Exception, throwIO)
import Data.Functor ((<&>))
import Misc
import Printer (printExpression)
import Text.Printf (printf)

data MergeException
  = WrongExpressionFormat Expression
  | CanNotMergeBinding Binding Binding
  | EmptyExpressionList
  deriving (Show MergeException
Typeable MergeException
(Typeable MergeException, Show MergeException) =>
(MergeException -> SomeException)
-> (SomeException -> Maybe MergeException)
-> (MergeException -> String)
-> Exception MergeException
SomeException -> Maybe MergeException
MergeException -> String
MergeException -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: MergeException -> SomeException
toException :: MergeException -> SomeException
$cfromException :: SomeException -> Maybe MergeException
fromException :: SomeException -> Maybe MergeException
$cdisplayException :: MergeException -> String
displayException :: MergeException -> String
Exception)

instance Show MergeException where
  show :: MergeException -> String
show (WrongExpressionFormat Expression
expr) =
    String -> ShowS
forall r. PrintfType r => String -> r
printf
      String
"Invalid expression format, only expressions with top level formations are supported for 'merge' command, given:\n%s"
      (Expression -> String
printExpression Expression
expr)
  show (CanNotMergeBinding Binding
first Binding
second) =
    String -> ShowS
forall r. PrintfType r => String -> r
printf
      String
"Can't merge two bindings, conflict found:\n%s"
      (Expression -> String
printExpression ([Binding] -> Expression
ExFormation [Binding
first, Binding
second]))
  show MergeException
EmptyExpressionList = String
"Nothing to merge: provide at least one expression"

mergeBinding :: Binding -> Binding -> IO Binding
mergeBinding :: Binding -> Binding -> IO Binding
mergeBinding first :: Binding
first@(BiTau Attribute
a (ExFormation [Binding]
xs)) second :: Binding
second@(BiTau Attribute
b (ExFormation [Binding]
ys))
  | Attribute
a Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
b = [Binding] -> [Binding] -> IO [Binding]
mergeBindings [Binding]
xs [Binding]
ys IO [Binding] -> ([Binding] -> Binding) -> IO Binding
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Attribute -> Expression -> Binding
BiTau Attribute
a (Expression -> Binding)
-> ([Binding] -> Expression) -> [Binding] -> Binding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Binding] -> Expression
ExFormation
  | Bool
otherwise = MergeException -> IO Binding
forall e a. Exception e => e -> IO a
throwIO (Binding -> Binding -> MergeException
CanNotMergeBinding Binding
first Binding
second)
mergeBinding Binding
x Binding
y
  | Binding
x Binding -> Binding -> Bool
forall a. Eq a => a -> a -> Bool
== Binding
y = Binding -> IO Binding
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Binding
x
  | Bool
otherwise = MergeException -> IO Binding
forall e a. Exception e => e -> IO a
throwIO (Binding -> Binding -> MergeException
CanNotMergeBinding Binding
x Binding
y)

mergeBindings :: [Binding] -> [Binding] -> IO [Binding]
mergeBindings :: [Binding] -> [Binding] -> IO [Binding]
mergeBindings [Binding]
xs [Binding]
ys = [Binding] -> [Binding]
unmarked ([Binding] -> [Binding]) -> IO [Binding] -> IO [Binding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding] -> [Binding] -> IO [Binding]
anchored [Binding]
xs [Binding]
ys
  where
    anchored :: [Binding] -> [Binding] -> IO [Binding]
    anchored :: [Binding] -> [Binding] -> IO [Binding]
anchored [] [Binding]
rest = [Binding] -> IO [Binding]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Binding]
rest
    anchored (Binding
x : [Binding]
more) [Binding]
rest = case (Binding -> Bool) -> [Binding] -> ([Binding], [Binding])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Binding -> Binding -> Bool
same Binding
x) [Binding]
rest of
      ([Binding]
before, Binding
y : [Binding]
after) -> do
        let later :: [Maybe Attribute]
later = [Binding] -> [Maybe Attribute]
attributesFromBindings' [Binding]
more
            ([Binding]
pending, [Binding]
ahead) = ((Binding -> Bool) -> [Binding] -> [Binding]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Maybe Attribute -> [Maybe Attribute] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Maybe Attribute]
later) (Maybe Attribute -> Bool)
-> (Binding -> Maybe Attribute) -> Binding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binding -> Maybe Attribute
attributeFromBinding) [Binding]
before, (Binding -> Bool) -> [Binding] -> [Binding]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Maybe Attribute -> [Maybe Attribute] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Maybe Attribute]
later) (Maybe Attribute -> Bool)
-> (Binding -> Maybe Attribute) -> Binding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binding -> Maybe Attribute
attributeFromBinding) [Binding]
before)
        Binding
united <- Binding -> Binding -> IO Binding
mergeBinding Binding
x Binding
y
        ([Binding]
ahead [Binding] -> [Binding] -> [Binding]
forall a. Semigroup a => a -> a -> a
<>) ([Binding] -> [Binding])
-> ([Binding] -> [Binding]) -> [Binding] -> [Binding]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Binding
united Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
:) ([Binding] -> [Binding]) -> IO [Binding] -> IO [Binding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding] -> [Binding] -> IO [Binding]
anchored [Binding]
more ([Binding]
pending [Binding] -> [Binding] -> [Binding]
forall a. Semigroup a => a -> a -> a
<> [Binding]
after)
      ([Binding]
_, []) -> (Binding
x Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
:) ([Binding] -> [Binding]) -> IO [Binding] -> IO [Binding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding] -> [Binding] -> IO [Binding]
anchored [Binding]
more [Binding]
rest
    same :: Binding -> Binding -> Bool
    same :: Binding -> Binding -> Bool
same Binding
x Binding
y = Binding -> Maybe Attribute
attributeFromBinding Binding
x Maybe Attribute -> Maybe Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Binding -> Maybe Attribute
attributeFromBinding Binding
y
    unmarked :: [Binding] -> [Binding]
    unmarked :: [Binding] -> [Binding]
unmarked [Binding]
bindings
      | (Binding -> Bool) -> [Binding] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Binding -> Bool
marker [Binding]
xs Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== (Binding -> Bool) -> [Binding] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Binding -> Bool
marker [Binding]
ys = [Binding]
bindings
      | Bool
otherwise = (Binding -> Bool) -> [Binding] -> [Binding]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Binding -> Bool) -> Binding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binding -> Bool
marker) [Binding]
bindings
    marker :: Binding -> Bool
    marker :: Binding -> Bool
marker (BiLambda (Function Text
"Package")) = Bool
True
    marker Binding
_ = Bool
False

merge' :: [Expression] -> IO Expression
merge' :: [Expression] -> IO Expression
merge' [] = MergeException -> IO Expression
forall e a. Exception e => e -> IO a
throwIO MergeException
EmptyExpressionList
merge' [p :: Expression
p@(ExFormation [Binding]
_)] = Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression
p
merge' (ExFormation [Binding]
bindings : [Expression]
rest) = do
  ExFormation [Binding]
bds' <- [Expression] -> IO Expression
merge' [Expression]
rest
  [Binding]
merged <- [Binding] -> [Binding] -> IO [Binding]
mergeBindings [Binding]
bds' [Binding]
bindings
  Expression -> IO Expression
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Binding] -> Expression
ExFormation [Binding]
merged)
merge' (Expression
expr : [Expression]
_) = MergeException -> IO Expression
forall e a. Exception e => e -> IO a
throwIO (Expression -> MergeException
WrongExpressionFormat Expression
expr)

merge :: [Expression] -> IO Expression
merge :: [Expression] -> IO Expression
merge [Expression]
exprs = [Expression] -> IO Expression
merge' ([Expression] -> [Expression]
forall a. [a] -> [a]
reverse [Expression]
exprs)