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

{- | A Snoc List type that merges elements of the same constructor using the Semigroup instance.
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 Data.TypeMergingList where

import Control.Lens ((^?))
import Data.Data
import Data.Generics.Sum.Constructors
import Data.List (foldl')
import Data.Vector (Vector)
import Data.Vector qualified as V
import GHC.Generics (Generic)
import GHC.IsList qualified as L
import JVM.Data.Pretty (Pretty (pretty))

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.
-}
class (Data a) => DataMergeable a where
    merge :: a -> a -> a

errorDifferentConstructors :: (Data a) => a -> a -> b
errorDifferentConstructors :: forall a b. Data a => 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 :: a -> a -> a
merge = a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)

getByCtor :: forall ctor s a. (Generic s, AsConstructor ctor s s a a) => TypeMergingList s -> Maybe a
getByCtor :: forall (ctor :: Symbol) s a.
(Generic s, AsConstructor ctor s s a a) =>
TypeMergingList s -> Maybe a
getByCtor (TypeMergingList [s]
xs) = [s] -> Maybe a
go [s]
xs
  where
    go :: [s] -> Maybe a
go [] = Maybe a
forall a. Maybe a
Nothing
    go (s
x : [s]
xs') = case s
x s -> Getting (First a) s a -> Maybe a
forall s a. s -> Getting (First a) s a -> Maybe a
^? forall (ctor :: Symbol) s t a b.
AsConstructor ctor s t a b =>
Prism s t a b
_Ctor @ctor of
        Just a
a -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
        Maybe a
Nothing -> [s] -> Maybe a
go [s]
xs'

snoc :: (DataMergeable a) => TypeMergingList a -> a -> TypeMergingList a
snoc :: forall a.
DataMergeable a =>
TypeMergingList a -> a -> TypeMergingList a
snoc TypeMergingList a
xs a
x = TypeMergingList a -> TypeMergingList a -> TypeMergingList a
forall a.
DataMergeable a =>
TypeMergingList a -> TypeMergingList a -> TypeMergingList a
append TypeMergingList a
xs ([a] -> TypeMergingList a
forall a. [a] -> TypeMergingList a
TypeMergingList [a
x])

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
forall a. [a] -> TypeMergingList a
TypeMergingList ([a] -> [a] -> [a]
forall a. (Data a, DataMergeable a) => [a] -> [a] -> [a]
go [a]
xs [a]
ys)
  where
    go :: (Data a, DataMergeable a) => [a] -> [a] -> [a]
    go :: forall a. (Data a, DataMergeable a) => [a] -> [a] -> [a]
go [] [a]
ys' = [a]
ys'
    go [a]
xs' [] = [a]
xs'
    go (a
x : [a]
xs') (a
y : [a]
ys')
        | a -> Constr
forall a. Data a => a -> Constr
toConstr a
x Constr -> Constr -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Constr
forall a. Data a => a -> Constr
toConstr a
y = (a
x a -> a -> a
forall a. DataMergeable a => a -> a -> a
`merge` a
y) a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
forall a. (Data a, DataMergeable a) => [a] -> [a] -> [a]
go [a]
xs' [a]
ys'
        | Bool
otherwise = a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
forall a. (Data a, DataMergeable a) => [a] -> [a] -> [a]
go (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs') [a]
ys'

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 [])

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

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
    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]
xs

instance (Pretty a) => Pretty (TypeMergingList a) where
    pretty :: forall ann. TypeMergingList a -> Doc ann
pretty (TypeMergingList [a]
xs) = (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]
xs