{-# 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 Data.Default (Default(..))
import Fmt (Buildable(..))
import GHC.TypeLits (KnownSymbol, symbolVal)
import Named (Name(..), NamedF(..), arg, argDef, argF, defaults, (!), (:!), (:?))
import Named.Internal (Defaults, Param)
import Text.Show qualified as T
import Morley.Util.Label (Label)
pattern (:!) :: Name name -> a -> NamedF Identity a name
pattern $m:! :: forall {r} {name :: Symbol} {a}.
NamedF Identity a name
-> (Name name -> a -> r) -> ((# #) -> r) -> r
$b:! :: forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
(:!) 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 $m:? :: forall {r} {name :: Symbol} {a}.
NamedF Maybe a name
-> (Name name -> Maybe a -> r) -> ((# #) -> r) -> r
$b:? :: forall (name :: Symbol) a.
Name name -> Maybe a -> NamedF Maybe a name
(:?) 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 a b. (a -> b) -> m a -> m b
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 a b. (a -> b) -> m a -> m b
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))
p (Unwrapped (Identity a)) (f (Unwrapped (Identity a)))
-> p (Identity a) (f (Identity a))
forall s. Wrapped s => Iso' s (Unwrapped s)
Iso' (Identity a) (Unwrapped (Identity a))
_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_prec Int -> 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 -> Doc
build (ArgF f a
a) = String -> Doc
forall a. Buildable a => a -> Doc
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)) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
": " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> f a -> Doc
forall a. Buildable a => a -> Doc
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)
instance f ~ Defaults => Default (Param f) where
def :: Param f
def = Param f
Param Defaults
defaults