{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
-- | 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 Control.Applicative ((<$>))
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.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' 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 :: * -> x -> x -> * where
  Const2 :: k -> Const2 k v v
  deriving (Typeable)

-- | Extract the value from a Const2
unConst2 :: Const2 k v v' -> k
unConst2 :: 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 :: 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 :: 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 :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
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 :: 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 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 :: 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 :=> Identity 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 :: 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 k :=> Identity 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 :: (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 :=> 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 :: 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 :: 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 :: 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 (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 -> *) -> (k -> *) -> * -> * 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 :: WrapArg g f a -> WrapArg g f b -> Maybe (a :~: b)
geq (WrapArg f a
a) (WrapArg f a
b) = (\a :~: a
Refl -> 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 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 :: 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 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 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 :: (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 (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 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
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 :: 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 :: 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 :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
    (EitherTag l r a
RightTag, EitherTag l r b
RightTag) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
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 :: 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 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 b
forall k (a :: k). GOrdering a a
GEQ

instance GShow (EitherTag l r) where
  gshowsPrec :: 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 :: 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 :: 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
  (EitherTag a b a
RightTag :=> Identity a
b) -> a -> Either a a
forall a b. b -> Either a b
Right a
b

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

-- | We can't use @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 'coerce'.
newtype ComposeMaybe f a =
  ComposeMaybe { 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
showList :: [ComposeMaybe f a] -> ShowS
$cshowList :: forall k (f :: k -> *) (a :: k).
Show (f a) =>
[ComposeMaybe f a] -> ShowS
show :: ComposeMaybe f a -> String
$cshow :: forall k (f :: k -> *) (a :: k).
Show (f a) =>
ComposeMaybe f a -> String
showsPrec :: Int -> ComposeMaybe f a -> ShowS
$cshowsPrec :: forall k (f :: k -> *) (a :: k).
Show (f a) =>
Int -> 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
/= :: 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
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
min :: 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
max :: ComposeMaybe f a -> ComposeMaybe f a -> ComposeMaybe f a
$cmax :: forall k (f :: k -> *) (a :: k).
Ord (f a) =>
ComposeMaybe f a -> ComposeMaybe f a -> ComposeMaybe f a
>= :: 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
$c< :: forall k (f :: k -> *) (a :: k).
Ord (f a) =>
ComposeMaybe f a -> ComposeMaybe f a -> Bool
compare :: ComposeMaybe f a -> ComposeMaybe f a -> Ordering
$ccompare :: forall k (f :: k -> *) (a :: k).
Ord (f a) =>
ComposeMaybe f a -> ComposeMaybe f a -> Ordering
$cp1Ord :: forall k (f :: k -> *) (a :: k). Ord (f a) => Eq (ComposeMaybe f a)
Ord)

deriving instance Functor f => Functor (ComposeMaybe f)