-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

{-# OPTIONS_GHC -Wno-orphans #-}

-- | Additional functionality for 'named' package.
module Util.Named
  ( (:!)
  , (:?)
  , (.!)
  , (.?)
  , (<.!>)
  , (<.?>)
  , ApplyNamedFunctor
  , NamedInner
  , KnownNamedFunctor (..)
  ) where

import Control.Lens (Iso', Wrapped(..), iso)
import Data.Aeson (FromJSON, ToJSON)
import Data.Data (Data)
import qualified Data.Kind as Kind
import Fmt (Buildable(..))
import GHC.TypeLits (KnownSymbol, symbolVal)
import Named ((:!), (:?), Name, NamedF(..))
import qualified Text.Show

import Util.Label (Label)

(.!) :: Name name -> a -> NamedF Identity a name
.! :: Name name -> a -> NamedF Identity a name
(.!) _ = Identity a -> NamedF Identity a name
forall (f :: * -> *) a (name :: Symbol). f a -> NamedF f a name
ArgF (Identity a -> NamedF Identity a name)
-> (a -> Identity a) -> a -> NamedF Identity a name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Identity a
forall a. a -> Identity a
Identity

(.?) :: Name name -> Maybe a -> NamedF Maybe a name
.? :: Name name -> Maybe a -> NamedF Maybe a name
(.?) _ = Maybe a -> NamedF Maybe a name
forall (f :: * -> *) a (name :: Symbol). f a -> NamedF f a name
ArgF

(<.!>) :: Functor m => Name name -> m a -> m (NamedF Identity a name)
<.!> :: Name name -> m a -> m (NamedF Identity a name)
(<.!>) name :: Name name
name = (a -> NamedF Identity a name) -> m a -> m (NamedF Identity a name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name name
name Name name -> a -> NamedF Identity a name
forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
.!)
infixl 4 <.!>

(<.?>) :: Functor m => Name name -> m (Maybe a) -> m (NamedF Maybe a name)
<.?> :: Name name -> m (Maybe a) -> m (NamedF Maybe a name)
(<.?>) name :: Name name
name = (Maybe a -> NamedF Maybe a name)
-> m (Maybe a) -> m (NamedF Maybe a name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name name
name Name name -> Maybe a -> NamedF Maybe a name
forall (name :: Symbol) a.
Name name -> Maybe a -> NamedF Maybe a name
.?)
infixl 4 <.?>

type family ApplyNamedFunctor (f :: Kind.Type -> Kind.Type) (a :: Kind.Type) where
  ApplyNamedFunctor Identity a = a
  ApplyNamedFunctor Maybe a = Maybe a

type family NamedInner (n :: Kind.Type) where
  NamedInner (NamedF f a _) = ApplyNamedFunctor f a

-- | Isomorphism between named entity and the entity itself wrapped into the
-- respective functor.
namedFL :: Label name -> Iso' (NamedF f a name) (f a)
namedFL :: Label name -> Iso' (NamedF f a name) (f a)
namedFL _ = (NamedF f a name -> f a)
-> (f a -> NamedF f a name) -> Iso' (NamedF f a name) (f a)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(ArgF x :: f a
x) -> f a
x) f a -> NamedF f a name
forall (f :: * -> *) a (name :: Symbol). f a -> NamedF f a name
ArgF

class KnownNamedFunctor f where
  -- | Isomorphism between named entity and the entity itself.
  namedL :: Label name -> Iso' (NamedF f a name) (ApplyNamedFunctor f a)

instance KnownNamedFunctor Identity where
  namedL :: Label name
-> Iso' (NamedF Identity a name) (ApplyNamedFunctor Identity a)
namedL l :: Label name
l = Label name -> Iso' (NamedF Identity a name) (Identity a)
forall (name :: Symbol) (f :: * -> *) a.
Label name -> Iso' (NamedF f a name) (f a)
namedFL Label name
l (p (Identity a) (f (Identity a))
 -> p (NamedF Identity a name) (f (NamedF Identity a name)))
-> (p a (f a) -> p (Identity a) (f (Identity a)))
-> p a (f a)
-> p (NamedF Identity a name) (f (NamedF Identity a name))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a (f a) -> p (Identity a) (f (Identity a))
forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped'

instance KnownNamedFunctor Maybe where
  namedL :: Label name
-> Iso' (NamedF Maybe a name) (ApplyNamedFunctor Maybe a)
namedL l :: Label name
l = Label name -> Iso' (NamedF Maybe a name) (Maybe a)
forall (name :: Symbol) (f :: * -> *) a.
Label name -> Iso' (NamedF f a name) (f a)
namedFL Label name
l

----------------------------------------------------------------------------
-- Instances
----------------------------------------------------------------------------

deriving stock instance Eq (f a) => Eq (NamedF f a name)
deriving stock instance Ord (f a) => Ord (NamedF f a name)

instance (Show a, KnownSymbol name) => Show (NamedF Identity a name) where
  show :: NamedF Identity a name -> String
show (ArgF a :: Identity a
a) = Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name
forall k (t :: k). Proxy t
Proxy @name) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> " :! " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Identity a -> String
forall b a. (Show a, IsString b) => a -> b
show Identity a
a

instance (KnownSymbol name, Buildable (f a)) => Buildable (NamedF f a name) where
  build :: NamedF f a name -> Builder
build (ArgF a :: f a
a) = String -> Builder
forall p. Buildable p => p -> Builder
build (Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name
forall k (t :: k). Proxy t
Proxy @name)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ": " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> f a -> Builder
forall p. Buildable p => p -> Builder
build f a
a

deriving stock instance
  (Typeable f, Typeable a, KnownSymbol name, Data (f a)) =>
  Data (NamedF f a name)

deriving newtype instance ToJSON a => ToJSON (NamedF Identity a name)
deriving newtype instance ToJSON a => ToJSON (NamedF Maybe a name)
deriving newtype instance FromJSON a => FromJSON (NamedF Identity a name)
deriving newtype instance FromJSON a => FromJSON (NamedF Maybe a name)