{- FOURMOLU_DISABLE -}
-- The MIT License (MIT)

-- Copyright (c) 2016-2024 Objectionary.com

-- Permission is hereby granted, free of charge, to any person obtaining a copy
-- of this software and associated documentation files (the "Software"), to deal
-- in the Software without restriction, including without limitation the rights
-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the Software is
-- furnished to do so, subject to the following conditions:

-- The above copyright notice and this permission notice shall be included
-- in all copies or substantial portions of the Software.

-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-- FITNESS FOR A PARTICULAR PURPOSE AND NON-INFRINGEMENT. IN NO EVENT SHALL THE
-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
-- SOFTWARE.
{- FOURMOLU_ENABLE -}
{-# LANGUAGE TypeApplications #-}

module Language.EO.Phi.Dependencies where

import Language.EO.Phi

import Control.Monad (foldM)

bindingAttr :: Binding -> Maybe Attribute
bindingAttr :: Binding -> Maybe Attribute
bindingAttr (AlphaBinding Attribute
a Object
_) = Attribute -> Maybe Attribute
forall a. a -> Maybe a
Just Attribute
a
bindingAttr (EmptyBinding Attribute
a) = Attribute -> Maybe Attribute
forall a. a -> Maybe a
Just Attribute
a
bindingAttr (DeltaBinding Bytes
_) = Attribute -> Maybe Attribute
forall a. a -> Maybe a
Just (AlphaIndex -> Attribute
Alpha (String -> AlphaIndex
AlphaIndex String
"Δ"))
bindingAttr Binding
DeltaEmptyBinding = Attribute -> Maybe Attribute
forall a. a -> Maybe a
Just (AlphaIndex -> Attribute
Alpha (String -> AlphaIndex
AlphaIndex String
"Δ"))
bindingAttr LambdaBinding{} = Attribute -> Maybe Attribute
forall a. a -> Maybe a
Just (AlphaIndex -> Attribute
Alpha (String -> AlphaIndex
AlphaIndex String
"λ"))
bindingAttr MetaBindings{} = Maybe Attribute
forall a. Maybe a
Nothing
bindingAttr MetaDeltaBinding{} = Maybe Attribute
forall a. Maybe a
Nothing

zipBindings :: [Binding] -> [Binding] -> ([Binding], [(Binding, Binding)])
zipBindings :: [Binding] -> [Binding] -> ([Binding], [(Binding, Binding)])
zipBindings [Binding]
xs [Binding]
ys = ([Binding]
xs' [Binding] -> [Binding] -> [Binding]
forall a. Semigroup a => a -> a -> a
<> [Binding]
ys', [(Binding, Binding)]
collisions)
 where
  as :: [Maybe Attribute]
as = (Binding -> Maybe Attribute) -> [Binding] -> [Maybe Attribute]
forall a b. (a -> b) -> [a] -> [b]
map Binding -> Maybe Attribute
bindingAttr [Binding]
xs
  bs :: [Maybe Attribute]
bs = (Binding -> Maybe Attribute) -> [Binding] -> [Maybe Attribute]
forall a b. (a -> b) -> [a] -> [b]
map Binding -> Maybe Attribute
bindingAttr [Binding]
ys

  xs' :: [Binding]
xs' = [Binding
x | Binding
x <- [Binding]
xs, Binding -> Maybe Attribute
bindingAttr Binding
x Maybe Attribute -> [Maybe Attribute] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Maybe Attribute]
bs]
  ys' :: [Binding]
ys' = [Binding
y | Binding
y <- [Binding]
ys, Binding -> Maybe Attribute
bindingAttr Binding
y Maybe Attribute -> [Maybe Attribute] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Maybe Attribute]
as]
  collisions :: [(Binding, Binding)]
collisions =
    [ (Binding
x, Binding
y)
    | Binding
x <- [Binding]
xs
    , Binding
y <- [Binding]
ys
    , Binding -> Maybe Attribute
bindingAttr Binding
x Maybe Attribute -> Maybe Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Binding -> Maybe Attribute
bindingAttr Binding
y
    ]

isPackage :: [Binding] -> Bool
isPackage :: [Binding] -> Bool
isPackage = (Binding -> Bool) -> [Binding] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Binding -> Bool
isPackageBinding

isPackageBinding :: Binding -> Bool
isPackageBinding :: Binding -> Bool
isPackageBinding (LambdaBinding (Function String
"Package")) = Bool
True
isPackageBinding Binding
_ = Bool
False

mergeBinding :: Binding -> Binding -> Either String Binding
mergeBinding :: Binding -> Binding -> Either String Binding
mergeBinding (AlphaBinding Attribute
a (Formation [Binding]
xs)) (AlphaBinding Attribute
b (Formation [Binding]
ys))
  | Attribute
a Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
b = Attribute -> Object -> Binding
AlphaBinding Attribute
a (Object -> Binding)
-> ([Binding] -> Object) -> [Binding] -> Binding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Binding] -> Object
Formation ([Binding] -> Binding)
-> Either String [Binding] -> Either String Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding] -> [Binding] -> Either String [Binding]
mergeBindings [Binding]
xs [Binding]
ys
mergeBinding Binding
x Binding
y | Binding
x Binding -> Binding -> Bool
forall a. Eq a => a -> a -> Bool
== Binding
y = Binding -> Either String Binding
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return Binding
x
mergeBinding Binding
x Binding
y =
  String -> Either String Binding
forall a b. a -> Either a b
Left (String -> Either String Binding)
-> String -> Either String Binding
forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat @[]
      [ String
"conflict when adding dependencies (trying to merge non-formations)"
      , Binding -> String
forall a. Print a => a -> String
printTree Binding
x
      , Binding -> String
forall a. Print a => a -> String
printTree Binding
y
      ]

mergeBindings :: [Binding] -> [Binding] -> Either String [Binding]
mergeBindings :: [Binding] -> [Binding] -> Either String [Binding]
mergeBindings [Binding]
xs [Binding]
ys
  | [Binding] -> Bool
isPackage [Binding]
xs Bool -> Bool -> Bool
&& [Binding] -> Bool
isPackage [Binding]
ys = do
      case [Binding] -> [Binding] -> ([Binding], [(Binding, Binding)])
zipBindings [Binding]
xs [Binding]
ys of
        ([Binding]
zs, [(Binding, Binding)]
collisions) -> do
          [Binding]
ws <- ((Binding, Binding) -> Either String Binding)
-> [(Binding, Binding)] -> Either String [Binding]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Binding -> Binding -> Either String Binding)
-> (Binding, Binding) -> Either String Binding
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Binding -> Binding -> Either String Binding
mergeBinding) [(Binding, Binding)]
collisions
          [Binding] -> Either String [Binding]
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Binding]
zs [Binding] -> [Binding] -> [Binding]
forall a. Semigroup a => a -> a -> a
<> [Binding]
ws)
  | Bool
otherwise =
      String -> Either String [Binding]
forall a b. a -> Either a b
Left (String -> Either String [Binding])
-> String -> Either String [Binding]
forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat @[]
          [ String
"conflict when adding dependencies (trying to merge non-Package formations "
          , Object -> String
forall a. Print a => a -> String
printTree ([Binding] -> Object
Formation [Binding]
xs)
          , Object -> String
forall a. Print a => a -> String
printTree ([Binding] -> Object
Formation [Binding]
ys)
          , String
" )"
          ]

deepMerge :: Program -> Program -> Either String Program
deepMerge :: Program -> Program -> Either String Program
deepMerge (Program [Binding]
xs) (Program [Binding]
ys) = [Binding] -> Program
Program ([Binding] -> Program)
-> Either String [Binding] -> Either String Program
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding] -> [Binding] -> Either String [Binding]
mergeBindings ([Binding] -> [Binding]
mkPackage [Binding]
xs) ([Binding] -> [Binding]
mkPackage [Binding]
ys)
 where
  mkPackage :: [Binding] -> [Binding]
mkPackage [Binding]
bs
    | [Binding] -> Bool
isPackage [Binding]
bs = [Binding]
bs
    -- FIXME: check if lambda attribute exists and throw error!
    | Bool
otherwise = Function -> Binding
LambdaBinding (String -> Function
Function String
"Package") Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
: [Binding]
bs

deepMergePrograms :: [Program] -> Either String Program
deepMergePrograms :: [Program] -> Either String Program
deepMergePrograms [] = Program -> Either String Program
forall a b. b -> Either a b
Right ([Binding] -> Program
Program [])
deepMergePrograms (Program
p : [Program]
ps) = (Program -> Program -> Either String Program)
-> Program -> [Program] -> Either String Program
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Program -> Program -> Either String Program
deepMerge Program
p [Program]
ps