ShowFirstField.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

-- Only needed in the last section:
-- {-# LANGUAGE UndecidableInstances #-}

module ShowFirstField where

import Data.Proxy (Proxy)
import Data.Kind (Type, Constraint)
import qualified GHC.Generics as GHC
import Generics.SOP as SOP

-- | Just a shorter name for 'Proxy'
p :: forall {k} (a :: k). Proxy a
p = Proxy


-- * The issue

-- | Sample datatype
data MyType a = My1 Int | My2 Bool | My3 a

-- | Suppose we want a 'Show' instance for 'MyType' that skips the constructor names.
-- While the following works, it is clearly boilerplate code that we would like to avoid
-- repeating all over the place.
instance (Show a) => Show (MyType a) where
    show (My1 x) = show x
    show (My2 x) = show x
    show (My3 x) = show x

-- * A generic solution based on generics-sop

showSingleField :: (IsSingleFieldType a, All2 Show (Code a)) => a -> String
showSingleField = hcfoldMap (p @Show) (show . unI) . from

type IsSingleFieldType a = (Generic a, IsSingleFieldTypeF (Code a))

-- | Translate a @Code a@ into @Constraint@s that can be satisfied if and only if
-- the type @a@ has at least one constructor and each constructor has exactly one field.
-- 
-- Of course, the second equation is simply @IsSingleFieldTypeF' (x:xs)@,
-- but expanding it like this, we can avoid @UndecidableInstances@. :)
type family IsSingleFieldTypeF (code :: [[Type]]) :: Constraint where
    IsSingleFieldTypeF '[] = IsntSingleFieldType -- no constructor
    IsSingleFieldTypeF (x:xs) = (HasSingleField x, IsSingleFieldTypeF' xs)
type family IsSingleFieldTypeF' (code :: [[Type]]) :: Constraint where
    IsSingleFieldTypeF' '[] = ()
    IsSingleFieldTypeF' (x:xs) = (HasSingleField x, IsSingleFieldTypeF' xs)

type family HasSingleField (code :: [Type]) :: Constraint where
    HasSingleField '[_] = () -- constructor has a single field (empty constraint)
    HasSingleField _ = IsntSingleFieldType -- constructor has no fields or more than one

-- | This is a bit of a hack to get a somewhat meaningful error message in case
-- the constraint @IsSingleFieldType a@ cannot be satisfied.
data IsSingleFieldTypeNope = IsSingleFieldTypeNope
type IsntSingleFieldType = () ~ IsSingleFieldTypeNope

-- | Sample datatype, revisited
data MyType' a = My1' Int | My2' Bool | My3' a
    deriving (GHC.Generic, SOP.Generic)

-- | Now we can simply use our generic 'showSingleField' to define the instance:
instance (Show a) => Show (MyType' a) where
    show = showSingleField

-- * DerivingVia

-- | Using the 'FirstField' wrapper and @DerivingVia@, we can even derive such instances.
newtype FirstField a = FirstField { unFirstField :: a }

-- | We use this helper class with a default signature to avoid @UndecidableInstances@.
class DefaultShowSingleField a where
    defaultShowSingleField :: a -> String
    default defaultShowSingleField :: (IsSingleFieldType a, All2 Show (Code a)) => a -> String
    defaultShowSingleField = showSingleField

instance (DefaultShowSingleField a) => Show (FirstField a) where
    show = defaultShowSingleField . unFirstField

-- | Sample datatype, again.
-- 
-- >>> My2'' True
-- True
data MyType'' a = My1'' Int | My2'' Bool | My3'' a
    deriving stock (GHC.Generic)
    deriving anyclass (SOP.Generic, DefaultShowSingleField)
    deriving Show via (FirstField (MyType'' a))

{-
-- (To enable this section, remove the @Show (FirstField a)@ instance in line 89,
-- and allow @UndecidableInstances@ at the top.)

-- * With @UndecidableInstances@

-- | If one is willing to use @UndecidableInstances@ (which is much less scary than it sounds),
-- the following alternative instance is also possible:
instance (IsSingleFieldType a, All2 Show (Code a)) => Show (FirstField a) where
    show = showSingleField . unFirstField

-- | Deriving our custom 'Show' instance is then as simple as:
data MyType''' a = My1''' Int | My2''' Bool | My3''' a
    deriving (GHC.Generic, SOP.Generic)
    deriving Show via (FirstField (MyType''' a))
-}