{-# OPTIONS_GHC -Wno-orphans #-}
module Util.Named
( (:!)
, (:?)
, (.!)
, (.?)
, (<.!>)
, (<.?>)
, ApplyNamedFunctor
, NamedInner
) where
import Control.Lens (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
(.!) :: Name name -> a -> NamedF Identity a name
(.!) _ = ArgF . Identity
(.?) :: Name name -> Maybe a -> NamedF Maybe a name
(.?) _ = ArgF
(<.!>) :: Functor m => Name name -> m a -> m (NamedF Identity a name)
(<.!>) name = fmap (name .!)
(<.?>) :: Functor m => Name name -> m (Maybe a) -> m (NamedF Maybe a name)
(<.?>) name = fmap (name .?)
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
instance Wrapped (NamedF Identity a name) where
type Unwrapped (NamedF Identity a name) = a
_Wrapped' = iso (\(ArgF a) -> runIdentity a) (ArgF . Identity)
instance Wrapped (NamedF Maybe a name) where
type Unwrapped (NamedF Maybe a name) = Maybe a
_Wrapped' = iso (\(ArgF a) -> a) ArgF
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 (ArgF a) = symbolVal (Proxy @name) <> " :! " <> show a
instance (KnownSymbol name, Buildable (f a)) => Buildable (NamedF f a name) where
build (ArgF a) = build (symbolVal (Proxy @name)) <> ": " <> build 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)