{-# LANGUAGE AllowAmbiguousTypes, UndecidableInstances #-}
module Raehik.HFunctorMap where
import Data.Kind
import GHC.TypeLits
import Data.Vinyl
import Data.Vinyl.TypeLevel
import GHC.Generics ( Generic )
import Data.Aeson
import GHC.Exts
import Data.Aeson.KeyMap qualified as KM
import Data.Aeson.Key qualified as K
type LFlap :: k -> (Symbol, k -> Type) -> Type
newtype LFlap a fl = LFlap { forall k (a :: k) (fl :: (Symbol, k -> *)). LFlap a fl -> Snd fl a
getLFlap :: (Snd fl) a }
deriving stock ((forall x. LFlap a fl -> Rep (LFlap a fl) x)
-> (forall x. Rep (LFlap a fl) x -> LFlap a fl)
-> Generic (LFlap a fl)
forall x. Rep (LFlap a fl) x -> LFlap a fl
forall x. LFlap a fl -> Rep (LFlap a fl) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k (a :: k) (fl :: (Symbol, k -> *)) x.
Rep (LFlap a fl) x -> LFlap a fl
forall k (a :: k) (fl :: (Symbol, k -> *)) x.
LFlap a fl -> Rep (LFlap a fl) x
$cto :: forall k (a :: k) (fl :: (Symbol, k -> *)) x.
Rep (LFlap a fl) x -> LFlap a fl
$cfrom :: forall k (a :: k) (fl :: (Symbol, k -> *)) x.
LFlap a fl -> Rep (LFlap a fl) x
Generic)
deriving stock instance Show (Snd fl a) => Show (LFlap a fl)
deriving anyclass instance ToJSON (Snd fl a) => ToJSON (LFlap a fl)
lFlap :: forall l a f. f a -> LFlap a '(l, f)
lFlap :: forall {k} (l :: Symbol) (a :: k) (f :: k -> *).
f a -> LFlap a '(l, f)
lFlap = f a -> LFlap a '(l, f)
forall k (a :: k) (fl :: (Symbol, k -> *)). Snd fl a -> LFlap a fl
LFlap
newtype LFunctorList fs a = LFunctorList { forall {k} (fs :: [(Symbol, k -> *)]) (a :: k).
LFunctorList fs a -> Rec (LFlap a) fs
getLFunctorList :: Rec (LFlap a) fs }
deriving stock ((forall x. LFunctorList fs a -> Rep (LFunctorList fs a) x)
-> (forall x. Rep (LFunctorList fs a) x -> LFunctorList fs a)
-> Generic (LFunctorList fs a)
forall x. Rep (LFunctorList fs a) x -> LFunctorList fs a
forall x. LFunctorList fs a -> Rep (LFunctorList fs a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k (fs :: [(Symbol, k -> *)]) (a :: k) x.
Rep (LFunctorList fs a) x -> LFunctorList fs a
forall k (fs :: [(Symbol, k -> *)]) (a :: k) x.
LFunctorList fs a -> Rep (LFunctorList fs a) x
$cto :: forall k (fs :: [(Symbol, k -> *)]) (a :: k) x.
Rep (LFunctorList fs a) x -> LFunctorList fs a
$cfrom :: forall k (fs :: [(Symbol, k -> *)]) (a :: k) x.
LFunctorList fs a -> Rep (LFunctorList fs a) x
Generic)
deriving stock instance
(ReifyConstraint Show (LFlap a) fs, RMap fs, RecordToList fs)
=> Show (LFunctorList fs a)
instance ToJSON (LFunctorList '[] a) where
toJSON :: LFunctorList '[] a -> Value
toJSON (LFunctorList Rec (LFlap a) '[]
RNil) = Object -> Value
Object Object
forall a. Monoid a => a
mempty
instance (ToJSON (f a), KnownSymbol l, ToJSON (LFunctorList fs a)) => ToJSON (LFunctorList ('(l, f) ': fs) a) where
toJSON :: LFunctorList ('(l, f) : fs) a -> Value
toJSON (LFunctorList (LFlap Snd r a
fa :& Rec (LFlap a) rs
fs)) =
let Object Object
os = LFunctorList rs a -> Value
forall a. ToJSON a => a -> Value
toJSON (LFunctorList rs a -> Value) -> LFunctorList rs a -> Value
forall a b. (a -> b) -> a -> b
$ Rec (LFlap a) rs -> LFunctorList rs a
forall {k} (fs :: [(Symbol, k -> *)]) (a :: k).
Rec (LFlap a) fs -> LFunctorList fs a
LFunctorList Rec (LFlap a) rs
fs
label :: String
label = forall (l :: Symbol). KnownSymbol l => String
symbolVal'' @l
o :: Value
o = f a -> Value
forall a. ToJSON a => a -> Value
toJSON f a
Snd r a
fa
in Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert (String -> Key
K.fromString String
label) Value
o Object
os
symbolVal'' :: forall l. KnownSymbol l => String
symbolVal'' :: forall (l :: Symbol). KnownSymbol l => String
symbolVal'' = Proxy# l -> String
forall (n :: Symbol). KnownSymbol n => Proxy# n -> String
symbolVal' (Proxy# l
forall {k} (a :: k). Proxy# a
proxy# :: Proxy# l)
lflgetf
:: forall (l :: Symbol) f fs a
. ( HasField Rec l fs fs f f )
=> LFunctorList fs a -> f a
lflgetf :: forall {k} (l :: Symbol) (f :: k -> *) (fs :: [(Symbol, k -> *)])
(a :: k).
HasField Rec l fs fs f f =>
LFunctorList fs a -> f a
lflgetf = LFlap a (l ::: f) -> f a
forall k (a :: k) (fl :: (Symbol, k -> *)). LFlap a fl -> Snd fl a
getLFlap (LFlap a (l ::: f) -> f a)
-> (LFunctorList fs a -> LFlap a (l ::: f))
-> LFunctorList fs a
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (r :: k) (rs :: [k]) (f :: k -> *)
(record :: (k -> *) -> [k] -> *).
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f) =>
record f rs -> f r
forall (r :: (Symbol, k -> *)) (rs :: [(Symbol, k -> *)])
(f :: (Symbol, k -> *) -> *)
(record :: ((Symbol, k -> *) -> *) -> [(Symbol, k -> *)] -> *).
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f) =>
record f rs -> f r
rget @(l ::: f) (Rec (LFlap a) fs -> LFlap a (l ::: f))
-> (LFunctorList fs a -> Rec (LFlap a) fs)
-> LFunctorList fs a
-> LFlap a (l ::: f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LFunctorList fs a -> Rec (LFlap a) fs
forall {k} (fs :: [(Symbol, k -> *)]) (a :: k).
LFunctorList fs a -> Rec (LFlap a) fs
getLFunctorList