Merge.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE RankNTypes #-}
{- |
Name: Data.Merge
Description: To describe merging of data types.
License: MIT
Copyright: Samuel Schlesinger 2021 (c)
-}
{-# LANGUAGE BlockArguments #-}
module Data.Merge
  ( Merge (Merge, runMerge)
  , merge
    -- * Construction
  , optional
  , required
  , combine
  , combineWith
  , combineGen
  , combineGenWith
  , Alternative(..)
  , Applicative(..)
    -- * Modification
  , flattenMaybe
  , Profunctor(..)
    -- * Useful Semigroups
  , Optional(..)
  , Required(..)
  , requiredToOptional
  , optionalToRequired
  , Last (..)
  , First (..)
  , Product (..)
  , Sum (..)
  , Dual (..)
  , Max (..)
  , Min (..)
  ) where

import GHC.Generics (Generic)
import Data.Typeable (Typeable)
import Control.Monad (join)
import Data.Coerce (Coercible, coerce)
import Control.Applicative (Alternative (..))
import Data.Profunctor (Profunctor (..))
import Data.Semigroup (Last (..), First (..), Product (..), Sum (..), Dual (..), Max (..), Min (..))

-- | Describes the merging of two values of the same type
-- into some other type. Represented as a 'Maybe' valued
-- function, one can also think of this as a predicate
-- showing which pairs of values can be merged in this way.
--
-- > data Example = Whatever { a :: Int, b :: Maybe Bool }
-- > mergeExamples :: Merge Example Example
-- > mergeExamples = Example <$> required a <*> optional b
newtype Merge x a = Merge { runMerge :: x -> x -> Maybe a }

-- | Flattens a 'Maybe' layer inside of a 'Merge'
flattenMaybe :: Merge x (Maybe a) -> Merge x a
flattenMaybe (Merge f) = Merge \x x' -> join (f x x')

-- | The most general combinator for constructing 'Merge's.
merge :: (x -> x -> Maybe a) -> Merge x a
merge = Merge

instance Profunctor Merge where
  dimap l r (Merge f) = Merge \x x' -> r <$> f (l x) (l x')

instance Functor (Merge x) where
  fmap = rmap

instance Applicative (Merge x) where
  pure x = Merge (\_ _ -> Just x)
  fa <*> a = Merge \x x' -> runMerge fa x x' <*> runMerge a x x'

instance Alternative (Merge x) where
  empty = Merge \_ _ -> Nothing
  Merge f <|> Merge g = Merge \x x' -> f x x' <|> g x x'

instance Monad (Merge x) where
  a >>= f = Merge \x x' -> join $ fmap (\b -> runMerge b x x') $ fmap f $ runMerge a x x'

instance Semigroup a => Semigroup (Merge x a) where
  a <> b = Merge \x x' -> runMerge a x x' <> runMerge b x x'

instance Semigroup a => Monoid (Merge x a) where
  mempty = Merge \_ _ -> mempty  

-- | Meant to be used to merge optional fields in a record.
optional :: Eq a => (x -> Maybe a) -> Merge x (Maybe a)
optional = combineGen (maybe (Optional (Just Nothing)) (Optional . Just . Just)) unOptional

-- | Meant to be used to merge required fields in a record.
required :: Eq a => (x -> a) -> Merge x a
required = combineGen (Required . Just) unRequired

-- | Associatively combine original fields of the record.
combine :: Semigroup a => (x -> a) -> Merge x a
combine = combineWith (<>)

-- | Combine original fields of the record with the given function.
combineWith :: (a -> a -> a) -> (x -> a) -> Merge x a
combineWith c f = Merge (\x x' -> go (f x) (f x')) where
  go x x' = Just (x `c` x')

-- | Sometimes, one can describe a merge strategy via a binary operator. 'Optional'
-- and 'Required' describe 'optional' and 'required', respectively, in this way.
combineGenWith :: forall s a x. (s -> s -> s) -> (a -> s) -> (s -> Maybe a) -> (x -> a) -> Merge x a
combineGenWith c g l f = flattenMaybe $ fmap l $ combineWith c (g . f)

-- | 'combineGen' specialized to 'Semigroup' operations.
combineGen :: Semigroup s => (a -> s) -> (s -> Maybe a) -> (x -> a) -> Merge x a
combineGen = combineGenWith (<>)

-- | This type's 'Semigroup' instance encodes the simple,
-- discrete lattice generated by any given set, excluding the
-- bottom.
newtype Required a = Required { unRequired :: Maybe a }
  deriving (Eq, Show, Read, Ord, Generic, Typeable)

-- | We can convert any 'Required' to an 'Optional'
-- without losing any information.
requiredToOptional :: Required a -> Optional a
requiredToOptional (Required ma) = Optional (fmap Just ma)

instance Eq a => Semigroup (Required a) where
  Required (Just a) <> Required (Just a')
    | a == a' = Required (Just a)
    | otherwise = Required Nothing
  Required _ <> Required _ = Required Nothing

-- | This type's 'Semigroup' instance encodes the simple,
-- deiscrete lattice generated by any given set.
newtype Optional a = Optional { unOptional :: Maybe (Maybe a) }
  deriving (Eq, Show, Read, Ord, Generic, Typeable)

-- | We can convert any 'Optional' to a 'Required',
-- entering the 'Required's inconsistent state if
-- the value is absent from the optional.
optionalToRequired :: Optional a -> Required a
optionalToRequired = Required . join . unOptional

instance Eq a => Semigroup (Optional a) where
  Optional (Just (Just a)) <> Optional (Just (Just a'))
    | a == a' = Optional (Just (Just a))
    | otherwise = Optional Nothing
  Optional (Just Nothing) <> x = x
  x <> Optional (Just Nothing) = x
  Optional Nothing <> x = Optional Nothing
  x <> Optional Nothing = Optional Nothing

instance Eq a => Monoid (Optional a) where
  mempty = Optional (Just Nothing)