{-# 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)

-- | For any record type, we can extract the labels generically using the
-- `Const` functor.
--
-- >>> import Data.Generic.HKD
-- >>> import Data.Functor.Identity (Identity (..))
--
-- >>> data User = User { name :: String, age :: Int } deriving Generic
-- >>> label @User
-- User {name = Const "name", age = Const "age"}
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 :: GHKD_ (Const String) (D1 meta inner) p
glabel = GHKD_ (Const String) inner p
-> M1 D meta (GHKD_ (Const String) inner) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 GHKD_ (Const String) inner p
forall (rep :: * -> *) p. GLabels rep => GHKD_ (Const String) rep p
glabel

instance GLabels inner
    => GLabels (C1 ('MetaCons name fixity 'True) inner) where
  glabel :: GHKD_ (Const String) (C1 ('MetaCons name fixity 'True) inner) p
glabel = GHKD_ (Const String) inner p
-> M1
     C ('MetaCons name fixity 'True) (GHKD_ (Const String) inner) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 GHKD_ (Const String) inner p
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 :: GHKD_ (Const String) (C1 ('MetaCons name fixity 'False) inner) p
glabel = GHKD_ (Const String) (C1 ('MetaCons name fixity 'False) inner) p
forall a. HasCallStack => a
undefined

instance KnownSymbol name
    => GLabels (S1 ('MetaSel ('Just name) i d c) (K1 index inner)) where
  glabel :: GHKD_
  (Const String)
  (S1 ('MetaSel ('Just name) i d c) (K1 index inner))
  p
glabel = K1 index (Const String inner) p
-> M1
     S ('MetaSel ('Just name) i d c) (K1 index (Const String inner)) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Const String inner -> K1 index (Const String inner) p
forall k i c (p :: k). c -> K1 i c p
K1 (String -> Const String inner
forall k a (b :: k). a -> Const a b
Const (Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name
forall k (t :: k). Proxy t
Proxy @name))))

instance (GLabels left, GLabels right) => GLabels (left :*: right) where
  glabel :: GHKD_ (Const String) (left :*: right) p
glabel = GHKD_ (Const String) left p
forall (rep :: * -> *) p. GLabels rep => GHKD_ (Const String) rep p
glabel GHKD_ (Const String) left p
-> GHKD_ (Const String) right p
-> (:*:) (GHKD_ (Const String) left) (GHKD_ (Const String) right) p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: GHKD_ (Const String) right 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 = HKD_ (Const String) structure Void -> HKD structure (Const String)
forall structure (f :: * -> *).
HKD_ f structure Void -> HKD structure f
HKD HKD_ (Const String) structure Void
forall (rep :: * -> *) p. GLabels rep => GHKD_ (Const String) rep p
glabel

-- | Because all HKD types are valid barbies, and we have the above mechanism
-- for extracting field names, we can ask some pretty interesting questions.
--
-- >>> import Control.Lens
-- >>> import Data.Maybe (isNothing)
-- >>> import Data.Monoid (Last (..))
-- >>> import Data.Generic.HKD
--
-- Let's imagine, for example, that we're half way through filling in a user's
-- details:
--
-- >>> data User = User { name :: String, age :: Int } deriving Generic
-- >>> test = mempty @(HKD User Last) & field @"name" .~ pure "Tom"
--
-- We want to send a JSON response back to the client containing the fields
-- that have yet to be finished. All we need to do is pick the fields where the
-- values are @Last Nothing@:
--
-- >>> labelsWhere (isNothing . getLast) test
-- ["age"]
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) -> HKD structure f -> [String]
labelsWhere forall a. f a -> Bool
p
  = Const [String] (HKD structure Maybe) -> [String]
forall a k (b :: k). Const a b -> a
getConst (Const [String] (HKD structure Maybe) -> [String])
-> (HKD structure f -> Const [String] (HKD structure Maybe))
-> HKD structure f
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Product (Const String) f a -> Const [String] (Maybe a))
-> HKD structure (Product (Const String) f)
-> Const [String] (HKD structure Maybe)
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 (HKD structure (Product (Const String) f)
 -> Const [String] (HKD structure Maybe))
-> (HKD structure f -> HKD structure (Product (Const String) f))
-> HKD structure f
-> Const [String] (HKD structure Maybe)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HKD structure (Const String)
-> HKD structure f -> HKD structure (Product (Const String) f)
forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
ApplicativeB b =>
b f -> b g -> b (Product f g)
bprod HKD structure (Const String)
forall structure. Label structure => HKD structure (Const String)
label
  where
    go :: Product (Const String) f a -> (Const [String]) (Maybe a)
    go :: Product (Const String) f a -> Const [String] (Maybe a)
go (Pair (Const String
key) f a
value) = [String] -> Const [String] (Maybe a)
forall k a (b :: k). a -> Const a b
Const if f a -> Bool
forall a. f a -> Bool
p f a
value then [String
key] else []