Labels.hs

{-# 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 = M1 glabel

instance GLabels inner
    => GLabels (C1 ('MetaCons name fixity 'True) inner) where
  glabel = M1 glabel

instance TypeError ('Text "You can't collect labels for a non-record type!")
    => GLabels (C1 ('MetaCons name fixity 'False) inner) where
  glabel = undefined

instance KnownSymbol name
    => GLabels (S1 ('MetaSel ('Just name) i d c) (K1 index inner)) where
  glabel = M1 (K1 (Const (symbolVal (Proxy @name))))

instance (GLabels left, GLabels right) => GLabels (left :*: right) where
  glabel = glabel :*: glabel

instance (Generic structure, GLabels (Rep structure)) => Label structure where
  label = HKD 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 p
  = getConst . btraverse go . bprod label
  where
    go :: Product (Const String) f a -> (Const [String]) (Maybe a)
    go (Pair (Const key) value) = Const if p value then [key] else []