{-# LANGUAGE
    CPP,
    DeriveFunctor,
    DerivingVia,
    FlexibleInstances,
    FunctionalDependencies,
    QuantifiedConstraints,
    ScopedTypeVariables
  #-}

module Data.Mapping where

#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)
#else
import Control.Applicative (liftA2)
#endif
import Prelude hiding (not, (&&), (||))
import Data.Algebra.Boolean (Boolean(..))
import Data.Function (on)
import Data.Functor.Const (Const(..))
import Data.Functor.Identity (Identity(..))
import Data.Monoid (All(..))
import Data.PartialOrd
import Data.Set (Set)
import qualified Data.Set as S
import Data.Void (Void)


-- | If @Mapping k m@, then @m v@ represents a function @k -> v@.
--
-- `Mapping` requires an instance of `Foldable`, folding over the
-- values that appear. Given that a value can be associated with a
-- very large collection of keys, the only folds that normally make
-- sense are those over idempotent monoids.
class Foldable m => Mapping k m | m -> k where
  cst :: v -> m v

  act :: m v -> k -> v

  isConst :: Ord v => m v -> Maybe v

  mtraverse :: (Applicative f, Ord v) => (u -> f v) -> m u -> f (m v)

  mmap :: Ord v => (u -> v) -> m u -> m v
  mmap u -> v
p = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (m :: * -> *) (f :: * -> *) v u.
(Mapping k m, Applicative f, Ord v) =>
(u -> f v) -> m u -> f (m v)
mtraverse (forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. u -> v
p)

  mergeA :: (Applicative f, Ord w) => (u -> v -> f w) -> m u -> m v -> f (m w)

  merge :: Ord w => (u -> v -> w) -> m u -> m v -> m w
  merge u -> v -> w
p m u
m m v
n = let
    q :: u -> v -> Identity w
q u
x v
y = forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ u -> v -> w
p u
x v
y
    in forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall k (m :: * -> *) (f :: * -> *) w u v.
(Mapping k m, Applicative f, Ord w) =>
(u -> v -> f w) -> m u -> m v -> f (m w)
mergeA u -> v -> Identity w
q m u
m m v
n


-- | A simultaneous foldMap over two maps
pairMappings :: forall k m u v a. (Mapping k m, Monoid a) => (u -> v -> a) -> m u -> m v -> a
pairMappings :: forall k (m :: * -> *) u v a.
(Mapping k m, Monoid a) =>
(u -> v -> a) -> m u -> m v -> a
pairMappings u -> v -> a
p m u
m m v
n = let
  q :: u -> v -> Const a Void
  q :: u -> v -> Const a Void
q u
x v
y = forall {k} a (b :: k). a -> Const a b
Const forall a b. (a -> b) -> a -> b
$ u -> v -> a
p u
x v
y
  in forall {k} a (b :: k). Const a b -> a
getConst (forall k (m :: * -> *) (f :: * -> *) w u v.
(Mapping k m, Applicative f, Ord w) =>
(u -> v -> f w) -> m u -> m v -> f (m w)
mergeA u -> v -> Const a Void
q m u
m m v
n)

-- | What values can these two take simultaneously?
mutualValues :: (Ord u, Ord v, Mapping k m) => m u -> m v -> Set (u, v)
mutualValues :: forall u v k (m :: * -> *).
(Ord u, Ord v, Mapping k m) =>
m u -> m v -> Set (u, v)
mutualValues = forall k (m :: * -> *) u v a.
(Mapping k m, Monoid a) =>
(u -> v -> a) -> m u -> m v -> a
pairMappings forall a b. (a -> b) -> a -> b
$ forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall a. a -> Set a
S.singleton



-- | A class representing data structures which have a concept of neighbouring
-- values
class Neighbourly m where
  neighbours :: Ord v => m v -> Set (v, v)


-- | A wrapper for representing pointwise algebraic structures on a Mapping
--
-- Eventually would like to use this only for "deriving via"
newtype AlgebraWrapper k m a = AlgebraWrapper { forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
AlgebraWrapper k m a -> m a
algebraUnwrap :: m a }

instance (Mapping k m, Ord a, Semigroup a) => Semigroup (AlgebraWrapper k m a) where
  <> :: AlgebraWrapper k m a
-> AlgebraWrapper k m a -> AlgebraWrapper k m a
(<>) = (forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
m a -> AlgebraWrapper k m a
AlgebraWrapper .) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (m :: * -> *) w u v.
(Mapping k m, Ord w) =>
(u -> v -> w) -> m u -> m v -> m w
merge forall a. Semigroup a => a -> a -> a
(<>) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
AlgebraWrapper k m a -> m a
algebraUnwrap

instance (Mapping k m, Ord a, Monoid a) => Monoid (AlgebraWrapper k m a) where
  mempty :: AlgebraWrapper k m a
mempty = forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
m a -> AlgebraWrapper k m a
AlgebraWrapper forall a b. (a -> b) -> a -> b
$ forall k (m :: * -> *) v. Mapping k m => v -> m v
cst forall a. Monoid a => a
mempty

instance (Mapping k m, Ord a, Num a) => Num (AlgebraWrapper k m a) where
  + :: AlgebraWrapper k m a
-> AlgebraWrapper k m a -> AlgebraWrapper k m a
(+) =  (forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
m a -> AlgebraWrapper k m a
AlgebraWrapper .) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (m :: * -> *) w u v.
(Mapping k m, Ord w) =>
(u -> v -> w) -> m u -> m v -> m w
merge forall a. Num a => a -> a -> a
(+) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
AlgebraWrapper k m a -> m a
algebraUnwrap
  (-) =  (forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
m a -> AlgebraWrapper k m a
AlgebraWrapper .) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (m :: * -> *) w u v.
(Mapping k m, Ord w) =>
(u -> v -> w) -> m u -> m v -> m w
merge (-) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
AlgebraWrapper k m a -> m a
algebraUnwrap
  * :: AlgebraWrapper k m a
-> AlgebraWrapper k m a -> AlgebraWrapper k m a
(*) =  (forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
m a -> AlgebraWrapper k m a
AlgebraWrapper .) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (m :: * -> *) w u v.
(Mapping k m, Ord w) =>
(u -> v -> w) -> m u -> m v -> m w
merge forall a. Num a => a -> a -> a
(*) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
AlgebraWrapper k m a -> m a
algebraUnwrap
  fromInteger :: Integer -> AlgebraWrapper k m a
fromInteger = forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
m a -> AlgebraWrapper k m a
AlgebraWrapper forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (m :: * -> *) v. Mapping k m => v -> m v
cst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger
  abs :: AlgebraWrapper k m a -> AlgebraWrapper k m a
abs = forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
m a -> AlgebraWrapper k m a
AlgebraWrapper forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (m :: * -> *) v u.
(Mapping k m, Ord v) =>
(u -> v) -> m u -> m v
mmap forall a. Num a => a -> a
abs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
AlgebraWrapper k m a -> m a
algebraUnwrap
  negate :: AlgebraWrapper k m a -> AlgebraWrapper k m a
negate = forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
m a -> AlgebraWrapper k m a
AlgebraWrapper forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (m :: * -> *) v u.
(Mapping k m, Ord v) =>
(u -> v) -> m u -> m v
mmap forall a. Num a => a -> a
negate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
AlgebraWrapper k m a -> m a
algebraUnwrap
  signum :: AlgebraWrapper k m a -> AlgebraWrapper k m a
signum = forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
m a -> AlgebraWrapper k m a
AlgebraWrapper forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (m :: * -> *) v u.
(Mapping k m, Ord v) =>
(u -> v) -> m u -> m v
mmap forall a. Num a => a -> a
signum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
AlgebraWrapper k m a -> m a
algebraUnwrap

instance (Mapping k m, Ord a, Boolean a) => Boolean (AlgebraWrapper k m a) where
  true :: AlgebraWrapper k m a
true = forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
m a -> AlgebraWrapper k m a
AlgebraWrapper forall a b. (a -> b) -> a -> b
$ forall k (m :: * -> *) v. Mapping k m => v -> m v
cst forall b. Boolean b => b
true
  false :: AlgebraWrapper k m a
false = forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
m a -> AlgebraWrapper k m a
AlgebraWrapper forall a b. (a -> b) -> a -> b
$ forall k (m :: * -> *) v. Mapping k m => v -> m v
cst forall b. Boolean b => b
false
  not :: AlgebraWrapper k m a -> AlgebraWrapper k m a
not = forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
m a -> AlgebraWrapper k m a
AlgebraWrapper forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (m :: * -> *) v u.
(Mapping k m, Ord v) =>
(u -> v) -> m u -> m v
mmap forall b. Boolean b => b -> b
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
AlgebraWrapper k m a -> m a
algebraUnwrap
  && :: AlgebraWrapper k m a
-> AlgebraWrapper k m a -> AlgebraWrapper k m a
(&&) = (forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
m a -> AlgebraWrapper k m a
AlgebraWrapper .) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (m :: * -> *) w u v.
(Mapping k m, Ord w) =>
(u -> v -> w) -> m u -> m v -> m w
merge forall b. Boolean b => b -> b -> b
(&&) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
AlgebraWrapper k m a -> m a
algebraUnwrap
  || :: AlgebraWrapper k m a
-> AlgebraWrapper k m a -> AlgebraWrapper k m a
(||) = (forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
m a -> AlgebraWrapper k m a
AlgebraWrapper .) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (m :: * -> *) w u v.
(Mapping k m, Ord w) =>
(u -> v -> w) -> m u -> m v -> m w
merge forall b. Boolean b => b -> b -> b
(||) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
AlgebraWrapper k m a -> m a
algebraUnwrap
  xor :: AlgebraWrapper k m a
-> AlgebraWrapper k m a -> AlgebraWrapper k m a
xor = (forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
m a -> AlgebraWrapper k m a
AlgebraWrapper .) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (m :: * -> *) w u v.
(Mapping k m, Ord w) =>
(u -> v -> w) -> m u -> m v -> m w
merge forall b. Boolean b => b -> b -> b
xor forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
AlgebraWrapper k m a -> m a
algebraUnwrap
  --> :: AlgebraWrapper k m a
-> AlgebraWrapper k m a -> AlgebraWrapper k m a
(-->) = (forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
m a -> AlgebraWrapper k m a
AlgebraWrapper .) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (m :: * -> *) w u v.
(Mapping k m, Ord w) =>
(u -> v -> w) -> m u -> m v -> m w
merge forall b. Boolean b => b -> b -> b
(-->) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
AlgebraWrapper k m a -> m a
algebraUnwrap
  <--> :: AlgebraWrapper k m a
-> AlgebraWrapper k m a -> AlgebraWrapper k m a
(<-->) = (forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
m a -> AlgebraWrapper k m a
AlgebraWrapper .) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (m :: * -> *) w u v.
(Mapping k m, Ord w) =>
(u -> v -> w) -> m u -> m v -> m w
merge forall b. Boolean b => b -> b -> b
(<-->) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall {k} {k} (k :: k) (m :: k -> *) (a :: k).
AlgebraWrapper k m a -> m a
algebraUnwrap


-- | Constant functions (on any domain)
newtype Constant k v = Constant { forall {k} (k :: k) v. Constant k v -> v
constantValue :: v }

instance Foldable (Constant k) where
  foldMap :: forall m a. Monoid m => (a -> m) -> Constant k a -> m
foldMap a -> m
f (Constant a
a) = a -> m
f a
a

instance Mapping k (Constant k) where
  cst :: forall v. v -> Constant k v
cst = forall {k} (k :: k) v. v -> Constant k v
Constant
  act :: forall v. Constant k v -> k -> v
act (Constant v
x) k
_ = v
x
  mmap :: forall v u. Ord v => (u -> v) -> Constant k u -> Constant k v
mmap u -> v
f (Constant u
x) = forall {k} (k :: k) v. v -> Constant k v
Constant forall a b. (a -> b) -> a -> b
$ u -> v
f u
x
  mtraverse :: forall (f :: * -> *) v u.
(Applicative f, Ord v) =>
(u -> f v) -> Constant k u -> f (Constant k v)
mtraverse u -> f v
f (Constant u
x) = forall {k} (k :: k) v. v -> Constant k v
Constant forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> u -> f v
f u
x
  isConst :: forall v. Ord v => Constant k v -> Maybe v
isConst (Constant v
x) = forall a. a -> Maybe a
Just v
x
  merge :: forall w u v.
Ord w =>
(u -> v -> w) -> Constant k u -> Constant k v -> Constant k w
merge u -> v -> w
f (Constant u
x) (Constant v
y) = forall {k} (k :: k) v. v -> Constant k v
Constant forall a b. (a -> b) -> a -> b
$ u -> v -> w
f u
x v
y
  mergeA :: forall (f :: * -> *) w u v.
(Applicative f, Ord w) =>
(u -> v -> f w) -> Constant k u -> Constant k v -> f (Constant k w)
mergeA u -> v -> f w
f (Constant u
x) (Constant v
y) = forall {k} (k :: k) v. v -> Constant k v
Constant forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> u -> v -> f w
f u
x v
y

instance Neighbourly (Constant k) where
  neighbours :: forall v. Ord v => Constant k v -> Set (v, v)
neighbours = forall a b. a -> b -> a
const forall a. Set a
S.empty

{-
deriving via (AlgebraWrapper k (Constant k) v)
  instance (Ord v, Semigroup v) => Semigroup (Constant k v)

deriving via (AlgebraWrapper k (Constant k) v)
  instance (Ord v, Monoid v) => Monoid (Constant k v)

deriving via (AlgebraWrapper k (Constant k) v)
  instance (Ord v, Num v) => Num (Constant k v)
-}


-- | Binary decisions, as functions defined on Bool
data OnBool a = OnBool {
  forall a. OnBool a -> a
onFalse :: a,
  forall a. OnBool a -> a
onTrue :: a
} deriving (OnBool a -> OnBool a -> Bool
forall a. Eq a => OnBool a -> OnBool a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OnBool a -> OnBool a -> Bool
$c/= :: forall a. Eq a => OnBool a -> OnBool a -> Bool
== :: OnBool a -> OnBool a -> Bool
$c== :: forall a. Eq a => OnBool a -> OnBool a -> Bool
Eq, OnBool a -> OnBool a -> Bool
OnBool a -> OnBool a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (OnBool a)
forall a. Ord a => OnBool a -> OnBool a -> Bool
forall a. Ord a => OnBool a -> OnBool a -> Ordering
forall a. Ord a => OnBool a -> OnBool a -> OnBool a
min :: OnBool a -> OnBool a -> OnBool a
$cmin :: forall a. Ord a => OnBool a -> OnBool a -> OnBool a
max :: OnBool a -> OnBool a -> OnBool a
$cmax :: forall a. Ord a => OnBool a -> OnBool a -> OnBool a
>= :: OnBool a -> OnBool a -> Bool
$c>= :: forall a. Ord a => OnBool a -> OnBool a -> Bool
> :: OnBool a -> OnBool a -> Bool
$c> :: forall a. Ord a => OnBool a -> OnBool a -> Bool
<= :: OnBool a -> OnBool a -> Bool
$c<= :: forall a. Ord a => OnBool a -> OnBool a -> Bool
< :: OnBool a -> OnBool a -> Bool
$c< :: forall a. Ord a => OnBool a -> OnBool a -> Bool
compare :: OnBool a -> OnBool a -> Ordering
$ccompare :: forall a. Ord a => OnBool a -> OnBool a -> Ordering
Ord, Int -> OnBool a -> ShowS
forall a. Show a => Int -> OnBool a -> ShowS
forall a. Show a => [OnBool a] -> ShowS
forall a. Show a => OnBool a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OnBool a] -> ShowS
$cshowList :: forall a. Show a => [OnBool a] -> ShowS
show :: OnBool a -> String
$cshow :: forall a. Show a => OnBool a -> String
showsPrec :: Int -> OnBool a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> OnBool a -> ShowS
Show, forall a b. a -> OnBool b -> OnBool a
forall a b. (a -> b) -> OnBool a -> OnBool b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> OnBool b -> OnBool a
$c<$ :: forall a b. a -> OnBool b -> OnBool a
fmap :: forall a b. (a -> b) -> OnBool a -> OnBool b
$cfmap :: forall a b. (a -> b) -> OnBool a -> OnBool b
Functor)

instance Foldable OnBool where
  foldMap :: forall m a. Monoid m => (a -> m) -> OnBool a -> m
foldMap a -> m
p (OnBool a
x a
y) = a -> m
p a
x forall a. Semigroup a => a -> a -> a
<> a -> m
p a
y

instance Traversable OnBool where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> OnBool a -> f (OnBool b)
traverse a -> f b
f (OnBool a
x a
y) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. a -> a -> OnBool a
OnBool (a -> f b
f a
x) (a -> f b
f a
y)

instance Mapping Bool OnBool where
  cst :: forall v. v -> OnBool v
cst v
x = forall a. a -> a -> OnBool a
OnBool v
x v
x
  mmap :: forall v u. Ord v => (u -> v) -> OnBool u -> OnBool v
mmap = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
  mtraverse :: forall (f :: * -> *) v u.
(Applicative f, Ord v) =>
(u -> f v) -> OnBool u -> f (OnBool v)
mtraverse = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
  act :: forall v. OnBool v -> Bool -> v
act (OnBool v
x v
_) Bool
False = v
x
  act (OnBool v
_ v
x) Bool
True = v
x
  isConst :: forall v. Ord v => OnBool v -> Maybe v
isConst (OnBool v
x v
y)
    | v
x forall a. Eq a => a -> a -> Bool
== v
y    = forall a. a -> Maybe a
Just v
x
    | Bool
otherwise = forall a. Maybe a
Nothing
  mergeA :: forall (f :: * -> *) w u v.
(Applicative f, Ord w) =>
(u -> v -> f w) -> OnBool u -> OnBool v -> f (OnBool w)
mergeA u -> v -> f w
h (OnBool u
x1 u
y1) (OnBool v
x2 v
y2) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. a -> a -> OnBool a
OnBool (u -> v -> f w
h u
x1 v
x2) (u -> v -> f w
h u
y1 v
y2)
  merge :: forall w u v.
Ord w =>
(u -> v -> w) -> OnBool u -> OnBool v -> OnBool w
merge u -> v -> w
h (OnBool u
x1 u
y1) (OnBool v
x2 v
y2) = forall a. a -> a -> OnBool a
OnBool (u -> v -> w
h u
x1 v
x2) (u -> v -> w
h u
y1 v
y2)

instance Neighbourly OnBool where
  neighbours :: forall v. Ord v => OnBool v -> Set (v, v)
neighbours (OnBool v
x v
y)
    | v
x forall a. Eq a => a -> a -> Bool
== v
y    = forall a. Set a
S.empty
    | Bool
otherwise = forall a. a -> Set a
S.singleton (v
x, v
y)

{-
-- May work with a future version of cond
deriving via (AlgebraWrapper Bool OnBool b)
  instance (Ord b, Boolean b) => Boolean (OnBool b)
-}


-- | Maps on Maybe
data OnMaybe k m v = OnMaybe {
  forall {k} (k :: k) (m :: * -> *) v. OnMaybe k m v -> v
onNothing :: v,
  forall {k} (k :: k) (m :: * -> *) v. OnMaybe k m v -> m v
onJust :: m v
}

instance Foldable m => Foldable (OnMaybe k m) where
  foldMap :: forall m a. Monoid m => (a -> m) -> OnMaybe k m a -> m
foldMap a -> m
f (OnMaybe a
x m a
a) = a -> m
f a
x forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f m a
a

instance Mapping k m => Mapping (Maybe k) (OnMaybe k m) where
  cst :: forall v. v -> OnMaybe k m v
cst v
x = forall {k} (k :: k) (m :: * -> *) v. v -> m v -> OnMaybe k m v
OnMaybe v
x forall a b. (a -> b) -> a -> b
$ forall k (m :: * -> *) v. Mapping k m => v -> m v
cst v
x
  mmap :: forall v u. Ord v => (u -> v) -> OnMaybe k m u -> OnMaybe k m v
mmap u -> v
p (OnMaybe u
x m u
a) = forall {k} (k :: k) (m :: * -> *) v. v -> m v -> OnMaybe k m v
OnMaybe (u -> v
p u
x) (forall k (m :: * -> *) v u.
(Mapping k m, Ord v) =>
(u -> v) -> m u -> m v
mmap u -> v
p m u
a)
  mtraverse :: forall (f :: * -> *) v u.
(Applicative f, Ord v) =>
(u -> f v) -> OnMaybe k m u -> f (OnMaybe k m v)
mtraverse u -> f v
p (OnMaybe u
x m u
a) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall {k} (k :: k) (m :: * -> *) v. v -> m v -> OnMaybe k m v
OnMaybe (u -> f v
p u
x) (forall k (m :: * -> *) (f :: * -> *) v u.
(Mapping k m, Applicative f, Ord v) =>
(u -> f v) -> m u -> f (m v)
mtraverse u -> f v
p m u
a)
  act :: forall v. OnMaybe k m v -> Maybe k -> v
act (OnMaybe v
x m v
_) Maybe k
Nothing = v
x
  act (OnMaybe v
_ m v
a) (Just k
y) = forall k (m :: * -> *) v. Mapping k m => m v -> k -> v
act m v
a k
y
  isConst :: forall v. Ord v => OnMaybe k m v -> Maybe v
isConst (OnMaybe v
x m v
a) = do
    v
y <- forall k (m :: * -> *) v. (Mapping k m, Ord v) => m v -> Maybe v
isConst m v
a
    if v
x forall a. Eq a => a -> a -> Bool
== v
y then forall a. a -> Maybe a
Just v
x else forall a. Maybe a
Nothing
  merge :: forall w u v.
Ord w =>
(u -> v -> w) -> OnMaybe k m u -> OnMaybe k m v -> OnMaybe k m w
merge u -> v -> w
h (OnMaybe u
x m u
a) (OnMaybe v
y m v
b) = forall {k} (k :: k) (m :: * -> *) v. v -> m v -> OnMaybe k m v
OnMaybe (u -> v -> w
h u
x v
y) (forall k (m :: * -> *) w u v.
(Mapping k m, Ord w) =>
(u -> v -> w) -> m u -> m v -> m w
merge u -> v -> w
h m u
a m v
b)
  mergeA :: forall (f :: * -> *) w u v.
(Applicative f, Ord w) =>
(u -> v -> f w)
-> OnMaybe k m u -> OnMaybe k m v -> f (OnMaybe k m w)
mergeA u -> v -> f w
h (OnMaybe u
x m u
a) (OnMaybe v
y m v
b) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall {k} (k :: k) (m :: * -> *) v. v -> m v -> OnMaybe k m v
OnMaybe (u -> v -> f w
h u
x v
y) (forall k (m :: * -> *) (f :: * -> *) w u v.
(Mapping k m, Applicative f, Ord w) =>
(u -> v -> f w) -> m u -> m v -> f (m w)
mergeA u -> v -> f w
h m u
a m v
b)


-- | Maps on Either
data OnEither k l m n v = OnEither {
  forall {k} {k} {k} (k :: k) (l :: k) (m :: k -> *) (n :: k -> *)
       (v :: k).
OnEither k l m n v -> m v
onLeft :: m v,
  forall {k} {k} {k} (k :: k) (l :: k) (m :: k -> *) (n :: k -> *)
       (v :: k).
OnEither k l m n v -> n v
onRight :: n v
} deriving (OnEither k l m n v -> OnEither k l m n v -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (k :: k) k (l :: k) k (m :: k -> *) (n :: k -> *)
       (v :: k).
(Eq (m v), Eq (n v)) =>
OnEither k l m n v -> OnEither k l m n v -> Bool
/= :: OnEither k l m n v -> OnEither k l m n v -> Bool
$c/= :: forall k (k :: k) k (l :: k) k (m :: k -> *) (n :: k -> *)
       (v :: k).
(Eq (m v), Eq (n v)) =>
OnEither k l m n v -> OnEither k l m n v -> Bool
== :: OnEither k l m n v -> OnEither k l m n v -> Bool
$c== :: forall k (k :: k) k (l :: k) k (m :: k -> *) (n :: k -> *)
       (v :: k).
(Eq (m v), Eq (n v)) =>
OnEither k l m n v -> OnEither k l m n v -> Bool
Eq, OnEither k l m n v -> OnEither k l m n v -> Bool
OnEither k l m n v -> OnEither k l m n v -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {k} {k :: k} {k} {l :: k} {k} {m :: k -> *} {n :: k -> *}
       {v :: k}.
(Ord (m v), Ord (n v)) =>
Eq (OnEither k l m n v)
forall k (k :: k) k (l :: k) k (m :: k -> *) (n :: k -> *)
       (v :: k).
(Ord (m v), Ord (n v)) =>
OnEither k l m n v -> OnEither k l m n v -> Bool
forall k (k :: k) k (l :: k) k (m :: k -> *) (n :: k -> *)
       (v :: k).
(Ord (m v), Ord (n v)) =>
OnEither k l m n v -> OnEither k l m n v -> Ordering
forall k (k :: k) k (l :: k) k (m :: k -> *) (n :: k -> *)
       (v :: k).
(Ord (m v), Ord (n v)) =>
OnEither k l m n v -> OnEither k l m n v -> OnEither k l m n v
min :: OnEither k l m n v -> OnEither k l m n v -> OnEither k l m n v
$cmin :: forall k (k :: k) k (l :: k) k (m :: k -> *) (n :: k -> *)
       (v :: k).
(Ord (m v), Ord (n v)) =>
OnEither k l m n v -> OnEither k l m n v -> OnEither k l m n v
max :: OnEither k l m n v -> OnEither k l m n v -> OnEither k l m n v
$cmax :: forall k (k :: k) k (l :: k) k (m :: k -> *) (n :: k -> *)
       (v :: k).
(Ord (m v), Ord (n v)) =>
OnEither k l m n v -> OnEither k l m n v -> OnEither k l m n v
>= :: OnEither k l m n v -> OnEither k l m n v -> Bool
$c>= :: forall k (k :: k) k (l :: k) k (m :: k -> *) (n :: k -> *)
       (v :: k).
(Ord (m v), Ord (n v)) =>
OnEither k l m n v -> OnEither k l m n v -> Bool
> :: OnEither k l m n v -> OnEither k l m n v -> Bool
$c> :: forall k (k :: k) k (l :: k) k (m :: k -> *) (n :: k -> *)
       (v :: k).
(Ord (m v), Ord (n v)) =>
OnEither k l m n v -> OnEither k l m n v -> Bool
<= :: OnEither k l m n v -> OnEither k l m n v -> Bool
$c<= :: forall k (k :: k) k (l :: k) k (m :: k -> *) (n :: k -> *)
       (v :: k).
(Ord (m v), Ord (n v)) =>
OnEither k l m n v -> OnEither k l m n v -> Bool
< :: OnEither k l m n v -> OnEither k l m n v -> Bool
$c< :: forall k (k :: k) k (l :: k) k (m :: k -> *) (n :: k -> *)
       (v :: k).
(Ord (m v), Ord (n v)) =>
OnEither k l m n v -> OnEither k l m n v -> Bool
compare :: OnEither k l m n v -> OnEither k l m n v -> Ordering
$ccompare :: forall k (k :: k) k (l :: k) k (m :: k -> *) (n :: k -> *)
       (v :: k).
(Ord (m v), Ord (n v)) =>
OnEither k l m n v -> OnEither k l m n v -> Ordering
Ord)

instance (Foldable m, Foldable n) => Foldable (OnEither k l m n) where
  foldMap :: forall m a. Monoid m => (a -> m) -> OnEither k l m n a -> m
foldMap a -> m
p (OnEither m a
f n a
g) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
p m a
f forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
p n a
g

instance (Mapping k m,
          Mapping l n)
       => Mapping (Either k l) (OnEither k l m n) where
  cst :: forall v. v -> OnEither k l m n v
cst v
x = forall {k} {k} {k} (k :: k) (l :: k) (m :: k -> *) (n :: k -> *)
       (v :: k).
m v -> n v -> OnEither k l m n v
OnEither (forall k (m :: * -> *) v. Mapping k m => v -> m v
cst v
x) (forall k (m :: * -> *) v. Mapping k m => v -> m v
cst v
x)
  mmap :: forall v u.
Ord v =>
(u -> v) -> OnEither k l m n u -> OnEither k l m n v
mmap u -> v
p (OnEither m u
f n u
g) = forall {k} {k} {k} (k :: k) (l :: k) (m :: k -> *) (n :: k -> *)
       (v :: k).
m v -> n v -> OnEither k l m n v
OnEither (forall k (m :: * -> *) v u.
(Mapping k m, Ord v) =>
(u -> v) -> m u -> m v
mmap u -> v
p m u
f) (forall k (m :: * -> *) v u.
(Mapping k m, Ord v) =>
(u -> v) -> m u -> m v
mmap u -> v
p n u
g)
  mtraverse :: forall (f :: * -> *) v u.
(Applicative f, Ord v) =>
(u -> f v) -> OnEither k l m n u -> f (OnEither k l m n v)
mtraverse u -> f v
p (OnEither m u
f n u
g) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall {k} {k} {k} (k :: k) (l :: k) (m :: k -> *) (n :: k -> *)
       (v :: k).
m v -> n v -> OnEither k l m n v
OnEither (forall k (m :: * -> *) (f :: * -> *) v u.
(Mapping k m, Applicative f, Ord v) =>
(u -> f v) -> m u -> f (m v)
mtraverse u -> f v
p m u
f) (forall k (m :: * -> *) (f :: * -> *) v u.
(Mapping k m, Applicative f, Ord v) =>
(u -> f v) -> m u -> f (m v)
mtraverse u -> f v
p n u
g)
  act :: forall v. OnEither k l m n v -> Either k l -> v
act (OnEither m v
f n v
_) (Left k
x) = forall k (m :: * -> *) v. Mapping k m => m v -> k -> v
act m v
f k
x
  act (OnEither m v
_ n v
g) (Right l
y) = forall k (m :: * -> *) v. Mapping k m => m v -> k -> v
act n v
g l
y
  isConst :: forall v. Ord v => OnEither k l m n v -> Maybe v
isConst (OnEither m v
f n v
g) = do
    v
x <- forall k (m :: * -> *) v. (Mapping k m, Ord v) => m v -> Maybe v
isConst m v
f
    v
y <- forall k (m :: * -> *) v. (Mapping k m, Ord v) => m v -> Maybe v
isConst n v
g
    if v
x forall a. Eq a => a -> a -> Bool
== v
y then forall a. a -> Maybe a
Just v
x else forall a. Maybe a
Nothing
  mergeA :: forall (f :: * -> *) w u v.
(Applicative f, Ord w) =>
(u -> v -> f w)
-> OnEither k l m n u
-> OnEither k l m n v
-> f (OnEither k l m n w)
mergeA u -> v -> f w
h (OnEither m u
f1 n u
g1) (OnEither m v
f2 n v
g2) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall {k} {k} {k} (k :: k) (l :: k) (m :: k -> *) (n :: k -> *)
       (v :: k).
m v -> n v -> OnEither k l m n v
OnEither (forall k (m :: * -> *) (f :: * -> *) w u v.
(Mapping k m, Applicative f, Ord w) =>
(u -> v -> f w) -> m u -> m v -> f (m w)
mergeA u -> v -> f w
h m u
f1 m v
f2) (forall k (m :: * -> *) (f :: * -> *) w u v.
(Mapping k m, Applicative f, Ord w) =>
(u -> v -> f w) -> m u -> m v -> f (m w)
mergeA u -> v -> f w
h n u
g1 n v
g2)
  merge :: forall w u v.
Ord w =>
(u -> v -> w)
-> OnEither k l m n u -> OnEither k l m n v -> OnEither k l m n w
merge u -> v -> w
h (OnEither m u
f1 n u
g1) (OnEither m v
f2 n v
g2) = forall {k} {k} {k} (k :: k) (l :: k) (m :: k -> *) (n :: k -> *)
       (v :: k).
m v -> n v -> OnEither k l m n v
OnEither (forall k (m :: * -> *) w u v.
(Mapping k m, Ord w) =>
(u -> v -> w) -> m u -> m v -> m w
merge u -> v -> w
h m u
f1 m v
f2) (forall k (m :: * -> *) w u v.
(Mapping k m, Ord w) =>
(u -> v -> w) -> m u -> m v -> m w
merge u -> v -> w
h n u
g1 n v
g2)

{-
-- May work with a future version of cond
deriving via (AlgebraWrapper (Either k l) (OnEither k l m n) b)
  instance (Mapping k m, Mapping l n, Ord b, Boolean b) => Boolean (OnEither k l m n b)
-}


-- | Maps on pairs
newtype OnPair k l m n v = OnPair {
  forall {k} {k} {k} {k} (k :: k) (l :: k) (m :: k -> *)
       (n :: k -> k) (v :: k).
OnPair k l m n v -> m (n v)
asComposite :: m (n v)
} deriving (OnPair k l m n v -> OnPair k l m n v -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (k :: k) k (l :: k) k (m :: k -> *) k (n :: k -> k)
       (v :: k).
Eq (m (n v)) =>
OnPair k l m n v -> OnPair k l m n v -> Bool
/= :: OnPair k l m n v -> OnPair k l m n v -> Bool
$c/= :: forall k (k :: k) k (l :: k) k (m :: k -> *) k (n :: k -> k)
       (v :: k).
Eq (m (n v)) =>
OnPair k l m n v -> OnPair k l m n v -> Bool
== :: OnPair k l m n v -> OnPair k l m n v -> Bool
$c== :: forall k (k :: k) k (l :: k) k (m :: k -> *) k (n :: k -> k)
       (v :: k).
Eq (m (n v)) =>
OnPair k l m n v -> OnPair k l m n v -> Bool
Eq, OnPair k l m n v -> OnPair k l m n v -> Bool
OnPair k l m n v -> OnPair k l m n v -> Ordering
OnPair k l m n v -> OnPair k l m n v -> OnPair k l m n v
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {k} {k :: k} {k} {l :: k} {k} {m :: k -> *} {k}
       {n :: k -> k} {v :: k}.
Ord (m (n v)) =>
Eq (OnPair k l m n v)
forall k (k :: k) k (l :: k) k (m :: k -> *) k (n :: k -> k)
       (v :: k).
Ord (m (n v)) =>
OnPair k l m n v -> OnPair k l m n v -> Bool
forall k (k :: k) k (l :: k) k (m :: k -> *) k (n :: k -> k)
       (v :: k).
Ord (m (n v)) =>
OnPair k l m n v -> OnPair k l m n v -> Ordering
forall k (k :: k) k (l :: k) k (m :: k -> *) k (n :: k -> k)
       (v :: k).
Ord (m (n v)) =>
OnPair k l m n v -> OnPair k l m n v -> OnPair k l m n v
min :: OnPair k l m n v -> OnPair k l m n v -> OnPair k l m n v
$cmin :: forall k (k :: k) k (l :: k) k (m :: k -> *) k (n :: k -> k)
       (v :: k).
Ord (m (n v)) =>
OnPair k l m n v -> OnPair k l m n v -> OnPair k l m n v
max :: OnPair k l m n v -> OnPair k l m n v -> OnPair k l m n v
$cmax :: forall k (k :: k) k (l :: k) k (m :: k -> *) k (n :: k -> k)
       (v :: k).
Ord (m (n v)) =>
OnPair k l m n v -> OnPair k l m n v -> OnPair k l m n v
>= :: OnPair k l m n v -> OnPair k l m n v -> Bool
$c>= :: forall k (k :: k) k (l :: k) k (m :: k -> *) k (n :: k -> k)
       (v :: k).
Ord (m (n v)) =>
OnPair k l m n v -> OnPair k l m n v -> Bool
> :: OnPair k l m n v -> OnPair k l m n v -> Bool
$c> :: forall k (k :: k) k (l :: k) k (m :: k -> *) k (n :: k -> k)
       (v :: k).
Ord (m (n v)) =>
OnPair k l m n v -> OnPair k l m n v -> Bool
<= :: OnPair k l m n v -> OnPair k l m n v -> Bool
$c<= :: forall k (k :: k) k (l :: k) k (m :: k -> *) k (n :: k -> k)
       (v :: k).
Ord (m (n v)) =>
OnPair k l m n v -> OnPair k l m n v -> Bool
< :: OnPair k l m n v -> OnPair k l m n v -> Bool
$c< :: forall k (k :: k) k (l :: k) k (m :: k -> *) k (n :: k -> k)
       (v :: k).
Ord (m (n v)) =>
OnPair k l m n v -> OnPair k l m n v -> Bool
compare :: OnPair k l m n v -> OnPair k l m n v -> Ordering
$ccompare :: forall k (k :: k) k (l :: k) k (m :: k -> *) k (n :: k -> k)
       (v :: k).
Ord (m (n v)) =>
OnPair k l m n v -> OnPair k l m n v -> Ordering
Ord)

instance (Foldable m, Foldable n) => Foldable (OnPair k l m n) where
  foldMap :: forall m a. Monoid m => (a -> m) -> OnPair k l m n a -> m
foldMap a -> m
p (OnPair m (n a)
f) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
p) m (n a)
f

instance (Mapping k m,
          Mapping l n,
          forall v. Ord v => Ord (n v))
       => Mapping (k, l) (OnPair k l m n) where
  cst :: forall v. v -> OnPair k l m n v
cst v
x = forall {k} {k} {k} {k} (k :: k) (l :: k) (m :: k -> *)
       (n :: k -> k) (v :: k).
m (n v) -> OnPair k l m n v
OnPair forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (m :: * -> *) v. Mapping k m => v -> m v
cst forall a b. (a -> b) -> a -> b
$ forall k (m :: * -> *) v. Mapping k m => v -> m v
cst v
x
  mmap :: forall v u.
Ord v =>
(u -> v) -> OnPair k l m n u -> OnPair k l m n v
mmap u -> v
p (OnPair m (n u)
f) = forall {k} {k} {k} {k} (k :: k) (l :: k) (m :: k -> *)
       (n :: k -> k) (v :: k).
m (n v) -> OnPair k l m n v
OnPair (forall k (m :: * -> *) v u.
(Mapping k m, Ord v) =>
(u -> v) -> m u -> m v
mmap (forall k (m :: * -> *) v u.
(Mapping k m, Ord v) =>
(u -> v) -> m u -> m v
mmap u -> v
p) m (n u)
f)
  mtraverse :: forall (f :: * -> *) v u.
(Applicative f, Ord v) =>
(u -> f v) -> OnPair k l m n u -> f (OnPair k l m n v)
mtraverse u -> f v
p (OnPair m (n u)
f) = forall {k} {k} {k} {k} (k :: k) (l :: k) (m :: k -> *)
       (n :: k -> k) (v :: k).
m (n v) -> OnPair k l m n v
OnPair forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k (m :: * -> *) (f :: * -> *) v u.
(Mapping k m, Applicative f, Ord v) =>
(u -> f v) -> m u -> f (m v)
mtraverse (forall k (m :: * -> *) (f :: * -> *) v u.
(Mapping k m, Applicative f, Ord v) =>
(u -> f v) -> m u -> f (m v)
mtraverse u -> f v
p) m (n u)
f
  act :: forall v. OnPair k l m n v -> (k, l) -> v
act (OnPair m (n v)
f) (k
x, l
y) = forall k (m :: * -> *) v. Mapping k m => m v -> k -> v
act (forall k (m :: * -> *) v. Mapping k m => m v -> k -> v
act m (n v)
f k
x) l
y
  isConst :: forall v. Ord v => OnPair k l m n v -> Maybe v
isConst (OnPair m (n v)
f) = forall k (m :: * -> *) v. (Mapping k m, Ord v) => m v -> Maybe v
isConst forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall k (m :: * -> *) v. (Mapping k m, Ord v) => m v -> Maybe v
isConst m (n v)
f
  mergeA :: forall (f :: * -> *) w u v.
(Applicative f, Ord w) =>
(u -> v -> f w)
-> OnPair k l m n u -> OnPair k l m n v -> f (OnPair k l m n w)
mergeA u -> v -> f w
h (OnPair m (n u)
f) (OnPair m (n v)
g) = forall {k} {k} {k} {k} (k :: k) (l :: k) (m :: k -> *)
       (n :: k -> k) (v :: k).
m (n v) -> OnPair k l m n v
OnPair forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k (m :: * -> *) (f :: * -> *) w u v.
(Mapping k m, Applicative f, Ord w) =>
(u -> v -> f w) -> m u -> m v -> f (m w)
mergeA (forall k (m :: * -> *) (f :: * -> *) w u v.
(Mapping k m, Applicative f, Ord w) =>
(u -> v -> f w) -> m u -> m v -> f (m w)
mergeA u -> v -> f w
h) m (n u)
f m (n v)
g
  merge :: forall w u v.
Ord w =>
(u -> v -> w)
-> OnPair k l m n u -> OnPair k l m n v -> OnPair k l m n w
merge u -> v -> w
h (OnPair m (n u)
f) (OnPair m (n v)
g) = forall {k} {k} {k} {k} (k :: k) (l :: k) (m :: k -> *)
       (n :: k -> k) (v :: k).
m (n v) -> OnPair k l m n v
OnPair forall a b. (a -> b) -> a -> b
$ forall k (m :: * -> *) w u v.
(Mapping k m, Ord w) =>
(u -> v -> w) -> m u -> m v -> m w
merge (forall k (m :: * -> *) w u v.
(Mapping k m, Ord w) =>
(u -> v -> w) -> m u -> m v -> m w
merge u -> v -> w
h) m (n u)
f m (n v)
g

{-
-- May work with a future version of cond
deriving via (AlgebraWrapper (k, l) (OnPair k l m n) b)
  instance (Mapping k m, Mapping l n, Ord b, Boolean b) => Boolean (OnPair k l m n b)
-}


-- Is the first a subset of the second?
--
-- With a future version of cond, we should be able to generalise this
isSubset :: Mapping k m => m Bool -> m Bool -> Bool
isSubset :: forall k (m :: * -> *). Mapping k m => m Bool -> m Bool -> Bool
isSubset m Bool
m m Bool
n = let
  p :: Bool -> Bool -> All
p Bool
True Bool
False = Bool -> All
All Bool
False
  p Bool
_ Bool
_        = Bool -> All
All Bool
True
  in All -> Bool
getAll forall a b. (a -> b) -> a -> b
$ forall k (m :: * -> *) u v a.
(Mapping k m, Monoid a) =>
(u -> v -> a) -> m u -> m v -> a
pairMappings Bool -> Bool -> All
p m Bool
m m Bool
n

-- Are the two true on distinct values?
--
-- Again, with a future version of cond, we should be able to generalise this
isDisjoint :: Mapping k m => m Bool -> m Bool -> Bool
isDisjoint :: forall k (m :: * -> *). Mapping k m => m Bool -> m Bool -> Bool
isDisjoint m Bool
m m Bool
n = let
  p :: Bool -> Bool -> All
p Bool
True Bool
True = Bool -> All
All Bool
False
  p Bool
_ Bool
_       = Bool -> All
All Bool
True
  in All -> Bool
getAll forall a b. (a -> b) -> a -> b
$ forall k (m :: * -> *) u v a.
(Mapping k m, Monoid a) =>
(u -> v -> a) -> m u -> m v -> a
pairMappings Bool -> Bool -> All
p m Bool
m m Bool
n


-- | A wrapper to allow defining `PartialOrd` instances on mappings whose keys
-- have an `Ord` instance.
newtype OrdWrapper k m v = OrdWrapper {
  forall {k} {k} (k :: k) (m :: k -> *) (v :: k).
OrdWrapper k m v -> m v
getOrdMapping :: m v
}

instance (Mapping k m, Ord v) => PartialOrd (OrdWrapper k m v) where
  compare' :: OrdWrapper k m v -> OrdWrapper k m v -> PartialOrdering
compare' (OrdWrapper m v
u) (OrdWrapper m v
v) = forall k (m :: * -> *) u v a.
(Mapping k m, Monoid a) =>
(u -> v -> a) -> m u -> m v -> a
pairMappings forall a. Ord a => a -> a -> PartialOrdering
fromCompare m v
u m v
v


  -- | A wrapper to allow defining `PartialOrd` instances on mappings whose keys
  -- have a `PartialOrd` instance.
newtype PartialOrdWrapper k m v = PartialOrdWrapper {
  forall {k} {k} (k :: k) (m :: k -> *) (v :: k).
PartialOrdWrapper k m v -> m v
getPartialOrdMapping :: m v
}

instance (Mapping k m, PartialOrd v) => PartialOrd (PartialOrdWrapper k m v) where
  compare' :: PartialOrdWrapper k m v
-> PartialOrdWrapper k m v -> PartialOrdering
compare' (PartialOrdWrapper m v
u) (PartialOrdWrapper m v
v) = forall k (m :: * -> *) u v a.
(Mapping k m, Monoid a) =>
(u -> v -> a) -> m u -> m v -> a
pairMappings forall a. PartialOrd a => a -> a -> PartialOrdering
compare' m v
u m v
v