{-# OPTIONS_GHC -Wno-orphans #-}
module Morley.Util.Named
( (!)
, (:!)
, (:?)
, (<:!>)
, (<:?>)
, ApplyNamedFunctor
, NamedInner
, KnownNamedFunctor (..)
, NamedF (.., (:!), (:?))
, Name
, arg
, argF
, argDef
) where
import Control.Lens (Iso', Wrapped(..), iso)
import Data.Aeson (FromJSON, ToJSON)
import Data.Data (Data)
import Fmt (Buildable(..))
import GHC.TypeLits (KnownSymbol, symbolVal)
import Named (Name(..), NamedF(..), arg, argDef, argF, (!), (:!), (:?))
import Text.Show qualified as T
import Morley.Util.Label (Label)
pattern (:!) :: Name name -> a -> NamedF Identity a name
pattern $b:! :: forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
$m:! :: forall {r} {name :: Symbol} {a}.
NamedF Identity a name
-> (Name name -> a -> r) -> (Void# -> r) -> r
(:!) n v <- ((Name,) -> (n, ArgF (Identity v)))
where (:!) Name name
_ a
v = Identity a -> NamedF Identity a name
forall (f :: * -> *) a (name :: Symbol). f a -> NamedF f a name
ArgF (a -> Identity a
forall a. a -> Identity a
Identity a
v)
{-# COMPLETE (:!) #-}
pattern (:?) :: Name name -> Maybe a -> NamedF Maybe a name
pattern $b:? :: forall (name :: Symbol) a.
Name name -> Maybe a -> NamedF Maybe a name
$m:? :: forall {r} {name :: Symbol} {a}.
NamedF Maybe a name
-> (Name name -> Maybe a -> r) -> (Void# -> r) -> r
(:?) n v <- ((Name,) -> (n, ArgF v))
where (:?) Name name
_ Maybe a
v = Maybe a -> NamedF Maybe a name
forall (f :: * -> *) a (name :: Symbol). f a -> NamedF f a name
ArgF Maybe a
v
{-# COMPLETE (:?) #-}
(<:!>) :: Functor m => Name name -> m a -> m (NamedF Identity a name)
<:!> :: forall (m :: * -> *) (name :: Symbol) a.
Functor m =>
Name name -> m a -> m (NamedF Identity a 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)
<:?> :: forall (m :: * -> *) (name :: Symbol) a.
Functor m =>
Name name -> m (Maybe a) -> m (NamedF Maybe a 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 :: Type -> Type) (a :: Type) where
ApplyNamedFunctor Identity a = a
ApplyNamedFunctor Maybe a = Maybe a
type family NamedInner (n :: Type) where
NamedInner (NamedF f a _) = ApplyNamedFunctor f a
namedFL :: Label name -> Iso' (NamedF f a name) (f a)
namedFL :: forall (name :: Symbol) (f :: * -> *) a.
Label name -> Iso' (NamedF f a name) (f a)
namedFL Label name
_ = (NamedF f a name -> f a)
-> (f a -> NamedF f a name)
-> Iso (NamedF f a name) (NamedF f a name) (f a) (f a)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(ArgF 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
namedL :: Label name -> Iso' (NamedF f a name) (ApplyNamedFunctor f a)
instance KnownNamedFunctor Identity where
namedL :: forall (name :: Symbol) a.
Label name
-> Iso' (NamedF Identity a name) (ApplyNamedFunctor Identity a)
namedL 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 :: forall (name :: Symbol) a.
Label name
-> Iso' (NamedF Maybe a name) (ApplyNamedFunctor Maybe a)
namedL 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
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
showsPrec :: Int -> NamedF Identity a name -> ShowS
showsPrec Int
d (ArgF (Identity a
a)) = Bool -> ShowS -> ShowS
T.showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
app_prec) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
String -> ShowS
T.showString String
"fromLabel @" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. Show a => a -> ShowS
T.shows (Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @name)) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> ShowS
T.showString String
" :! " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
T.showsPrec (Int
bang_precInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) a
a
where
app_prec :: Int
app_prec = Int
10
bang_prec :: Int
bang_prec = Int
9
instance (KnownSymbol name, Buildable (f a)) => Buildable (NamedF f a name) where
build :: NamedF f a name -> Builder
build (ArgF 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 (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @name)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
": " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> f a -> Builder
forall p. Buildable p => p -> Builder
build f a
a
instance (NFData (f a)) => NFData (NamedF f a name) where
rnf :: NamedF f a name -> ()
rnf (ArgF f a
a) = f a -> ()
forall a. NFData a => a -> ()
rnf 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)