SemiFree.hs

{-# LANGUAGE LambdaCase, DeriveFunctor #-}

module SemiFree where

import Data.Bifunctor
import Data.Semigroup (Endo(..))

-- | Semigroups where some elements reduce in combination, while others only combine
--   symbolically (denoted by @Nothing@)
--
--   Law: (associativity) forall x y z.
--     (x <:> y) >>= (<:> z) = (x <:>) =<< (y <:> z)
class SemiFree a where

  {-# MINIMAL (<:>) | reduce #-}

  (<:>) :: a -> a -> Maybe a
  x <:> y = case reduce [x, y] of
    [xy] -> Just xy
    _    -> Nothing

  reduce :: [a] -> [a]
  reduce []     = []
  reduce (x:xs) = go x xs
    where
      go y [] = [y]
      go y (z:zs) = case y <:> z of
        Nothing -> y:go  z zs
        Just yz ->   go yz zs

instance (Semigroup a, Semigroup b) => SemiFree (Either a b) where
  Left  x <:> Left  y = Just (Left  (x <> y))
  Right x <:> Right y = Just (Right (x <> y))
  _       <:> _       = Nothing

groupEithers1 :: [Either a b] -> [Either [a] [b]]
groupEithers1 = reduce . fmap (bimap pure pure)

groupEithers2 :: [Either a b] -> [Either [a] [b]]
groupEithers2 = fmap (bimap fromDL fromDL) . reduce . fmap (bimap toDL toDL)
  where
    toDL x = Endo (x:)
    fromDL d = appEndo d []

data Diff a
  = First a
  | Second a
  | Both a a
  deriving (Show, Eq, Ord, Functor)

instance Semigroup a => SemiFree (Diff a) where
  First  a <:> First  b  = Just (First  (a <> b))
  Second a <:> Second b  = Just (Second (a <> b))
  Both a b <:> Both c d  = Just (Both   (a <> c) (b <> d))
  _        <:> _         = Nothing

groupDiffs1 :: [Diff a] -> [Diff [a]]
groupDiffs1 = reduce . (fmap . fmap) pure

groupDiffs2 :: [Diff a] -> [Diff [a]]
groupDiffs2 = ffmap (\e -> appEndo e []) . reduce . ffmap (\x -> Endo (x:))
  where ffmap = fmap . fmap