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

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

-- | A projection function that updates a value given a set of variables.
module Data.Valuation.ProjectValuation
  ( ProjectValuation (..),
    ProjectValuation',
    SetProjectValuation,

    -- * optics
    HasProjectValuation (..),
    AsProjectValuation (..),

    -- * combinators
    semigroupProjectValuation,
    applyHasProjectValuation,
    applyAsProjectValuation,
  )
where

import Control.Category (Category (..))
import Control.Lens
  ( Lens',
    Prism',
    Rewrapped,
    Wrapped (..),
    iso,
    review,
    _Wrapped,
  )
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.Semigroup
  ( Semigroup',
    applySemigroup,
    runSemigroup,
  )
import Witherable (Filterable (mapMaybe))
import Prelude hiding (Semigroup, id, (.))
import qualified Prelude

-- $setup
-- >>> :set -Wno-name-shadowing -Wno-type-defaults
-- >>> import Data.Void (Void)

-- |
-- >>> let ProjectValuation f = ProjectValuation (\s v -> v + sum s) in f [1,2,3] (10 :: Int)
-- 16
--
-- >>> let ProjectValuation f = ProjectValuation (\s v -> v + length s) in f [1,2,3] (10 :: Int)
-- 13
newtype ProjectValuation p v set var
  = ProjectValuation (p (set var) (p v v))

type ProjectValuation' v set var =
  ProjectValuation (->) v set var

instance
  (ProjectValuation p v set var ~ t) =>
  Rewrapped (ProjectValuation p' v' set' var') t

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 p v set var | c -> p v set var where
  projectValuation :: Lens' c (ProjectValuation p v set var)

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 p v set var | c -> p v set var where
  _ProjectValuation :: Prism' c (ProjectValuation p v set var)

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 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 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 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 ProjectValuation f = contramap negate pv in f [1,2,3] 0
-- -6
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
-- 42
--
-- >>> import Data.Functor.Contravariant.Divisible (conquer, divide)
-- >>> 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 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 ProjectValuation f = divide (\x -> (x, x)) pvB pvC in f [1,2,3] 5
-- 21
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) =
    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
-- 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 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 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 ProjectValuation f = choose Right pvB pvC in f [1,2,3] 10
-- 30
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) =
    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 ProjectValuation f = divise (\x -> (x, x * 10)) pvB pvC in f [1,2,3] 5
-- 21
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 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, 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
-- 42
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 = 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 ProjectValuation f = p1 <> p2 in f [1,2,3] 5
-- 21
instance Prelude.Semigroup (ProjectValuation (->) v set var) where
  (<>) = runSemigroup semigroupProjectValuation

-- |
-- >>> 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
  mempty = ProjectValuation (const id)

-- | A 'ProjectValuation' specialised to 'Set'.
type SetProjectValuation p v var =
  ProjectValuation p v Set var