{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}

{- |
Description: Misc utilities relating to functor.

This module provides types and functions with no particular theme, but which
are relevant to the use of 'Functor'-based datastructures like
'Data.Dependent.Map.DMap'.
-}
module Data.Functor.Misc
  ( -- * Const2
    Const2 (..)
  , unConst2
  , dmapToMap
  , dmapToIntMap
  , dmapToMapWith
  , mapToDMap
  , weakenDMapWith
    -- * WrapArg
  , WrapArg (..)
    -- * Convenience functions for DMap
  , mapWithFunctorToDMap
  , intMapWithFunctorToDMap
  , mapKeyValuePairsMonotonic
  , combineDMapsWithKey
  , EitherTag (..)
  , dmapToThese
  , eitherToDSum
  , dsumToEither
  , ComposeMaybe (..)
  ) where

import Data.Dependent.Map (DMap)
import qualified Data.Dependent.Map as DMap
import Data.Dependent.Sum
import Data.Functor.Identity
import Data.GADT.Compare
import Data.GADT.Show
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Kind (Type)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Some (Some, mkSome)
import Data.These
import Data.Type.Equality ((:~:)(Refl))
import Data.Typeable hiding (Refl)

--------------------------------------------------------------------------------
-- Const2
--------------------------------------------------------------------------------

-- | @'Const2' k v v@ stores a value of a given type @k@ and ensures
-- that a particular type @v@ is always given for the last type
-- parameter
data Const2 :: Type -> x -> x -> Type where
  Const2 :: k -> Const2 k v v
  deriving (Typeable)

-- | Extract the value from a Const2
unConst2 :: Const2 k v v' -> k
unConst2 :: forall {x} k (v :: x) (v' :: x). Const2 k v v' -> k
unConst2 (Const2 k
k) = k
k

deriving instance Eq k => Eq (Const2 k v v')
deriving instance Ord k => Ord (Const2 k v v')
deriving instance Show k => Show (Const2 k v v')
deriving instance Read k => Read (Const2 k v v)

instance Show k => GShow (Const2 k v) where
  gshowsPrec :: forall (a :: k). Int -> Const2 k v a -> ShowS
gshowsPrec Int
n x :: Const2 k v a
x@(Const2 k
_) = Int -> Const2 k v a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
n Const2 k v a
x

instance Eq k => GEq (Const2 k v) where
  geq :: forall (a :: k) (b :: k).
Const2 k v a -> Const2 k v b -> Maybe (a :~: b)
geq (Const2 k
a) (Const2 k
b) =
    if k
a k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
b
    then (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
    else Maybe (a :~: b)
forall a. Maybe a
Nothing

instance Ord k => GCompare (Const2 k v) where
  gcompare :: forall (a :: k) (b :: k).
Const2 k v a -> Const2 k v b -> GOrdering a b
gcompare (Const2 k
a) (Const2 k
b) = case k -> k -> Ordering
forall a. Ord a => a -> a -> Ordering
compare k
a k
b of
    Ordering
LT -> GOrdering a b
forall {k} (a :: k) (b :: k). GOrdering a b
GLT
    Ordering
EQ -> GOrdering a a
GOrdering a b
forall {k} (a :: k). GOrdering a a
GEQ
    Ordering
GT -> GOrdering a b
forall {k} (a :: k) (b :: k). GOrdering a b
GGT

-- | Convert a 'DMap' to a regular 'Map'
dmapToMap :: DMap (Const2 k v) Identity -> Map k v
dmapToMap :: forall k v. DMap (Const2 k v) Identity -> Map k v
dmapToMap = [(k, v)] -> Map k v
forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList ([(k, v)] -> Map k v)
-> (DMap (Const2 k v) Identity -> [(k, v)])
-> DMap (Const2 k v) Identity
-> Map k v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DSum (Const2 k v) Identity -> (k, v))
-> [DSum (Const2 k v) Identity] -> [(k, v)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Const2 k
k :=> Identity v
v) -> (k
k, v
v)) ([DSum (Const2 k v) Identity] -> [(k, v)])
-> (DMap (Const2 k v) Identity -> [DSum (Const2 k v) Identity])
-> DMap (Const2 k v) Identity
-> [(k, v)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DMap (Const2 k v) Identity -> [DSum (Const2 k v) Identity]
forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
DMap k2 f -> [DSum k2 f]
DMap.toAscList

-- | Convert a 'DMap' to an 'IntMap'
dmapToIntMap :: DMap (Const2 IntMap.Key v) Identity -> IntMap v
dmapToIntMap :: forall v. DMap (Const2 Int v) Identity -> IntMap v
dmapToIntMap = [(Int, v)] -> IntMap v
forall a. [(Int, a)] -> IntMap a
IntMap.fromDistinctAscList ([(Int, v)] -> IntMap v)
-> (DMap (Const2 Int v) Identity -> [(Int, v)])
-> DMap (Const2 Int v) Identity
-> IntMap v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DSum (Const2 Int v) Identity -> (Int, v))
-> [DSum (Const2 Int v) Identity] -> [(Int, v)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Const2 Int
k :=> Identity v
v) -> (Int
k, v
v)) ([DSum (Const2 Int v) Identity] -> [(Int, v)])
-> (DMap (Const2 Int v) Identity -> [DSum (Const2 Int v) Identity])
-> DMap (Const2 Int v) Identity
-> [(Int, v)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DMap (Const2 Int v) Identity -> [DSum (Const2 Int v) Identity]
forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
DMap k2 f -> [DSum k2 f]
DMap.toAscList

-- | Convert a 'DMap' to a regular 'Map', applying the given function to remove
-- the wrapping 'Functor'
dmapToMapWith :: (f v -> v') -> DMap (Const2 k v) f -> Map k v'
dmapToMapWith :: forall {k} (f :: k -> *) (v :: k) v' k.
(f v -> v') -> DMap (Const2 k v) f -> Map k v'
dmapToMapWith f v -> v'
f = [(k, v')] -> Map k v'
forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList ([(k, v')] -> Map k v')
-> (DMap (Const2 k v) f -> [(k, v')])
-> DMap (Const2 k v) f
-> Map k v'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DSum (Const2 k v) f -> (k, v'))
-> [DSum (Const2 k v) f] -> [(k, v')]
forall a b. (a -> b) -> [a] -> [b]
map (\(Const2 k
k :=> f a
v) -> (k
k, f v -> v'
f f v
f a
v)) ([DSum (Const2 k v) f] -> [(k, v')])
-> (DMap (Const2 k v) f -> [DSum (Const2 k v) f])
-> DMap (Const2 k v) f
-> [(k, v')]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DMap (Const2 k v) f -> [DSum (Const2 k v) f]
forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
DMap k2 f -> [DSum k2 f]
DMap.toAscList

-- | Convert a regular 'Map' to a 'DMap'
mapToDMap :: Map k v -> DMap (Const2 k v) Identity
mapToDMap :: forall k v. Map k v -> DMap (Const2 k v) Identity
mapToDMap = [DSum (Const2 k v) Identity] -> DMap (Const2 k v) Identity
forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
[DSum k2 f] -> DMap k2 f
DMap.fromDistinctAscList ([DSum (Const2 k v) Identity] -> DMap (Const2 k v) Identity)
-> (Map k v -> [DSum (Const2 k v) Identity])
-> Map k v
-> DMap (Const2 k v) Identity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, v) -> DSum (Const2 k v) Identity)
-> [(k, v)] -> [DSum (Const2 k v) Identity]
forall a b. (a -> b) -> [a] -> [b]
map (\(k
k, v
v) -> k -> Const2 k v v
forall {x} k (v :: x). k -> Const2 k v v
Const2 k
k Const2 k v v -> Identity v -> DSum (Const2 k v) Identity
forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> v -> Identity v
forall a. a -> Identity a
Identity v
v) ([(k, v)] -> [DSum (Const2 k v) Identity])
-> (Map k v -> [(k, v)]) -> Map k v -> [DSum (Const2 k v) Identity]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k v -> [(k, v)]
forall k a. Map k a -> [(k, a)]
Map.toAscList

-- | Convert a regular 'Map', where the values are already wrapped in a functor,
-- to a 'DMap'
mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f
mapWithFunctorToDMap :: forall {k} k (f :: k -> *) (v :: k).
Map k (f v) -> DMap (Const2 k v) f
mapWithFunctorToDMap = [DSum (Const2 k v) f] -> DMap (Const2 k v) f
forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
[DSum k2 f] -> DMap k2 f
DMap.fromDistinctAscList ([DSum (Const2 k v) f] -> DMap (Const2 k v) f)
-> (Map k (f v) -> [DSum (Const2 k v) f])
-> Map k (f v)
-> DMap (Const2 k v) f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, f v) -> DSum (Const2 k v) f)
-> [(k, f v)] -> [DSum (Const2 k v) f]
forall a b. (a -> b) -> [a] -> [b]
map (\(k
k, f v
v) -> k -> Const2 k v v
forall {x} k (v :: x). k -> Const2 k v v
Const2 k
k Const2 k v v -> f v -> DSum (Const2 k v) f
forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> f v
v) ([(k, f v)] -> [DSum (Const2 k v) f])
-> (Map k (f v) -> [(k, f v)])
-> Map k (f v)
-> [DSum (Const2 k v) f]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k (f v) -> [(k, f v)]
forall k a. Map k a -> [(k, a)]
Map.toAscList

-- | Convert a regular 'IntMap', where the values are already wrapped in a
-- functor, to a 'DMap'
intMapWithFunctorToDMap :: IntMap (f v) -> DMap (Const2 IntMap.Key v) f
intMapWithFunctorToDMap :: forall {k} (f :: k -> *) (v :: k).
IntMap (f v) -> DMap (Const2 Int v) f
intMapWithFunctorToDMap = [DSum (Const2 Int v) f] -> DMap (Const2 Int v) f
forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
[DSum k2 f] -> DMap k2 f
DMap.fromDistinctAscList ([DSum (Const2 Int v) f] -> DMap (Const2 Int v) f)
-> (IntMap (f v) -> [DSum (Const2 Int v) f])
-> IntMap (f v)
-> DMap (Const2 Int v) f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, f v) -> DSum (Const2 Int v) f)
-> [(Int, f v)] -> [DSum (Const2 Int v) f]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
k, f v
v) -> Int -> Const2 Int v v
forall {x} k (v :: x). k -> Const2 k v v
Const2 Int
k Const2 Int v v -> f v -> DSum (Const2 Int v) f
forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> f v
v) ([(Int, f v)] -> [DSum (Const2 Int v) f])
-> (IntMap (f v) -> [(Int, f v)])
-> IntMap (f v)
-> [DSum (Const2 Int v) f]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap (f v) -> [(Int, f v)]
forall a. IntMap a -> [(Int, a)]
IntMap.toAscList

-- | Convert a 'DMap' to a regular 'Map' by forgetting the types associated with
-- the keys, using a function to remove the wrapping 'Functor'
weakenDMapWith :: (forall a. v a -> v') -> DMap k v -> Map (Some k) v'
weakenDMapWith :: forall {k} (v :: k -> *) v' (k :: k -> *).
(forall (a :: k). v a -> v') -> DMap k v -> Map (Some k) v'
weakenDMapWith forall (a :: k). v a -> v'
f = [(Some k, v')] -> Map (Some k) v'
forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList ([(Some k, v')] -> Map (Some k) v')
-> (DMap k v -> [(Some k, v')]) -> DMap k v -> Map (Some k) v'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DSum k v -> (Some k, v')) -> [DSum k v] -> [(Some k, v')]
forall a b. (a -> b) -> [a] -> [b]
map (\(k a
k :=> v a
v) -> (k a -> Some k
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
mkSome k a
k, v a -> v'
forall (a :: k). v a -> v'
f v a
v)) ([DSum k v] -> [(Some k, v')])
-> (DMap k v -> [DSum k v]) -> DMap k v -> [(Some k, v')]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DMap k v -> [DSum k v]
forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
DMap k2 f -> [DSum k2 f]
DMap.toAscList

--------------------------------------------------------------------------------
-- WrapArg
--------------------------------------------------------------------------------

-- | 'WrapArg' can be used to tag a value in one functor with a type
-- representing another functor.  This was primarily used with dependent-map <
-- 0.2, in which the value type was not wrapped in a separate functor.
data WrapArg :: (k -> Type) -> (k -> Type) -> Type -> Type where
  WrapArg :: f a -> WrapArg g f (g a)

deriving instance Eq (f a) => Eq (WrapArg g f (g' a))
deriving instance Ord (f a) => Ord (WrapArg g f (g' a))
deriving instance Show (f a) => Show (WrapArg g f (g' a))
deriving instance Read (f a) => Read (WrapArg g f (g a))

instance GEq f => GEq (WrapArg g f) where
  geq :: forall a b. WrapArg g f a -> WrapArg g f b -> Maybe (a :~: b)
geq (WrapArg f a
a) (WrapArg f a
b) = (\a :~: a
Refl -> a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl) ((a :~: a) -> a :~: b) -> Maybe (a :~: a) -> Maybe (a :~: b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a -> f a -> Maybe (a :~: a)
forall (a :: k) (b :: k). f a -> f b -> Maybe (a :~: b)
forall k (f :: k -> *) (a :: k) (b :: k).
GEq f =>
f a -> f b -> Maybe (a :~: b)
geq f a
a f a
b

instance GCompare f => GCompare (WrapArg g f) where
  gcompare :: forall a b. WrapArg g f a -> WrapArg g f b -> GOrdering a b
gcompare (WrapArg f a
a) (WrapArg f a
b) = case f a -> f a -> GOrdering a a
forall (a :: k) (b :: k). f a -> f b -> GOrdering a b
forall k (f :: k -> *) (a :: k) (b :: k).
GCompare f =>
f a -> f b -> GOrdering a b
gcompare f a
a f a
b of
    GOrdering a a
GLT -> GOrdering a b
forall {k} (a :: k) (b :: k). GOrdering a b
GLT
    GOrdering a a
GEQ -> GOrdering a a
GOrdering a b
forall {k} (a :: k). GOrdering a a
GEQ
    GOrdering a a
GGT -> GOrdering a b
forall {k} (a :: k) (b :: k). GOrdering a b
GGT

--------------------------------------------------------------------------------
-- Convenience functions for DMap
--------------------------------------------------------------------------------

-- | Map over all key/value pairs in a 'DMap', potentially altering the key as
-- well as the value.  The provided function MUST preserve the ordering of the
-- keys, or the resulting 'DMap' will be malformed.
mapKeyValuePairsMonotonic :: (DSum k v -> DSum k' v') -> DMap k v -> DMap k' v'
mapKeyValuePairsMonotonic :: forall {k} {k} (k :: k -> *) (v :: k -> *) (k' :: k -> *)
       (v' :: k -> *).
(DSum k v -> DSum k' v') -> DMap k v -> DMap k' v'
mapKeyValuePairsMonotonic DSum k v -> DSum k' v'
f = [DSum k' v'] -> DMap k' v'
forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
[DSum k2 f] -> DMap k2 f
DMap.fromDistinctAscList ([DSum k' v'] -> DMap k' v')
-> (DMap k v -> [DSum k' v']) -> DMap k v -> DMap k' v'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DSum k v -> DSum k' v') -> [DSum k v] -> [DSum k' v']
forall a b. (a -> b) -> [a] -> [b]
map DSum k v -> DSum k' v'
f ([DSum k v] -> [DSum k' v'])
-> (DMap k v -> [DSum k v]) -> DMap k v -> [DSum k' v']
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DMap k v -> [DSum k v]
forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
DMap k2 f -> [DSum k2 f]
DMap.toAscList

{-# INLINE combineDMapsWithKey #-}
-- | Union two 'DMap's of different types, yielding another type.  Each key that
-- is present in either input map will be present in the output.
combineDMapsWithKey :: forall f g h i.
                       GCompare f
                    => (forall a. f a -> These (g a) (h a) -> i a)
                    -> DMap f g
                    -> DMap f h
                    -> DMap f i
combineDMapsWithKey :: forall {k} (f :: k -> *) (g :: k -> *) (h :: k -> *) (i :: k -> *).
GCompare f =>
(forall (a :: k). f a -> These (g a) (h a) -> i a)
-> DMap f g -> DMap f h -> DMap f i
combineDMapsWithKey forall (a :: k). f a -> These (g a) (h a) -> i a
f DMap f g
mg DMap f h
mh = [DSum f i] -> DMap f i
forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
GCompare k2 =>
[DSum k2 f] -> DMap k2 f
DMap.fromList ([DSum f i] -> DMap f i) -> [DSum f i] -> DMap f i
forall a b. (a -> b) -> a -> b
$ [DSum f g] -> [DSum f h] -> [DSum f i]
go (DMap f g -> [DSum f g]
forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
DMap k2 f -> [DSum k2 f]
DMap.toList DMap f g
mg) (DMap f h -> [DSum f h]
forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
DMap k2 f -> [DSum k2 f]
DMap.toList DMap f h
mh)
  where go :: [DSum f g] -> [DSum f h] -> [DSum f i]
        go :: [DSum f g] -> [DSum f h] -> [DSum f i]
go [] [DSum f h]
hs = (DSum f h -> DSum f i) -> [DSum f h] -> [DSum f i]
forall a b. (a -> b) -> [a] -> [b]
map (\(f a
hk :=> h a
hv) -> f a
hk f a -> i a -> DSum f i
forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> f a -> These (g a) (h a) -> i a
forall (a :: k). f a -> These (g a) (h a) -> i a
f f a
hk (h a -> These (g a) (h a)
forall a b. b -> These a b
That h a
hv)) [DSum f h]
hs
        go [DSum f g]
gs [] = (DSum f g -> DSum f i) -> [DSum f g] -> [DSum f i]
forall a b. (a -> b) -> [a] -> [b]
map (\(f a
gk :=> g a
gv) -> f a
gk f a -> i a -> DSum f i
forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> f a -> These (g a) (h a) -> i a
forall (a :: k). f a -> These (g a) (h a) -> i a
f f a
gk (g a -> These (g a) (h a)
forall a b. a -> These a b
This g a
gv)) [DSum f g]
gs
        go gs :: [DSum f g]
gs@((f a
gk :=> g a
gv) : [DSum f g]
gs') hs :: [DSum f h]
hs@((f a
hk :=> h a
hv) : [DSum f h]
hs') = case f a
gk f a -> f a -> GOrdering a a
forall (a :: k) (b :: k). f a -> f b -> GOrdering a b
forall k (f :: k -> *) (a :: k) (b :: k).
GCompare f =>
f a -> f b -> GOrdering a b
`gcompare` f a
hk of
          GOrdering a a
GLT -> (f a
gk f a -> i a -> DSum f i
forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> f a -> These (g a) (h a) -> i a
forall (a :: k). f a -> These (g a) (h a) -> i a
f f a
gk (g a -> These (g a) (h a)
forall a b. a -> These a b
This g a
gv)) DSum f i -> [DSum f i] -> [DSum f i]
forall a. a -> [a] -> [a]
: [DSum f g] -> [DSum f h] -> [DSum f i]
go [DSum f g]
gs' [DSum f h]
hs
          GOrdering a a
GEQ -> (f a
gk f a -> i a -> DSum f i
forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> f a -> These (g a) (h a) -> i a
forall (a :: k). f a -> These (g a) (h a) -> i a
f f a
gk (g a -> h a -> These (g a) (h a)
forall a b. a -> b -> These a b
These g a
gv h a
h a
hv)) DSum f i -> [DSum f i] -> [DSum f i]
forall a. a -> [a] -> [a]
: [DSum f g] -> [DSum f h] -> [DSum f i]
go [DSum f g]
gs' [DSum f h]
hs'
          GOrdering a a
GGT -> (f a
hk f a -> i a -> DSum f i
forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> f a -> These (g a) (h a) -> i a
forall (a :: k). f a -> These (g a) (h a) -> i a
f f a
hk (h a -> These (g a) (h a)
forall a b. b -> These a b
That h a
hv)) DSum f i -> [DSum f i] -> [DSum f i]
forall a. a -> [a] -> [a]
: [DSum f g] -> [DSum f h] -> [DSum f i]
go [DSum f g]
gs [DSum f h]
hs'

-- | Extract the values of a 'DMap' of 'EitherTag's.
dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b)
dmapToThese :: forall a b. DMap (EitherTag a b) Identity -> Maybe (These a b)
dmapToThese DMap (EitherTag a b) Identity
m = case (EitherTag a b a
-> DMap (EitherTag a b) Identity -> Maybe (Identity a)
forall {k1} (k2 :: k1 -> *) (f :: k1 -> *) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
DMap.lookup EitherTag a b a
forall {k} (l :: k) (r :: k). EitherTag l r l
LeftTag DMap (EitherTag a b) Identity
m, EitherTag a b b
-> DMap (EitherTag a b) Identity -> Maybe (Identity b)
forall {k1} (k2 :: k1 -> *) (f :: k1 -> *) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
DMap.lookup EitherTag a b b
forall {k} (l :: k) (r :: k). EitherTag l r r
RightTag DMap (EitherTag a b) Identity
m) of
  (Maybe (Identity a)
Nothing, Maybe (Identity b)
Nothing) -> Maybe (These a b)
forall a. Maybe a
Nothing
  (Just (Identity a
a), Maybe (Identity b)
Nothing) -> These a b -> Maybe (These a b)
forall a. a -> Maybe a
Just (These a b -> Maybe (These a b)) -> These a b -> Maybe (These a b)
forall a b. (a -> b) -> a -> b
$ a -> These a b
forall a b. a -> These a b
This a
a
  (Maybe (Identity a)
Nothing, Just (Identity b
b)) -> These a b -> Maybe (These a b)
forall a. a -> Maybe a
Just (These a b -> Maybe (These a b)) -> These a b -> Maybe (These a b)
forall a b. (a -> b) -> a -> b
$ b -> These a b
forall a b. b -> These a b
That b
b
  (Just (Identity a
a), Just (Identity b
b)) -> These a b -> Maybe (These a b)
forall a. a -> Maybe a
Just (These a b -> Maybe (These a b)) -> These a b -> Maybe (These a b)
forall a b. (a -> b) -> a -> b
$ a -> b -> These a b
forall a b. a -> b -> These a b
These a
a b
b

-- | Tag type for 'Either' to use it as a 'DSum'.
data EitherTag l r a where
  LeftTag :: EitherTag l r l
  RightTag :: EitherTag l r r
  deriving (Typeable)

deriving instance Show (EitherTag l r a)
deriving instance Eq (EitherTag l r a)
deriving instance Ord (EitherTag l r a)

instance GEq (EitherTag l r) where
  geq :: forall (a :: k) (b :: k).
EitherTag l r a -> EitherTag l r b -> Maybe (a :~: b)
geq EitherTag l r a
a EitherTag l r b
b = case (EitherTag l r a
a, EitherTag l r b
b) of
    (EitherTag l r a
LeftTag, EitherTag l r b
LeftTag) -> (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
    (EitherTag l r a
RightTag, EitherTag l r b
RightTag) -> (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
    (EitherTag l r a, EitherTag l r b)
_ -> Maybe (a :~: b)
forall a. Maybe a
Nothing

instance GCompare (EitherTag l r) where
  gcompare :: forall (a :: k) (b :: k).
EitherTag l r a -> EitherTag l r b -> GOrdering a b
gcompare EitherTag l r a
a EitherTag l r b
b = case (EitherTag l r a
a, EitherTag l r b
b) of
    (EitherTag l r a
LeftTag, EitherTag l r b
LeftTag) -> GOrdering a a
GOrdering a b
forall {k} (a :: k). GOrdering a a
GEQ
    (EitherTag l r a
LeftTag, EitherTag l r b
RightTag) -> GOrdering a b
forall {k} (a :: k) (b :: k). GOrdering a b
GLT
    (EitherTag l r a
RightTag, EitherTag l r b
LeftTag) -> GOrdering a b
forall {k} (a :: k) (b :: k). GOrdering a b
GGT
    (EitherTag l r a
RightTag, EitherTag l r b
RightTag) -> GOrdering a a
GOrdering a b
forall {k} (a :: k). GOrdering a a
GEQ

instance GShow (EitherTag l r) where
  gshowsPrec :: forall (a :: k). Int -> EitherTag l r a -> ShowS
gshowsPrec Int
_ EitherTag l r a
a = case EitherTag l r a
a of
    EitherTag l r a
LeftTag -> String -> ShowS
showString String
"LeftTag"
    EitherTag l r a
RightTag -> String -> ShowS
showString String
"RightTag"

-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.
eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity
eitherToDSum :: forall a b. Either a b -> DSum (EitherTag a b) Identity
eitherToDSum = \case
  Left a
a -> (EitherTag a b a
forall {k} (l :: k) (r :: k). EitherTag l r l
LeftTag EitherTag a b a -> Identity a -> DSum (EitherTag a b) Identity
forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> a -> Identity a
forall a. a -> Identity a
Identity a
a)
  Right b
b -> (EitherTag a b b
forall {k} (l :: k) (r :: k). EitherTag l r r
RightTag EitherTag a b b -> Identity b -> DSum (EitherTag a b) Identity
forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> b -> Identity b
forall a. a -> Identity a
Identity b
b)

-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.
dsumToEither :: DSum (EitherTag a b) Identity -> Either a b
dsumToEither :: forall a b. DSum (EitherTag a b) Identity -> Either a b
dsumToEither = \case
  (EitherTag a b a
LeftTag :=> Identity a
a) -> a -> Either a b
forall a b. a -> Either a b
Left a
a
a
  (EitherTag a b a
RightTag :=> Identity a
b) -> b -> Either a b
forall a b. b -> Either a b
Right b
a
b

--------------------------------------------------------------------------------
-- ComposeMaybe
--------------------------------------------------------------------------------

-- | We can't use @'Data.Functor.Compose.Compose' 'Maybe'@ instead of @'ComposeMaybe'@,
-- because that would make the @f@ parameter have a nominal type role.
-- We need @f@ to be representational so that we can use safe
-- @'Data.Coerce.coerce'@.
newtype ComposeMaybe f a =
  ComposeMaybe { forall {k} (f :: k -> *) (a :: k). ComposeMaybe f a -> Maybe (f a)
getComposeMaybe :: Maybe (f a) } deriving (Int -> ComposeMaybe f a -> ShowS
[ComposeMaybe f a] -> ShowS
ComposeMaybe f a -> String
(Int -> ComposeMaybe f a -> ShowS)
-> (ComposeMaybe f a -> String)
-> ([ComposeMaybe f a] -> ShowS)
-> Show (ComposeMaybe f a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (f :: k -> *) (a :: k).
Show (f a) =>
Int -> ComposeMaybe f a -> ShowS
forall k (f :: k -> *) (a :: k).
Show (f a) =>
[ComposeMaybe f a] -> ShowS
forall k (f :: k -> *) (a :: k).
Show (f a) =>
ComposeMaybe f a -> String
$cshowsPrec :: forall k (f :: k -> *) (a :: k).
Show (f a) =>
Int -> ComposeMaybe f a -> ShowS
showsPrec :: Int -> ComposeMaybe f a -> ShowS
$cshow :: forall k (f :: k -> *) (a :: k).
Show (f a) =>
ComposeMaybe f a -> String
show :: ComposeMaybe f a -> String
$cshowList :: forall k (f :: k -> *) (a :: k).
Show (f a) =>
[ComposeMaybe f a] -> ShowS
showList :: [ComposeMaybe f a] -> ShowS
Show, ComposeMaybe f a -> ComposeMaybe f a -> Bool
(ComposeMaybe f a -> ComposeMaybe f a -> Bool)
-> (ComposeMaybe f a -> ComposeMaybe f a -> Bool)
-> Eq (ComposeMaybe f a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (f :: k -> *) (a :: k).
Eq (f a) =>
ComposeMaybe f a -> ComposeMaybe f a -> Bool
$c== :: forall k (f :: k -> *) (a :: k).
Eq (f a) =>
ComposeMaybe f a -> ComposeMaybe f a -> Bool
== :: ComposeMaybe f a -> ComposeMaybe f a -> Bool
$c/= :: forall k (f :: k -> *) (a :: k).
Eq (f a) =>
ComposeMaybe f a -> ComposeMaybe f a -> Bool
/= :: ComposeMaybe f a -> ComposeMaybe f a -> Bool
Eq, Eq (ComposeMaybe f a)
Eq (ComposeMaybe f a) =>
(ComposeMaybe f a -> ComposeMaybe f a -> Ordering)
-> (ComposeMaybe f a -> ComposeMaybe f a -> Bool)
-> (ComposeMaybe f a -> ComposeMaybe f a -> Bool)
-> (ComposeMaybe f a -> ComposeMaybe f a -> Bool)
-> (ComposeMaybe f a -> ComposeMaybe f a -> Bool)
-> (ComposeMaybe f a -> ComposeMaybe f a -> ComposeMaybe f a)
-> (ComposeMaybe f a -> ComposeMaybe f a -> ComposeMaybe f a)
-> Ord (ComposeMaybe f a)
ComposeMaybe f a -> ComposeMaybe f a -> Bool
ComposeMaybe f a -> ComposeMaybe f a -> Ordering
ComposeMaybe f a -> ComposeMaybe f a -> ComposeMaybe f a
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 (f :: k -> *) (a :: k). Ord (f a) => Eq (ComposeMaybe f a)
forall k (f :: k -> *) (a :: k).
Ord (f a) =>
ComposeMaybe f a -> ComposeMaybe f a -> Bool
forall k (f :: k -> *) (a :: k).
Ord (f a) =>
ComposeMaybe f a -> ComposeMaybe f a -> Ordering
forall k (f :: k -> *) (a :: k).
Ord (f a) =>
ComposeMaybe f a -> ComposeMaybe f a -> ComposeMaybe f a
$ccompare :: forall k (f :: k -> *) (a :: k).
Ord (f a) =>
ComposeMaybe f a -> ComposeMaybe f a -> Ordering
compare :: ComposeMaybe f a -> ComposeMaybe f a -> Ordering
$c< :: forall k (f :: k -> *) (a :: k).
Ord (f a) =>
ComposeMaybe f a -> ComposeMaybe f a -> Bool
< :: ComposeMaybe f a -> ComposeMaybe f a -> Bool
$c<= :: forall k (f :: k -> *) (a :: k).
Ord (f a) =>
ComposeMaybe f a -> ComposeMaybe f a -> Bool
<= :: ComposeMaybe f a -> ComposeMaybe f a -> Bool
$c> :: forall k (f :: k -> *) (a :: k).
Ord (f a) =>
ComposeMaybe f a -> ComposeMaybe f a -> Bool
> :: ComposeMaybe f a -> ComposeMaybe f a -> Bool
$c>= :: forall k (f :: k -> *) (a :: k).
Ord (f a) =>
ComposeMaybe f a -> ComposeMaybe f a -> Bool
>= :: ComposeMaybe f a -> ComposeMaybe f a -> Bool
$cmax :: forall k (f :: k -> *) (a :: k).
Ord (f a) =>
ComposeMaybe f a -> ComposeMaybe f a -> ComposeMaybe f a
max :: ComposeMaybe f a -> ComposeMaybe f a -> ComposeMaybe f a
$cmin :: forall k (f :: k -> *) (a :: k).
Ord (f a) =>
ComposeMaybe f a -> ComposeMaybe f a -> ComposeMaybe f a
min :: ComposeMaybe f a -> ComposeMaybe f a -> ComposeMaybe f a
Ord)

deriving instance Functor f => Functor (ComposeMaybe f)