valuations-0.0.3: 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,
  )
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 (..))
import Data.Valuation.SemiValuationAlgebra (SemiValuationAlgebra (..))
import Data.Valuation.Semigroup (Semigroup', applySemigroup, runSemigroup, semigroup')
import Data.Valuation.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

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