valuations-0.0.3: src/Data/Valuation/BinaryFunction.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wall -Werror #-}

-- | Binary functions over a functor, generalising magmas and semigroups.
module Data.Valuation.BinaryFunction
  ( BinaryFunctionT (..),
    BinaryFunction,
    MagmaT,
    Magma,

    -- * optics
    HasBinaryFunctionT (..),
    AsBinaryFunctionT (..),

    -- * combinators
    binaryFunction,
    semigroupBinaryFunctionT,
  )
where

import Control.Applicative (Alternative (..))
import Control.Lens
  ( Iso,
    Lens',
    Prism',
    Rewrapped,
    Wrapped (..),
    from,
    iso,
    over,
    review,
    view,
    _Wrapped,
  )
import Control.Monad.Fix (MonadFix (..))
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Zip (MonadZip (..))
import Control.Selective (Selective (..), selectM)
import Data.Distributive (Distributive (..))
import Data.Functor.Alt (Alt (..))
import Data.Functor.Apply (Apply (..))
import Data.Functor.Bind (Bind (..))
import Data.Functor.Identity (Identity (..))
import Data.Functor.Plus (Plus (..))
import Data.Profunctor (Choice (..), Profunctor (..), Strong (..))
import Data.Profunctor.Closed (Closed (..))
import Data.Valuation.Semigroup
  ( Semigroup',
    applySemigroup,
    runSemigroup,
  )
import Prelude hiding (Semigroup)
import qualified Prelude

-- $setup
-- >>> :set -Wno-name-shadowing -Wno-type-defaults

-- |
-- >>> let BinaryFunctionT f = BinaryFunctionT (\x y -> [x + y]) :: BinaryFunctionT [] Int Int
-- >>> f 3 5
-- [8]
--
-- >>> let BinaryFunctionT f = BinaryFunctionT (\x y -> Just (x ++ y)) :: BinaryFunctionT Maybe String String
-- >>> f "hello" " world"
-- Just "hello world"
newtype BinaryFunctionT f a b
  = BinaryFunctionT (a -> a -> f b)

instance
  (BinaryFunctionT f a b ~ t) =>
  Rewrapped (BinaryFunctionT f' a' b') t

instance Wrapped (BinaryFunctionT f a b) where
  type Unwrapped (BinaryFunctionT f a b) = a -> a -> f b
  _Wrapped' =
    iso (\(BinaryFunctionT x) -> x) BinaryFunctionT

-- | A 'BinaryFunctionT' specialised to 'Identity'.
type BinaryFunction a b =
  BinaryFunctionT Identity a b

-- | A 'BinaryFunctionT' where the input and output types coincide.
type MagmaT f x =
  BinaryFunctionT f x x

-- | A 'BinaryFunction' where the input and output types coincide.
type Magma x =
  BinaryFunction x x

-- | Classy lens for types that contain a 'BinaryFunctionT'.
class HasBinaryFunctionT c f a b | c -> f a b where
  binaryFunctionT ::
    Lens' c (BinaryFunctionT f a b)

instance HasBinaryFunctionT (BinaryFunctionT f a b) f a b where
  binaryFunctionT = id

-- | Classy prism for types that can be constructed from a 'BinaryFunctionT'.
class AsBinaryFunctionT c f a b | c -> f a b where
  _BinaryFunctionT ::
    Prism' c (BinaryFunctionT f a b)

instance AsBinaryFunctionT (BinaryFunctionT f a b) f a b where
  _BinaryFunctionT = id

instance HasBinaryFunctionT (Semigroup' a) Identity a a where
  binaryFunctionT = applySemigroup . from binaryFunction

instance AsBinaryFunctionT (Semigroup' a) Identity a a where
  _BinaryFunctionT = applySemigroup . from binaryFunction

-- | Iso between a 'BinaryFunction' and its underlying binary function.
binaryFunction :: Iso (BinaryFunction a b) (BinaryFunction a' b') (a -> a -> b) (a' -> a' -> b')
binaryFunction = _Wrapped . iso (\k a1 a2 -> runIdentity (k a1 a2)) (\k a1 a2 -> Identity (k a1 a2))

-- |
-- >>> let BinaryFunctionT f = fmap (*2) (BinaryFunctionT (\x y -> [x + y]) :: BinaryFunctionT [] Int Int)
-- >>> f 3 5
-- [16]
--
-- >>> let BinaryFunctionT f = fmap show (BinaryFunctionT (\x y -> Just (x + y)) :: BinaryFunctionT Maybe Int Int)
-- >>> f 3 5
-- Just "8"
instance (Functor f) => Functor (BinaryFunctionT f a) where
  fmap g = over _Wrapped (\h a1 a2 -> fmap g (h a1 a2))

-- |
-- >>> import Data.Functor.Apply ((<.>))
-- >>> let BinaryFunctionT f = (BinaryFunctionT (\x y -> [(*x), (*y)]) :: BinaryFunctionT [] Int (Int -> Int)) <.> BinaryFunctionT (\x y -> [x + y, x * y])
-- >>> f 3 5
-- [24,45,40,75]
apBFT :: (f (b -> c) -> f b -> f c) -> BinaryFunctionT f a (b -> c) -> BinaryFunctionT f a b -> BinaryFunctionT f a c
apBFT ap' (BinaryFunctionT hf) (BinaryFunctionT ha) = BinaryFunctionT (\a1 a2 -> ap' (hf a1 a2) (ha a1 a2))

instance (Apply f) => Apply (BinaryFunctionT f a) where
  (<.>) = apBFT (<.>)

-- |
-- >>> let BinaryFunctionT f = pure 42 :: BinaryFunctionT [] Int Int
-- >>> f 1 2
-- [42]
--
-- >>> let BinaryFunctionT f = (BinaryFunctionT (\x y -> [(*x), (*y)]) :: BinaryFunctionT [] Int (Int -> Int)) <*> BinaryFunctionT (\x y -> [x + y, x * y])
-- >>> f 3 5
-- [24,45,40,75]
instance (Applicative f) => Applicative (BinaryFunctionT f a) where
  pure b = BinaryFunctionT (\_ _ -> pure b)
  (<*>) = apBFT (<*>)

-- |
-- >>> import Data.Functor.Bind ((>>-))
-- >>> let BinaryFunctionT f = BinaryFunctionT (\x y -> [x + y, x * y]) >>- (\b -> BinaryFunctionT (\x y -> [b + x, b + y])) :: BinaryFunctionT [] Int Int
-- >>> f 3 5
-- [11,13,18,20]
bindBFT :: (f b -> (b -> f c) -> f c) -> BinaryFunctionT f a b -> (b -> BinaryFunctionT f a c) -> BinaryFunctionT f a c
bindBFT bnd (BinaryFunctionT h) k = BinaryFunctionT (\a1 a2 -> bnd (h a1 a2) (\b -> view _Wrapped (k b) a1 a2))

instance (Bind f) => Bind (BinaryFunctionT f a) where
  (>>-) = bindBFT (>>-)

-- |
-- >>> let BinaryFunctionT f = BinaryFunctionT (\x y -> [x + y, x * y]) >>= (\b -> BinaryFunctionT (\x y -> [b + x, b + y])) :: BinaryFunctionT [] Int Int
-- >>> f 3 5
-- [11,13,18,20]
--
-- >>> let BinaryFunctionT f = return 42 :: BinaryFunctionT [] Int Int
-- >>> f 1 2
-- [42]
instance (Monad f) => Monad (BinaryFunctionT f a) where
  (>>=) = bindBFT (>>=)

-- |
-- >>> import Data.Profunctor (dimap, lmap, rmap)
-- >>> let BinaryFunctionT f = dimap (+1) (*2) (BinaryFunctionT (\x y -> [x + y]) :: BinaryFunctionT [] Int Int)
-- >>> f 3 5
-- [20]
--
-- >>> import Data.Profunctor (lmap)
-- >>> let BinaryFunctionT f = lmap (*10) (BinaryFunctionT (\x y -> [x, y]) :: BinaryFunctionT [] Int Int)
-- >>> f 3 5
-- [30,50]
--
-- >>> import Data.Profunctor (rmap)
-- >>> let BinaryFunctionT f = rmap show (BinaryFunctionT (\x y -> [x + y]) :: BinaryFunctionT [] Int Int)
-- >>> f 3 5
-- ["8"]
instance (Functor f) => Profunctor (BinaryFunctionT f) where
  dimap f g = over _Wrapped (\h a1 a2 -> fmap g (h (f a1) (f a2)))
  lmap f = over _Wrapped (\h a1 a2 -> h (f a1) (f a2))
  rmap g = over _Wrapped (\h a1 a2 -> fmap g (h a1 a2))

-- |
-- >>> import Data.Profunctor (Strong(..))
-- >>> let BinaryFunctionT f = first' (BinaryFunctionT (\x y -> [x + y]) :: BinaryFunctionT [] Int Int)
-- >>> f (1, "hello") (2, "world")
-- [(3,"hello")]
--
-- >>> import Data.Profunctor (Strong(..))
-- >>> let BinaryFunctionT f = second' (BinaryFunctionT (\x y -> [x + y]) :: BinaryFunctionT [] Int Int)
-- >>> f ("hello", 1) ("world", 2)
-- [("hello",3)]
instance (Functor f) => Strong (BinaryFunctionT f) where
  first' = over _Wrapped (\h (a1, c) (a2, _) -> fmap (,c) (h a1 a2))
  second' = over _Wrapped (\h (c, a1) (_, a2) -> fmap (c,) (h a1 a2))

-- |
-- >>> import Data.Profunctor (Choice(..))
-- >>> let BinaryFunctionT f = left' (BinaryFunctionT (\x y -> [x + y]) :: BinaryFunctionT [] Int Int)
-- >>> f (Left 1) (Left 2)
-- [Left 3]
-- >>> f (Left 1) (Right "hi")
-- [Right "hi"]
-- >>> f (Right "hi") (Left 2)
-- [Right "hi"]
-- >>> f (Right "a") (Right "b")
-- [Right "a"]
--
-- >>> import Data.Profunctor (Choice(..))
-- >>> let BinaryFunctionT f = right' (BinaryFunctionT (\x y -> [x + y]) :: BinaryFunctionT [] Int Int)
-- >>> f (Right 1) (Right 2)
-- [Right 3]
-- >>> f (Left "hi") (Right 2)
-- [Left "hi"]
instance (Applicative f) => Choice (BinaryFunctionT f) where
  left' = over _Wrapped $ \h ea1 ea2 -> case (ea1, ea2) of
    (Left a1, Left a2) -> fmap Left (h a1 a2)
    (Right c, _) -> pure (Right c)
    (_, Right c) -> pure (Right c)
  right' = over _Wrapped $ \h ea1 ea2 -> case (ea1, ea2) of
    (Right a1, Right a2) -> fmap Right (h a1 a2)
    (Left c, _) -> pure (Left c)
    (_, Left c) -> pure (Left c)

-- |
-- >>> import Control.Monad.Fix (mfix)
-- >>> let BinaryFunctionT f = mfix (\x -> BinaryFunctionT (\a _ -> [const 42 x + a])) :: BinaryFunctionT [] Int Int
-- >>> f 1 2
-- [43]
instance (MonadFix f) => MonadFix (BinaryFunctionT f a) where
  mfix g = BinaryFunctionT (\a1 a2 -> mfix (\b -> view _Wrapped (g b) a1 a2))

-- |
-- >>> import Control.Selective (select)
-- >>> let BinaryFunctionT f = select (BinaryFunctionT (\_ _ -> [Left 1, Right 2]) :: BinaryFunctionT [] Int (Either Int Int)) (BinaryFunctionT (\_ _ -> [(+10)]))
-- >>> f 0 0
-- [11,2]
instance (Monad f) => Selective (BinaryFunctionT f a) where
  select = selectM

-- |
-- >>> import Control.Monad.Zip (mzip)
-- >>> let BinaryFunctionT f = mzip (BinaryFunctionT (\x y -> [x + y, x * y]) :: BinaryFunctionT [] Int Int) (BinaryFunctionT (\x y -> [x - y]))
-- >>> f 5 3
-- [(8,2)]
instance (MonadZip f) => MonadZip (BinaryFunctionT f a) where
  mzipWith g (BinaryFunctionT h1) (BinaryFunctionT h2) = BinaryFunctionT (\a1 a2 -> mzipWith g (h1 a1 a2) (h2 a1 a2))

-- |
-- >>> let BinaryFunctionT f = liftIO (putStrLn "hello") :: BinaryFunctionT IO Int ()
-- >>> f 1 2
-- hello
instance (MonadIO f) => MonadIO (BinaryFunctionT f a) where
  liftIO io = BinaryFunctionT (\_ _ -> liftIO io)

-- |
-- >>> import Data.Functor.Alt ((<!>))
-- >>> let BinaryFunctionT f = (BinaryFunctionT (\_ _ -> Nothing) :: BinaryFunctionT Maybe Int Int) <!> BinaryFunctionT (\x y -> Just (x + y))
-- >>> f 3 5
-- Just 8
instance (Alt f) => Alt (BinaryFunctionT f a) where
  BinaryFunctionT h1 <!> BinaryFunctionT h2 = BinaryFunctionT (\a1 a2 -> h1 a1 a2 <!> h2 a1 a2)

-- |
-- >>> import Data.Functor.Plus (zero)
-- >>> let BinaryFunctionT f = zero :: BinaryFunctionT [] Int Int
-- >>> f 1 2
-- []
instance (Plus f) => Plus (BinaryFunctionT f a) where
  zero = BinaryFunctionT (\_ _ -> zero)

-- |
-- >>> import Control.Applicative (empty, (<|>))
-- >>> let BinaryFunctionT f = (BinaryFunctionT (\_ _ -> Nothing) :: BinaryFunctionT Maybe Int Int) <|> BinaryFunctionT (\x y -> Just (x + y))
-- >>> f 3 5
-- Just 8
--
-- >>> import Control.Applicative (empty)
-- >>> let BinaryFunctionT f = empty :: BinaryFunctionT [] Int Int
-- >>> f 1 2
-- []
instance (Alternative f) => Alternative (BinaryFunctionT f a) where
  empty = BinaryFunctionT (\_ _ -> empty)
  BinaryFunctionT h1 <|> BinaryFunctionT h2 = BinaryFunctionT (\a1 a2 -> h1 a1 a2 <|> h2 a1 a2)

-- |
-- >>> let BinaryFunctionT f = runSemigroup semigroupBinaryFunctionT (BinaryFunctionT (\_ _ -> [1, 2]) :: BinaryFunctionT [] Int Int) (BinaryFunctionT (\_ _ -> [10, 20])) in f 0 0
-- [1,2,10,20]
semigroupBinaryFunctionT :: (Prelude.Semigroup (f b)) => Semigroup' (BinaryFunctionT f a b)
semigroupBinaryFunctionT = review applySemigroup (\(BinaryFunctionT h1) (BinaryFunctionT h2) -> BinaryFunctionT (\a1 a2 -> h1 a1 a2 <> h2 a1 a2))

-- |
-- >>> let BinaryFunctionT f = BinaryFunctionT (\_ _ -> [1, 2]) <> (BinaryFunctionT (\_ _ -> [3, 4]) :: BinaryFunctionT [] Int Int)
-- >>> f 0 0
-- [1,2,3,4]
instance (Prelude.Semigroup (f b)) => Prelude.Semigroup (BinaryFunctionT f a b) where
  (<>) = runSemigroup semigroupBinaryFunctionT

-- |
-- >>> let BinaryFunctionT f = mempty :: BinaryFunctionT [] Int Int
-- >>> f 1 2
-- []
instance (Prelude.Monoid (f b)) => Prelude.Monoid (BinaryFunctionT f a b) where
  mempty = BinaryFunctionT (\_ _ -> mempty)

-- |
-- >>> import Data.Distributive (distribute)
-- >>> import Data.Functor.Identity (Identity(..))
-- >>> let BinaryFunctionT f = distribute [BinaryFunctionT (\x y -> Identity (x + y)), BinaryFunctionT (\x y -> Identity (x * y))] :: BinaryFunctionT Identity Int [Int]
-- >>> f 3 5
-- Identity [8,15]
instance (Distributive f) => Distributive (BinaryFunctionT f a) where
  distribute gs = BinaryFunctionT (\a1 a2 -> distribute (fmap (\(BinaryFunctionT h) -> h a1 a2) gs))

-- |
-- >>> import Data.Profunctor.Closed (Closed(..))
-- >>> import Data.Functor.Identity (Identity(..))
-- >>> let BinaryFunctionT f = closed (BinaryFunctionT (\x y -> Identity (x + y)) :: BinaryFunctionT Identity Int Int)
-- >>> runIdentity (f (*2) (*3)) 10
-- 50
instance (Distributive f) => Closed (BinaryFunctionT f) where
  closed (BinaryFunctionT h) = BinaryFunctionT (\xa1 xa2 -> distribute (\x -> h (xa1 x) (xa2 x)))