{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE UndecidableInstances #-}

{- | A Snoc List type that merges elements of the same constructor.
We use this for managing class attributes, where adding a new attribute of the same type should merge with the existing one rather than just being added to the list.
For example, suppose we have some data type:

@
data Entry = IntEntry Int | StringEntry String deriving (Eq, Data, Show)
instance Semigroup Entry where
   IntEntry a <> IntEntry b = IntEntry (a + b)
   StringEntry a <> StringEntry b = StringEntry (a ++ b)
   _ <> b = b -- if the constructors don't match, just take the right one
@

Then we can do:

@
snoc (TypeMergingList []) (IntEntry 1) = TypeMergingList [IntEntry 1]
snoc (TypeMergingList [IntEntry 1]) (IntEntry 2) = TypeMergingList [IntEntry 3]
snoc (TypeMergingList [IntEntry 1]) (StringEntry "hello") = TypeMergingList [IntEntry 1, StringEntry "hello"]
snoc (TypeMergingList [IntEntry 1, StringEntry "hello"]) (StringEntry "world") = TypeMergingList [IntEntry 1, StringEntry "helloworld"]
@
-}
module H2JVM.Data.TypeMergingList (
    -- * Data types
    TypeMergingList (..),
    DataMergeable (..),
    errorDifferentConstructors,

    -- * Operations
    snoc,

    -- * Conversions
    toList,
    toVector,
    fromList,
)
where

import Data.Data
import Data.Vector (Vector)
import GHC.Stack

import Data.Vector qualified as V
import GHC.IsList qualified as L

import H2JVM.Internal.Pretty (Pretty (pretty))

-- | A list type that merges elements of the same constructor using the 'merge' function from the 'DataMergeable' class.
newtype TypeMergingList a = TypeMergingList [a]
    deriving (TypeMergingList a -> TypeMergingList a -> Bool
(TypeMergingList a -> TypeMergingList a -> Bool)
-> (TypeMergingList a -> TypeMergingList a -> Bool)
-> Eq (TypeMergingList a)
forall a. Eq a => TypeMergingList a -> TypeMergingList a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => TypeMergingList a -> TypeMergingList a -> Bool
== :: TypeMergingList a -> TypeMergingList a -> Bool
$c/= :: forall a. Eq a => TypeMergingList a -> TypeMergingList a -> Bool
/= :: TypeMergingList a -> TypeMergingList a -> Bool
Eq, Eq (TypeMergingList a)
Eq (TypeMergingList a) =>
(TypeMergingList a -> TypeMergingList a -> Ordering)
-> (TypeMergingList a -> TypeMergingList a -> Bool)
-> (TypeMergingList a -> TypeMergingList a -> Bool)
-> (TypeMergingList a -> TypeMergingList a -> Bool)
-> (TypeMergingList a -> TypeMergingList a -> Bool)
-> (TypeMergingList a -> TypeMergingList a -> TypeMergingList a)
-> (TypeMergingList a -> TypeMergingList a -> TypeMergingList a)
-> Ord (TypeMergingList a)
TypeMergingList a -> TypeMergingList a -> Bool
TypeMergingList a -> TypeMergingList a -> Ordering
TypeMergingList a -> TypeMergingList a -> TypeMergingList a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (TypeMergingList a)
forall a. Ord a => TypeMergingList a -> TypeMergingList a -> Bool
forall a.
Ord a =>
TypeMergingList a -> TypeMergingList a -> Ordering
forall a.
Ord a =>
TypeMergingList a -> TypeMergingList a -> TypeMergingList a
$ccompare :: forall a.
Ord a =>
TypeMergingList a -> TypeMergingList a -> Ordering
compare :: TypeMergingList a -> TypeMergingList a -> Ordering
$c< :: forall a. Ord a => TypeMergingList a -> TypeMergingList a -> Bool
< :: TypeMergingList a -> TypeMergingList a -> Bool
$c<= :: forall a. Ord a => TypeMergingList a -> TypeMergingList a -> Bool
<= :: TypeMergingList a -> TypeMergingList a -> Bool
$c> :: forall a. Ord a => TypeMergingList a -> TypeMergingList a -> Bool
> :: TypeMergingList a -> TypeMergingList a -> Bool
$c>= :: forall a. Ord a => TypeMergingList a -> TypeMergingList a -> Bool
>= :: TypeMergingList a -> TypeMergingList a -> Bool
$cmax :: forall a.
Ord a =>
TypeMergingList a -> TypeMergingList a -> TypeMergingList a
max :: TypeMergingList a -> TypeMergingList a -> TypeMergingList a
$cmin :: forall a.
Ord a =>
TypeMergingList a -> TypeMergingList a -> TypeMergingList a
min :: TypeMergingList a -> TypeMergingList a -> TypeMergingList a
Ord, Int -> TypeMergingList a -> ShowS
[TypeMergingList a] -> ShowS
TypeMergingList a -> String
(Int -> TypeMergingList a -> ShowS)
-> (TypeMergingList a -> String)
-> ([TypeMergingList a] -> ShowS)
-> Show (TypeMergingList a)
forall a. Show a => Int -> TypeMergingList a -> ShowS
forall a. Show a => [TypeMergingList a] -> ShowS
forall a. Show a => TypeMergingList a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> TypeMergingList a -> ShowS
showsPrec :: Int -> TypeMergingList a -> ShowS
$cshow :: forall a. Show a => TypeMergingList a -> String
show :: TypeMergingList a -> String
$cshowList :: forall a. Show a => [TypeMergingList a] -> ShowS
showList :: [TypeMergingList a] -> ShowS
Show)

{- | Class of partially mergeable types.
Instances of this class may assume that the constructors of the two arguments are the same (i.e. @'toConstr' x == 'toConstr' y@), and
are permitted to be partial if this is not the case. The helper function 'errorDifferentConstructors' is provided for conveniently throwing an error in this case.
-}
class Data a => DataMergeable a where
    -- | Merge two values of the same constructor. This function is partial if the constructors of the two arguments are different.
    merge :: HasCallStack => a -> a -> a

-- | Convenience function for writing invalid merge errors.
errorDifferentConstructors :: (Data a, HasCallStack) => a -> a -> b
errorDifferentConstructors :: forall a b. (Data a, HasCallStack) => a -> a -> b
errorDifferentConstructors a
x a
y = String -> b
forall a. HasCallStack => String -> a
error (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$ String
"Cannot merge values as they have different data constructors: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Constr -> String
showConstr (a -> Constr
forall a. Data a => a -> Constr
toConstr a
x) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" and " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Constr -> String
showConstr (a -> Constr
forall a. Data a => a -> Constr
toConstr a
y)

instance {-# OVERLAPPABLE #-} (Data a, Semigroup a) => DataMergeable a where
    merge :: HasCallStack => a -> a -> a
merge = a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)

{- | Append an element to the end of a 'TypeMergingList', merging it with the last element if they have the same constructor. \(O(1)\)

>>> data Entry = IntEntry Int | StringEntry String deriving (Eq, Data, Show)
>>> instance DataMergeable Entry where { IntEntry a `merge` IntEntry b = IntEntry (a + b); StringEntry a `merge` StringEntry b = StringEntry (a ++ b); _ `merge` b = b}
>>> snoc (TypeMergingList [IntEntry 1]) (IntEntry 2)
TypeMergingList [IntEntry 3]
>>> snoc (TypeMergingList [IntEntry 1]) (StringEntry "hello")
TypeMergingList [StringEntry "hello",IntEntry 1]
>>> snoc (TypeMergingList [IntEntry 1, StringEntry "hello"]) (StringEntry "world")
TypeMergingList [StringEntry "world",IntEntry 1,StringEntry "hello"]
-}
snoc :: DataMergeable a => TypeMergingList a -> a -> TypeMergingList a
snoc :: forall a.
DataMergeable a =>
TypeMergingList a -> a -> TypeMergingList a
snoc (TypeMergingList []) a
x = [a] -> TypeMergingList a
forall a. [a] -> TypeMergingList a
TypeMergingList [a
x]
snoc (TypeMergingList (a
y : [a]
ys)) a
x
    | a -> Constr
forall a. Data a => a -> Constr
toConstr a
y Constr -> Constr -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Constr
forall a. Data a => a -> Constr
toConstr a
x = [a] -> TypeMergingList a
forall a. [a] -> TypeMergingList a
TypeMergingList ((a
y a -> a -> a
forall a. (DataMergeable a, HasCallStack) => a -> a -> a
`merge` a
x) a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ys)
    | Bool
otherwise = [a] -> TypeMergingList a
forall a. [a] -> TypeMergingList a
TypeMergingList (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ys)

{- | Append two 'TypeMergingList's, merging the last element of the first list with the first element of the second list if they have the same constructor.
\(O(M)\) where \(M\) is the length of the second list.

>>> data Entry = IntEntry Int | StringEntry String deriving (Eq, Data, Show)
>>> instance DataMergeable Entry where { IntEntry a `merge` IntEntry b = IntEntry (a + b); StringEntry a `merge` StringEntry b = StringEntry (a ++ b); _ `merge` b = b}
>>> append (TypeMergingList [IntEntry 1]) (TypeMergingList [IntEntry 2, StringEntry "hello"])
TypeMergingList [IntEntry 2,StringEntry "hello",IntEntry 1]
>>> append (TypeMergingList [IntEntry 1]) (TypeMergingList [StringEntry "hello"])
TypeMergingList [StringEntry "hello",IntEntry 1]
>>> append (TypeMergingList [IntEntry 1, StringEntry "hello"]) (TypeMergingList [StringEntry "world"])
TypeMergingList [StringEntry "world",IntEntry 1,StringEntry "hello"]
-}
append :: DataMergeable a => TypeMergingList a -> TypeMergingList a -> TypeMergingList a
append :: forall a.
DataMergeable a =>
TypeMergingList a -> TypeMergingList a -> TypeMergingList a
append TypeMergingList a
xs (TypeMergingList [a]
ys) = (a -> TypeMergingList a -> TypeMergingList a)
-> TypeMergingList a -> [a] -> TypeMergingList a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((TypeMergingList a -> a -> TypeMergingList a)
-> a -> TypeMergingList a -> TypeMergingList a
forall a b c. (a -> b -> c) -> b -> a -> c
flip TypeMergingList a -> a -> TypeMergingList a
forall a.
DataMergeable a =>
TypeMergingList a -> a -> TypeMergingList a
snoc) TypeMergingList a
xs [a]
ys

-- | Create a 'TypeMergingList' from a regular list. \(O(N)\)
fromList :: DataMergeable a => Data a => [a] -> TypeMergingList a
fromList :: forall a. (DataMergeable a, Data a) => [a] -> TypeMergingList a
fromList = (TypeMergingList a -> a -> TypeMergingList a)
-> TypeMergingList a -> [a] -> TypeMergingList a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TypeMergingList a -> a -> TypeMergingList a
forall a.
DataMergeable a =>
TypeMergingList a -> a -> TypeMergingList a
snoc ([a] -> TypeMergingList a
forall a. [a] -> TypeMergingList a
TypeMergingList [])

-- | Convert a 'TypeMergingList' to a regular list. \(O(N)\)
toList :: TypeMergingList a -> [a]
toList :: forall a. TypeMergingList a -> [a]
toList (TypeMergingList [a]
xs) = [a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs -- snoc list to cons list

-- | Convert a 'TypeMergingList' to a 'Vector'. \(O(N)\)
toVector :: TypeMergingList a -> Vector a
toVector :: forall a. TypeMergingList a -> Vector a
toVector (TypeMergingList [a]
xs) = [a] -> Vector a
forall a. [a] -> Vector a
V.fromList ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs)

instance DataMergeable a => Semigroup (TypeMergingList a) where
    <> :: TypeMergingList a -> TypeMergingList a -> TypeMergingList a
(<>) = TypeMergingList a -> TypeMergingList a -> TypeMergingList a
forall a.
DataMergeable a =>
TypeMergingList a -> TypeMergingList a -> TypeMergingList a
append

instance DataMergeable a => Monoid (TypeMergingList a) where
    mempty :: TypeMergingList a
mempty = [a] -> TypeMergingList a
forall a. [a] -> TypeMergingList a
TypeMergingList []

instance DataMergeable a => L.IsList (TypeMergingList a) where
    type Item (TypeMergingList a) = a
    fromList :: [Item (TypeMergingList a)] -> TypeMergingList a
fromList = [a] -> TypeMergingList a
[Item (TypeMergingList a)] -> TypeMergingList a
forall a. (DataMergeable a, Data a) => [a] -> TypeMergingList a
fromList
    toList :: TypeMergingList a -> [Item (TypeMergingList a)]
toList = TypeMergingList a -> [a]
TypeMergingList a -> [Item (TypeMergingList a)]
forall a. TypeMergingList a -> [a]
toList

instance Foldable TypeMergingList where
    -- We fold in reverse order to maintain the left-to-right order of the list, since the snoc list is stored in reverse.
    foldMap :: forall m a. Monoid m => (a -> m) -> TypeMergingList a -> m
foldMap a -> m
f (TypeMergingList [a]
xs) = (a -> m) -> [a] -> m
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs)

instance Pretty a => Pretty (TypeMergingList a) where
    pretty :: forall ann. TypeMergingList a -> Doc ann
pretty = (a -> Doc ann) -> [a] -> Doc ann
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([a] -> Doc ann)
-> (TypeMergingList a -> [a]) -> TypeMergingList a -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeMergingList a -> [a]
forall a. TypeMergingList a -> [a]
toList