{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Generic.HKD.Labels
( Label (..)
, labelsWhere
) where
import Barbies (ApplicativeB (..), TraversableB (..))
import Data.Functor.Const (Const (..))
import Data.Functor.Product (Product (..))
import Data.Generic.HKD.Types (HKD (..), GHKD_)
import Data.Kind (Type)
import Data.Proxy (Proxy (..))
import GHC.Generics
import GHC.TypeLits (ErrorMessage (..), KnownSymbol, TypeError, symbolVal)
class Label (structure :: Type) where
label :: HKD structure (Const String)
class GLabels (rep :: Type -> Type) where
glabel :: GHKD_ (Const String) rep p
instance GLabels inner => GLabels (D1 meta inner) where
glabel :: forall p. GHKD_ (Const String) (D1 meta inner) p
glabel = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (rep :: * -> *) p. GLabels rep => GHKD_ (Const String) rep p
glabel
instance GLabels inner
=> GLabels (C1 ('MetaCons name fixity 'True) inner) where
glabel :: forall p.
GHKD_ (Const String) (C1 ('MetaCons name fixity 'True) inner) p
glabel = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (rep :: * -> *) p. GLabels rep => GHKD_ (Const String) rep p
glabel
instance TypeError ('Text "You can't collect labels for a non-record type!")
=> GLabels (C1 ('MetaCons name fixity 'False) inner) where
glabel :: forall p.
GHKD_ (Const String) (C1 ('MetaCons name fixity 'False) inner) p
glabel = forall a. HasCallStack => a
undefined
instance KnownSymbol name
=> GLabels (S1 ('MetaSel ('Just name) i d c) (K1 index inner)) where
glabel :: forall p.
GHKD_
(Const String)
(S1 ('MetaSel ('Just name) i d c) (K1 index inner))
p
glabel = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall k i c (p :: k). c -> K1 i c p
K1 (forall {k} a (b :: k). a -> Const a b
Const (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @name))))
instance (GLabels left, GLabels right) => GLabels (left :*: right) where
glabel :: forall p. GHKD_ (Const String) (left :*: right) p
glabel = forall (rep :: * -> *) p. GLabels rep => GHKD_ (Const String) rep p
glabel forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall (rep :: * -> *) p. GLabels rep => GHKD_ (Const String) rep p
glabel
instance (Generic structure, GLabels (Rep structure)) => Label structure where
label :: HKD structure (Const String)
label = forall structure (f :: * -> *).
HKD_ f structure Void -> HKD structure f
HKD forall (rep :: * -> *) p. GLabels rep => GHKD_ (Const String) rep p
glabel
labelsWhere
:: forall structure f
. ( Label structure
, ApplicativeB (HKD structure)
, TraversableB (HKD structure)
)
=> (forall a. f a -> Bool)
-> HKD structure f
-> [String]
labelsWhere :: forall structure (f :: * -> *).
(Label structure, ApplicativeB (HKD structure),
TraversableB (HKD structure)) =>
(forall a. f a -> Bool) -> HKD structure f -> [String]
labelsWhere forall a. f a -> Bool
p
= forall {k} a (b :: k). Const a b -> a
getConst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (b :: (k -> *) -> *) (e :: * -> *) (f :: k -> *)
(g :: k -> *).
(TraversableB b, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> b f -> e (b g)
btraverse forall a. Product (Const String) f a -> Const [String] (Maybe a)
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
ApplicativeB b =>
b f -> b g -> b (Product f g)
bprod forall structure. Label structure => HKD structure (Const String)
label
where
go :: Product (Const String) f a -> (Const [String]) (Maybe a)
go :: forall a. Product (Const String) f a -> Const [String] (Maybe a)
go (Pair (Const String
key) f a
value) = forall {k} a (b :: k). a -> Const a b
Const if forall a. f a -> Bool
p f a
value then [String
key] else []