ProjectValuation.hs

{-# 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 (..),
    SetProjectValuation,

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

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

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.Set (Set)
import Data.Valuation.Semigroup
  ( Semigroup,
    applySemigroup,
    runSemigroup,
  )
import Witherable (Filterable (mapMaybe))
import Prelude hiding (Semigroup)
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 v set var
  = ProjectValuation (set var -> v -> v)

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

instance Wrapped (ProjectValuation v set var) where
  type Unwrapped (ProjectValuation v set var) = set var -> 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)

instance HasProjectValuation (ProjectValuation v set var) 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)

instance AsProjectValuation (ProjectValuation v set var) 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 = projectValuation . _Wrapped

-- | Prism to the underlying function of an 'AsProjectValuation'.
applyAsProjectValuation :: (AsProjectValuation pv v set var) => Prism' pv (set var -> 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) => Contravariant (ProjectValuation v set) where
  contramap f (ProjectValuation g) = ProjectValuation (g . fmap f)

-- |
-- >>> 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) => Divisible (ProjectValuation v set) where
  conquer = ProjectValuation (const id)
  divide split (ProjectValuation pb) (ProjectValuation pc) =
    ProjectValuation (\fa v -> pb (fmap (fst . split) fa) (pc (fmap (snd . split) fa) v))

-- |
-- >>> 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) => Decidable (ProjectValuation v set) where
  lose _ = ProjectValuation (const 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)
      )

-- |
-- >>> 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) => Divise (ProjectValuation v set) where
  divise = divide

-- |
-- >>> 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) => Decide (ProjectValuation v set) where
  decide = choose

-- |
-- >>> 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) => Conclude (ProjectValuation v set) where
  conclude _ = ProjectValuation (const 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 v var =
  ProjectValuation v Set var