-- | Small module to support the higher-kinded data (HKD) pattern
--
-- This module is similar in spirit to libraries such as @barbies@ (and to
-- lesser degree @hkd@), but the technical details of the approach are somewhat
-- different.
--
-- Intended for qualified import.
--
-- > import Network.GRPC.Spec.Util.HKD (HKD, Undecorated, DecoratedWith) import
-- > Network.GRPC.Spec.Util.HKD qualified as HKD
module Network.GRPC.Spec.Util.HKD (
    -- * Definition
    HKD
  , DecoratedWith
  , Undecorated
    -- * Dealing with HKD records
  , Coerce(..)
  , Traversable(..)
  , sequence
  , map
    -- * Dealing with HKD fields
  , ValidDecoration
  , pure
    -- * Error decorations
  , Checked
  , sequenceChecked
  ) where

import Prelude hiding (Traversable(..), pure, map)
import Prelude qualified

import Control.Monad.Except (MonadError, throwError)
import Data.Functor.Identity
import Data.Kind
import Data.Proxy
import Unsafe.Coerce (unsafeCoerce)

{-------------------------------------------------------------------------------
  Definition
-------------------------------------------------------------------------------}

-- | Marker for undecorated fields
--
-- @HKD Undecorated x@ is equivalent to simply @x@. See 'HKD' for details.
data Undecorated (x :: Type)

-- | Marker for fields decorated with type constructor @f@
--
-- @HKD (DecoratedWith f) x@ is equivalent to @(f x)@. See 'HKD' for details.
data DecoratedWith (f :: Type -> Type) (x :: Type)

-- | Marker for fields of HKD types
--
-- A common pattern for datatypes is to wrap every field in a type constructor:
--
-- > data RequestHeaders_ f = RequestHeaders {
-- >     requestTimeout     :: f (Maybe Timeout)
-- >   , requestCompression :: f (Maybe CompressionId)
-- >   , ..
-- >   }
--
-- The downside of such an approach is that if we don't need that type
-- constructor, we must instantiate @f@ to t'Identity', which results in
-- syntactic overhead.
-- (See also
-- [The Haskell Unfolder episode 14: Higher-kinded types]
-- (https://www.youtube.com/watch?v=EXgsXy1BR-0&list=PLD8gywOEY4HaG5VSrKVnHxCptlJv2GAn7&index=15).)
-- The @HKD@ family is designed to avoid this overhead:
--
-- > data RequestHeaders_ f = RequestHeaders {
-- >     requestTimeout     :: HKD f (Maybe Timeout)
-- >   , requestCompression :: HKD f (Maybe CompressionId)
-- >   , ..
-- >   }
--
-- There are then two valid choices for @f@:
--
-- * 'Undecorated': @HKD Undecorated x@ is simply equal to @x@.
--   This avoids the overhead mentioned above.
-- * 'DecoratedWith' @f@, for some @f@:
--   @HKD (DecoratedWith f) x@ is equal to @f x@.
--
-- This explicit distinction between 'Undecorated' and 'DecoratedWith' is the
-- main difference between the approach in this module and other libraries that
-- provide similar functionality.
type family HKD (f :: Type -> Type) (x :: Type) :: Type

type instance HKD Undecorated       x = x
type instance HKD (DecoratedWith f) x = f x

{-------------------------------------------------------------------------------
  Dealing with HKD records
-------------------------------------------------------------------------------}

-- | Witness the isomorphism between @Undecorated@ and @DecoratedWith Identity@.
class Coerce t where
  -- | Drop decoration
  --
  -- /NOTE/: The default instance is valid only for datatypes that are morally
  -- have a "higher order representative role"; that is, the type of every field
  -- of @t (DecoratedWith Identity)@ must be representationally equal to the
  -- corresponding type of @t Undecorated@. In the typical case of
  --
  -- > data SomeRecord f = MkSomeRecord {
  -- >     field1 :: HKD f a1
  -- >   , field2 :: HKD f a2
  -- >     ..
  -- >   , fieldN :: aN
  -- >   , ..
  -- >   , fieldM :: HKD f aM
  -- >   }
  --
  -- where every field either has type @HKD f a@ or @a@ (not mentioning @f@ at
  -- all), this will automatically be the case.
  undecorate :: t (DecoratedWith Identity) -> t Undecorated
  undecorate = t (DecoratedWith Identity) -> t Undecorated
forall a b. a -> b
unsafeCoerce

  -- | Introduce trivial decoration
  --
  -- See 'undecorate' for discussion of the validity of the default definitino.
  decorate :: t Undecorated -> t (DecoratedWith Identity)
  decorate = t Undecorated -> t (DecoratedWith Identity)
forall a b. a -> b
unsafeCoerce

-- | Higher-kinded equivalent of 'Prelude.Traversable'
class Coerce t => Traversable t where
  traverse ::
       Applicative m
    => (forall a. f a -> m (g a))
    ->    t (DecoratedWith f)
    -> m (t (DecoratedWith g))

-- | Higher-kinded equivalent of 'Prelude.sequence'
sequence ::
     (Traversable t, Applicative m)
  => t (DecoratedWith m) -> m (t Undecorated)
sequence :: forall (t :: (* -> *) -> *) (m :: * -> *).
(Traversable t, Applicative m) =>
t (DecoratedWith m) -> m (t Undecorated)
sequence = (t (DecoratedWith Identity) -> t Undecorated)
-> m (t (DecoratedWith Identity)) -> m (t Undecorated)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t (DecoratedWith Identity) -> t Undecorated
forall (t :: (* -> *) -> *).
Coerce t =>
t (DecoratedWith Identity) -> t Undecorated
undecorate (m (t (DecoratedWith Identity)) -> m (t Undecorated))
-> (t (DecoratedWith m) -> m (t (DecoratedWith Identity)))
-> t (DecoratedWith m)
-> m (t Undecorated)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. m a -> m (Identity a))
-> t (DecoratedWith m) -> m (t (DecoratedWith Identity))
forall (m :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative m =>
(forall a. f a -> m (g a))
-> t (DecoratedWith f) -> m (t (DecoratedWith g))
forall (t :: (* -> *) -> *) (m :: * -> *) (f :: * -> *)
       (g :: * -> *).
(Traversable t, Applicative m) =>
(forall a. f a -> m (g a))
-> t (DecoratedWith f) -> m (t (DecoratedWith g))
traverse ((a -> Identity a) -> m a -> m (Identity a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Identity a
forall a. a -> Identity a
Identity)

-- | Higher-kinded equivalent of 'Prelude.map'
map ::
     Traversable t
  => (forall a. f a -> g a)
  -> t (DecoratedWith f)
  -> t (DecoratedWith g)
map :: forall (t :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
Traversable t =>
(forall a. f a -> g a)
-> t (DecoratedWith f) -> t (DecoratedWith g)
map forall a. f a -> g a
f = Identity (t (DecoratedWith g)) -> t (DecoratedWith g)
forall a. Identity a -> a
runIdentity (Identity (t (DecoratedWith g)) -> t (DecoratedWith g))
-> (t (DecoratedWith f) -> Identity (t (DecoratedWith g)))
-> t (DecoratedWith f)
-> t (DecoratedWith g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. f a -> Identity (g a))
-> t (DecoratedWith f) -> Identity (t (DecoratedWith g))
forall (m :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative m =>
(forall a. f a -> m (g a))
-> t (DecoratedWith f) -> m (t (DecoratedWith g))
forall (t :: (* -> *) -> *) (m :: * -> *) (f :: * -> *)
       (g :: * -> *).
(Traversable t, Applicative m) =>
(forall a. f a -> m (g a))
-> t (DecoratedWith f) -> m (t (DecoratedWith g))
traverse (g a -> Identity (g a)
forall a. a -> Identity a
Identity (g a -> Identity (g a)) -> (f a -> g a) -> f a -> Identity (g a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> g a
forall a. f a -> g a
f)

{-------------------------------------------------------------------------------
  Dealing with HKD fields
-------------------------------------------------------------------------------}

data IsValidDecoration (c :: (Type -> Type) -> Constraint) f where
  ValidUndecorated :: IsValidDecoration c Undecorated
  ValidDecoratedWith :: c f => IsValidDecoration c (DecoratedWith f)

-- | Valid decorations
--
-- These are only two valid decorations (and new instances of this class cannot
-- be defined):
--
-- * @ValidDecoration c Undecorated@, for any @c@
-- * @ValidDecoration c (DecoratedWith f)@, for any @f@ satisfying @c@
class ValidDecoration (c :: (Type -> Type) -> Constraint) f where
  validDecoration :: IsValidDecoration c f
  validDecoration = IsValidDecoration c f
forall a. HasCallStack => a
undefined

instance ValidDecoration c Undecorated where
  validDecoration :: IsValidDecoration c Undecorated
validDecoration = IsValidDecoration c Undecorated
forall (c :: (* -> *) -> Constraint).
IsValidDecoration c Undecorated
ValidUndecorated

instance c f => ValidDecoration c (DecoratedWith f) where
  validDecoration :: IsValidDecoration c (DecoratedWith f)
validDecoration = IsValidDecoration c (DecoratedWith f)
forall (c :: (* -> *) -> Constraint) (f :: * -> *).
c f =>
IsValidDecoration c (DecoratedWith f)
ValidDecoratedWith

-- | Specify field value of record with unknown decoration
--
-- You may need an additional type annotation also for @a@; for example
--
-- > HKD.pure (Proxy @f) Nothing
--
-- will result in an error message such as
--
-- > Couldn't match expected type: HKD f (Maybe SomeConcreteType)
-- >             with actual type: HKD f (Maybe a0)
--
-- This is because @HKD@ is a type family in two arguments (even though in an
-- ideal world it should be defined as a type family in /one/ argument).
pure :: forall f a. ValidDecoration Applicative f => Proxy f -> a -> HKD f a
pure :: forall (f :: * -> *) a.
ValidDecoration Applicative f =>
Proxy f -> a -> HKD f a
pure Proxy f
_ =
    case IsValidDecoration Applicative f
forall (c :: (* -> *) -> Constraint) (f :: * -> *).
ValidDecoration c f =>
IsValidDecoration c f
validDecoration :: IsValidDecoration Applicative f of
      IsValidDecoration Applicative f
ValidDecoratedWith -> a -> f a
a -> HKD f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
      IsValidDecoration Applicative f
ValidUndecorated   -> a -> a
a -> HKD f a
forall a. a -> a
id

{-------------------------------------------------------------------------------
  Error decorations
-------------------------------------------------------------------------------}

-- | Decorate with potential errors
type Checked e = DecoratedWith (Either e)

-- | Throw all errors found in the datatype
--
-- Given a datatype decorated with potential errors, find and throw any errors;
-- if no errors are found, return the undecorated value.
sequenceChecked ::
     (MonadError e m, Traversable t)
  => t (Checked e) -> m (t Undecorated)
sequenceChecked :: forall e (m :: * -> *) (t :: (* -> *) -> *).
(MonadError e m, Traversable t) =>
t (Checked e) -> m (t Undecorated)
sequenceChecked = (e -> m (t Undecorated))
-> (t Undecorated -> m (t Undecorated))
-> Either e (t Undecorated)
-> m (t Undecorated)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> m (t Undecorated)
forall a. e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError t Undecorated -> m (t Undecorated)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e (t Undecorated) -> m (t Undecorated))
-> (t (Checked e) -> Either e (t Undecorated))
-> t (Checked e)
-> m (t Undecorated)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t (Checked e) -> Either e (t Undecorated)
forall (t :: (* -> *) -> *) (m :: * -> *).
(Traversable t, Applicative m) =>
t (DecoratedWith m) -> m (t Undecorated)
sequence