packages feed

valuations 0.0.2 → 0.0.3

raw patch · 12 files changed

+541/−462 lines, 12 files

Files

changelog.md view
@@ -1,3 +1,7 @@+0.0.3++* Generalise data types over the Profunctor and not (->)+ 0.0.2  * Fix typo in cabal file
src/Data/Valuation/BinaryFunction.hs view
@@ -49,7 +49,7 @@ import Data.Profunctor (Choice (..), Profunctor (..), Strong (..)) import Data.Profunctor.Closed (Closed (..)) import Data.Valuation.Semigroup-  ( Semigroup,+  ( Semigroup',     applySemigroup,     runSemigroup,   )@@ -107,10 +107,10 @@ instance AsBinaryFunctionT (BinaryFunctionT f a b) f a b where   _BinaryFunctionT = id -instance HasBinaryFunctionT (Semigroup a) Identity a a where+instance HasBinaryFunctionT (Semigroup' a) Identity a a where   binaryFunctionT = applySemigroup . from binaryFunction -instance AsBinaryFunctionT (Semigroup a) Identity a a where+instance AsBinaryFunctionT (Semigroup' a) Identity a a where   _BinaryFunctionT = applySemigroup . from binaryFunction  -- | Iso between a 'BinaryFunction' and its underlying binary function.@@ -299,7 +299,7 @@ -- | -- >>> 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 :: (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))  -- |
src/Data/Valuation/DomainLattice.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# OPTIONS_GHC -Wall -Werror #-}@@ -56,7 +57,7 @@  -- | -- >>> import qualified Data.Set as Set--- >>> let lat = setDomainLattice :: DomainLattice (Set Int) (Set Int)+-- >>> let lat = setDomainLattice :: DomainLattice (->) (Set Int) (Set Int) -- >>> runDomainJoin lat (Set.fromList [1,2]) (Set.fromList [2,3]) -- fromList [1,2,3] -- >>> runDomainMeet lat (Set.fromList [1,2]) (Set.fromList [2,3])@@ -67,67 +68,67 @@ -- False -- >>> runDomainCompare lat (Set.fromList [1,2]) (Set.fromList [2,3]) -- Nothing-data DomainLattice sg p+data DomainLattice p sg o   = DomainLattice       -- | join (\/ / supremum)-      (Semigroup sg)+      (Semigroup p sg)       -- | meet (/\ / infimum)-      (Semigroup sg)+      (Semigroup p sg)       -- | partial order-      (PartialOrder p)+      (PartialOrder o)  type DomainLattice' x =-  DomainLattice x x+  DomainLattice (->) x x  -- | Classy lens for types that contain a 'DomainLattice'.-class HasDomainLattice c sg p | c -> sg p where-  domainLattice :: Lens' c (DomainLattice sg p)-  domainLatticeJoin :: Lens' c (Semigroup sg)+class HasDomainLattice c p sg o | c -> p sg o where+  domainLattice :: Lens' c (DomainLattice p sg o)+  domainLatticeJoin :: Lens' c (Semigroup p sg)   domainLatticeJoin = domainLattice . domainLatticeJoin-  domainLatticeMeet :: Lens' c (Semigroup sg)+  domainLatticeMeet :: Lens' c (Semigroup p sg)   domainLatticeMeet = domainLattice . domainLatticeMeet -instance HasDomainLattice (DomainLattice sg p) sg p where+instance HasDomainLattice (DomainLattice p sg o) p sg o where   domainLattice = id   domainLatticeJoin f (DomainLattice j m o) = fmap (\j' -> DomainLattice j' m o) (f j)   domainLatticeMeet f (DomainLattice j m o) = fmap (\m' -> DomainLattice j m' o) (f m)  -- | Classy prism for types that can be constructed from a 'DomainLattice'.-class AsDomainLattice c sg p | c -> sg p where-  _DomainLattice :: Prism' c (DomainLattice sg p)+class AsDomainLattice c p sg o | c -> p sg o where+  _DomainLattice :: Prism' c (DomainLattice p sg o) -instance AsDomainLattice (DomainLattice sg p) sg p where+instance AsDomainLattice (DomainLattice p sg o) p sg o where   _DomainLattice = id -instance HasPartialOrder (DomainLattice sg p) p where+instance HasPartialOrder (DomainLattice p sg o) o where   partialOrder f (DomainLattice j m o) = fmap (DomainLattice j m) (f o)  -- | Apply the domain join (\/): the supremum of two domains. {-# SPECIALIZE runDomainJoin ::-  DomainLattice sg p -> sg -> sg -> sg+  DomainLattice (->) sg o -> sg -> sg -> sg   #-}-runDomainJoin :: (HasDomainLattice lat sg p) => lat -> sg -> sg -> sg+runDomainJoin :: (HasDomainLattice lat (->) sg o) => lat -> sg -> sg -> sg runDomainJoin = runSemigroup . view domainLatticeJoin  -- | Apply the domain meet (/\): the infimum of two domains. {-# SPECIALIZE runDomainMeet ::-  DomainLattice sg p -> sg -> sg -> sg+  DomainLattice (->) sg o -> sg -> sg -> sg   #-}-runDomainMeet :: (HasDomainLattice lat sg p) => lat -> sg -> sg -> sg+runDomainMeet :: (HasDomainLattice lat (->) sg o) => lat -> sg -> sg -> sg runDomainMeet = runSemigroup . view domainLatticeMeet  -- | Compare two domains using the partial order. -- Returns 'Nothing' for incomparable elements. -- -- >>> import qualified Data.Set as Set--- >>> runDomainCompare (setDomainLattice :: DomainLattice (Set Int) (Set Int)) (Set.fromList [1]) (Set.fromList [1,2])+-- >>> runDomainCompare (setDomainLattice :: DomainLattice (->) (Set Int) (Set Int)) (Set.fromList [1]) (Set.fromList [1,2]) -- Just LT--- >>> runDomainCompare (setDomainLattice :: DomainLattice (Set Int) (Set Int)) (Set.fromList [1,2]) (Set.fromList [1,2])+-- >>> runDomainCompare (setDomainLattice :: DomainLattice (->) (Set Int) (Set Int)) (Set.fromList [1,2]) (Set.fromList [1,2]) -- Just EQ--- >>> runDomainCompare (setDomainLattice :: DomainLattice (Set Int) (Set Int)) (Set.fromList [1,2]) (Set.fromList [2,3])+-- >>> runDomainCompare (setDomainLattice :: DomainLattice (->) (Set Int) (Set Int)) (Set.fromList [1,2]) (Set.fromList [2,3]) -- Nothing {-# SPECIALIZE runDomainCompare ::-  DomainLattice sg p -> p -> p -> Maybe Ordering+  DomainLattice p sg o -> o -> o -> Maybe Ordering   #-} runDomainCompare :: (HasPartialOrder lat p) => lat -> p -> p -> Maybe Ordering runDomainCompare = runPartialOrder . view partialOrder@@ -136,12 +137,12 @@ -- Returns 'False' for incomparable elements. -- -- >>> import qualified Data.Set as Set--- >>> runDomainLeq (setDomainLattice :: DomainLattice (Set Int) (Set Int)) (Set.fromList [1]) (Set.fromList [1,2])+-- >>> runDomainLeq (setDomainLattice :: DomainLattice (->) (Set Int) (Set Int)) (Set.fromList [1]) (Set.fromList [1,2]) -- True--- >>> runDomainLeq (setDomainLattice :: DomainLattice (Set Int) (Set Int)) (Set.fromList [1,2]) (Set.fromList [2,3])+-- >>> runDomainLeq (setDomainLattice :: DomainLattice (->) (Set Int) (Set Int)) (Set.fromList [1,2]) (Set.fromList [2,3]) -- False {-# SPECIALIZE runDomainLeq ::-  DomainLattice sg p -> p -> p -> Bool+  DomainLattice p sg o -> o -> o -> Bool   #-} runDomainLeq :: (HasPartialOrder lat p) => lat -> p -> p -> Bool runDomainLeq = partialOrderLeq . view partialOrder@@ -150,7 +151,7 @@ -- intersection as meet, and subset as the partial order. -- -- >>> import qualified Data.Set as Set--- >>> let lat = setDomainLattice :: DomainLattice (Set String) (Set String)+-- >>> let lat = setDomainLattice :: DomainLattice (->) (Set String) (Set String) -- >>> runDomainJoin lat (Set.fromList ["x","y"]) (Set.fromList ["y","z"]) -- fromList ["x","y","z"] -- >>> runDomainMeet lat (Set.fromList ["x","y"]) (Set.fromList ["y","z"])@@ -168,80 +169,80 @@  -- | -- >>> import qualified Data.Set as Set--- >>> lawJoinAssociative (setDomainLattice :: DomainLattice (Set Int) (Set Int)) (Set.fromList [1,2]) (Set.fromList [2,3]) (Set.fromList [3,4])+-- >>> lawJoinAssociative (setDomainLattice :: DomainLattice (->) (Set Int) (Set Int)) (Set.fromList [1,2]) (Set.fromList [2,3]) (Set.fromList [3,4]) -- True-lawJoinAssociative :: (Eq sg) => DomainLattice sg p -> sg -> sg -> sg -> Bool+lawJoinAssociative :: (Eq sg) => DomainLattice (->) sg o -> sg -> sg -> sg -> Bool lawJoinAssociative lat a b c =   let j = runDomainJoin lat    in j (j a b) c == j a (j b c)  -- | -- >>> import qualified Data.Set as Set--- >>> lawMeetAssociative (setDomainLattice :: DomainLattice (Set Int) (Set Int)) (Set.fromList [1,2]) (Set.fromList [2,3]) (Set.fromList [3,4])+-- >>> lawMeetAssociative (setDomainLattice :: DomainLattice (->) (Set Int) (Set Int)) (Set.fromList [1,2]) (Set.fromList [2,3]) (Set.fromList [3,4]) -- True-lawMeetAssociative :: (Eq sg) => DomainLattice sg p -> sg -> sg -> sg -> Bool+lawMeetAssociative :: (Eq sg) => DomainLattice (->) sg o -> sg -> sg -> sg -> Bool lawMeetAssociative lat a b c =   let m = runDomainMeet lat    in m (m a b) c == m a (m b c)  -- | -- >>> import qualified Data.Set as Set--- >>> lawJoinCommutative (setDomainLattice :: DomainLattice (Set Int) (Set Int)) (Set.fromList [1,2]) (Set.fromList [2,3])+-- >>> lawJoinCommutative (setDomainLattice :: DomainLattice (->) (Set Int) (Set Int)) (Set.fromList [1,2]) (Set.fromList [2,3]) -- True-lawJoinCommutative :: (Eq sg) => DomainLattice sg p -> sg -> sg -> Bool+lawJoinCommutative :: (Eq sg) => DomainLattice (->) sg o -> sg -> sg -> Bool lawJoinCommutative lat a b =   runDomainJoin lat a b == runDomainJoin lat b a  -- | -- >>> import qualified Data.Set as Set--- >>> lawMeetCommutative (setDomainLattice :: DomainLattice (Set Int) (Set Int)) (Set.fromList [1,2]) (Set.fromList [2,3])+-- >>> lawMeetCommutative (setDomainLattice :: DomainLattice (->) (Set Int) (Set Int)) (Set.fromList [1,2]) (Set.fromList [2,3]) -- True-lawMeetCommutative :: (Eq sg) => DomainLattice sg p -> sg -> sg -> Bool+lawMeetCommutative :: (Eq sg) => DomainLattice (->) sg o -> sg -> sg -> Bool lawMeetCommutative lat a b =   runDomainMeet lat a b == runDomainMeet lat b a  -- | Absorption law 1: @a \/ (a /\ b) = a@. -- -- >>> import qualified Data.Set as Set--- >>> lawAbsorption1 (setDomainLattice :: DomainLattice (Set Int) (Set Int)) (Set.fromList [1,2]) (Set.fromList [2,3])+-- >>> lawAbsorption1 (setDomainLattice :: DomainLattice (->) (Set Int) (Set Int)) (Set.fromList [1,2]) (Set.fromList [2,3]) -- True-lawAbsorption1 :: (Eq sg) => DomainLattice sg p -> sg -> sg -> Bool+lawAbsorption1 :: (Eq sg) => DomainLattice (->) sg o -> sg -> sg -> Bool lawAbsorption1 lat a b =   runDomainJoin lat a (runDomainMeet lat a b) == a  -- | Absorption law 2: @a /\ (a \/ b) = a@. -- -- >>> import qualified Data.Set as Set--- >>> lawAbsorption2 (setDomainLattice :: DomainLattice (Set Int) (Set Int)) (Set.fromList [1,2]) (Set.fromList [2,3])+-- >>> lawAbsorption2 (setDomainLattice :: DomainLattice (->) (Set Int) (Set Int)) (Set.fromList [1,2]) (Set.fromList [2,3]) -- True-lawAbsorption2 :: (Eq sg) => DomainLattice sg p -> sg -> sg -> Bool+lawAbsorption2 :: (Eq sg) => DomainLattice (->) sg o -> sg -> sg -> Bool lawAbsorption2 lat a b =   runDomainMeet lat a (runDomainJoin lat a b) == a  -- | Join idempotence: @a \/ a = a@. -- -- >>> import qualified Data.Set as Set--- >>> lawJoinIdempotent (setDomainLattice :: DomainLattice (Set Int) (Set Int)) (Set.fromList [1,2])+-- >>> lawJoinIdempotent (setDomainLattice :: DomainLattice (->) (Set Int) (Set Int)) (Set.fromList [1,2]) -- True-lawJoinIdempotent :: (Eq sg) => DomainLattice sg p -> sg -> Bool+lawJoinIdempotent :: (Eq sg) => DomainLattice (->) sg o -> sg -> Bool lawJoinIdempotent lat a =   runDomainJoin lat a a == a  -- | Meet idempotence: @a /\ a = a@. -- -- >>> import qualified Data.Set as Set--- >>> lawMeetIdempotent (setDomainLattice :: DomainLattice (Set Int) (Set Int)) (Set.fromList [1,2])+-- >>> lawMeetIdempotent (setDomainLattice :: DomainLattice (->) (Set Int) (Set Int)) (Set.fromList [1,2]) -- True-lawMeetIdempotent :: (Eq sg) => DomainLattice sg p -> sg -> Bool+lawMeetIdempotent :: (Eq sg) => DomainLattice (->) sg o -> sg -> Bool lawMeetIdempotent lat a =   runDomainMeet lat a a == a  -- | Consistency of partial order with join: @a <= b@ iff @a \/ b = b@. -- -- >>> import qualified Data.Set as Set--- >>> lawLeqFromJoin (setDomainLattice :: DomainLattice (Set Int) (Set Int)) (Set.fromList [1]) (Set.fromList [1,2])+-- >>> lawLeqFromJoin (setDomainLattice :: DomainLattice (->) (Set Int) (Set Int)) (Set.fromList [1]) (Set.fromList [1,2]) -- True--- >>> lawLeqFromJoin (setDomainLattice :: DomainLattice (Set Int) (Set Int)) (Set.fromList [1,3]) (Set.fromList [1,2])+-- >>> lawLeqFromJoin (setDomainLattice :: DomainLattice (->) (Set Int) (Set Int)) (Set.fromList [1,3]) (Set.fromList [1,2]) -- True lawLeqFromJoin :: (Eq d) => DomainLattice' d -> d -> d -> Bool lawLeqFromJoin lat a b =
src/Data/Valuation/PartialOrder.hs view
@@ -55,7 +55,7 @@     HasBinaryFunctionT (..),   ) import Data.Valuation.Semigroup-  ( Semigroup,+  ( Semigroup',     applySemigroup,     runSemigroup,   )@@ -195,7 +195,7 @@ -- Just LT -- >>> runPartialOrder (runSemigroup semigroupPartialOrder po po) 2 2 -- Just EQ-semigroupPartialOrder :: Semigroup (PartialOrder a)+semigroupPartialOrder :: Semigroup' (PartialOrder a) semigroupPartialOrder = review applySemigroup $ \(PartialOrder f) (PartialOrder g) -> PartialOrder $ \a b ->   case f a b of     Just EQ -> g a b
src/Data/Valuation/PresheafValuationAlgebra.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# OPTIONS_GHC -Wall -Werror #-}@@ -16,6 +17,7 @@ -- operations that work directly on 'Valuation' values. module Data.Valuation.PresheafValuationAlgebra   ( PresheafValuationAlgebra (..),+    PresheafValuationAlgebra',     SetPresheafValuationAlgebra,     HasPresheafValuationAlgebra (..),     AsPresheafValuationAlgebra (..),@@ -49,7 +51,7 @@   ) import Data.Valuation.Semigroup   ( HasSemigroup (..),-    Semigroup,+    Semigroup',     applySemigroup,     runSemigroup,   )@@ -75,52 +77,55 @@ -- >>> import Prelude hiding (Semigroup)  -- |--- >>> let lat = setDomainLattice :: DomainLattice (Set Int) (Set Int)+-- >>> let lat = setDomainLattice :: DomainLattice (->) (Set Int) (Set Int) -- >>> let sva = SemiValuationAlgebra (review applySemigroup (+)) (ProjectValuation (\_ v -> v))--- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 0)) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra Int Set Int+-- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 0)) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra (->) Int Set Int -- >>> let pva = PresheafValuationAlgebra lat va -- >>> let v1 = Valuation (Set.fromList [1,2]) 10 :: Valuation Set Int Int -- >>> let v2 = Valuation (Set.fromList [2,3]) 20 -- >>> combine pva v1 v2 -- Valuation (fromList [1,2,3]) 30-data PresheafValuationAlgebra v set var+data PresheafValuationAlgebra p v set var   = PresheafValuationAlgebra       -- | lattice structure on domains-      (DomainLattice (set var) (set var))+      (DomainLattice p (set var) (set var))       -- | the valuation algebra-      (ValuationAlgebra v set var)+      (ValuationAlgebra p v set var) +type PresheafValuationAlgebra' v set var =+  PresheafValuationAlgebra (->) v set var+ -- | A 'PresheafValuationAlgebra' specialised to 'Set'.-type SetPresheafValuationAlgebra v var =-  PresheafValuationAlgebra v Set var+type SetPresheafValuationAlgebra p v var =+  PresheafValuationAlgebra p v Set var  -- | Classy lens for types that contain a 'PresheafValuationAlgebra'.-class HasPresheafValuationAlgebra c v set var | c -> v set var where-  presheafValuationAlgebra :: Lens' c (PresheafValuationAlgebra v set var)+class HasPresheafValuationAlgebra c p v set var | c -> p v set var where+  presheafValuationAlgebra :: Lens' c (PresheafValuationAlgebra p v set var) -instance HasPresheafValuationAlgebra (PresheafValuationAlgebra v set var) v set var where+instance HasPresheafValuationAlgebra (PresheafValuationAlgebra p v set var) p v set var where   presheafValuationAlgebra = id  -- | Classy prism for types that can be constructed from a 'PresheafValuationAlgebra'.-class AsPresheafValuationAlgebra c v set var | c -> v set var where-  _PresheafValuationAlgebra :: Prism' c (PresheafValuationAlgebra v set var)+class AsPresheafValuationAlgebra c p v set var | c -> p v set var where+  _PresheafValuationAlgebra :: Prism' c (PresheafValuationAlgebra p v set var) -instance AsPresheafValuationAlgebra (PresheafValuationAlgebra v set var) v set var where+instance AsPresheafValuationAlgebra (PresheafValuationAlgebra p v set var) p v set var where   _PresheafValuationAlgebra = id -instance HasDomainLattice (PresheafValuationAlgebra v set var) (set var) (set var) where+instance HasDomainLattice (PresheafValuationAlgebra p v set var) p (set var) (set var) where   domainLattice f (PresheafValuationAlgebra l a) = fmap (`PresheafValuationAlgebra` a) (f l) -instance HasValuationAlgebra (PresheafValuationAlgebra v set var) v set var where+instance HasValuationAlgebra (PresheafValuationAlgebra p v set var) p v set var where   valuationAlgebra f (PresheafValuationAlgebra l a) = fmap (PresheafValuationAlgebra l) (f a) -instance HasSemiValuationAlgebra (PresheafValuationAlgebra v set var) v set var where+instance HasSemiValuationAlgebra (PresheafValuationAlgebra p v set var) p v set var where   semiValuationAlgebra = valuationAlgebra . semiValuationAlgebra -instance HasSemigroup (PresheafValuationAlgebra v set var) v where+instance HasSemigroup (PresheafValuationAlgebra p v set var) p v where   semigroup = semiValuationAlgebra . semigroup -instance HasProjectValuation (PresheafValuationAlgebra v set var) v set var where+instance HasProjectValuation (PresheafValuationAlgebra p v set var) p v set var where   projectValuation = semiValuationAlgebra . projectValuation  -- | Marginalise a valuation to a subdomain: the restriction map of the presheaf.@@ -132,16 +137,16 @@ -- -- The caller should ensure @d' <= d(phi)@. ----- >>> let lat = setDomainLattice :: DomainLattice (Set Int) (Set Int)+-- >>> let lat = setDomainLattice :: DomainLattice (->) (Set Int) (Set Int) -- >>> let sva = SemiValuationAlgebra (review applySemigroup (+)) (ProjectValuation (\s v -> v + Set.size s))--- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 0)) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra Int Set Int+-- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 0)) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra (->) Int Set Int -- >>> let pva = PresheafValuationAlgebra lat va -- >>> marginalise pva (Set.fromList [1]) (Valuation (Set.fromList [1,2]) 10) -- Valuation (fromList [1]) 11 {-# SPECIALIZE marginalise ::-  PresheafValuationAlgebra v set var -> set var -> Valuation set var v -> Valuation set var v+  PresheafValuationAlgebra (->) v set var -> set var -> Valuation set var v -> Valuation set var v   #-}-marginalise :: (HasProjectValuation algebra v set var, HasValuation valuation set' var' v) => algebra -> set var -> valuation -> Valuation set var v+marginalise :: (HasProjectValuation algebra (->) v set var, HasValuation valuation set' var' v) => algebra -> set var -> valuation -> Valuation set var v marginalise algebra targetDomain =   Valuation targetDomain . view (projectValuation . _Wrapped) algebra targetDomain . view valuationInformation @@ -152,88 +157,88 @@ -- The information values are combined using the algebra's semigroup, -- and the result has the joined domain. ----- >>> let lat = setDomainLattice :: DomainLattice (Set Int) (Set Int)+-- >>> let lat = setDomainLattice :: DomainLattice (->) (Set Int) (Set Int) -- >>> let sva = SemiValuationAlgebra (review applySemigroup (+)) (ProjectValuation (\_ v -> v))--- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 0)) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra Int Set Int+-- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 0)) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra (->) Int Set Int -- >>> let pva = PresheafValuationAlgebra lat va -- >>> combine pva (Valuation (Set.fromList [1,2]) 10) (Valuation (Set.fromList [2,3]) 20) -- Valuation (fromList [1,2,3]) 30 ----- >>> let lat = setDomainLattice :: DomainLattice (Set Int) (Set Int)+-- >>> let lat = setDomainLattice :: DomainLattice (->) (Set Int) (Set Int) -- >>> let sva = SemiValuationAlgebra (review applySemigroup (*)) (ProjectValuation (\_ v -> v))--- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 1)) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra Int Set Int+-- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 1)) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra (->) Int Set Int -- >>> let pva = PresheafValuationAlgebra lat va -- >>> combine pva (Valuation (Set.fromList [1]) 3) (Valuation (Set.fromList [2]) 4) -- Valuation (fromList [1,2]) 12 {-# SPECIALIZE combine ::-  PresheafValuationAlgebra v set var -> Valuation set var v -> Valuation set var v -> Valuation set var v+  PresheafValuationAlgebra (->) v set var -> Valuation set var v -> Valuation set var v -> Valuation set var v   #-} combine ::-  (HasSemigroup s1 a, HasDomainLattice s1 (set var) p, HasValuation s2 set var a, HasValuation s3 set var a) => s1 -> s2 -> s3 -> Valuation set var a+  (HasSemigroup s1 (->) a, HasDomainLattice s1 (->) (set var) p, HasValuation s2 set var a, HasValuation s3 set var a) => s1 -> s2 -> s3 -> Valuation set var a combine alg phi =   Valuation . runSemigroup (view domainLatticeJoin alg) (view valuationDomain phi) . view valuationDomain <*> runSemigroup (view semigroup alg) (view valuationInformation phi) . view valuationInformation  -- | The neutral valuation for a domain: @e_d@ such that @e_d ⊗ phi = phi@ -- for all phi with @d(phi) <= d@. ----- >>> let lat = setDomainLattice :: DomainLattice (Set Int) (Set Int)+-- >>> let lat = setDomainLattice :: DomainLattice (->) (Set Int) (Set Int) -- >>> let sva = SemiValuationAlgebra (review applySemigroup (+)) (ProjectValuation (\_ v -> v))--- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 0)) (ValuationAlgebraOp (const 99)) :: ValuationAlgebra Int Set Int+-- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 0)) (ValuationAlgebraOp (const 99)) :: ValuationAlgebra (->) Int Set Int -- >>> let pva = PresheafValuationAlgebra lat va -- >>> neutralValuation pva (Set.fromList [1,2]) -- Valuation (fromList [1,2]) 0 {-# SPECIALIZE neutralValuation ::-  PresheafValuationAlgebra v set var -> set var -> Valuation set var v+  PresheafValuationAlgebra (->) v set var -> set var -> Valuation set var v   #-}-neutralValuation :: (HasValuationAlgebra s a set var) => s -> set var -> Valuation set var a+neutralValuation :: (HasValuationAlgebra s (->) a set var) => s -> set var -> Valuation set var a neutralValuation algebra =   Valuation <*> view (valuationAlgebra . valuationAlgebraUnit . _Wrapped) algebra  -- | The null/zero valuation for a domain: @z_d@ such that @z_d ⊗ phi = z_{d \/ d(phi)}@ -- for all phi. ----- >>> let lat = setDomainLattice :: DomainLattice (Set Int) (Set Int)+-- >>> let lat = setDomainLattice :: DomainLattice (->) (Set Int) (Set Int) -- >>> let sva = SemiValuationAlgebra (review applySemigroup (+)) (ProjectValuation (\_ v -> v))--- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 0)) (ValuationAlgebraOp (const 99)) :: ValuationAlgebra Int Set Int+-- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 0)) (ValuationAlgebraOp (const 99)) :: ValuationAlgebra (->) Int Set Int -- >>> let pva = PresheafValuationAlgebra lat va -- >>> nullValuation pva (Set.fromList [1,2]) -- Valuation (fromList [1,2]) 99 {-# SPECIALIZE nullValuation ::-  PresheafValuationAlgebra v set var -> set var -> Valuation set var v+  PresheafValuationAlgebra (->) v set var -> set var -> Valuation set var v   #-}-nullValuation :: (HasValuationAlgebra s a set var) => s -> set var -> Valuation set var a+nullValuation :: (HasValuationAlgebra s (->) a set var) => s -> set var -> Valuation set var a nullValuation algebra =   Valuation <*> view (valuationAlgebra . valuationAlgebraZero . _Wrapped) algebra  -- | A first-class 'Semigroup' on 'Valuation' derived from the presheaf algebra's -- combination operation. ----- >>> let lat = setDomainLattice :: DomainLattice (Set Int) (Set Int)+-- >>> let lat = setDomainLattice :: DomainLattice (->) (Set Int) (Set Int) -- >>> let sva = SemiValuationAlgebra (review applySemigroup (+)) (ProjectValuation (\_ v -> v))--- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 0)) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra Int Set Int+-- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 0)) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra (->) Int Set Int -- >>> let pva = PresheafValuationAlgebra lat va -- >>> let sg = presheafCombineSemigroup pva -- >>> runSemigroup sg (Valuation (Set.fromList [1]) 10) (Valuation (Set.fromList [2]) 20) -- Valuation (fromList [1,2]) 30 {-# SPECIALIZE presheafCombineSemigroup ::-  PresheafValuationAlgebra v set var -> Semigroup (Valuation set var v)+  PresheafValuationAlgebra (->) v set var -> Semigroup' (Valuation set var v)   #-}-presheafCombineSemigroup :: (HasSemigroup algebra v, HasDomainLattice algebra (set var) p) => algebra -> Semigroup (Valuation set var v)+presheafCombineSemigroup :: (HasSemigroup algebra (->) v, HasDomainLattice algebra (->) (set var) p) => algebra -> Semigroup' (Valuation set var v) presheafCombineSemigroup = review applySemigroup . combine  -- | Transitivity of marginalisation: @(phi↓d')↓d'' = phi↓d''@ for @d'' <= d' <= d(phi)@. ----- >>> let lat = setDomainLattice :: DomainLattice (Set Int) (Set Int)+-- >>> let lat = setDomainLattice :: DomainLattice (->) (Set Int) (Set Int) -- >>> let sva = SemiValuationAlgebra (review applySemigroup (+)) (ProjectValuation (\_ v -> v))--- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 0)) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra Int Set Int+-- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 0)) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra (->) Int Set Int -- >>> let pva = PresheafValuationAlgebra lat va -- >>> let phi = Valuation (Set.fromList [1,2,3]) 10 -- >>> lawTransitivity pva (Set.fromList [1,2]) (Set.fromList [1]) phi -- True {-# SPECIALIZE lawTransitivity ::-  (Eq v) => PresheafValuationAlgebra v set var -> set var -> set var -> Valuation set var v -> Bool+  (Eq v) => PresheafValuationAlgebra (->) v set var -> set var -> set var -> Valuation set var v -> Bool   #-}-lawTransitivity :: (Eq a, HasProjectValuation p a set var, HasValuation q set' var' a) => p -> set var -> set var -> q -> Bool+lawTransitivity :: (Eq a, HasProjectValuation p (->) a set var, HasValuation q set' var' a) => p -> set var -> set var -> q -> Bool lawTransitivity pva d' d'' phi =   let step = marginalise pva d'' (marginalise pva d' phi)       direct = marginalise pva d'' phi@@ -242,16 +247,16 @@  -- | Domain of combination: @d(phi ⊗ psi) = d(phi) \/ d(psi)@. ----- >>> let lat = setDomainLattice :: DomainLattice (Set Int) (Set Int)+-- >>> let lat = setDomainLattice :: DomainLattice (->) (Set Int) (Set Int) -- >>> let sva = SemiValuationAlgebra (review applySemigroup (+)) (ProjectValuation (\_ v -> v))--- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 0)) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra Int Set Int+-- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 0)) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra (->) Int Set Int -- >>> let pva = PresheafValuationAlgebra lat va -- >>> lawCombinationDomain pva (Valuation (Set.fromList [1,2]) 10) (Valuation (Set.fromList [2,3]) 20) -- True {-# SPECIALIZE lawCombinationDomain ::-  (Eq (set var)) => PresheafValuationAlgebra v set var -> Valuation set var v -> Valuation set var v -> Bool+  (Eq (set var)) => PresheafValuationAlgebra (->) v set var -> Valuation set var v -> Valuation set var v -> Bool   #-}-lawCombinationDomain :: (HasSemigroup s1 a, Eq (set var), HasValuation s2 set var a, HasValuation s3 set var a, HasDomainLattice s1 (set var) p) => s1 -> s2 -> s3 -> Bool+lawCombinationDomain :: (HasSemigroup s1 (->) a, Eq (set var), HasValuation s2 set var a, HasValuation s3 set var a, HasDomainLattice s1 (->) (set var) p) => s1 -> s2 -> s3 -> Bool lawCombinationDomain pva val1 val2 =   let lat = view domainLattice pva       d1 = view valuationDomain val1@@ -261,16 +266,16 @@  -- | Marginalisation identity: @phi↓d(phi) = phi@ (marginalising to own domain is identity). ----- >>> let lat = setDomainLattice :: DomainLattice (Set Int) (Set Int)+-- >>> let lat = setDomainLattice :: DomainLattice (->) (Set Int) (Set Int) -- >>> let sva = SemiValuationAlgebra (review applySemigroup (+)) (ProjectValuation (\_ v -> v))--- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 0)) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra Int Set Int+-- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 0)) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra (->) Int Set Int -- >>> let pva = PresheafValuationAlgebra lat va -- >>> lawMarginalisationIdentity pva (Valuation (Set.fromList [1,2]) 42) -- True {-# SPECIALIZE lawMarginalisationIdentity ::-  (Eq (set var), Eq v) => PresheafValuationAlgebra v set var -> Valuation set var v -> Bool+  (Eq (set var), Eq v) => PresheafValuationAlgebra (->) v set var -> Valuation set var v -> Bool   #-}-lawMarginalisationIdentity :: (Eq a, Eq (set var), HasValuation s set var a, HasProjectValuation p a set var) => p -> s -> Bool+lawMarginalisationIdentity :: (Eq a, Eq (set var), HasValuation s set var a, HasProjectValuation p (->) a set var) => p -> s -> Bool lawMarginalisationIdentity pva val =   let d = view valuationDomain val       v = view valuationInformation val@@ -280,17 +285,17 @@ -- | Neutral element axiom: @combine pva (neutralValuation pva d) phi = phi@ -- when @d(phi) <= d@ (the neutral valuation is an identity for combination). ----- >>> let lat = setDomainLattice :: DomainLattice (Set Int) (Set Int)+-- >>> let lat = setDomainLattice :: DomainLattice (->) (Set Int) (Set Int) -- >>> let sva = SemiValuationAlgebra (review applySemigroup (+)) (ProjectValuation (\_ v -> v))--- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 0)) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra Int Set Int+-- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 0)) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra (->) Int Set Int -- >>> let pva = PresheafValuationAlgebra lat va -- >>> let phi = Valuation (Set.fromList [1]) 42 -- >>> lawNeutralCombination pva (Set.fromList [1,2]) phi -- True {-# SPECIALIZE lawNeutralCombination ::-  (Eq (set var), Eq v) => PresheafValuationAlgebra v set var -> set var -> Valuation set var v -> Bool+  (Eq (set var), Eq v) => PresheafValuationAlgebra (->) v set var -> set var -> Valuation set var v -> Bool   #-}-lawNeutralCombination :: (HasSemigroup s1 a, Eq a, Eq (set var), HasDomainLattice s1 (set var) (set var), HasValuation s2 set var a, HasValuationAlgebra s1 a set var) => s1 -> set var -> s2 -> Bool+lawNeutralCombination :: (HasSemigroup s1 (->) a, Eq a, Eq (set var), HasDomainLattice s1 (->) (set var) (set var), HasValuation s2 set var a, HasValuationAlgebra s1 (->) a set var) => s1 -> set var -> s2 -> Bool lawNeutralCombination pva d phi =   let lat = view domainLattice pva       dPhi = view valuationDomain phi@@ -302,17 +307,17 @@  -- | Null element axiom: @combine pva (nullValuation pva d) phi = nullValuation pva (d \/ d(phi))@. ----- >>> let lat = setDomainLattice :: DomainLattice (Set Int) (Set Int)+-- >>> let lat = setDomainLattice :: DomainLattice (->) (Set Int) (Set Int) -- >>> let sva = SemiValuationAlgebra (review applySemigroup (*)) (ProjectValuation (\_ v -> v))--- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 1)) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra Int Set Int+-- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 1)) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra (->) Int Set Int -- >>> let pva = PresheafValuationAlgebra lat va -- >>> let phi = Valuation (Set.fromList [1]) 42 -- >>> lawNullCombination pva (Set.fromList [2]) phi -- True {-# SPECIALIZE lawNullCombination ::-  (Eq (set var), Eq v) => PresheafValuationAlgebra v set var -> set var -> Valuation set var v -> Bool+  (Eq (set var), Eq v) => PresheafValuationAlgebra (->) v set var -> set var -> Valuation set var v -> Bool   #-}-lawNullCombination :: (HasSemigroup s1 a, Eq a, Eq (set var), HasValuation s2 set var a, HasDomainLattice s1 (set var) p, HasValuationAlgebra s1 a set var) => s1 -> set var -> s2 -> Bool+lawNullCombination :: (HasSemigroup s1 (->) a, Eq a, Eq (set var), HasValuation s2 set var a, HasDomainLattice s1 (->) (set var) p, HasValuationAlgebra s1 (->) a set var) => s1 -> set var -> s2 -> Bool lawNullCombination pva d phi =   let lat = view domainLattice pva       dPhi = view valuationDomain phi@@ -325,16 +330,16 @@  -- | Combination is commutative: @phi ⊗ psi = psi ⊗ phi@. ----- >>> let lat = setDomainLattice :: DomainLattice (Set Int) (Set Int)+-- >>> let lat = setDomainLattice :: DomainLattice (->) (Set Int) (Set Int) -- >>> let sva = SemiValuationAlgebra (review applySemigroup (+)) (ProjectValuation (\_ v -> v))--- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 0)) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra Int Set Int+-- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp (const 0)) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra (->) Int Set Int -- >>> let pva = PresheafValuationAlgebra lat va -- >>> lawCombinationCommutative pva (Valuation (Set.fromList [1]) 10) (Valuation (Set.fromList [2]) 20) -- True {-# SPECIALIZE lawCombinationCommutative ::-  (Eq (set var), Eq v) => PresheafValuationAlgebra v set var -> Valuation set var v -> Valuation set var v -> Bool+  (Eq (set var), Eq v) => PresheafValuationAlgebra (->) v set var -> Valuation set var v -> Valuation set var v -> Bool   #-}-lawCombinationCommutative :: (HasSemigroup s1 a, Eq a, Eq (set var), HasDomainLattice s1 (set var) p, HasValuation s2 set var a, HasValuation s3 set var a) => s1 -> s2 -> s3 -> Bool+lawCombinationCommutative :: (HasSemigroup s1 (->) a, Eq a, Eq (set var), HasDomainLattice s1 (->) (set var) p, HasValuation s2 set var a, HasValuation s3 set var a) => s1 -> s2 -> s3 -> Bool lawCombinationCommutative pva phi psi =   let Valuation d1 v1 = combine pva phi psi       Valuation d2 v2 = combine pva psi phi
src/Data/Valuation/ProjectValuation.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeFamilies #-}@@ -7,6 +8,7 @@ -- | A projection function that updates a value given a set of variables. module Data.Valuation.ProjectValuation   ( ProjectValuation (..),+    ProjectValuation',     SetProjectValuation,      -- * optics@@ -20,6 +22,7 @@   ) where +import Control.Category (Category (..)) import Control.Lens   ( Lens',     Prism',@@ -34,14 +37,16 @@ import Data.Functor.Contravariant.Decide (Decide (..)) import Data.Functor.Contravariant.Divise (Divise (..)) import Data.Functor.Contravariant.Divisible (Decidable (..), Divisible (..))+import Data.Profunctor (Profunctor (..), Strong (..))+import Data.Semigroupoid (Semigroupoid (..)) import Data.Set (Set) import Data.Valuation.Semigroup-  ( Semigroup,+  ( Semigroup',     applySemigroup,     runSemigroup,   ) import Witherable (Filterable (mapMaybe))-import Prelude hiding (Semigroup)+import Prelude hiding (Semigroup, id, (.)) import qualified Prelude  -- $setup@@ -54,157 +59,165 @@ -- -- >>> let ProjectValuation f = ProjectValuation (\s v -> v + length s) in f [1,2,3] (10 :: Int) -- 13-newtype ProjectValuation v set var-  = ProjectValuation (set var -> v -> v)+newtype ProjectValuation p v set var+  = ProjectValuation (p (set var) (p v v)) +type ProjectValuation' v set var =+  ProjectValuation (->) v set var+ instance-  (ProjectValuation v set var ~ t) =>-  Rewrapped (ProjectValuation v' set' var') t+  (ProjectValuation p v set var ~ t) =>+  Rewrapped (ProjectValuation p' v' set' var') t -instance Wrapped (ProjectValuation v set var) where-  type Unwrapped (ProjectValuation v set var) = set var -> v -> v+instance Wrapped (ProjectValuation p v set var) where+  type Unwrapped (ProjectValuation p v set var) = p (set var) (p v v)   _Wrapped' = iso (\(ProjectValuation x) -> x) ProjectValuation  -- | Classy lens for types that contain a 'ProjectValuation'.-class HasProjectValuation c v set var | c -> v set var where-  projectValuation :: Lens' c (ProjectValuation v set var)+class HasProjectValuation c p v set var | c -> p v set var where+  projectValuation :: Lens' c (ProjectValuation p v set var) -instance HasProjectValuation (ProjectValuation v set var) v set var where+instance HasProjectValuation (ProjectValuation p v set var) p v set var where   projectValuation = id  -- | Classy prism for types that can be constructed from a 'ProjectValuation'.-class AsProjectValuation c v set var | c -> v set var where-  _ProjectValuation :: Prism' c (ProjectValuation v set var)+class AsProjectValuation c p v set var | c -> p v set var where+  _ProjectValuation :: Prism' c (ProjectValuation p v set var) -instance AsProjectValuation (ProjectValuation v set var) v set var where+instance AsProjectValuation (ProjectValuation p v set var) p v set var where   _ProjectValuation = id  -- | Lens to the underlying function of a 'HasProjectValuation'.-applyHasProjectValuation :: (HasProjectValuation pv v set var) => Lens' pv (set var -> v -> v)+applyHasProjectValuation :: (HasProjectValuation pv p v set var) => Lens' pv (p (set var) (p v v)) applyHasProjectValuation = projectValuation . _Wrapped  -- | Prism to the underlying function of an 'AsProjectValuation'.-applyAsProjectValuation :: (AsProjectValuation pv v set var) => Prism' pv (set var -> v -> v)+applyAsProjectValuation :: (AsProjectValuation pv p v set var) => Prism' pv (p (set var) (p v v)) applyAsProjectValuation = _ProjectValuation . _Wrapped  -- | -- >>> import Data.Functor.Contravariant (contramap)--- >>> let pv = ProjectValuation (\s v -> v + sum s) :: ProjectValuation Int [] Int+-- >>> let pv = ProjectValuation (\s v -> v + sum s) :: ProjectValuation (->) Int [] Int -- >>> let ProjectValuation f = contramap (*2) pv in f [1,2,3] 10 -- 22 -- -- >>> import Data.Functor.Contravariant (contramap)--- >>> let pv = ProjectValuation (\s v -> v + sum s) :: ProjectValuation Int [] Int+-- >>> let pv = ProjectValuation (\s v -> v + sum s) :: ProjectValuation (->) Int [] Int -- >>> let ProjectValuation f = contramap negate pv in f [1,2,3] 0 -- -6-instance (Functor set) => Contravariant (ProjectValuation v set) where-  contramap f (ProjectValuation g) = ProjectValuation (g . fmap f)+instance (Functor set, Profunctor p) => Contravariant (ProjectValuation p v set) where+  contramap f (ProjectValuation g) = ProjectValuation (lmap (fmap f) g)  -- | -- >>> import Data.Functor.Contravariant.Divisible (conquer, divide)--- >>> let ProjectValuation f = conquer :: ProjectValuation Int [] Int in f [1,2,3] 42+-- >>> let ProjectValuation f = conquer :: ProjectValuation (->) Int [] Int in f [1,2,3] 42 -- 42 -- -- >>> import Data.Functor.Contravariant.Divisible (conquer, divide)--- >>> let ProjectValuation f = conquer :: ProjectValuation String [] Char in f "abc" "hello"+-- >>> let ProjectValuation f = conquer :: ProjectValuation (->) String [] Char in f "abc" "hello" -- "hello" -- -- >>> import Data.Functor.Contravariant.Divisible (conquer, divide)--- >>> let pvB = ProjectValuation (\s v -> v + sum s) :: ProjectValuation Int [] Int--- >>> let pvC = ProjectValuation (\s v -> v * length s) :: ProjectValuation Int [] Int+-- >>> let pvB = ProjectValuation (\s v -> v + sum s) :: ProjectValuation (->) Int [] Int+-- >>> let pvC = ProjectValuation (\s v -> v * length s) :: ProjectValuation (->) Int [] Int -- >>> let ProjectValuation f = divide (\x -> (x, x * 10)) pvB pvC in f [1,2,3] 5 -- 21 -- -- >>> import Data.Functor.Contravariant.Divisible (conquer, divide)--- >>> let pvB = ProjectValuation (\s v -> v + sum s) :: ProjectValuation Int [] Int--- >>> let pvC = ProjectValuation (\s v -> v * length s) :: ProjectValuation Int [] Int+-- >>> let pvB = ProjectValuation (\s v -> v + sum s) :: ProjectValuation (->) Int [] Int+-- >>> let pvC = ProjectValuation (\s v -> v * length s) :: ProjectValuation (->) Int [] Int -- >>> let ProjectValuation f = divide (\x -> (x, x)) pvB pvC in f [1,2,3] 5 -- 21-instance (Functor set) => Divisible (ProjectValuation v set) where-  conquer = ProjectValuation (const id)+instance (Functor set, Strong p, Category p) => Divisible (ProjectValuation p v set) where+  conquer = ProjectValuation (rmap (const id) id)   divide split (ProjectValuation pb) (ProjectValuation pc) =-    ProjectValuation (\fa v -> pb (fmap (fst . split) fa) (pc (fmap (snd . split) fa) v))+    let pb' = lmap (fmap (fst . split)) pb+        pc' = lmap (fmap (snd . split)) pc+     in ProjectValuation (lmap (\x -> (x, x)) (rmap (uncurry (.)) (second' pc' . first' pb')))  -- | -- >>> import Data.Functor.Contravariant.Divisible (choose, lose) -- >>> import Data.Void (Void, absurd)--- >>> let ProjectValuation f = lose absurd :: ProjectValuation Int [] Void in f [] 42+-- >>> let ProjectValuation f = lose absurd :: ProjectValuation (->) Int [] Void in f [] 42 -- 42 -- -- >>> import Data.Functor.Contravariant.Divisible (choose)--- >>> let pvB = ProjectValuation (\s v -> v + sum s) :: ProjectValuation Int [] Int--- >>> let pvC = ProjectValuation (\s v -> v * length s) :: ProjectValuation Int [] Int+-- >>> let pvB = ProjectValuation (\s v -> v + sum s) :: ProjectValuation (->) Int [] Int+-- >>> let pvC = ProjectValuation (\s v -> v * length s) :: ProjectValuation (->) Int [] Int -- >>> let ProjectValuation f = choose (\x -> if even x then Left x else Right x) pvB pvC in f [1,2,3,4] 10 -- 26 -- -- >>> import Data.Functor.Contravariant.Divisible (choose)--- >>> let pvB = ProjectValuation (\s v -> v + sum s) :: ProjectValuation Int [] Int--- >>> let pvC = ProjectValuation (\s v -> v * length s) :: ProjectValuation Int [] Int+-- >>> let pvB = ProjectValuation (\s v -> v + sum s) :: ProjectValuation (->) Int [] Int+-- >>> let pvC = ProjectValuation (\s v -> v * length s) :: ProjectValuation (->) Int [] Int -- >>> let ProjectValuation f = choose Left pvB pvC in f [1,2,3] 10 -- 6 -- -- >>> import Data.Functor.Contravariant.Divisible (choose)--- >>> let pvB = ProjectValuation (\s v -> v + sum s) :: ProjectValuation Int [] Int--- >>> let pvC = ProjectValuation (\s v -> v * length s) :: ProjectValuation Int [] Int+-- >>> let pvB = ProjectValuation (\s v -> v + sum s) :: ProjectValuation (->) Int [] Int+-- >>> let pvC = ProjectValuation (\s v -> v * length s) :: ProjectValuation (->) Int [] Int -- >>> let ProjectValuation f = choose Right pvB pvC in f [1,2,3] 10 -- 30-instance (Filterable set) => Decidable (ProjectValuation v set) where-  lose _ = ProjectValuation (const id)+instance (Filterable set, Strong p, Category p) => Decidable (ProjectValuation p v set) where+  lose _ = ProjectValuation (rmap (const id) id)   choose ch (ProjectValuation pb) (ProjectValuation pc) =-    ProjectValuation-      ( \fa v ->-          let fb = mapMaybe (either Just (const Nothing) . ch) fa-              fc = mapMaybe (either (const Nothing) Just . ch) fa-           in pb fb (pc fc v)-      )+    let pb' = lmap (mapMaybe (either Just (const Nothing) . ch)) pb+        pc' = lmap (mapMaybe (either (const Nothing) Just . ch)) pc+     in ProjectValuation (lmap (\x -> (x, x)) (rmap (uncurry (.)) (second' pc' . first' pb')))  -- | -- >>> import Data.Functor.Contravariant.Divise (divise)--- >>> let pvB = ProjectValuation (\s v -> v + sum s) :: ProjectValuation Int [] Int--- >>> let pvC = ProjectValuation (\s v -> v * length s) :: ProjectValuation Int [] Int+-- >>> let pvB = ProjectValuation (\s v -> v + sum s) :: ProjectValuation (->) Int [] Int+-- >>> let pvC = ProjectValuation (\s v -> v * length s) :: ProjectValuation (->) Int [] Int -- >>> let ProjectValuation f = divise (\x -> (x, x * 10)) pvB pvC in f [1,2,3] 5 -- 21-instance (Functor set) => Divise (ProjectValuation v set) where-  divise = divide+instance (Functor set, Strong p, Semigroupoid p) => Divise (ProjectValuation p v set) where+  divise split (ProjectValuation pb) (ProjectValuation pc) =+    let pb' = lmap (fmap (fst . split)) pb+        pc' = lmap (fmap (snd . split)) pc+     in ProjectValuation (lmap (\x -> (x, x)) (rmap (uncurry o) (second' pc' `o` first' pb')))  -- | -- >>> import Data.Functor.Contravariant.Decide (decide)--- >>> let pvB = ProjectValuation (\s v -> v + sum s) :: ProjectValuation Int [] Int--- >>> let pvC = ProjectValuation (\s v -> v * length s) :: ProjectValuation Int [] Int+-- >>> let pvB = ProjectValuation (\s v -> v + sum s) :: ProjectValuation (->) Int [] Int+-- >>> let pvC = ProjectValuation (\s v -> v * length s) :: ProjectValuation (->) Int [] Int -- >>> let ProjectValuation f = decide (\x -> if even x then Left x else Right x) pvB pvC in f [1,2,3,4] 10 -- 26-instance (Filterable set) => Decide (ProjectValuation v set) where-  decide = choose+instance (Filterable set, Strong p, Semigroupoid p) => Decide (ProjectValuation p v set) where+  decide ch (ProjectValuation pb) (ProjectValuation pc) =+    let pb' = lmap (mapMaybe (either Just (const Nothing) . ch)) pb+        pc' = lmap (mapMaybe (either (const Nothing) Just . ch)) pc+     in ProjectValuation (lmap (\x -> (x, x)) (rmap (uncurry o) (second' pc' `o` first' pb')))  -- | -- >>> import Data.Functor.Contravariant.Conclude (conclude) -- >>> import Data.Void (absurd)--- >>> let ProjectValuation f = conclude absurd :: ProjectValuation Int [] Void in f [] 42+-- >>> let ProjectValuation f = conclude absurd :: ProjectValuation (->) Int [] Void in f [] 42 -- 42-instance (Filterable set) => Conclude (ProjectValuation v set) where-  conclude _ = ProjectValuation (const id)+instance (Filterable set, Strong p, Semigroupoid p, Category p) => Conclude (ProjectValuation p v set) where+  conclude _ = ProjectValuation (rmap (const id) id)  -- | -- >>> let ProjectValuation f = runSemigroup semigroupProjectValuation (ProjectValuation (\_ v -> v + 1)) (ProjectValuation (\_ v -> v * 2)) in f [] (3 :: Int) -- 7-semigroupProjectValuation :: Semigroup (ProjectValuation v set var)+semigroupProjectValuation :: Semigroup' (ProjectValuation (->) v set var) semigroupProjectValuation = review applySemigroup (\(ProjectValuation p1) (ProjectValuation p2) -> ProjectValuation (\s -> p1 s . p2 s))  -- |--- >>> let p1 = ProjectValuation (\s v -> v + sum s) :: ProjectValuation Int [] Int--- >>> let p2 = ProjectValuation (\s v -> v * length s) :: ProjectValuation Int [] Int+-- >>> let p1 = ProjectValuation (\s v -> v + sum s) :: ProjectValuation (->) Int [] Int+-- >>> let p2 = ProjectValuation (\s v -> v * length s) :: ProjectValuation (->) Int [] Int -- >>> let ProjectValuation f = p1 <> p2 in f [1,2,3] 5 -- 21-instance Prelude.Semigroup (ProjectValuation v set var) where+instance Prelude.Semigroup (ProjectValuation (->) v set var) where   (<>) = runSemigroup semigroupProjectValuation  -- |--- >>> let p = ProjectValuation (\s v -> v + sum s) :: ProjectValuation Int [] Int+-- >>> let p = ProjectValuation (\s v -> v + sum s) :: ProjectValuation (->) Int [] Int -- >>> let ProjectValuation f = mempty <> p in f [1,2,3] 5 -- 11-instance Monoid (ProjectValuation v set var) where+instance Monoid (ProjectValuation (->) v set var) where   mempty = ProjectValuation (const id)  -- | A 'ProjectValuation' specialised to 'Set'.-type SetProjectValuation v var =-  ProjectValuation v Set var+type SetProjectValuation p v var =+  ProjectValuation p v Set var
src/Data/Valuation/SemiValuationAlgebra.hs view
@@ -5,6 +5,7 @@ -- | A semi-valuation algebra: a semigroup paired with a projection. module Data.Valuation.SemiValuationAlgebra   ( SemiValuationAlgebra (..),+    SemiValuationAlgebra',     SetSemiValuationAlgebra,      -- * optics@@ -16,6 +17,8 @@   ) where +import Control.Arrow (Arrow (..))+import Control.Category (Category (..)) import Control.Lens   ( Lens,     Lens',@@ -27,6 +30,8 @@ import Data.Functor.Contravariant.Decide (Decide (..)) import Data.Functor.Contravariant.Divise (Divise (..)) import Data.Functor.Contravariant.Divisible (Decidable (..), Divisible (..))+import Data.Profunctor (Profunctor (..), Strong (..))+import Data.Semigroupoid (Semigroupoid) import Data.Set (Set) import Data.Valuation.ProjectValuation   ( HasProjectValuation (..),@@ -38,7 +43,7 @@     applySemigroup,   ) import Witherable (Filterable)-import Prelude hiding (Semigroup)+import Prelude hiding (Semigroup, id, (.)) import qualified Prelude  -- $setup@@ -49,135 +54,138 @@ -- >>> import Prelude hiding (Semigroup)  -- |--- >>> let SemiValuationAlgebra sg (ProjectValuation p) = SemiValuationAlgebra (review applySemigroup (+)) (ProjectValuation (\s v -> v + sum s)) :: SemiValuationAlgebra Int [] Int+-- >>> let SemiValuationAlgebra sg (ProjectValuation p) = SemiValuationAlgebra (review applySemigroup (+)) (ProjectValuation (\s v -> v + sum s)) :: SemiValuationAlgebra (->) Int [] Int -- >>> runSemigroup sg 3 4 -- 7 -- >>> p [1,2,3] 10 -- 16-data SemiValuationAlgebra v set var+data SemiValuationAlgebra p v set var   = SemiValuationAlgebra       -- | algebra combine-      (Semigroup v)+      (Semigroup p v)       -- | algebra project-      (ProjectValuation v set var)+      (ProjectValuation p v set var) +type SemiValuationAlgebra' v set var =+  SemiValuationAlgebra (->) v set var+ -- | Type-changing lens to the 'ProjectValuation' component.-projectValuation' :: Lens (SemiValuationAlgebra v set var) (SemiValuationAlgebra v set' var') (ProjectValuation v set var) (ProjectValuation v set' var')+projectValuation' :: Lens (SemiValuationAlgebra p v set var) (SemiValuationAlgebra p v set' var') (ProjectValuation p v set var) (ProjectValuation p v set' var') projectValuation' f (SemiValuationAlgebra s p) = fmap (SemiValuationAlgebra s) (f p)  -- | Classy lens for types that contain a 'SemiValuationAlgebra'.-class HasSemiValuationAlgebra c v set var | c -> v set var where+class HasSemiValuationAlgebra c p v set var | c -> p v set var where   semiValuationAlgebra ::-    Lens' c (SemiValuationAlgebra v set var)+    Lens' c (SemiValuationAlgebra p v set var) -instance HasSemiValuationAlgebra (SemiValuationAlgebra v set var) v set var where+instance HasSemiValuationAlgebra (SemiValuationAlgebra p v set var) p v set var where   semiValuationAlgebra = id  -- | Classy prism for types that can be constructed from a 'SemiValuationAlgebra'.-class AsSemiValuationAlgebra c v set var | c -> v set var where+class AsSemiValuationAlgebra c p v set var | c -> p v set var where   _SemiValuationAlgebra ::-    Prism' c (SemiValuationAlgebra v set var)+    Prism' c (SemiValuationAlgebra p v set var) -instance AsSemiValuationAlgebra (SemiValuationAlgebra v set var) v set var where+instance AsSemiValuationAlgebra (SemiValuationAlgebra p v set var) p v set var where   _SemiValuationAlgebra = id -instance HasSemigroup (SemiValuationAlgebra v set var) v where+instance HasSemigroup (SemiValuationAlgebra p v set var) p v where   semigroup f (SemiValuationAlgebra s p) = fmap (`SemiValuationAlgebra` p) (f s) -instance HasProjectValuation (SemiValuationAlgebra v set var) v set var where+instance HasProjectValuation (SemiValuationAlgebra p v set var) p v set var where   projectValuation = projectValuation'  -- | -- >>> import Data.Functor.Contravariant (contramap)--- >>> let sva = SemiValuationAlgebra (review applySemigroup (+)) (ProjectValuation (\s v -> v + sum s)) :: SemiValuationAlgebra Int [] Int+-- >>> let sva = SemiValuationAlgebra (review applySemigroup (+)) (ProjectValuation (\s v -> v + sum s)) :: SemiValuationAlgebra (->) Int [] Int -- >>> let SemiValuationAlgebra sg (ProjectValuation p) = contramap (*2) sva -- >>> runSemigroup sg 3 4 -- 7 -- >>> p [1,2,3] 10 -- 22-instance (Functor set) => Contravariant (SemiValuationAlgebra v set) where+instance (Functor set, Profunctor p) => Contravariant (SemiValuationAlgebra p v set) where   contramap f (SemiValuationAlgebra s p) = SemiValuationAlgebra s (contramap f p)  -- | -- >>> import Data.Functor.Contravariant.Divisible (conquer, divide)--- >>> let SemiValuationAlgebra sg (ProjectValuation p) = conquer :: SemiValuationAlgebra [Int] [] Int+-- >>> let SemiValuationAlgebra sg (ProjectValuation p) = conquer :: SemiValuationAlgebra (->) [Int] [] Int -- >>> runSemigroup sg [1,2] [3,4] -- [1,2,3,4] -- >>> p [10,20,30] [42] -- [42] -- -- >>> import Data.Functor.Contravariant.Divisible (conquer, divide)--- >>> let sva1 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ s)) :: SemiValuationAlgebra [Int] [] Int--- >>> let sva2 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ reverse s)) :: SemiValuationAlgebra [Int] [] Int+-- >>> let sva1 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ s)) :: SemiValuationAlgebra (->) [Int] [] Int+-- >>> let sva2 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ reverse s)) :: SemiValuationAlgebra (->) [Int] [] Int -- >>> let SemiValuationAlgebra sg (ProjectValuation p) = divide (\x -> (x, x + 10)) sva1 sva2 -- >>> runSemigroup sg [1] [2] -- [1,2] -- >>> p [1,2,3] [0] -- [0,13,12,11,1,2,3]-instance (Functor set, Prelude.Semigroup v) => Divisible (SemiValuationAlgebra v set) where-  conquer = SemiValuationAlgebra (review applySemigroup (<>)) conquer+instance (Functor set, Strong p, Arrow p, Prelude.Semigroup v) => Divisible (SemiValuationAlgebra p v set) where+  conquer = SemiValuationAlgebra (review applySemigroup (rmap arr (arr (<>)))) conquer   divide f (SemiValuationAlgebra s p1) (SemiValuationAlgebra _ p2) =     SemiValuationAlgebra s (divide f p1 p2)  -- | -- >>> import Data.Functor.Contravariant.Divisible (choose, lose) -- >>> import Data.Void (Void, absurd)--- >>> let SemiValuationAlgebra sg (ProjectValuation p) = lose absurd :: SemiValuationAlgebra [Int] [] Void+-- >>> let SemiValuationAlgebra sg (ProjectValuation p) = lose absurd :: SemiValuationAlgebra (->) [Int] [] Void -- >>> runSemigroup sg [1,2] [3,4] -- [1,2,3,4] -- >>> p [] [42] -- [42] -- -- >>> import Data.Functor.Contravariant.Divisible (choose)--- >>> let sva1 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ s)) :: SemiValuationAlgebra [Int] [] Int--- >>> let sva2 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ map negate s)) :: SemiValuationAlgebra [Int] [] Int+-- >>> let sva1 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ s)) :: SemiValuationAlgebra (->) [Int] [] Int+-- >>> let sva2 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ map negate s)) :: SemiValuationAlgebra (->) [Int] [] Int -- >>> let SemiValuationAlgebra sg (ProjectValuation p) = choose (\x -> if even x then Left x else Right x) sva1 sva2 -- >>> runSemigroup sg [1] [2] -- [1,2] -- >>> p [1,2,3,4] [0] -- [0,-1,-3,2,4]-instance (Filterable set, Prelude.Semigroup v) => Decidable (SemiValuationAlgebra v set) where-  lose f = SemiValuationAlgebra (review applySemigroup (<>)) (lose f)+instance (Filterable set, Strong p, Arrow p, Prelude.Semigroup v) => Decidable (SemiValuationAlgebra p v set) where+  lose f = SemiValuationAlgebra (review applySemigroup (rmap arr (arr (<>)))) (lose f)   choose f (SemiValuationAlgebra s p1) (SemiValuationAlgebra _ p2) =     SemiValuationAlgebra s (choose f p1 p2)  -- | -- >>> import Data.Functor.Contravariant.Divise (divise)--- >>> let sva1 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ s)) :: SemiValuationAlgebra [Int] [] Int--- >>> let sva2 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ reverse s)) :: SemiValuationAlgebra [Int] [] Int+-- >>> let sva1 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ s)) :: SemiValuationAlgebra (->) [Int] [] Int+-- >>> let sva2 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ reverse s)) :: SemiValuationAlgebra (->) [Int] [] Int -- >>> let SemiValuationAlgebra sg (ProjectValuation p) = divise (\x -> (x, x + 10)) sva1 sva2 -- >>> runSemigroup sg [1] [2] -- [1,2] -- >>> p [1,2,3] [0] -- [0,13,12,11,1,2,3]-instance (Functor set) => Divise (SemiValuationAlgebra v set) where+instance (Functor set, Strong p, Semigroupoid p) => Divise (SemiValuationAlgebra p v set) where   divise f (SemiValuationAlgebra s p1) (SemiValuationAlgebra _ p2) =     SemiValuationAlgebra s (divise f p1 p2)  -- | -- >>> import Data.Functor.Contravariant.Decide (decide)--- >>> let sva1 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ s)) :: SemiValuationAlgebra [Int] [] Int--- >>> let sva2 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ map negate s)) :: SemiValuationAlgebra [Int] [] Int+-- >>> let sva1 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ s)) :: SemiValuationAlgebra (->) [Int] [] Int+-- >>> let sva2 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ map negate s)) :: SemiValuationAlgebra (->) [Int] [] Int -- >>> let SemiValuationAlgebra sg (ProjectValuation p) = decide (\x -> if even x then Left x else Right x) sva1 sva2 -- >>> runSemigroup sg [1] [2] -- [1,2] -- >>> p [1,2,3,4] [0] -- [0,-1,-3,2,4]-instance (Filterable set) => Decide (SemiValuationAlgebra v set) where+instance (Filterable set, Strong p, Semigroupoid p) => Decide (SemiValuationAlgebra p v set) where   decide f (SemiValuationAlgebra s p1) (SemiValuationAlgebra _ p2) =     SemiValuationAlgebra s (decide f p1 p2)  -- | -- >>> import Data.Functor.Contravariant.Conclude (conclude) -- >>> import Data.Void (absurd)--- >>> let SemiValuationAlgebra sg (ProjectValuation p) = conclude absurd :: SemiValuationAlgebra [Int] [] Void+-- >>> let SemiValuationAlgebra sg (ProjectValuation p) = conclude absurd :: SemiValuationAlgebra (->) [Int] [] Void -- >>> runSemigroup sg [1,2] [3,4] -- [1,2,3,4] -- >>> p [] [42] -- [42]-instance (Filterable set, Prelude.Semigroup v) => Conclude (SemiValuationAlgebra v set) where-  conclude f = SemiValuationAlgebra (review applySemigroup (<>)) (conclude f)+instance (Filterable set, Strong p, Semigroupoid p, Arrow p, Prelude.Semigroup v) => Conclude (SemiValuationAlgebra p v set) where+  conclude f = SemiValuationAlgebra (review applySemigroup (rmap arr (arr (<>)))) (conclude f)  -- | A 'SemiValuationAlgebra' specialised to 'Set'.-type SetSemiValuationAlgebra v var =-  SemiValuationAlgebra v Set var+type SetSemiValuationAlgebra p v var =+  SemiValuationAlgebra p v Set var
src/Data/Valuation/Semigroup.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeFamilies #-}@@ -7,6 +8,7 @@ -- | First-class semigroup values, independent of the 'Prelude.Semigroup' type class. module Data.Valuation.Semigroup   ( Semigroup (..),+    Semigroup',      -- * optics     HasSemigroup (..),@@ -122,39 +124,42 @@ import qualified Prelude  -- | A first-class semigroup: an associative binary operation on @a@.-newtype Semigroup a-  = Semigroup (a -> a -> a)+newtype Semigroup p a+  = Semigroup (p a (p a a)) -instance (Semigroup a ~ t) => Rewrapped (Semigroup a') t+-- | A 'Semigroup' specialised to @(->)@.+type Semigroup' a = Semigroup (->) a -instance Wrapped (Semigroup a) where-  type Unwrapped (Semigroup a) = a -> a -> a+instance (Semigroup p a ~ t) => Rewrapped (Semigroup p' a') t++instance Wrapped (Semigroup p a) where+  type Unwrapped (Semigroup p a) = p a (p a a)   _Wrapped' = iso (\(Semigroup x) -> x) Semigroup  -- | Classy lens for types that contain a 'Semigroup'.-class HasSemigroup c a | c -> a where-  semigroup :: Lens' c (Semigroup a)+class HasSemigroup c p a | c -> p a where+  semigroup :: Lens' c (Semigroup p a) -instance HasSemigroup (Semigroup a) a where+instance HasSemigroup (Semigroup p a) p a where   semigroup = id  -- | Classy prism for types that can be constructed from a 'Semigroup'.-class AsSemigroup c a | c -> a where-  _Semigroup :: Prism' c (Semigroup a)+class AsSemigroup c p a | c -> p a where+  _Semigroup :: Prism' c (Semigroup p a) -instance AsSemigroup (Semigroup a) a where+instance AsSemigroup (Semigroup p a) p a where   _Semigroup = id  -- | Iso between a 'Semigroup' and its underlying binary operation.-applySemigroup :: Iso (Semigroup a) (Semigroup a') (a -> a -> a) (a' -> a' -> a')+applySemigroup :: Iso (Semigroup p a) (Semigroup p' a') (p a (p a a)) (p' a' (p' a' a')) applySemigroup = _Wrapped  -- | Lens to the underlying binary operation of a 'HasSemigroup'.-applyHasSemigroup :: (HasSemigroup s a) => Lens' s (a -> a -> a)+applyHasSemigroup :: (HasSemigroup s (->) a) => Lens' s (a -> a -> a) applyHasSemigroup = semigroup . applySemigroup  -- | Prism to the underlying binary operation of an 'AsSemigroup'.-applyAsSemigroup :: (AsSemigroup s a) => Prism' s (a -> a -> a)+applyAsSemigroup :: (AsSemigroup s (->) a) => Prism' s (a -> a -> a) applyAsSemigroup = _Semigroup . applySemigroup  -- |@@ -196,7 +201,7 @@ -- -- >>> lawAssociative second (1 :: Int) 2 3 -- True-lawAssociative :: (Eq a) => Semigroup a -> a -> a -> a -> Bool+lawAssociative :: (Eq a) => Semigroup' a -> a -> a -> a -> Bool lawAssociative s a b c =   let f = runSemigroup s    in f (f a b) c == f a (f b c)@@ -204,17 +209,17 @@ -- | -- >>> runSemigroup semigroup' "ab" "cd" :: String -- "abcd"-semigroup' :: (Prelude.Semigroup a) => Semigroup a+semigroup' :: (Prelude.Semigroup a) => Semigroup' a semigroup' = review applySemigroup (<>)  -- | -- >>> runSemigroup sum 3 4 :: Int -- 7-runSemigroup :: Semigroup a -> a -> a -> a+runSemigroup :: Semigroup' a -> a -> a -> a runSemigroup (Semigroup f) = f --- | Map a 'Semigroup' through an isomorphism (unwrap, wrap).-mapSemigroup :: (b -> a) -> (a -> b) -> Semigroup a -> Semigroup b+-- | Map a 'Semigroup'' through an isomorphism (unwrap, wrap).+mapSemigroup :: (b -> a) -> (a -> b) -> Semigroup' a -> Semigroup' b mapSemigroup unwrap wrap s = review applySemigroup (\b1 b2 -> wrap (runSemigroup s (unwrap b1) (unwrap b2)))  -- |@@ -223,13 +228,13 @@ -- -- >>> runSemigroup (liftSemigroup sum) (Just 3) (Just 4) :: Maybe Int -- Just 7-liftSemigroup :: (Applicative f) => Semigroup a -> Semigroup (f a)+liftSemigroup :: (Applicative f) => Semigroup' a -> Semigroup' (f a) liftSemigroup = review applySemigroup . liftA2 . runSemigroup  -- | -- >>> liftRunSemigroup sum [1, 2] [10, 20] :: [Int] -- [11,21,12,22]-liftRunSemigroup :: (Applicative f) => Semigroup a -> f a -> f a -> f a+liftRunSemigroup :: (Applicative f) => Semigroup' a -> f a -> f a -> f a liftRunSemigroup = liftA2 . runSemigroup  -- |@@ -238,7 +243,7 @@ -- -- >>> runSemigroup first "a" "b" -- "a"-first :: Semigroup a+first :: Semigroup' a first = review applySemigroup const  -- |@@ -247,7 +252,7 @@ -- -- >>> runSemigroup second "a" "b" -- "b"-second :: Semigroup a+second :: Semigroup' a second = review applySemigroup (const id)  -- |@@ -256,7 +261,7 @@ -- -- >>> runSemigroup (dual second) 1 2 :: Int -- 1-dual :: Semigroup a -> Semigroup a+dual :: Semigroup' a -> Semigroup' a dual = review applySemigroup . flip . runSemigroup  -- |@@ -265,7 +270,7 @@ -- -- >>> runSemigroup min 5 3 :: Int -- 3-min :: (Ord a) => Semigroup a+min :: (Ord a) => Semigroup' a min = review applySemigroup Prelude.min  -- |@@ -274,7 +279,7 @@ -- -- >>> runSemigroup max 5 3 :: Int -- 5-max :: (Ord a) => Semigroup a+max :: (Ord a) => Semigroup' a max = review applySemigroup Prelude.max  -- |@@ -283,7 +288,7 @@ -- -- >>> runSemigroup sum 0 5 :: Int -- 5-sum :: (Num a) => Semigroup a+sum :: (Num a) => Semigroup' a sum = review applySemigroup (+)  -- |@@ -292,7 +297,7 @@ -- -- >>> runSemigroup product 1 5 :: Int -- 5-product :: (Num a) => Semigroup a+product :: (Num a) => Semigroup' a product = review applySemigroup (*)  -- |@@ -304,7 +309,7 @@ -- -- >>> runSemigroup Data.Valuation.Semigroup.all False False -- False-all :: Semigroup Bool+all :: Semigroup' Bool all = review applySemigroup (&&)  -- |@@ -316,7 +321,7 @@ -- -- >>> runSemigroup Data.Valuation.Semigroup.any False True -- True-any :: Semigroup Bool+any :: Semigroup' Bool any = review applySemigroup (||)  -- |@@ -325,19 +330,19 @@ -- -- >>> runSemigroup endo (*2) (+1) 3 :: Int -- 8-endo :: Semigroup (a -> a)+endo :: Semigroup' (a -> a) endo = review applySemigroup (.)  -- | -- >>> runSemigroup endoDual (+1) (*2) 3 :: Int -- 8-endoDual :: Semigroup (a -> a)+endoDual :: Semigroup' (a -> a) endoDual = dual endo  -- | -- >>> runSemigroup unit () () -- ()-unit :: Semigroup ()+unit :: Semigroup' () unit = review applySemigroup (\() () -> ())  -- |@@ -346,7 +351,7 @@ -- -- >>> runSemigroup (pair min max) (1, 2) (3, 4) :: (Int, Int) -- (1,4)-pair :: Semigroup a -> Semigroup b -> Semigroup (a, b)+pair :: Semigroup' a -> Semigroup' b -> Semigroup' (a, b) pair sa sb = review applySemigroup (\(a1, b1) (a2, b2) -> (runSemigroup sa a1 a2, runSemigroup sb b1 b2))  -- |@@ -361,7 +366,7 @@ -- -- >>> runSemigroup ordering GT LT -- GT-ordering :: Semigroup Ordering+ordering :: Semigroup' Ordering ordering = review applySemigroup (\a b -> if a /= EQ then a else b)  -- |@@ -376,7 +381,7 @@ -- -- >>> runSemigroup (Data.Valuation.Semigroup.maybe sum) Nothing Nothing :: Maybe Int -- Nothing-maybe :: Semigroup a -> Semigroup (Maybe a)+maybe :: Semigroup' a -> Semigroup' (Maybe a) maybe s = review applySemigroup (\a1 a2 -> Prelude.maybe a2 (\a1' -> Prelude.maybe a1 (Just . runSemigroup s a1') a2) a1)  -- |@@ -385,19 +390,19 @@ -- -- >>> runSemigroup list "ab" "cd" -- "abcd"-list :: Semigroup [a]+list :: Semigroup' [a] list = review applySemigroup (<>)  -- | -- >>> runSemigroup nonEmpty (1 :| [2]) (3 :| [4]) :: NonEmpty Int -- 1 :| [2,3,4]-nonEmpty :: Semigroup (NonEmpty a)+nonEmpty :: Semigroup' (NonEmpty a) nonEmpty = review applySemigroup (\(a :| as) (b :| bs) -> a :| (as <> (b : bs)))  -- | -- >>> runSemigroup (io sum) (pure 3) (pure 4) :: IO Int -- 7-io :: Semigroup a -> Semigroup (IO a)+io :: Semigroup' a -> Semigroup' (IO a) io = liftSemigroup  -- |@@ -412,19 +417,19 @@ -- -- >>> runSemigroup Data.Valuation.Semigroup.either (Left "a") (Left "b") :: Either String String -- Left "b"-either :: Semigroup (Either a b)+either :: Semigroup' (Either a b) either = review applySemigroup (\a b -> case a of Right _ -> a; Left _ -> b)  -- | Vacuous semigroup on 'Void'.-void :: Semigroup Void+void :: Semigroup' Void void = review applySemigroup (pure . absurd)  -- | Semigroup on 'ByteArray' via concatenation.-byteArray :: Semigroup ByteArray+byteArray :: Semigroup' ByteArray byteArray = semigroup'  -- | Semigroup on 'Event' via bitwise OR.-event :: Semigroup Event+event :: Semigroup' Event event = semigroup'  -- |@@ -439,7 +444,7 @@ -- >>> let cmp2 = Comparison compare -- >>> getComparison (runSemigroup comparison cmp1 cmp2) 1 2 -- LT-comparison :: Semigroup (Comparison a)+comparison :: Semigroup' (Comparison a) comparison = semigroup'  -- |@@ -454,7 +459,7 @@ -- >>> let eq2 = Equivalence (\a b -> even a == even b) -- >>> getEquivalence (runSemigroup equivalence eq1 eq2) 2 4 -- False-equivalence :: Semigroup (Equivalence a)+equivalence :: Semigroup' (Equivalence a) equivalence = semigroup'  -- |@@ -475,77 +480,77 @@ -- >>> let p2 = Predicate (> 0) -- >>> getPredicate (runSemigroup predicate p1 p2) (-2) -- False-predicate :: Semigroup (Predicate a)+predicate :: Semigroup' (Predicate a) predicate = semigroup'  -- | -- >>> runSemigroup (Data.Valuation.Semigroup.op sum) (+ 1) (+ 2) 10 :: Int -- 23-op :: Semigroup b -> Semigroup (a -> b)+op :: Semigroup' b -> Semigroup' (a -> b) op = liftSemigroup  -- | -- >>> runSemigroup Data.Valuation.Semigroup.and (0xFF :: Int) (0x0F :: Int) :: Int -- 15-and :: (Bits a) => Semigroup a+and :: (Bits a) => Semigroup' a and = review applySemigroup (.&.)  -- | -- >>> runSemigroup ior (0xF0 :: Int) (0x0F :: Int) :: Int -- 255-ior :: (Bits a) => Semigroup a+ior :: (Bits a) => Semigroup' a ior = review applySemigroup (.|.)  -- | -- >>> runSemigroup Data.Valuation.Semigroup.xor (0xFF :: Int) (0x0F :: Int) :: Int -- 240-xor :: (Bits a) => Semigroup a+xor :: (Bits a) => Semigroup' a xor = review applySemigroup Data.Bits.xor  -- | -- >>> import Data.Word (Word8) -- >>> runSemigroup iff (0xFF :: Word8) (0x0F :: Word8) -- 15-iff :: (FiniteBits a) => Semigroup a+iff :: (FiniteBits a) => Semigroup' a iff = review applySemigroup (\a b -> complement (Data.Bits.xor a b))  -- | -- >>> runSemigroup wrappedMonoid "ab" "cd" -- "abcd"-wrappedMonoid :: (Prelude.Monoid a) => Semigroup a+wrappedMonoid :: (Prelude.Monoid a) => Semigroup' a wrappedMonoid = review applySemigroup mappend  -- | -- >>> import Data.Functor.Identity (Identity(..)) -- >>> runSemigroup (identity sum) (Identity 3) (Identity 4) -- Identity 7-identity :: Semigroup a -> Semigroup (Identity a)+identity :: Semigroup' a -> Semigroup' (Identity a) identity = liftSemigroup  -- | -- >>> runSemigroup (down sum) (Down 3) (Down 4) -- Down 7-down :: Semigroup a -> Semigroup (Down a)+down :: Semigroup' a -> Semigroup' (Down a) down = liftSemigroup  -- | -- >>> runSemigroup (dualM sum) (1, 2) (3, 4) :: (Int, Int) -- (4,6)-dualM :: Semigroup a -> Semigroup (a, a)+dualM :: Semigroup' a -> Semigroup' (a, a) dualM s = pair s s  -- | -- >>> runSemigroup (solo sum) (pure 3) (pure 4) :: Solo Int -- MkSolo 7-solo :: Semigroup a -> Semigroup (Solo a)+solo :: Semigroup' a -> Semigroup' (Solo a) solo = liftSemigroup --- | Lift a 'Semigroup' through 'STM'.-stm :: Semigroup a -> Semigroup (STM a)+-- | Lift a 'Semigroup'' through 'STM'.+stm :: Semigroup' a -> Semigroup' (STM a) stm = liftSemigroup --- | Lift a 'Semigroup' through 'ST'.-st :: Semigroup a -> Semigroup (ST s a)+-- | Lift a 'Semigroup'' through 'ST'.+st :: Semigroup' a -> Semigroup' (ST s a) st = liftSemigroup  -- |@@ -554,13 +559,13 @@ -- -- >>> runSemigroup (function list) words lines "hello world" -- ["hello","world","hello world"]-function :: Semigroup b -> Semigroup (a -> b)+function :: Semigroup' b -> Semigroup' (a -> b) function = liftSemigroup  -- | -- >>> runSemigroup (const' sum) (Const 3) (Const 4) :: Const Int String -- Const 7-const' :: Semigroup a -> Semigroup (Const a b)+const' :: Semigroup' a -> Semigroup' (Const a b) const' = mapSemigroup getConst Const  -- |@@ -569,23 +574,23 @@ -- -- >>> runSemigroup alt Nothing (Just 1) :: Maybe Int -- Just 1-alt :: (Alternative f) => Semigroup (f a)+alt :: (Alternative f) => Semigroup' (f a) alt = review applySemigroup (<|>)  -- | -- >>> runSemigroup proxy Proxy Proxy -- Proxy-proxy :: Semigroup (Proxy s)+proxy :: Semigroup' (Proxy s) proxy = review applySemigroup (\_ _ -> Proxy)  -- | Semigroup on 'Lifetime'.-lifetime :: Semigroup Lifetime+lifetime :: Semigroup' Lifetime lifetime = semigroup'  -- | -- >>> runSemigroup (tuple3 sum product min) (1, 2, 3) (4, 5, 6) :: (Int, Int, Int) -- (5,10,3)-tuple3 :: Semigroup a -> Semigroup b -> Semigroup c -> Semigroup (a, b, c)+tuple3 :: Semigroup' a -> Semigroup' b -> Semigroup' c -> Semigroup' (a, b, c) tuple3 sa sb sc =   let f = runSemigroup sa; g = runSemigroup sb; h = runSemigroup sc    in review applySemigroup (\(a1, b1, c1) (a2, b2, c2) -> (f a1 a2, g b1 b2, h c1 c2))@@ -593,7 +598,7 @@ -- | -- >>> runSemigroup (tuple4 sum sum sum sum) (1, 2, 3, 4) (5, 6, 7, 8) :: (Int, Int, Int, Int) -- (6,8,10,12)-tuple4 :: Semigroup a -> Semigroup b -> Semigroup c -> Semigroup d -> Semigroup (a, b, c, d)+tuple4 :: Semigroup' a -> Semigroup' b -> Semigroup' c -> Semigroup' d -> Semigroup' (a, b, c, d) tuple4 sa sb sc sd =   let f = runSemigroup sa; g = runSemigroup sb; h = runSemigroup sc; i = runSemigroup sd    in review applySemigroup (\(a1, b1, c1, d1) (a2, b2, c2, d2) -> (f a1 a2, g b1 b2, h c1 c2, i d1 d2))@@ -601,7 +606,7 @@ -- | -- >>> runSemigroup (tuple5 sum sum sum sum sum) (1, 2, 3, 4, 5) (6, 7, 8, 9, 10) :: (Int, Int, Int, Int, Int) -- (7,9,11,13,15)-tuple5 :: Semigroup a -> Semigroup b -> Semigroup c -> Semigroup d -> Semigroup e -> Semigroup (a, b, c, d, e)+tuple5 :: Semigroup' a -> Semigroup' b -> Semigroup' c -> Semigroup' d -> Semigroup' e -> Semigroup' (a, b, c, d, e) tuple5 sa sb sc sd se =   let f = runSemigroup sa; g = runSemigroup sb; h = runSemigroup sc; i = runSemigroup sd; j = runSemigroup se    in review applySemigroup (\(a1, b1, c1, d1, e1) (a2, b2, c2, d2, e2) -> (f a1 a2, g b1 b2, h c1 c2, i d1 d2, j e1 e2))@@ -609,43 +614,43 @@ -- | -- >>> runSemigroup u1 U1 U1 -- U1-u1 :: Semigroup (U1 p)+u1 :: Semigroup' (U1 p) u1 = review applySemigroup (\_ _ -> U1)  -- | Vacuous semigroup on 'V1' (uninhabited type).-v1 :: Semigroup (V1 p)+v1 :: Semigroup' (V1 p) v1 = review applySemigroup const  -- | -- >>> runSemigroup (par1 sum) (Par1 3) (Par1 4) -- Par1 {unPar1 = 7}-par1 :: Semigroup p -> Semigroup (Par1 p)+par1 :: Semigroup' p -> Semigroup' (Par1 p) par1 = mapSemigroup unPar1 Par1  -- | -- >>> runSemigroup (rec1 list) (Rec1 [1, 2]) (Rec1 [3, 4]) :: Rec1 [] Int -- Rec1 {unRec1 = [1,2,3,4]}-rec1 :: Semigroup (f p) -> Semigroup (Rec1 f p)+rec1 :: Semigroup' (f p) -> Semigroup' (Rec1 f p) rec1 = mapSemigroup unRec1 Rec1  -- | -- >>> runSemigroup (k1 sum) (K1 3) (K1 4) :: K1 () Int () -- K1 {unK1 = 7}-k1 :: Semigroup c -> Semigroup (K1 i c p)+k1 :: Semigroup' c -> Semigroup' (K1 i c p) k1 = mapSemigroup unK1 K1  -- | -- >>> :set -XDataKinds -- >>> runSemigroup (m1 (k1 sum)) (M1 (K1 3)) (M1 (K1 4)) :: M1 () ('GHC.Generics.MetaData "" "" "" 'False) (K1 () Int) () -- M1 {unM1 = K1 {unK1 = 7}}-m1 :: Semigroup (f p) -> Semigroup (M1 i c f p)+m1 :: Semigroup' (f p) -> Semigroup' (M1 i c f p) m1 = mapSemigroup unM1 M1  -- | -- >>> :set -XTypeOperators -- >>> runSemigroup (productG (par1 sum) (par1 product)) (Par1 1 :*: Par1 2) (Par1 3 :*: Par1 4) :: (Par1 :*: Par1) Int -- Par1 {unPar1 = 4} :*: Par1 {unPar1 = 8}-productG :: Semigroup (f p) -> Semigroup (g p) -> Semigroup ((f :*: g) p)+productG :: Semigroup' (f p) -> Semigroup' (g p) -> Semigroup' ((f :*: g) p) productG sf sg =   let f = runSemigroup sf; g = runSemigroup sg    in review applySemigroup (\(a :*: b) (c :*: d) -> f a c :*: g b d)@@ -654,13 +659,13 @@ -- >>> :set -XTypeOperators -- >>> runSemigroup (composeG (par1 list)) (Comp1 (Par1 [1, 2])) (Comp1 (Par1 [3, 4])) :: (Par1 :.: []) Int -- Comp1 {unComp1 = Par1 {unPar1 = [1,2,3,4]}}-composeG :: Semigroup (f (g p)) -> Semigroup ((f :.: g) p)+composeG :: Semigroup' (f (g p)) -> Semigroup' ((f :.: g) p) composeG = mapSemigroup unComp1 Comp1  -- | -- >>> runSemigroup (productF list list) (Pair [1] [2]) (Pair [3] [4]) :: Product [] [] Int -- Pair [1,3] [2,4]-productF :: Semigroup (f a) -> Semigroup (g a) -> Semigroup (Product f g a)+productF :: Semigroup' (f a) -> Semigroup' (g a) -> Semigroup' (Product f g a) productF sf sg =   let f = runSemigroup sf; g = runSemigroup sg    in review applySemigroup (\(Pair a b) (Pair c d) -> Pair (f a c) (g b d))@@ -668,5 +673,5 @@ -- | -- >>> runSemigroup (composeF list) (Compose [[1, 2]]) (Compose [[3, 4]]) :: Compose [] [] Int -- Compose [[1,2],[3,4]]-composeF :: Semigroup (f (g a)) -> Semigroup (Compose f g a)+composeF :: Semigroup' (f (g a)) -> Semigroup' (Compose f g a) composeF = mapSemigroup getCompose Compose
src/Data/Valuation/Valuation.hs view
@@ -50,7 +50,7 @@ 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.Semigroup (Semigroup', applySemigroup, runSemigroup, semigroup') import Data.Valuation.ValuationAlgebra (ValuationAlgebra (..)) import Data.Valuation.ValuationAlgebraOp (ValuationAlgebraOp (..)) import GHC.Generics (Generic, Generic1)@@ -467,15 +467,15 @@     Valuation <$> traverse1 f dom <.> g info  -- |--- >>> let pv = ProjectValuation (\s v -> v + sum s) :: ProjectValuation Int [] Int+-- >>> 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+-- >>> let pv = ProjectValuation (\s v -> v * length s) :: ProjectValuation (->) Int [] Int -- >>> projectVar pv (Valuation [1,2,3] 5) -- 15 projectVar ::-  ProjectValuation v set var ->+  ProjectValuation (->) v set var ->   Valuation set var v ->   v projectVar (ProjectValuation p) (Valuation dom info) =@@ -490,8 +490,8 @@ -- >>> 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 ->+  Semigroup' (set var) ->+  Semigroup' v ->   Valuation set var v ->   Valuation set var v ->   Valuation set var v@@ -501,18 +501,18 @@ -- | -- >>> 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+-- >>> 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+-- >>> 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 ->+  Semigroup' (set var) ->+  SemiValuationAlgebra (->) v set var ->   Valuation set var v ->   Valuation set var v ->   Valuation set var v@@ -525,7 +525,7 @@ -- >>> 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+-- >>> 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 --@@ -533,12 +533,12 @@ -- >>> 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+-- >>> 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 ->+  Semigroup' (set var) ->+  ValuationAlgebra (->) v set var ->   Valuation set var v ->   Valuation set var v ->   Valuation set var v@@ -574,8 +574,8 @@ -- >>> 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)+  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))
src/Data/Valuation/ValuationAlgebra.hs view
@@ -5,6 +5,7 @@ -- | A valuation algebra: a semi-valuation algebra with unit and zero operations. module Data.Valuation.ValuationAlgebra   ( ValuationAlgebra (..),+    ValuationAlgebra',     SetValuationAlgebra,      -- * optics@@ -13,12 +14,16 @@   ) where +import Control.Arrow (Arrow (..))+import Control.Category (Category (..)) import Control.Lens (Lens', Prism') import Data.Functor.Contravariant (Contravariant (..)) import Data.Functor.Contravariant.Conclude (Conclude (..)) import Data.Functor.Contravariant.Decide (Decide (..)) import Data.Functor.Contravariant.Divise (Divise (..)) import Data.Functor.Contravariant.Divisible (Decidable (..), Divisible (..))+import Data.Profunctor (Profunctor (..), Strong (..))+import Data.Semigroupoid (Semigroupoid (..)) import Data.Set (Set) import Data.Valuation.ProjectValuation (HasProjectValuation (..)) import Data.Valuation.SemiValuationAlgebra@@ -28,7 +33,7 @@ import Data.Valuation.Semigroup (HasSemigroup (..)) import Data.Valuation.ValuationAlgebraOp (ValuationAlgebraOp (..)) import Witherable (Filterable (mapMaybe))-import Prelude hiding (Semigroup)+import Prelude hiding (Semigroup, id, (.)) import qualified Prelude  -- $setup@@ -42,7 +47,7 @@ -- >>> import Control.Lens (review) -- >>> import Data.Valuation.Semigroup (Semigroup, applySemigroup, runSemigroup) -- >>> let sva = SemiValuationAlgebra (review applySemigroup (+)) (ProjectValuation (\s v -> v + sum s))--- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp sum) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra Int [] Int+-- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp sum) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra (->) Int [] Int -- >>> let ValuationAlgebra (SemiValuationAlgebra sg (ProjectValuation p)) (ValuationAlgebraOp u) (ValuationAlgebraOp z) = va -- >>> runSemigroup sg 3 4 -- 7@@ -52,41 +57,44 @@ -- 6 -- >>> z [1,2,3] -- 0-data ValuationAlgebra v set var+data ValuationAlgebra p v set var   = ValuationAlgebra-      (SemiValuationAlgebra v set var)+      (SemiValuationAlgebra p v set var)       -- | algebra unit-      (ValuationAlgebraOp set var v)+      (ValuationAlgebraOp p set var v)       -- | algebra zero-      (ValuationAlgebraOp set var v)+      (ValuationAlgebraOp p set var v) +type ValuationAlgebra' v set var =+  ValuationAlgebra (->) v set var+ -- | Classy lens for types that contain a 'ValuationAlgebra'.-class HasValuationAlgebra c v set var | c -> v set var where-  valuationAlgebra :: Lens' c (ValuationAlgebra v set var)-  valuationAlgebraUnit :: Lens' c (ValuationAlgebraOp set var v)+class HasValuationAlgebra c p v set var | c -> p v set var where+  valuationAlgebra :: Lens' c (ValuationAlgebra p v set var)+  valuationAlgebraUnit :: Lens' c (ValuationAlgebraOp p set var v)   valuationAlgebraUnit = valuationAlgebra . valuationAlgebraUnit-  valuationAlgebraZero :: Lens' c (ValuationAlgebraOp set var v)+  valuationAlgebraZero :: Lens' c (ValuationAlgebraOp p set var v)   valuationAlgebraZero = valuationAlgebra . valuationAlgebraZero -instance HasValuationAlgebra (ValuationAlgebra v set var) v set var where+instance HasValuationAlgebra (ValuationAlgebra p v set var) p v set var where   valuationAlgebra = id   valuationAlgebraUnit f (ValuationAlgebra s u z) = fmap (\u' -> ValuationAlgebra s u' z) (f u)   valuationAlgebraZero f (ValuationAlgebra s u z) = fmap (ValuationAlgebra s u) (f z)  -- | Classy prism for types that can be constructed from a 'ValuationAlgebra'.-class AsValuationAlgebra c v set var | c -> v set var where-  _ValuationAlgebra :: Prism' c (ValuationAlgebra v set var)+class AsValuationAlgebra c p v set var | c -> p v set var where+  _ValuationAlgebra :: Prism' c (ValuationAlgebra p v set var) -instance AsValuationAlgebra (ValuationAlgebra v set var) v set var where+instance AsValuationAlgebra (ValuationAlgebra p v set var) p v set var where   _ValuationAlgebra = id -instance HasSemiValuationAlgebra (ValuationAlgebra v set var) v set var where+instance HasSemiValuationAlgebra (ValuationAlgebra p v set var) p v set var where   semiValuationAlgebra f (ValuationAlgebra a u z) = fmap (\a' -> ValuationAlgebra a' u z) (f a) -instance HasSemigroup (ValuationAlgebra v set var) v where+instance HasSemigroup (ValuationAlgebra p v set var) p v where   semigroup = semiValuationAlgebra . semigroup -instance HasProjectValuation (ValuationAlgebra v set var) v set var where+instance HasProjectValuation (ValuationAlgebra p v set var) p v set var where   projectValuation = semiValuationAlgebra . projectValuation  -- |@@ -97,7 +105,7 @@ -- >>> import Control.Lens (review) -- >>> import Data.Valuation.Semigroup (Semigroup, applySemigroup, runSemigroup) -- >>> let sva = SemiValuationAlgebra (review applySemigroup (+)) (ProjectValuation (\s v -> v + sum s))--- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp sum) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra Int [] Int+-- >>> let va = ValuationAlgebra sva (ValuationAlgebraOp sum) (ValuationAlgebraOp (const 0)) :: ValuationAlgebra (->) Int [] Int -- >>> let ValuationAlgebra (SemiValuationAlgebra sg (ProjectValuation p)) (ValuationAlgebraOp u) (ValuationAlgebraOp z) = contramap (*2) va -- >>> runSemigroup sg 3 4 -- 7@@ -107,9 +115,9 @@ -- 12 -- >>> z [1,2,3] -- 0-instance (Functor set) => Contravariant (ValuationAlgebra v set) where+instance (Profunctor p, Functor set) => Contravariant (ValuationAlgebra p v set) where   contramap f (ValuationAlgebra s (ValuationAlgebraOp u) (ValuationAlgebraOp z)) =-    ValuationAlgebra (contramap f s) (ValuationAlgebraOp (u . fmap f)) (ValuationAlgebraOp (z . fmap f))+    ValuationAlgebra (contramap f s) (ValuationAlgebraOp (lmap (fmap f) u)) (ValuationAlgebraOp (lmap (fmap f) z))  -- | -- >>> import Data.Functor.Contravariant.Divisible (conquer, divide)@@ -118,7 +126,7 @@ -- >>> import Data.Valuation.ValuationAlgebraOp (ValuationAlgebraOp(..)) -- >>> import Control.Lens (review) -- >>> import Data.Valuation.Semigroup (Semigroup, applySemigroup, runSemigroup)--- >>> let ValuationAlgebra (SemiValuationAlgebra sg (ProjectValuation p)) (ValuationAlgebraOp u) (ValuationAlgebraOp z) = conquer :: ValuationAlgebra [Int] [] Int+-- >>> let ValuationAlgebra (SemiValuationAlgebra sg (ProjectValuation p)) (ValuationAlgebraOp u) (ValuationAlgebraOp z) = conquer :: ValuationAlgebra (->) [Int] [] Int -- >>> runSemigroup sg [1] [2] -- [1,2] -- >>> p [10,20] [42]@@ -135,9 +143,9 @@ -- >>> import Control.Lens (review) -- >>> import Data.Valuation.Semigroup (Semigroup, applySemigroup, runSemigroup) -- >>> let sva1 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ s))--- >>> let va1 = ValuationAlgebra sva1 (ValuationAlgebraOp id) (ValuationAlgebraOp (map negate)) :: ValuationAlgebra [Int] [] Int+-- >>> let va1 = ValuationAlgebra sva1 (ValuationAlgebraOp id) (ValuationAlgebraOp (map negate)) :: ValuationAlgebra (->) [Int] [] Int -- >>> let sva2 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ reverse s))--- >>> let va2 = ValuationAlgebra sva2 (ValuationAlgebraOp reverse) (ValuationAlgebraOp (const [])) :: ValuationAlgebra [Int] [] Int+-- >>> let va2 = ValuationAlgebra sva2 (ValuationAlgebraOp reverse) (ValuationAlgebraOp (const [])) :: ValuationAlgebra (->) [Int] [] Int -- >>> let ValuationAlgebra (SemiValuationAlgebra sg (ProjectValuation p)) (ValuationAlgebraOp u) (ValuationAlgebraOp z) = divide (\x -> (x, x + 10)) va1 va2 -- >>> runSemigroup sg [1] [2] -- [1,2]@@ -145,10 +153,13 @@ -- [1,2,3,13,12,11] -- >>> z [1,2,3] -- [-1,-2,-3]-instance (Functor set, Prelude.Semigroup v, Prelude.Monoid v) => Divisible (ValuationAlgebra v set) where-  conquer = ValuationAlgebra conquer (ValuationAlgebraOp (const mempty)) (ValuationAlgebraOp (const mempty))+instance (Functor set, Strong p, Arrow p, Prelude.Semigroup v, Prelude.Monoid v) => Divisible (ValuationAlgebra p v set) where+  conquer = ValuationAlgebra conquer (ValuationAlgebraOp (rmap (const mempty) id)) (ValuationAlgebraOp (rmap (const mempty) id))   divide f (ValuationAlgebra s1 (ValuationAlgebraOp u1) (ValuationAlgebraOp z1)) (ValuationAlgebra s2 (ValuationAlgebraOp u2) (ValuationAlgebraOp z2)) =-    let combine g1 g2 = ValuationAlgebraOp (\fa -> g1 (fmap (fst . f) fa) <> g2 (fmap (snd . f) fa))+    let combine g1 g2 =+          let g1' = lmap (fmap (fst . f)) g1+              g2' = lmap (fmap (snd . f)) g2+           in ValuationAlgebraOp (lmap (\x -> (x, x)) (rmap (uncurry (<>)) (second' g2' . first' g1')))      in ValuationAlgebra (divide f s1 s2) (combine u1 u2) (combine z1 z2)  -- |@@ -159,7 +170,7 @@ -- >>> import Data.Valuation.ValuationAlgebraOp (ValuationAlgebraOp(..)) -- >>> import Control.Lens (review) -- >>> import Data.Valuation.Semigroup (Semigroup, applySemigroup, runSemigroup)--- >>> let ValuationAlgebra (SemiValuationAlgebra sg (ProjectValuation p)) (ValuationAlgebraOp u) (ValuationAlgebraOp z) = lose absurd :: ValuationAlgebra [Int] [] Void+-- >>> let ValuationAlgebra (SemiValuationAlgebra sg (ProjectValuation p)) (ValuationAlgebraOp u) (ValuationAlgebraOp z) = lose absurd :: ValuationAlgebra (->) [Int] [] Void -- >>> runSemigroup sg [1] [2] -- [1,2] -- >>> p [] [42]@@ -176,9 +187,9 @@ -- >>> import Control.Lens (review) -- >>> import Data.Valuation.Semigroup (Semigroup, applySemigroup, runSemigroup) -- >>> let sva1 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ s))--- >>> let va1 = ValuationAlgebra sva1 (ValuationAlgebraOp id) (ValuationAlgebraOp (map negate)) :: ValuationAlgebra [Int] [] Int+-- >>> let va1 = ValuationAlgebra sva1 (ValuationAlgebraOp id) (ValuationAlgebraOp (map negate)) :: ValuationAlgebra (->) [Int] [] Int -- >>> let sva2 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ reverse s))--- >>> let va2 = ValuationAlgebra sva2 (ValuationAlgebraOp reverse) (ValuationAlgebraOp (const [])) :: ValuationAlgebra [Int] [] Int+-- >>> let va2 = ValuationAlgebra sva2 (ValuationAlgebraOp reverse) (ValuationAlgebraOp (const [])) :: ValuationAlgebra (->) [Int] [] Int -- >>> let ValuationAlgebra (SemiValuationAlgebra sg (ProjectValuation p)) (ValuationAlgebraOp u) (ValuationAlgebraOp z) = choose (\x -> if even x then Left x else Right x) va1 va2 -- >>> runSemigroup sg [1] [2] -- [1,2]@@ -186,12 +197,15 @@ -- [2,4,3,1] -- >>> z [1,2,3,4] -- [-2,-4]-instance (Filterable set, Prelude.Semigroup v, Prelude.Monoid v) => Decidable (ValuationAlgebra v set) where-  lose f = ValuationAlgebra (lose f) (ValuationAlgebraOp (const mempty)) (ValuationAlgebraOp (const mempty))+instance (Filterable set, Strong p, Arrow p, Prelude.Semigroup v, Prelude.Monoid v) => Decidable (ValuationAlgebra p v set) where+  lose f = ValuationAlgebra (lose f) (ValuationAlgebraOp (rmap (const mempty) id)) (ValuationAlgebraOp (rmap (const mempty) id))   choose ch (ValuationAlgebra s1 (ValuationAlgebraOp u1) (ValuationAlgebraOp z1)) (ValuationAlgebra s2 (ValuationAlgebraOp u2) (ValuationAlgebraOp z2)) =     let lefts = mapMaybe (either Just (const Nothing) . ch)         rights = mapMaybe (either (const Nothing) Just . ch)-        combine g1 g2 = ValuationAlgebraOp (\fa -> g1 (lefts fa) <> g2 (rights fa))+        combine g1 g2 =+          let g1' = lmap lefts g1+              g2' = lmap rights g2+           in ValuationAlgebraOp (lmap (\x -> (x, x)) (rmap (uncurry (<>)) (second' g2' . first' g1')))      in ValuationAlgebra (choose ch s1 s2) (combine u1 u2) (combine z1 z2)  -- |@@ -202,9 +216,9 @@ -- >>> import Control.Lens (review) -- >>> import Data.Valuation.Semigroup (Semigroup, applySemigroup, runSemigroup) -- >>> let sva1 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ s))--- >>> let va1 = ValuationAlgebra sva1 (ValuationAlgebraOp id) (ValuationAlgebraOp (map negate)) :: ValuationAlgebra [Int] [] Int+-- >>> let va1 = ValuationAlgebra sva1 (ValuationAlgebraOp id) (ValuationAlgebraOp (map negate)) :: ValuationAlgebra (->) [Int] [] Int -- >>> let sva2 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ reverse s))--- >>> let va2 = ValuationAlgebra sva2 (ValuationAlgebraOp reverse) (ValuationAlgebraOp (const [])) :: ValuationAlgebra [Int] [] Int+-- >>> let va2 = ValuationAlgebra sva2 (ValuationAlgebraOp reverse) (ValuationAlgebraOp (const [])) :: ValuationAlgebra (->) [Int] [] Int -- >>> let ValuationAlgebra (SemiValuationAlgebra sg (ProjectValuation p)) (ValuationAlgebraOp u) (ValuationAlgebraOp z) = divise (\x -> (x, x + 10)) va1 va2 -- >>> runSemigroup sg [1] [2] -- [1,2]@@ -212,9 +226,12 @@ -- [1,2,3,13,12,11] -- >>> z [1,2,3] -- [-1,-2,-3]-instance (Functor set, Prelude.Semigroup v) => Divise (ValuationAlgebra v set) where+instance (Functor set, Strong p, Semigroupoid p, Prelude.Semigroup v) => Divise (ValuationAlgebra p v set) where   divise f (ValuationAlgebra s1 (ValuationAlgebraOp u1) (ValuationAlgebraOp z1)) (ValuationAlgebra s2 (ValuationAlgebraOp u2) (ValuationAlgebraOp z2)) =-    let combine g1 g2 = ValuationAlgebraOp (\fa -> g1 (fmap (fst . f) fa) <> g2 (fmap (snd . f) fa))+    let combine g1 g2 =+          let g1' = lmap (fmap (fst . f)) g1+              g2' = lmap (fmap (snd . f)) g2+           in ValuationAlgebraOp (lmap (\x -> (x, x)) (rmap (uncurry (<>)) (second' g2' `o` first' g1')))      in ValuationAlgebra (divise f s1 s2) (combine u1 u2) (combine z1 z2)  -- |@@ -225,9 +242,9 @@ -- >>> import Control.Lens (review) -- >>> import Data.Valuation.Semigroup (Semigroup, applySemigroup, runSemigroup) -- >>> let sva1 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ s))--- >>> let va1 = ValuationAlgebra sva1 (ValuationAlgebraOp id) (ValuationAlgebraOp (map negate)) :: ValuationAlgebra [Int] [] Int+-- >>> let va1 = ValuationAlgebra sva1 (ValuationAlgebraOp id) (ValuationAlgebraOp (map negate)) :: ValuationAlgebra (->) [Int] [] Int -- >>> let sva2 = SemiValuationAlgebra (review applySemigroup (++)) (ProjectValuation (\s v -> v ++ reverse s))--- >>> let va2 = ValuationAlgebra sva2 (ValuationAlgebraOp reverse) (ValuationAlgebraOp (const [])) :: ValuationAlgebra [Int] [] Int+-- >>> let va2 = ValuationAlgebra sva2 (ValuationAlgebraOp reverse) (ValuationAlgebraOp (const [])) :: ValuationAlgebra (->) [Int] [] Int -- >>> let ValuationAlgebra (SemiValuationAlgebra sg (ProjectValuation p)) (ValuationAlgebraOp u) (ValuationAlgebraOp z) = decide (\x -> if even x then Left x else Right x) va1 va2 -- >>> runSemigroup sg [1] [2] -- [1,2]@@ -235,11 +252,14 @@ -- [2,4,3,1] -- >>> z [1,2,3,4] -- [-2,-4]-instance (Filterable set, Prelude.Semigroup v) => Decide (ValuationAlgebra v set) where+instance (Filterable set, Strong p, Semigroupoid p, Prelude.Semigroup v) => Decide (ValuationAlgebra p v set) where   decide ch (ValuationAlgebra s1 (ValuationAlgebraOp u1) (ValuationAlgebraOp z1)) (ValuationAlgebra s2 (ValuationAlgebraOp u2) (ValuationAlgebraOp z2)) =     let lefts = mapMaybe (either Just (const Nothing) . ch)         rights = mapMaybe (either (const Nothing) Just . ch)-        combine g1 g2 = ValuationAlgebraOp (\fa -> g1 (lefts fa) <> g2 (rights fa))+        combine g1 g2 =+          let g1' = lmap lefts g1+              g2' = lmap rights g2+           in ValuationAlgebraOp (lmap (\x -> (x, x)) (rmap (uncurry (<>)) (second' g2' `o` first' g1')))      in ValuationAlgebra (decide ch s1 s2) (combine u1 u2) (combine z1 z2)  -- |@@ -250,16 +270,16 @@ -- >>> import Data.Valuation.ValuationAlgebraOp (ValuationAlgebraOp(..)) -- >>> import Control.Lens (review) -- >>> import Data.Valuation.Semigroup (Semigroup, applySemigroup, runSemigroup)--- >>> let ValuationAlgebra (SemiValuationAlgebra sg (ProjectValuation p)) (ValuationAlgebraOp u) (ValuationAlgebraOp z) = conclude absurd :: ValuationAlgebra [Int] [] Void+-- >>> let ValuationAlgebra (SemiValuationAlgebra sg (ProjectValuation p)) (ValuationAlgebraOp u) (ValuationAlgebraOp z) = conclude absurd :: ValuationAlgebra (->) [Int] [] Void -- >>> runSemigroup sg [1] [2] -- [1,2] -- >>> u [] -- [] -- >>> z [] -- []-instance (Filterable set, Prelude.Semigroup v, Prelude.Monoid v) => Conclude (ValuationAlgebra v set) where-  conclude f = ValuationAlgebra (conclude f) (ValuationAlgebraOp (const mempty)) (ValuationAlgebraOp (const mempty))+instance (Filterable set, Strong p, Semigroupoid p, Arrow p, Prelude.Semigroup v, Prelude.Monoid v) => Conclude (ValuationAlgebra p v set) where+  conclude f = ValuationAlgebra (conclude f) (ValuationAlgebraOp (rmap (const mempty) id)) (ValuationAlgebraOp (rmap (const mempty) id))  -- | A 'ValuationAlgebra' specialised to 'Set'.-type SetValuationAlgebra v var =-  ValuationAlgebra v Set var+type SetValuationAlgebra p v var =+  ValuationAlgebra p v Set var
src/Data/Valuation/ValuationAlgebraOp.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeFamilies #-}@@ -7,6 +8,7 @@ -- | An operation on a valuation algebra, a function from a set of variables to a value. module Data.Valuation.ValuationAlgebraOp   ( ValuationAlgebraOp (..),+    ValuationAlgebraOp',      -- * optics     HasValuationAlgebraOp (..),@@ -36,7 +38,7 @@ import Control.Monad.Fix (MonadFix (..)) import Control.Monad.Reader.Class (MonadReader (..)) import Control.Monad.Zip (MonadZip (..))-import Control.Selective (Selective (..), selectM)+import Control.Selective (Selective (..)) import Data.Distributive (Distributive (..)) import Data.Either (fromLeft, fromRight) import Data.Function (fix)@@ -52,7 +54,6 @@ import Data.Valuation.Semigroup   ( Semigroup,     applySemigroup,-    runSemigroup,   ) import Prelude hiding (Semigroup, id, (.)) import qualified Prelude@@ -61,152 +62,161 @@ -- >>> :set -Wno-name-shadowing -Wno-type-defaults  -- | A function from a set of variables to a value. Isomorphic to @set var -> v@.-newtype ValuationAlgebraOp set var v-  = ValuationAlgebraOp (set var -> v)+newtype ValuationAlgebraOp p set var v+  = ValuationAlgebraOp (p (set var) v) -instance (ValuationAlgebraOp set var v ~ t) => Rewrapped (ValuationAlgebraOp set' var' v') t+type ValuationAlgebraOp' set var v =+  ValuationAlgebraOp (->) set var v -instance Wrapped (ValuationAlgebraOp set var v) where-  type Unwrapped (ValuationAlgebraOp set var v) = set var -> v+instance (ValuationAlgebraOp p set var v ~ t) => Rewrapped (ValuationAlgebraOp p' set' var' v') t++instance Wrapped (ValuationAlgebraOp p set var v) where+  type Unwrapped (ValuationAlgebraOp p set var v) = p (set var) v   _Wrapped' =     iso (\(ValuationAlgebraOp x) -> x) ValuationAlgebraOp  -- | Classy lens for types that contain a 'ValuationAlgebraOp'.-class HasValuationAlgebraOp c set var v | c -> set var v where+class HasValuationAlgebraOp c p set var v | c -> p set var v where   valuationAlgebraOp ::-    Lens' c (ValuationAlgebraOp set var v)+    Lens' c (ValuationAlgebraOp p set var v) -instance HasValuationAlgebraOp (ValuationAlgebraOp set var v) set var v where-  valuationAlgebraOp = id+instance HasValuationAlgebraOp (ValuationAlgebraOp p set var v) p set var v where+  valuationAlgebraOp = Prelude.id  -- | Classy prism for types that can be constructed from a 'ValuationAlgebraOp'.-class AsValuationAlgebraOp c set var v | c -> set var v where+class AsValuationAlgebraOp c p set var v | c -> p set var v where   _ValuationAlgebraOp ::-    Prism' c (ValuationAlgebraOp set var v)+    Prism' c (ValuationAlgebraOp p set var v) -instance AsValuationAlgebraOp (ValuationAlgebraOp set var v) set var v where-  _ValuationAlgebraOp = id+instance AsValuationAlgebraOp (ValuationAlgebraOp p set var v) p set var v where+  _ValuationAlgebraOp = Prelude.id  -- | Iso between a 'ValuationAlgebraOp' producing an endomorphism and a 'ProjectValuation'.-valuationAlgebraOpProjectValuation :: Iso (ValuationAlgebraOp set var (v -> v)) (ValuationAlgebraOp set' var' (v' -> v')) (ProjectValuation v set var) (ProjectValuation v' set' var')+valuationAlgebraOpProjectValuation :: Iso (ValuationAlgebraOp p set var (p v v)) (ValuationAlgebraOp p' set' var' (p' v' v')) (ProjectValuation p v set var) (ProjectValuation p' v' set' var') valuationAlgebraOpProjectValuation =   iso     (\(ValuationAlgebraOp k) -> ProjectValuation k)     (\(ProjectValuation k) -> ValuationAlgebraOp k)  -- | Lens to the underlying function of a 'HasValuationAlgebraOp'.-applyHasValuationAlgebraOp :: (HasValuationAlgebraOp op set var v) => Lens' op (set var -> v)+applyHasValuationAlgebraOp :: (HasValuationAlgebraOp op p set var v) => Lens' op (p (set var) v) applyHasValuationAlgebraOp = valuationAlgebraOp . _Wrapped  -- | Prism to the underlying function of an 'AsValuationAlgebraOp'.-applyAsValuationAlgebraOp :: (AsValuationAlgebraOp op set var v) => Prism' op (set var -> v)+applyAsValuationAlgebraOp :: (AsValuationAlgebraOp op p set var v) => Prism' op (p (set var) v) applyAsValuationAlgebraOp = _ValuationAlgebraOp . _Wrapped  -- |--- >>> let ValuationAlgebraOp f = fmap (*2) (ValuationAlgebraOp sum :: ValuationAlgebraOp [] Int Int)+-- >>> let ValuationAlgebraOp f = fmap (*2) (ValuationAlgebraOp sum :: ValuationAlgebraOp (->) [] Int Int) -- >>> f [1,2,3] -- 12-instance Functor (ValuationAlgebraOp set a) where-  fmap f (ValuationAlgebraOp g) = ValuationAlgebraOp (f . g)+instance (Profunctor p) => Functor (ValuationAlgebraOp p set a) where+  fmap f (ValuationAlgebraOp g) = ValuationAlgebraOp (rmap f g)  -- | -- >>> import Data.Functor.Apply ((<.>))--- >>> let ValuationAlgebraOp f = (ValuationAlgebraOp (\s -> (+ sum s)) :: ValuationAlgebraOp [] Int (Int -> Int)) <.> ValuationAlgebraOp product+-- >>> let ValuationAlgebraOp f = (ValuationAlgebraOp (\s -> (+ sum s)) :: ValuationAlgebraOp (->) [] Int (Int -> Int)) <.> ValuationAlgebraOp product -- >>> f [1,2,3] -- 12-instance Apply (ValuationAlgebraOp set a) where-  ValuationAlgebraOp f <.> ValuationAlgebraOp g = ValuationAlgebraOp (\sa -> f sa (g sa))+instance (Strong p, Semigroupoid p) => Apply (ValuationAlgebraOp p set a) where+  ValuationAlgebraOp f <.> ValuationAlgebraOp g = ValuationAlgebraOp (lmap (\x -> (x, x)) (rmap (uncurry ($)) (second' g `o` first' f)))  -- |--- >>> let ValuationAlgebraOp f = pure 42 :: ValuationAlgebraOp [] Int Int+-- >>> let ValuationAlgebraOp f = pure 42 :: ValuationAlgebraOp (->) [] Int Int -- >>> f [1,2,3] -- 42 ----- >>> let ValuationAlgebraOp f = (ValuationAlgebraOp (\s -> (+ sum s)) :: ValuationAlgebraOp [] Int (Int -> Int)) <*> ValuationAlgebraOp product+-- >>> let ValuationAlgebraOp f = (ValuationAlgebraOp (\s -> (+ sum s)) :: ValuationAlgebraOp (->) [] Int (Int -> Int)) <*> ValuationAlgebraOp product -- >>> f [1,2,3] -- 12-instance Applicative (ValuationAlgebraOp set a) where-  pure b = ValuationAlgebraOp (const b)+instance (Strong p, Semigroupoid p, Category p) => Applicative (ValuationAlgebraOp p set a) where+  pure b = ValuationAlgebraOp (rmap (const b) id)   (<*>) = (<.>)  -- | -- >>> import Data.Functor.Bind ((>>-))--- >>> let ValuationAlgebraOp f = (ValuationAlgebraOp sum :: ValuationAlgebraOp [] Int Int) >>- (\n -> ValuationAlgebraOp (\s -> n + product s))+-- >>> let ValuationAlgebraOp f = (ValuationAlgebraOp sum :: ValuationAlgebraOp (->) [] Int Int) >>- (\n -> ValuationAlgebraOp (\s -> n + product s)) -- >>> f [1,2,3] -- 12-instance Bind (ValuationAlgebraOp set a) where-  ValuationAlgebraOp f >>- k = ValuationAlgebraOp (\sa -> let ValuationAlgebraOp g = k (f sa) in g sa)+instance (Strong p, Semigroupoid p, Bind (p (set a))) => Bind (ValuationAlgebraOp p set a) where+  ValuationAlgebraOp f >>- k = ValuationAlgebraOp (f >>- (\b -> let ValuationAlgebraOp g = k b in g))  -- |--- >>> let ValuationAlgebraOp f = (ValuationAlgebraOp sum :: ValuationAlgebraOp [] Int Int) >>= (\n -> ValuationAlgebraOp (\s -> n * length s))+-- >>> let ValuationAlgebraOp f = (ValuationAlgebraOp sum :: ValuationAlgebraOp (->) [] Int Int) >>= (\n -> ValuationAlgebraOp (\s -> n * length s)) -- >>> f [1,2,3] -- 18 ----- >>> let ValuationAlgebraOp f = return 42 :: ValuationAlgebraOp [] Int Int+-- >>> let ValuationAlgebraOp f = return 42 :: ValuationAlgebraOp (->) [] Int Int -- >>> f [1,2,3] -- 42-instance Monad (ValuationAlgebraOp set a) where+instance Monad (ValuationAlgebraOp (->) set a) where   (>>=) = (>>-)  -- | -- >>> import Data.Semigroupoid (o) -- >>> import Data.List.NonEmpty (NonEmpty(..))--- >>> let ValuationAlgebraOp f = o (ValuationAlgebraOp sum :: ValuationAlgebraOp NonEmpty Int Int) (ValuationAlgebraOp sum)+-- >>> let ValuationAlgebraOp f = o (ValuationAlgebraOp sum :: ValuationAlgebraOp (->) NonEmpty Int Int) (ValuationAlgebraOp sum) -- >>> f (1 :| [2, 3]) -- 14-instance (Extend set) => Semigroupoid (ValuationAlgebraOp set) where-  o (ValuationAlgebraOp g) (ValuationAlgebraOp f) = ValuationAlgebraOp (g . extended f)+instance (Closed p, Strong p, Semigroupoid p, Extend set) => Semigroupoid (ValuationAlgebraOp p set) where+  o (ValuationAlgebraOp g) (ValuationAlgebraOp f) =+    let step = rmap extended (lmap (const id) (closed f))+        ext = lmap (\x -> (x, x)) (rmap (\(h, x) -> h x) (first' step))+     in ValuationAlgebraOp (g `o` ext)  -- | -- >>> import Control.Category (id, (.)) -- >>> import Data.List.NonEmpty (NonEmpty(..))--- >>> let ValuationAlgebraOp f = id :: ValuationAlgebraOp NonEmpty Int Int+-- >>> let ValuationAlgebraOp f = id :: ValuationAlgebraOp (->) NonEmpty Int Int -- >>> f (1 :| [2, 3]) -- 1 -- -- >>> import Control.Category ((.)) -- >>> import Data.List.NonEmpty (NonEmpty(..))--- >>> let ValuationAlgebraOp f = (ValuationAlgebraOp sum :: ValuationAlgebraOp NonEmpty Int Int) . ValuationAlgebraOp sum+-- >>> let ValuationAlgebraOp f = (ValuationAlgebraOp sum :: ValuationAlgebraOp (->) NonEmpty Int Int) . ValuationAlgebraOp sum -- >>> f (1 :| [2, 3]) -- 14-instance (Comonad set) => Category (ValuationAlgebraOp set) where-  id = ValuationAlgebraOp extract-  ValuationAlgebraOp g . ValuationAlgebraOp f = ValuationAlgebraOp (g . extend f)+instance (Closed p, Strong p, Category p, Comonad set) => Category (ValuationAlgebraOp p set) where+  id = ValuationAlgebraOp (rmap extract id)+  ValuationAlgebraOp g . ValuationAlgebraOp f =+    let step = rmap extend (lmap (const id) (closed f))+        ext = lmap (\x -> (x, x)) (rmap (\(h, x) -> h x) (first' step))+     in ValuationAlgebraOp (g . ext)  -- | -- >>> import Control.Arrow (arr, first) -- >>> import Data.List.NonEmpty (NonEmpty(..))--- >>> let ValuationAlgebraOp f = arr (*2) :: ValuationAlgebraOp NonEmpty Int Int+-- >>> let ValuationAlgebraOp f = arr (*2) :: ValuationAlgebraOp (->) NonEmpty Int Int -- >>> f (3 :| [4, 5]) -- 6 -- -- >>> import Control.Arrow (first) -- >>> import Data.List.NonEmpty (NonEmpty(..))--- >>> let ValuationAlgebraOp f = first (ValuationAlgebraOp sum :: ValuationAlgebraOp NonEmpty Int Int)+-- >>> let ValuationAlgebraOp f = first (ValuationAlgebraOp sum :: ValuationAlgebraOp (->) NonEmpty Int Int) -- >>> f ((1, "a") :| [(2, "b"), (3, "c")]) -- (6,"a")-instance (Comonad set) => Arrow (ValuationAlgebraOp set) where-  arr f = ValuationAlgebraOp (f . extract)+instance (Closed p, Strong p, Category p, Comonad set) => Arrow (ValuationAlgebraOp p set) where+  arr f = ValuationAlgebraOp (rmap (f . extract) id)   first = first'  -- | -- >>> import Control.Arrow (left) -- >>> import Data.List.NonEmpty (NonEmpty(..))--- >>> let ValuationAlgebraOp f = left (ValuationAlgebraOp sum :: ValuationAlgebraOp NonEmpty Int Int)+-- >>> let ValuationAlgebraOp f = left (ValuationAlgebraOp sum :: ValuationAlgebraOp (->) NonEmpty Int Int) -- >>> f (Left 1 :| [Left 2, Left 3]) -- Left 6 -- >>> f (Right "hi" :| [Left 2]) -- Right "hi"-instance (Comonad set) => ArrowChoice (ValuationAlgebraOp set) where+instance (Closed p, Strong p, Choice p, Category p, Comonad set) => ArrowChoice (ValuationAlgebraOp p set) where   left = left'  -- | -- >>> import Control.Arrow (app) -- >>> import Data.List.NonEmpty (NonEmpty(..))--- >>> let ValuationAlgebraOp f = app :: ValuationAlgebraOp NonEmpty (ValuationAlgebraOp NonEmpty Int Int, Int) Int+-- >>> let ValuationAlgebraOp f = app :: ValuationAlgebraOp (->) NonEmpty (ValuationAlgebraOp (->) NonEmpty Int Int, Int) Int -- >>> f ((ValuationAlgebraOp sum, 99) :| [(ValuationAlgebraOp product, 1)]) -- 100-instance (Comonad set) => ArrowApply (ValuationAlgebraOp set) where+instance (Comonad set) => ArrowApply (ValuationAlgebraOp (->) set) where   app = ValuationAlgebraOp $ \wpair ->     let (ValuationAlgebraOp f, _) = extract wpair      in f (fmap snd wpair)@@ -214,91 +224,92 @@ -- | -- >>> import Control.Arrow (loop) -- >>> import Data.Functor.Identity (Identity(..))--- >>> let ValuationAlgebraOp f = loop (ValuationAlgebraOp (\(Identity (b, _)) -> (b * 2, 0))) :: ValuationAlgebraOp Identity Int Int+-- >>> let ValuationAlgebraOp f = loop (ValuationAlgebraOp (\(Identity (b, _)) -> (b * 2, 0))) :: ValuationAlgebraOp (->) Identity Int Int -- >>> f (Identity 3) -- 6-instance (ComonadApply set) => ArrowLoop (ValuationAlgebraOp set) where+instance (ComonadApply set) => ArrowLoop (ValuationAlgebraOp (->) set) where   loop (ValuationAlgebraOp f) = ValuationAlgebraOp $ \wa ->     fst . extract $ fix $ \wbd -> extend f ((,) <$> wa <@> fmap snd wbd)  -- | -- >>> import Control.Monad.Fix (mfix)--- >>> let ValuationAlgebraOp f = mfix (\x -> ValuationAlgebraOp (\s -> const 42 x + sum s)) :: ValuationAlgebraOp [] Int Int+-- >>> let ValuationAlgebraOp f = mfix (\x -> ValuationAlgebraOp (\s -> const 42 x + sum s)) :: ValuationAlgebraOp (->) [] Int Int -- >>> f [1,2,3] -- 48-instance MonadFix (ValuationAlgebraOp set var) where+instance MonadFix (ValuationAlgebraOp (->) set var) where   mfix f = ValuationAlgebraOp (\s -> fix (\a -> let ValuationAlgebraOp g = f a in g s))  -- | -- >>> import Control.Monad.Zip (mzipWith)--- >>> let ValuationAlgebraOp f = mzipWith (+) (ValuationAlgebraOp sum) (ValuationAlgebraOp product :: ValuationAlgebraOp [] Int Int)+-- >>> let ValuationAlgebraOp f = mzipWith (+) (ValuationAlgebraOp sum) (ValuationAlgebraOp product :: ValuationAlgebraOp (->) [] Int Int) -- >>> f [1,2,3] -- 12-instance MonadZip (ValuationAlgebraOp set var) where+instance MonadZip (ValuationAlgebraOp (->) set var) where   mzipWith f (ValuationAlgebraOp g) (ValuationAlgebraOp h) = ValuationAlgebraOp (\s -> f (g s) (h s))  -- | -- >>> import Control.Selective (select)--- >>> let ValuationAlgebraOp f = select (ValuationAlgebraOp (\s -> Left (sum s)) :: ValuationAlgebraOp [] Int (Either Int Int)) (ValuationAlgebraOp (\_ -> (+10)))+-- >>> let ValuationAlgebraOp f = select (ValuationAlgebraOp (\s -> Left (sum s)) :: ValuationAlgebraOp (->) [] Int (Either Int Int)) (ValuationAlgebraOp (\_ -> (+10))) -- >>> f [1,2,3] -- 16-instance Selective (ValuationAlgebraOp set var) where-  select = selectM+instance (Strong p, Semigroupoid p, Category p) => Selective (ValuationAlgebraOp p set var) where+  select (ValuationAlgebraOp feab) (ValuationAlgebraOp fab) =+    ValuationAlgebraOp (lmap (\x -> (x, x)) (rmap (\(eab, f) -> either f Prelude.id eab) (second' fab . first' feab)))  -- | -- >>> import Control.Monad.Reader.Class (ask, local)--- >>> let ValuationAlgebraOp f = ask :: ValuationAlgebraOp [] Int [Int]+-- >>> let ValuationAlgebraOp f = ask :: ValuationAlgebraOp (->) [] Int [Int] -- >>> f [1,2,3] -- [1,2,3] -- -- >>> import Control.Monad.Reader.Class (ask, local)--- >>> let ValuationAlgebraOp f = local (map (*2)) (ValuationAlgebraOp sum :: ValuationAlgebraOp [] Int Int)+-- >>> let ValuationAlgebraOp f = local (map (*2)) (ValuationAlgebraOp sum :: ValuationAlgebraOp (->) [] Int Int) -- >>> f [1,2,3] -- 12-instance MonadReader (set var) (ValuationAlgebraOp set var) where-  ask = ValuationAlgebraOp id+instance MonadReader (set var) (ValuationAlgebraOp (->) set var) where+  ask = ValuationAlgebraOp Prelude.id   local f (ValuationAlgebraOp g) = ValuationAlgebraOp (g . f)  -- | -- >>> import Data.Profunctor (dimap, lmap, rmap)--- >>> let ValuationAlgebraOp f = dimap (+1) (*2) (ValuationAlgebraOp sum :: ValuationAlgebraOp [] Int Int)+-- >>> let ValuationAlgebraOp f = dimap (+1) (*2) (ValuationAlgebraOp sum :: ValuationAlgebraOp (->) [] Int Int) -- >>> f [1,2,3] -- 18 -- -- >>> import Data.Profunctor (lmap)--- >>> let ValuationAlgebraOp f = lmap (*10) (ValuationAlgebraOp sum :: ValuationAlgebraOp [] Int Int)+-- >>> let ValuationAlgebraOp f = lmap (*10) (ValuationAlgebraOp sum :: ValuationAlgebraOp (->) [] Int Int) -- >>> f [1,2,3] -- 60 -- -- >>> import Data.Profunctor (rmap)--- >>> let ValuationAlgebraOp f = rmap show (ValuationAlgebraOp sum :: ValuationAlgebraOp [] Int Int)+-- >>> let ValuationAlgebraOp f = rmap show (ValuationAlgebraOp sum :: ValuationAlgebraOp (->) [] Int Int) -- >>> f [1,2,3] -- "6"-instance (Functor set) => Profunctor (ValuationAlgebraOp set) where-  dimap f g (ValuationAlgebraOp h) = ValuationAlgebraOp (g . h . fmap f)-  lmap f (ValuationAlgebraOp h) = ValuationAlgebraOp (h . fmap f)-  rmap g (ValuationAlgebraOp h) = ValuationAlgebraOp (g . h)+instance (Functor set, Profunctor p) => Profunctor (ValuationAlgebraOp p set) where+  dimap f g (ValuationAlgebraOp h) = ValuationAlgebraOp (dimap (fmap f) g h)+  lmap f (ValuationAlgebraOp h) = ValuationAlgebraOp (lmap (fmap f) h)+  rmap g (ValuationAlgebraOp h) = ValuationAlgebraOp (rmap g h)  -- | -- >>> import Data.Profunctor (Strong(..)) -- >>> import Data.List.NonEmpty (NonEmpty(..))--- >>> let ValuationAlgebraOp f = first' (ValuationAlgebraOp sum :: ValuationAlgebraOp NonEmpty Int Int)+-- >>> let ValuationAlgebraOp f = first' (ValuationAlgebraOp sum :: ValuationAlgebraOp (->) NonEmpty Int Int) -- >>> f ((1, "a") :| [(2, "b"), (3, "c")]) -- (6,"a") -- -- >>> import Data.Profunctor (Strong(..)) -- >>> import Data.List.NonEmpty (NonEmpty(..))--- >>> let ValuationAlgebraOp f = second' (ValuationAlgebraOp sum :: ValuationAlgebraOp NonEmpty Int Int)+-- >>> let ValuationAlgebraOp f = second' (ValuationAlgebraOp sum :: ValuationAlgebraOp (->) NonEmpty Int Int) -- >>> f (("a", 1) :| [("b", 2), ("c", 3)]) -- ("a",6)-instance (Comonad set) => Strong (ValuationAlgebraOp set) where-  first' (ValuationAlgebraOp f) = ValuationAlgebraOp (\sac -> (f (fmap fst sac), snd (extract sac)))-  second' (ValuationAlgebraOp f) = ValuationAlgebraOp (\sca -> (fst (extract sca), f (fmap snd sca)))+instance (Comonad set, Strong p) => Strong (ValuationAlgebraOp p set) where+  first' (ValuationAlgebraOp f) = ValuationAlgebraOp (lmap (\s -> (fmap fst s, snd (extract s))) (first' f))+  second' (ValuationAlgebraOp f) = ValuationAlgebraOp (lmap (\s -> (fst (extract s), fmap snd s)) (second' f))  -- | -- >>> import Data.Profunctor (Choice(..)) -- >>> import Data.List.NonEmpty (NonEmpty(..))--- >>> let ValuationAlgebraOp f = left' (ValuationAlgebraOp sum :: ValuationAlgebraOp NonEmpty Int Int)+-- >>> let ValuationAlgebraOp f = left' (ValuationAlgebraOp sum :: ValuationAlgebraOp (->) NonEmpty Int Int) -- >>> f (Left 1 :| [Left 2, Left 3]) -- Left 6 -- >>> f (Right "hi" :| [Left 2])@@ -306,68 +317,80 @@ -- -- >>> import Data.Profunctor (Choice(..)) -- >>> import Data.List.NonEmpty (NonEmpty(..))--- >>> let ValuationAlgebraOp f = right' (ValuationAlgebraOp sum :: ValuationAlgebraOp NonEmpty Int Int)+-- >>> let ValuationAlgebraOp f = right' (ValuationAlgebraOp sum :: ValuationAlgebraOp (->) NonEmpty Int Int) -- >>> f (Right 1 :| [Right 2, Right 3]) -- Right 6 -- >>> f (Left "hi" :| [Right 2]) -- Left "hi"-instance (Comonad set) => Choice (ValuationAlgebraOp set) where-  left' (ValuationAlgebraOp f) = ValuationAlgebraOp $ \seac ->-    case extract seac of-      Left a -> Left (f (fmap (fromLeft a) seac))-      Right c -> Right c-  right' (ValuationAlgebraOp f) = ValuationAlgebraOp $ \seca ->-    case extract seca of-      Right a -> Right (f (fmap (fromRight a) seca))-      Left c -> Left c+instance (Comonad set, Choice p) => Choice (ValuationAlgebraOp p set) where+  left' (ValuationAlgebraOp f) =+    ValuationAlgebraOp $+      lmap+        ( \s -> case extract s of+            Left a -> Left (fmap (fromLeft a) s)+            Right c -> Right c+        )+        (left' f)+  right' (ValuationAlgebraOp f) =+    ValuationAlgebraOp $+      lmap+        ( \s -> case extract s of+            Right a -> Right (fmap (fromRight a) s)+            Left c -> Left c+        )+        (right' f)  -- | -- >>> import Data.Profunctor.Closed (Closed(..))--- >>> let ValuationAlgebraOp f = closed (ValuationAlgebraOp sum :: ValuationAlgebraOp [] Int Int)+-- >>> let ValuationAlgebraOp f = closed (ValuationAlgebraOp sum :: ValuationAlgebraOp (->) [] Int Int) -- >>> f [(*2), (*3)] 10 -- 50-instance (Functor set) => Closed (ValuationAlgebraOp set) where-  closed (ValuationAlgebraOp f) = ValuationAlgebraOp (\sxa x -> f (fmap ($ x) sxa))+instance (Functor set, Closed p) => Closed (ValuationAlgebraOp p set) where+  closed (ValuationAlgebraOp f) = ValuationAlgebraOp (lmap distribute (closed f))  -- | -- >>> import Data.Profunctor.Sieve (Cosieve(..))--- >>> cosieve (ValuationAlgebraOp sum :: ValuationAlgebraOp [] Int Int) [1,2,3]+-- >>> cosieve (ValuationAlgebraOp sum :: ValuationAlgebraOp (->) [] Int Int) [1,2,3] -- 6-instance (Functor set) => Cosieve (ValuationAlgebraOp set) set where+instance (Functor set) => Cosieve (ValuationAlgebraOp (->) set) set where   cosieve (ValuationAlgebraOp f) = f  -- | -- >>> import Data.Distributive (distribute)--- >>> let ValuationAlgebraOp f = distribute [ValuationAlgebraOp sum, ValuationAlgebraOp product] :: ValuationAlgebraOp [] Int [Int]+-- >>> let ValuationAlgebraOp f = distribute [ValuationAlgebraOp sum, ValuationAlgebraOp product] :: ValuationAlgebraOp (->) [] Int [Int] -- >>> f [1,2,3] -- [6,6]-instance Distributive (ValuationAlgebraOp set var) where+instance Distributive (ValuationAlgebraOp (->) set var) where   distribute fs = ValuationAlgebraOp (\s -> fmap (\(ValuationAlgebraOp g) -> g s) fs)  -- | -- >>> import Data.Functor.Rep (tabulate, index)--- >>> let vao = tabulate (\s -> sum s * 2) :: ValuationAlgebraOp [] Int Int+-- >>> let vao = tabulate (\s -> sum s * 2) :: ValuationAlgebraOp (->) [] Int Int -- >>> index vao [1,2,3] -- 12-instance Representable (ValuationAlgebraOp set var) where-  type Rep (ValuationAlgebraOp set var) = set var+instance Representable (ValuationAlgebraOp (->) set var) where+  type Rep (ValuationAlgebraOp (->) set var) = set var   tabulate = ValuationAlgebraOp   index (ValuationAlgebraOp f) = f  -- |--- >>> let ValuationAlgebraOp f = runSemigroup semigroupValuationAlgebraOp (ValuationAlgebraOp (const "hello")) (ValuationAlgebraOp (const " world") :: ValuationAlgebraOp [] Int String) in f []+-- >>> import Data.Valuation.Semigroup (runSemigroup)+-- >>> let ValuationAlgebraOp f = runSemigroup semigroupValuationAlgebraOp (ValuationAlgebraOp (const "hello")) (ValuationAlgebraOp (const " world") :: ValuationAlgebraOp (->) [] Int String) in f [] -- "hello world"-semigroupValuationAlgebraOp :: (Prelude.Semigroup v) => Semigroup (ValuationAlgebraOp set var v)-semigroupValuationAlgebraOp = review applySemigroup (\(ValuationAlgebraOp f) (ValuationAlgebraOp g) -> ValuationAlgebraOp (\s -> f s <> g s))+semigroupValuationAlgebraOp :: (Arrow p, Prelude.Semigroup v) => Semigroup p (ValuationAlgebraOp p set var v)+semigroupValuationAlgebraOp =+  let combine f g = arr (uncurry (Prelude.<>)) . (f *** g) . arr (\x -> (x, x))+   in review applySemigroup (arr (\(ValuationAlgebraOp f) -> arr (\(ValuationAlgebraOp g) -> ValuationAlgebraOp (combine f g))))  -- |--- >>> let ValuationAlgebraOp f = ValuationAlgebraOp (const "hello") <> (ValuationAlgebraOp (const " world") :: ValuationAlgebraOp [] Int String) in f []+-- >>> let ValuationAlgebraOp f = ValuationAlgebraOp (const "hello") <> (ValuationAlgebraOp (const " world") :: ValuationAlgebraOp (->) [] Int String) in f [] -- "hello world"-instance (Prelude.Semigroup v) => Prelude.Semigroup (ValuationAlgebraOp set var v) where-  (<>) = runSemigroup semigroupValuationAlgebraOp+instance (Strong p, Semigroupoid p, Prelude.Semigroup v) => Prelude.Semigroup (ValuationAlgebraOp p set var v) where+  ValuationAlgebraOp f <> ValuationAlgebraOp g =+    ValuationAlgebraOp (lmap (\x -> (x, x)) (rmap (uncurry (Prelude.<>)) (second' g `o` first' f)))  -- |--- >>> let ValuationAlgebraOp f = mempty :: ValuationAlgebraOp [] Int String in f [1,2,3]+-- >>> let ValuationAlgebraOp f = mempty :: ValuationAlgebraOp (->) [] Int String in f [1,2,3] -- ""-instance (Prelude.Monoid v) => Prelude.Monoid (ValuationAlgebraOp set var v) where-  mempty = ValuationAlgebraOp (const mempty)+instance (Prelude.Monoid v) => Prelude.Monoid (ValuationAlgebraOp (->) set var v) where+  mempty = ValuationAlgebraOp (const Prelude.mempty)
valuations.cabal view
@@ -1,5 +1,5 @@ name:                 valuations-version:              0.0.2+version:              0.0.3 synopsis:             Valuations description:          Valuations: Valuation and Valuation Algebra license:              BSD3