valuations-0.0.4: src/Data/Valuation/Valuation.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# OPTIONS_GHC -Wall -Werror #-}

-- | A valuation: a domain paired with information. Isomorphic to @(set var, a)@.
module Data.Valuation.Valuation
  ( Valuation (..),
    SetValuation,

    -- * optics
    HasValuation (..),
    AsValuation (..),

    -- * combinators
    valuationDomain',
    valuationInformation',
    projectVar,
    combineVar,
    combineSemiValuation,
    combineValuation,
    semigroupValuation,

    -- * laws
    lawFunctorIdentity,
    lawFunctorComposition,
    lawMonadLeftIdentity,
    lawMonadRightIdentity,
    lawMonadAssociativity,
    lawComonadExtractDuplicate,
    lawComonadDuplicateExtract,
    lawComonadAssociativity,
    lawBifunctorIdentity,
    lawBifunctorComposition,
    lawCombineVarAssociative,
    lawCombineVarCommutative,
  )
where

import Control.Comonad (Comonad (..), ComonadApply (..))
import Control.Comonad.Env.Class (ComonadEnv (..))
import Control.Lens
  ( Lens,
    Lens',
    Prism',
    review,
  )
import Control.Monad.Fix (MonadFix (..))
import Control.Monad.Writer.Class (MonadWriter (..))
import Control.Monad.Zip (MonadZip (..))
import Control.Selective (Selective (..), selectM)
import Data.Biapplicative (Biapplicative (..))
import Data.Bifoldable (Bifoldable (..))
import Data.Bifoldable1 (Bifoldable1 (..))
import Data.Bifunctor (Bifunctor (..))
import Data.Bifunctor.Apply (Biapply (..))
import Data.Bitraversable (Bitraversable (..))
import Data.Foldable1 (Foldable1 (..))
import Data.Functor.Apply (Apply (..))
import Data.Functor.Bind (Bind (..))
import Data.Functor.Classes (Eq1 (..), Eq2 (..), Ord1 (..), Ord2 (..), Show1 (..), Show2 (..))
import Data.Functor.Extend (Extend (..))
import Data.Semigroup.Traversable.Class (Bitraversable1 (..), Traversable1 (..))
import Data.Set (Set)
import Data.Valuation.ProjectValuation (ProjectValuation (..), ProjectValuation')
import Data.Valuation.SemiValuationAlgebra (SemiValuationAlgebra (..), SemiValuationAlgebra')
import Data.Valuation.Semigroup (Semigroup', applySemigroup, runSemigroup, semigroup')
import Data.Valuation.ValuationAlgebra (ValuationAlgebra (..), ValuationAlgebra')
import Data.Valuation.ValuationAlgebraOp (ValuationAlgebraOp (..))
import GHC.Generics (Generic, Generic1)
import Prelude hiding (Semigroup)
import qualified Prelude (Semigroup (..))

-- $setup
-- >>> :set -Wno-name-shadowing -Wno-type-defaults
-- >>> import qualified Data.Set as Set
-- >>> import Control.Lens (review)
-- >>> import Data.Valuation.Semigroup (applySemigroup)

-- |
-- >>> Valuation [1,2,3] "hello"
-- Valuation [1,2,3] "hello"
--
-- >>> let Valuation d a = Valuation [1,2,3] "hello" :: Valuation [] Int String in (d, a)
-- ([1,2,3],"hello")
data Valuation set var a
  = Valuation
      -- | valuation domain
      (set var)
      -- | valuation information
      a
  deriving (Generic, Generic1)

-- | A 'Valuation' specialised to 'Set'.
type SetValuation var a =
  Valuation Set var a

-- | Type-changing lens to the domain component.
valuationDomain' ::
  Lens (Valuation set var a) (Valuation set' var' a) (set var) (set' var')
valuationDomain' f (Valuation d i) =
  fmap (`Valuation` i) (f d)

-- | Type-changing lens to the information component.
valuationInformation' ::
  Lens (Valuation set var a) (Valuation set var a') a a'
valuationInformation' f (Valuation d i) =
  fmap (Valuation d) (f i)

-- | Classy lens for types that contain a 'Valuation'.
class HasValuation c set var a | c -> set var a where
  valuation ::
    Lens' c (Valuation set var a)
  valuationDomain ::
    Lens' c (set var)
  valuationDomain =
    valuation . valuationDomain
  valuationInformation ::
    Lens' c a
  valuationInformation =
    valuation . valuationInformation

instance HasValuation (Valuation set var a) set var a where
  valuation =
    id
  valuationDomain =
    valuationDomain'
  valuationInformation =
    valuationInformation'

-- | Classy prism for types that can be constructed from a 'Valuation'.
class AsValuation c set var a | c -> set var a where
  _Valuation ::
    Prism' c (Valuation set var a)

instance AsValuation (Valuation set var a) set var a where
  _Valuation =
    id

-- |
-- >>> (Valuation [1,2] "ab" :: Valuation [] Int String) <> Valuation [3,4] "cd"
-- Valuation [1,2,3,4] "abcd"
instance (Prelude.Semigroup (set var), Prelude.Semigroup a) => Prelude.Semigroup (Valuation set var a) where
  (<>) =
    runSemigroup (semigroupValuation semigroup' semigroup')

-- |
-- >>> mempty :: Valuation [] Int String
-- Valuation [] ""
--
-- >>> mempty <> Valuation [1,2] "ab" :: Valuation [] Int String
-- Valuation [1,2] "ab"
instance (Monoid (set var), Monoid a) => Monoid (Valuation set var a) where
  mempty =
    Valuation mempty mempty

-- |
-- >>> Valuation [1,2] "a" == (Valuation [1,2] "a" :: Valuation [] Int String)
-- True
--
-- >>> Valuation [1,2] "a" == (Valuation [1,2] "b" :: Valuation [] Int String)
-- False
--
-- >>> Valuation [1,2] "a" == (Valuation [3,4] "a" :: Valuation [] Int String)
-- False
instance (Eq (set var), Eq a) => Eq (Valuation set var a) where
  Valuation d1 a1 == Valuation d2 a2 =
    d1 == d2 && a1 == a2

-- |
-- >>> compare (Valuation [1] "a") (Valuation [2] "a" :: Valuation [] Int String)
-- LT
--
-- >>> compare (Valuation [1] "a") (Valuation [1] "b" :: Valuation [] Int String)
-- LT
--
-- >>> compare (Valuation [1] "b") (Valuation [1] "a" :: Valuation [] Int String)
-- GT
instance (Ord (set var), Ord a) => Ord (Valuation set var a) where
  compare (Valuation d1 a1) (Valuation d2 a2) =
    compare d1 d2 <> compare a1 a2

-- |
-- >>> show (Valuation [1,2,3] "hello" :: Valuation [] Int String)
-- "Valuation [1,2,3] \"hello\""
--
-- >>> show (Valuation [1] (42 :: Int) :: Valuation [] Int Int)
-- "Valuation [1] 42"
instance (Show (set var), Show a) => Show (Valuation set var a) where
  showsPrec d (Valuation dom info) =
    showParen (d > 10) $
      showString "Valuation " . showsPrec 11 dom . showChar ' ' . showsPrec 11 info

-- |
-- >>> import Data.Functor.Classes (eq1)
-- >>> eq1 (Valuation [1,2] "a") (Valuation [1,2] "a" :: Valuation [] Int String)
-- True
--
-- >>> import Data.Functor.Classes (eq1)
-- >>> eq1 (Valuation [1,2] "a") (Valuation [1,2] "b" :: Valuation [] Int String)
-- False
instance (Eq (set var)) => Eq1 (Valuation set var) where
  liftEq eq (Valuation d1 a1) (Valuation d2 a2) =
    d1 == d2 && eq a1 a2

-- |
-- >>> import Data.Functor.Classes (compare1)
-- >>> compare1 (Valuation [1] "a") (Valuation [2] "a" :: Valuation [] Int String)
-- LT
instance (Ord (set var)) => Ord1 (Valuation set var) where
  liftCompare cmp (Valuation d1 a1) (Valuation d2 a2) =
    compare d1 d2 <> cmp a1 a2

-- |
-- >>> import Data.Functor.Classes (showsPrec1)
-- >>> showsPrec1 0 (Valuation [1] "hi" :: Valuation [] Int String) ""
-- "Valuation [1] \"hi\""
instance (Show (set var)) => Show1 (Valuation set var) where
  liftShowsPrec sp _ d (Valuation dom info) =
    showParen (d > 10) $
      showString "Valuation " . showsPrec 11 dom . showChar ' ' . sp 11 info

-- |
-- >>> import Data.Functor.Classes (liftEq2)
-- >>> liftEq2 (==) (==) (Valuation [1,2] "a") (Valuation [1,2] "a" :: Valuation [] Int String)
-- True
--
-- >>> import Data.Functor.Classes (liftEq2)
-- >>> liftEq2 (\_ _ -> True) (==) (Valuation [1] "a") (Valuation [2] "a" :: Valuation [] Int String)
-- True
instance (Eq1 set) => Eq2 (Valuation set) where
  liftEq2 eqV eqA (Valuation d1 a1) (Valuation d2 a2) = liftEq eqV d1 d2 && eqA a1 a2

-- |
-- >>> import Data.Functor.Classes (liftCompare2)
-- >>> liftCompare2 compare compare (Valuation [1] "a") (Valuation [2] "b" :: Valuation [] Int String)
-- LT
instance (Ord1 set) => Ord2 (Valuation set) where
  liftCompare2 cmpV cmpA (Valuation d1 a1) (Valuation d2 a2) =
    liftCompare cmpV d1 d2 <> cmpA a1 a2

-- |
-- >>> import Data.Functor.Classes (liftShowsPrec2)
-- >>> liftShowsPrec2 showsPrec showList showsPrec showList 0 (Valuation [1] "hi" :: Valuation [] Int String) ""
-- "Valuation [1] \"hi\""
instance (Show1 set) => Show2 (Valuation set) where
  liftShowsPrec2 spV slV spA _ d (Valuation dom info) =
    showParen (d > 10) $
      showString "Valuation " . liftShowsPrec spV slV 11 dom . showChar ' ' . spA 11 info

-- |
-- >>> fmap (*2) (Valuation [1,2,3] 10 :: Valuation [] Int Int)
-- Valuation [1,2,3] 20
--
-- >>> fmap length (Valuation [1,2,3] "hello" :: Valuation [] Int String)
-- Valuation [1,2,3] 5
instance Functor (Valuation set var) where
  fmap f (Valuation dom info) =
    Valuation dom (f info)

-- |
-- >>> import Data.Semigroup (Sum(..))
-- >>> foldMap Sum (Valuation [1,2,3] 42 :: Valuation [] Int Int)
-- Sum {getSum = 42}
--
-- >>> foldr (:) [] (Valuation [1,2,3] 42 :: Valuation [] Int Int)
-- [42]
instance Foldable (Valuation set var) where
  foldMap f (Valuation _ info) =
    f info

-- |
-- >>> traverse Just (Valuation [1,2,3] 42 :: Valuation [] Int Int)
-- Just (Valuation [1,2,3] 42)
--
-- >>> sequenceA (Valuation [1,2,3] (Just 42) :: Valuation [] Int (Maybe Int))
-- Just (Valuation [1,2,3] 42)
--
-- >>> sequenceA (Valuation [1,2,3] Nothing :: Valuation [] Int (Maybe Int))
-- Nothing
instance Traversable (Valuation set var) where
  traverse f (Valuation dom info) =
    Valuation dom <$> f info

-- |
-- >>> import Data.Foldable1 (foldMap1)
-- >>> import Data.Semigroup (Sum(..))
-- >>> foldMap1 Sum (Valuation [1,2,3] 42 :: Valuation [] Int Int)
-- Sum {getSum = 42}
instance Foldable1 (Valuation set var) where
  foldMap1 f (Valuation _ info) =
    f info

-- |
-- >>> import Data.Semigroup.Traversable.Class (traverse1)
-- >>> import Data.Functor.Identity (Identity(..))
-- >>> traverse1 (Identity . (*2)) (Valuation [1,2,3] 5 :: Valuation [] Int Int)
-- Identity (Valuation [1,2,3] 10)
instance Traversable1 (Valuation set var) where
  traverse1 f (Valuation dom info) =
    Valuation dom <$> f info

-- |
-- >>> import Data.Functor.Apply ((<.>))
-- >>> (Valuation [1,2] (*2) :: Valuation [] Int (Int -> Int)) <.> Valuation [3,4] 5
-- Valuation [1,2,3,4] 10
instance (Prelude.Semigroup (set var)) => Apply (Valuation set var) where
  Valuation d1 f <.> Valuation d2 a =
    Valuation (d1 <> d2) (f a)

-- |
-- >>> import Data.Functor.Bind ((>>-))
-- >>> (Valuation [1,2] 3 :: Valuation [] Int Int) >>- (\x -> Valuation [4,5] (x * 10))
-- Valuation [1,2,4,5] 30
instance (Prelude.Semigroup (set var)) => Bind (Valuation set var) where
  Valuation d1 a >>- f =
    let Valuation d2 b = f a
     in Valuation (d1 <> d2) b

-- |
-- >>> pure 42 :: Valuation [] Int Int
-- Valuation [] 42
--
-- >>> Valuation [1,2] (*2) <*> Valuation [3,4] (5 :: Int)
-- Valuation [1,2,3,4] 10
instance (Monoid (set var)) => Applicative (Valuation set var) where
  pure =
    Valuation mempty
  (<*>) =
    (<.>)

-- |
-- >>> Valuation [1,2] 3 >>= (\x -> Valuation [4,5] (x * 10)) :: Valuation [] Int Int
-- Valuation [1,2,4,5] 30
--
-- >>> return 42 :: Valuation [] Int Int
-- Valuation [] 42
instance (Monoid (set var)) => Monad (Valuation set var) where
  (>>=) =
    (>>-)

-- |
-- >>> import Control.Monad.Writer.Class (writer, tell, listen, pass)
-- >>> writer ("hello", [1,2,3]) :: Valuation [] Int String
-- Valuation [1,2,3] "hello"
-- >>> tell [1,2,3] :: Valuation [] Int ()
-- Valuation [1,2,3] ()
-- >>> listen (Valuation [1,2,3] "hello" :: Valuation [] Int String)
-- Valuation [1,2,3] ("hello",[1,2,3])
-- >>> pass (Valuation [1,2,3] ("hello", map (*2)) :: Valuation [] Int (String, [Int] -> [Int]))
-- Valuation [2,4,6] "hello"
instance (Monoid (set var)) => MonadWriter (set var) (Valuation set var) where
  writer (a, w) =
    Valuation w a
  tell w =
    Valuation w ()
  listen (Valuation dom info) =
    Valuation dom (info, dom)
  pass (Valuation dom (info, f)) =
    Valuation (f dom) info

-- |
-- >>> import Data.Functor.Extend (duplicated)
-- >>> duplicated (Valuation [1,2] "hello" :: Valuation [] Int String)
-- Valuation [1,2] (Valuation [1,2] "hello")
instance Extend (Valuation set var) where
  duplicated =
    duplicate

-- |
-- >>> import Control.Comonad (extract, duplicate)
-- >>> extract (Valuation [1,2] "hello" :: Valuation [] Int String)
-- "hello"
-- >>> duplicate (Valuation [1,2] "hello" :: Valuation [] Int String)
-- Valuation [1,2] (Valuation [1,2] "hello")
instance Comonad (Valuation set var) where
  extract (Valuation _ info) =
    info
  duplicate (Valuation dom info) =
    Valuation dom (Valuation dom info)

-- |
-- >>> import Control.Comonad ((<@>))
-- >>> (Valuation [1,2] (*2) :: Valuation [] Int (Int -> Int)) <@> Valuation [3,4] 5
-- Valuation [1,2,3,4] 10
instance (Prelude.Semigroup (set var)) => ComonadApply (Valuation set var) where
  (<@>) =
    (<.>)

-- |
-- >>> import Control.Comonad.Env.Class (ask)
-- >>> ask (Valuation [1,2,3] "hello" :: Valuation [] Int String)
-- [1,2,3]
instance ComonadEnv (set var) (Valuation set var) where
  ask (Valuation dom _) =
    dom

-- |
-- >>> import Control.Selective (select)
-- >>> select (Valuation [1] (Right 42) :: Valuation [] Int (Either String Int)) (Valuation [2] read)
-- Valuation [1] 42
--
-- >>> import Control.Selective (select)
-- >>> select (Valuation [1] (Left "42") :: Valuation [] Int (Either String Int)) (Valuation [2] read)
-- Valuation [1,2] 42
instance (Monoid (set var)) => Selective (Valuation set var) where
  select =
    selectM

-- |
-- >>> import Control.Monad.Fix (mfix)
-- >>> mfix (\x -> Valuation [1,2] (const 42 x)) :: Valuation [] Int Int
-- Valuation [1,2] 42
instance (Monoid (set var)) => MonadFix (Valuation set var) where
  mfix f =
    let Valuation d a = f a
     in Valuation d a

-- |
-- >>> import Control.Monad.Zip (mzip, mzipWith)
-- >>> mzip (Valuation [1,2] 3) (Valuation [3,4] "hi" :: Valuation [] Int String)
-- Valuation [1,2,3,4] (3,"hi")
--
-- >>> import Control.Monad.Zip (mzipWith)
-- >>> mzipWith (+) (Valuation [1,2] 3) (Valuation [3,4] 4 :: Valuation [] Int Int)
-- Valuation [1,2,3,4] 7
instance (Monoid (set var)) => MonadZip (Valuation set var) where
  mzip (Valuation d1 a) (Valuation d2 b) =
    Valuation (d1 <> d2) (a, b)
  mzipWith f (Valuation d1 a) (Valuation d2 b) =
    Valuation (d1 <> d2) (f a b)

-- |
-- >>> import Data.Bifunctor (bimap, first, second)
-- >>> bimap (*2) length (Valuation [1,2,3] "hello" :: Valuation [] Int String)
-- Valuation [2,4,6] 5
--
-- >>> import Data.Bifunctor (bimap, first, second)
-- >>> first (*2) (Valuation [1,2,3] "hello" :: Valuation [] Int String)
-- Valuation [2,4,6] "hello"
--
-- >>> import Data.Bifunctor (bimap, first, second)
-- >>> second length (Valuation [1,2,3] "hello" :: Valuation [] Int String)
-- Valuation [1,2,3] 5
instance (Functor set) => Bifunctor (Valuation set) where
  bimap f g (Valuation dom info) =
    Valuation (fmap f dom) (g info)

-- |
-- >>> import Data.Bifoldable (bifoldMap)
-- >>> import Data.Semigroup (Sum(..))
-- >>> bifoldMap (Sum . (*10)) Sum (Valuation [1,2,3] 4 :: Valuation [] Int Int)
-- Sum {getSum = 64}
instance (Foldable set) => Bifoldable (Valuation set) where
  bifoldMap f g (Valuation dom info) =
    foldMap f dom <> g info

-- |
-- >>> import Data.Bitraversable (bitraverse)
-- >>> bitraverse (\x -> [x, x*2]) (\s -> [s, s ++ "!"]) (Valuation [1] "hi" :: Valuation [] Int String)
-- [Valuation [1] "hi",Valuation [1] "hi!",Valuation [2] "hi",Valuation [2] "hi!"]
instance (Traversable set) => Bitraversable (Valuation set) where
  bitraverse f g (Valuation dom info) =
    Valuation <$> traverse f dom <*> g info

-- |
-- >>> import Data.Bifoldable1 (bifoldMap1)
-- >>> import Data.Semigroup (Sum(..))
-- >>> import Data.List.NonEmpty (NonEmpty(..))
-- >>> bifoldMap1 Sum Sum (Valuation (1 :| [2,3]) 4 :: Valuation NonEmpty Int Int)
-- Sum {getSum = 10}
instance (Foldable1 set) => Bifoldable1 (Valuation set) where
  bifoldMap1 f g (Valuation dom info) =
    foldMap1 f dom <> g info

-- |
-- >>> import Data.Semigroup.Traversable.Class (bitraverse1)
-- >>> import Data.Functor.Identity (Identity(..))
-- >>> import Data.List.NonEmpty (NonEmpty(..))
-- >>> bitraverse1 (Identity . (*2)) (Identity . (*3)) (Valuation (1 :| [2]) 3 :: Valuation NonEmpty Int Int)
-- Identity (Valuation (2 :| [4]) 9)
instance (Traversable1 set) => Bitraversable1 (Valuation set) where
  bitraverse1 f g (Valuation dom info) =
    Valuation <$> traverse1 f dom <.> g info

-- |
-- >>> let pv = ProjectValuation (\s v -> v + sum s) :: ProjectValuation (->) (->) Int [] Int
-- >>> projectVar pv (Valuation [1,2,3] 10)
-- 16
--
-- >>> let pv = ProjectValuation (\s v -> v * length s) :: ProjectValuation (->) (->) Int [] Int
-- >>> projectVar pv (Valuation [1,2,3] 5)
-- 15
projectVar ::
  ProjectValuation' v set var ->
  Valuation set var v ->
  v
projectVar (ProjectValuation p) (Valuation dom info) =
  p dom info

-- |
-- >>> import qualified Data.Valuation.Semigroup as S
-- >>> combineVar S.list S.sum (Valuation [1,2] 10) (Valuation [3,4] 20 :: Valuation [] Int Int)
-- Valuation [1,2,3,4] 30
--
-- >>> import qualified Data.Valuation.Semigroup as S
-- >>> combineVar S.list S.product (Valuation [1,2] 10) (Valuation [3,4] 20 :: Valuation [] Int Int)
-- Valuation [1,2,3,4] 200
combineVar ::
  Semigroup' (set var) ->
  Semigroup' v ->
  Valuation set var v ->
  Valuation set var v ->
  Valuation set var v
combineVar sd sv (Valuation d1 a1) (Valuation d2 a2) =
  Valuation (runSemigroup sd d1 d2) (runSemigroup sv a1 a2)

-- |
-- >>> import Control.Lens (review)
-- >>> import qualified Data.Valuation.Semigroup as S
-- >>> let sva = SemiValuationAlgebra (review S.applySemigroup (+)) (ProjectValuation (\s v -> v + sum s)) :: SemiValuationAlgebra (->) (->) (->) Int [] Int
-- >>> combineSemiValuation S.list sva (Valuation [1,2] 10) (Valuation [3,4] 20)
-- Valuation [1,2,3,4] 40
--
-- >>> import Control.Lens (review)
-- >>> import qualified Data.Valuation.Semigroup as S
-- >>> let sva = SemiValuationAlgebra (review S.applySemigroup (*)) (ProjectValuation (\s v -> v + length s)) :: SemiValuationAlgebra (->) (->) (->) Int [] Int
-- >>> combineSemiValuation S.list sva (Valuation [1,2] 3) (Valuation [3] 4)
-- Valuation [1,2,3] 15
combineSemiValuation ::
  Semigroup' (set var) ->
  SemiValuationAlgebra' v set var ->
  Valuation set var v ->
  Valuation set var v ->
  Valuation set var v
combineSemiValuation sd (SemiValuationAlgebra sg (ProjectValuation p)) (Valuation d1 v1) (Valuation d2 v2) =
  let d = runSemigroup sd d1 d2
   in Valuation d (p d (runSemigroup sg v1 v2))

-- |
-- >>> import Control.Lens (review)
-- >>> import qualified Data.Valuation.Semigroup as S
-- >>> let sva = SemiValuationAlgebra (review S.applySemigroup (+)) (ProjectValuation (\s v -> v + sum s))
-- >>> import Data.Valuation.ValuationAlgebraOp (ValuationAlgebraOp(..))
-- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp sum) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra (->) (->) (->) Int [] Int
-- >>> combineValuation S.list va (Valuation [1,2] 10) (Valuation [3,4] 20)
-- Valuation [1,2,3,4] 50
--
-- >>> import Control.Lens (review)
-- >>> import qualified Data.Valuation.Semigroup as S
-- >>> let sva = SemiValuationAlgebra (review S.applySemigroup (*)) (ProjectValuation (\s v -> v + length s))
-- >>> import Data.Valuation.ValuationAlgebraOp (ValuationAlgebraOp(..))
-- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 1)) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra (->) (->) (->) Int [] Int
-- >>> combineValuation S.list va (Valuation [1,2] 3) (Valuation [3] 4)
-- Valuation [1,2,3] 15
combineValuation ::
  Semigroup' (set var) ->
  ValuationAlgebra' v set var ->
  Valuation set var v ->
  Valuation set var v ->
  Valuation set var v
combineValuation sd (ValuationAlgebra (SemiValuationAlgebra sg (ProjectValuation p)) (ValuationAlgebraOp u) _) (Valuation d1 v1) (Valuation d2 v2) =
  let d = runSemigroup sd d1 d2
      v = runSemigroup sg (u d) (runSemigroup sg v1 v2)
   in Valuation d (p d v)

-- |
-- >>> import Data.Bifunctor.Apply ((<<.>>))
-- >>> Valuation [(*2), (+10)] length <<.>> (Valuation [3] "hi" :: Valuation [] Int String)
-- Valuation [6,13] 2
instance (Apply set) => Biapply (Valuation set) where
  Valuation d1 f <<.>> Valuation d2 a =
    Valuation (d1 <.> d2) (f a)

-- |
-- >>> import Data.Biapplicative (bipure, (<<*>>))
-- >>> bipure 1 "hello" :: Valuation [] Int String
-- Valuation [1] "hello"
--
-- >>> import Data.Biapplicative (bipure, (<<*>>))
-- >>> Valuation [(*2), (+10)] length <<*>> (Valuation [3] "hi" :: Valuation [] Int String)
-- Valuation [6,13] 2
instance (Applicative set) => Biapplicative (Valuation set) where
  bipure =
    Valuation . pure
  Valuation d1 f <<*>> Valuation d2 a =
    Valuation (d1 <*> d2) (f a)

-- |
-- >>> import qualified Data.Valuation.Semigroup as S
-- >>> runSemigroup (semigroupValuation S.list S.sum) (Valuation [1,2] 10) (Valuation [3,4] 20 :: Valuation [] Int Int)
-- Valuation [1,2,3,4] 30
semigroupValuation ::
  Semigroup' (set var) ->
  Semigroup' a ->
  Semigroup' (Valuation set var a)
semigroupValuation sd sa =
  review applySemigroup (\(Valuation d1 a1) (Valuation d2 a2) -> Valuation (runSemigroup sd d1 d2) (runSemigroup sa a1 a2))

-- | Functor identity law: @fmap id v == v@.
--
-- >>> lawFunctorIdentity (Valuation [1,2,3] "hello" :: Valuation [] Int String)
-- True
--
-- >>> lawFunctorIdentity (Valuation [1] (42 :: Int) :: Valuation [] Int Int)
-- True
lawFunctorIdentity :: (Eq (set var), Eq a) => Valuation set var a -> Bool
lawFunctorIdentity v =
  fmap id v == v

-- | Functor composition law: @fmap (f . g) v == fmap f (fmap g v)@.
--
-- >>> lawFunctorComposition length show (Valuation [1,2] (42 :: Int) :: Valuation [] Int Int)
-- True
--
-- >>> lawFunctorComposition (*2) (+1) (Valuation [1,2,3] 10 :: Valuation [] Int Int)
-- True
lawFunctorComposition :: (Eq (set var), Eq c) => (b -> c) -> (a -> b) -> Valuation set var a -> Bool
lawFunctorComposition f g v =
  fmap (f . g) v == fmap f (fmap g v)

-- | Monad left identity law: @return a >>= f == f a@.
--
-- >>> lawMonadLeftIdentity 42 (\x -> Valuation [x] (show x)) :: Bool
-- True
--
-- >>> lawMonadLeftIdentity "hi" (\s -> Valuation [length s] s) :: Bool
-- True
lawMonadLeftIdentity :: (Eq (set var), Eq b, Monoid (set var)) => a -> (a -> Valuation set var b) -> Bool
lawMonadLeftIdentity a f =
  (return a >>= f) == f a

-- | Monad right identity law: @m >>= return == m@.
--
-- >>> lawMonadRightIdentity (Valuation [1,2,3] "hello" :: Valuation [] Int String)
-- True
--
-- >>> lawMonadRightIdentity (Valuation [] (42 :: Int) :: Valuation [] Int Int)
-- True
lawMonadRightIdentity :: (Eq (set var), Eq a, Monoid (set var)) => Valuation set var a -> Bool
lawMonadRightIdentity m =
  (m >>= return) == m

-- | Monad associativity law: @(m >>= f) >>= g == m >>= (\\x -> f x >>= g)@.
--
-- >>> let f x = Valuation [x] (show x) :: Valuation [] Int String
-- >>> let g s = Valuation [length s] s
-- >>> lawMonadAssociativity (Valuation [0] (42 :: Int)) f g
-- True
--
-- >>> let f x = Valuation [1] (x * 2) :: Valuation [] Int Int
-- >>> let g x = Valuation [2] (x + 1)
-- >>> lawMonadAssociativity (Valuation [0] 10 :: Valuation [] Int Int) f g
-- True
lawMonadAssociativity :: (Eq (set var), Eq c, Monoid (set var)) => Valuation set var a -> (a -> Valuation set var b) -> (b -> Valuation set var c) -> Bool
lawMonadAssociativity m f g =
  ((m >>= f) >>= g) == (m >>= (\x -> f x >>= g))

-- | Comonad left identity law: @extract (duplicate v) == v@.
--
-- >>> lawComonadExtractDuplicate (Valuation [1,2] "hello" :: Valuation [] Int String)
-- True
--
-- >>> lawComonadExtractDuplicate (Valuation [] (42 :: Int) :: Valuation [] Int Int)
-- True
lawComonadExtractDuplicate :: (Eq (set var), Eq a) => Valuation set var a -> Bool
lawComonadExtractDuplicate v =
  extract (duplicate v) == v

-- | Comonad right identity law: @fmap extract (duplicate v) == v@.
--
-- >>> lawComonadDuplicateExtract (Valuation [1,2] "hello" :: Valuation [] Int String)
-- True
--
-- >>> lawComonadDuplicateExtract (Valuation [1] (42 :: Int) :: Valuation [] Int Int)
-- True
lawComonadDuplicateExtract :: (Eq (set var), Eq a) => Valuation set var a -> Bool
lawComonadDuplicateExtract v =
  fmap extract (duplicate v) == v

-- | Comonad associativity law: @duplicate (duplicate v) == fmap duplicate (duplicate v)@.
--
-- >>> lawComonadAssociativity (Valuation [1,2] "hello" :: Valuation [] Int String)
-- True
--
-- >>> lawComonadAssociativity (Valuation [1] (42 :: Int) :: Valuation [] Int Int)
-- True
lawComonadAssociativity :: (Eq (set var), Eq a) => Valuation set var a -> Bool
lawComonadAssociativity v =
  duplicate (duplicate v) == fmap duplicate (duplicate v)

-- | Bifunctor identity law: @bimap id id v == v@.
--
-- >>> lawBifunctorIdentity (Valuation [1,2,3] "hello" :: Valuation [] Int String)
-- True
--
-- >>> lawBifunctorIdentity (Valuation [1] (42 :: Int) :: Valuation [] Int Int)
-- True
lawBifunctorIdentity :: (Functor set, Eq (set var), Eq a) => Valuation set var a -> Bool
lawBifunctorIdentity v =
  bimap id id v == v

-- | Bifunctor composition law:
-- @bimap f1 g1 (bimap f2 g2 v) == bimap (f1 . f2) (g1 . g2) v@.
--
-- >>> lawBifunctorComposition (*2) length (+1) show (Valuation [1,2,3] (42 :: Int) :: Valuation [] Int Int)
-- True
--
-- >>> lawBifunctorComposition negate reverse (+1) (:[]) (Valuation [1,2] 'a' :: Valuation [] Int Char)
-- True
lawBifunctorComposition ::
  (Functor set, Eq (set var''), Eq c) =>
  (var' -> var'') ->
  (b -> c) ->
  (var -> var') ->
  (a -> b) ->
  Valuation set var a ->
  Bool
lawBifunctorComposition f1 g1 f2 g2 v =
  bimap f1 g1 (bimap f2 g2 v) == bimap (f1 . f2) (g1 . g2) v

-- | Associativity of 'combineVar': given two 'Semigroup''s,
-- @combineVar sd sv (combineVar sd sv a b) c == combineVar sd sv a (combineVar sd sv b c)@.
--
-- >>> import qualified Data.Valuation.Semigroup as S
-- >>> let a = Valuation [1] 10 :: Valuation [] Int Int
-- >>> let b = Valuation [2] 20
-- >>> let c = Valuation [3] 30
-- >>> lawCombineVarAssociative S.list S.sum a b c
-- True
--
-- >>> import qualified Data.Valuation.Semigroup as S
-- >>> let a = Valuation [1] 2 :: Valuation [] Int Int
-- >>> let b = Valuation [2] 3
-- >>> let c = Valuation [3] 4
-- >>> lawCombineVarAssociative S.list S.product a b c
-- True
lawCombineVarAssociative ::
  (Eq (set var), Eq v) =>
  Semigroup' (set var) ->
  Semigroup' v ->
  Valuation set var v ->
  Valuation set var v ->
  Valuation set var v ->
  Bool
lawCombineVarAssociative sd sv a b c =
  combineVar sd sv (combineVar sd sv a b) c == combineVar sd sv a (combineVar sd sv b c)

-- | Commutativity of 'combineVar': given two commutative 'Semigroup''s,
-- @combineVar sd sv a b == combineVar sd sv b a@.
--
-- The caller should ensure the semigroups are commutative; this function
-- tests whether the property holds for the given inputs.
--
-- >>> import qualified Data.Valuation.Semigroup as S
-- >>> let a = Valuation [1] 10 :: Valuation [] Int Int
-- >>> let b = Valuation [2] 20
-- >>> lawCombineVarCommutative S.list S.sum a b
-- False
--
-- >>> import qualified Data.Valuation.Semigroup as S
-- >>> import qualified Data.Set as Set
-- >>> let a = Valuation (Set.fromList [1]) 10 :: Valuation Set Int Int
-- >>> let b = Valuation (Set.fromList [2]) 20
-- >>> lawCombineVarCommutative (review applySemigroup Set.union) S.sum a b
-- True
lawCombineVarCommutative ::
  (Eq (set var), Eq v) =>
  Semigroup' (set var) ->
  Semigroup' v ->
  Valuation set var v ->
  Valuation set var v ->
  Bool
lawCombineVarCommutative sd sv a b =
  combineVar sd sv a b == combineVar sd sv b a