{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
--  Module      : Data.Text.Display.Generic
--  Copyright   : © Jonathan Lorimer, 2023
--  License     : MIT
--  Maintainer  : jonathanlorimer@pm.me
--  Stability   : stable
--
--  Generic machinery for automatically deriving display instances for record types
module Data.Text.Display.Generic where

import Data.Kind
import Data.Text.Display.Core
import Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.Lazy.Builder as TB
import Data.Type.Bool
import GHC.Generics
import GHC.TypeLits

-- | Generic typeclass machinery for inducting on the structure
-- of the type, such that we can thread `Display` instances through
-- the structure of the type. The primary use case is for implementing
-- `RecordInstance`, which does this "threading" for record fields. This
-- machinery does, crucially, depend on child types (i.e. the type of a
-- record field) having a `Display` instance.
--
-- @since 0.0.5.0
class GDisplay1 f where
  gdisplayBuilder1 :: f p -> Builder

instance GDisplay1 V1 where
  gdisplayBuilder1 :: forall p. V1 p -> Builder
gdisplayBuilder1 V1 p
x = case V1 p
x of {}

instance GDisplay1 U1 where
  gdisplayBuilder1 :: forall p. U1 p -> Builder
gdisplayBuilder1 U1 p
_ = Builder
"()"

-- | This is the most important instance, it can be considered as the "base case". It
-- requires a non-generic `Display` instance. All this generic machinery can be conceptualized
-- as distributing these `displayBuilder` calls across a product type.
instance Display c => GDisplay1 (K1 i c) where
  gdisplayBuilder1 :: forall p. K1 i c p -> Builder
gdisplayBuilder1 (K1 c
a) = forall a. Display a => a -> Builder
displayBuilder c
a

instance (Constructor c, GDisplay1 f) => GDisplay1 (M1 C c f) where
  gdisplayBuilder1 :: forall p. M1 C c f p -> Builder
gdisplayBuilder1 c :: M1 C c f p
c@(M1 f p
a)
    | forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Bool
conIsRecord M1 C c f p
c = String -> Builder
TB.fromString (forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName M1 C c f p
c) forall a. Semigroup a => a -> a -> a
<> Builder
"\n  { " forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) p. GDisplay1 f => f p -> Builder
gdisplayBuilder1 f p
a forall a. Semigroup a => a -> a -> a
<> Builder
"\n  }"
    | forall p. C1 c f p -> Bool
conIsTuple M1 C c f p
c = String -> Builder
TB.fromString (forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName M1 C c f p
c) forall a. Semigroup a => a -> a -> a
<> Builder
" ( " forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) p. GDisplay1 f => f p -> Builder
gdisplayBuilder1 f p
a forall a. Semigroup a => a -> a -> a
<> Builder
" )"
    | Bool
otherwise = String -> Builder
TB.fromString (forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName M1 C c f p
c) forall a. Semigroup a => a -> a -> a
<> Builder
" " forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) p. GDisplay1 f => f p -> Builder
gdisplayBuilder1 f p
a
    where
      conIsTuple :: C1 c f p -> Bool
      conIsTuple :: forall p. C1 c f p -> Bool
conIsTuple C1 c f p
y =
        String -> Bool
tupleName (forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName C1 c f p
y)
        where
          tupleName :: String -> Bool
tupleName (Char
'(' : Char
',' : String
_) = Bool
True
          tupleName String
_ = Bool
False

instance (Selector s, GDisplay1 f) => GDisplay1 (M1 S s f) where
  gdisplayBuilder1 :: forall p. M1 S s f p -> Builder
gdisplayBuilder1 s :: M1 S s f p
s@(M1 f p
a) =
    if forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName M1 S s f p
s forall a. Eq a => a -> a -> Bool
== String
""
      then forall (f :: * -> *) p. GDisplay1 f => f p -> Builder
gdisplayBuilder1 f p
a
      else String -> Builder
TB.fromString (forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName M1 S s f p
s) forall a. Semigroup a => a -> a -> a
<> Builder
" = " forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) p. GDisplay1 f => f p -> Builder
gdisplayBuilder1 f p
a

instance GDisplay1 f => GDisplay1 (M1 D s f) where
  gdisplayBuilder1 :: forall p. M1 D s f p -> Builder
gdisplayBuilder1 (M1 f p
a) = forall (f :: * -> *) p. GDisplay1 f => f p -> Builder
gdisplayBuilder1 f p
a

instance (GDisplay1 a, GDisplay1 b) => GDisplay1 (a :*: b) where
  gdisplayBuilder1 :: forall p. (:*:) a b p -> Builder
gdisplayBuilder1 (a p
a :*: b p
b) = forall (f :: * -> *) p. GDisplay1 f => f p -> Builder
gdisplayBuilder1 a p
a forall a. Semigroup a => a -> a -> a
<> Builder
"\n  , " forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) p. GDisplay1 f => f p -> Builder
gdisplayBuilder1 b p
b

instance (GDisplay1 a, GDisplay1 b) => GDisplay1 (a :+: b) where
  gdisplayBuilder1 :: forall p. (:+:) a b p -> Builder
gdisplayBuilder1 (L1 a p
a) = forall (f :: * -> *) p. GDisplay1 f => f p -> Builder
gdisplayBuilder1 a p
a
  gdisplayBuilder1 (R1 b p
b) = forall (f :: * -> *) p. GDisplay1 f => f p -> Builder
gdisplayBuilder1 b p
b

gdisplayBuilderDefault :: (Generic a, GDisplay1 (Rep a)) => a -> Builder
gdisplayBuilderDefault :: forall a. (Generic a, GDisplay1 (Rep a)) => a -> Builder
gdisplayBuilderDefault = forall (f :: * -> *) p. GDisplay1 f => f p -> Builder
gdisplayBuilder1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from

-- | This wrapper allows you to create an `Display` instance for a record,
-- so long as all the record fields have a `Display` instance as well.
--
-- === Example
--
-- > data Password = Password
-- >  deriving Display
-- >    via (OpaqueInstance "[REDACTED]" Password)
--
-- > data MyRecord =
-- >    MyRecord
-- >      { fieldA :: String
-- >      , fieldB :: Maybe String
-- >      , fieldC :: Int
-- >      , pword :: Password
-- >      }
-- >      deriving stock (Generic)
-- >      deriving (Display) via (RecordInstance MyRecord)
--
-- > putStrLn . Data.Text.unpack . display $ MyRecord "hello" (Just "world") 22 Password
--
-- > MyRecord
-- >   { fieldA = hello
-- >   , fieldB = Just world
-- >   , fieldC = 22
-- >   , pword = [REDACTED]
-- >   }
--
-- @since 0.0.5.0
newtype RecordInstance a = RecordInstance {forall a. RecordInstance a -> a
unDisplayProduct :: a}

instance Generic a => Generic (RecordInstance a) where
  type Rep (RecordInstance a) = Rep a
  to :: forall x. Rep (RecordInstance a) x -> RecordInstance a
to = forall a. a -> RecordInstance a
RecordInstance forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => Rep a x -> a
to
  from :: forall x. RecordInstance a -> Rep (RecordInstance a) x
from (RecordInstance a
x) = forall a x. Generic a => a -> Rep a x
from a
x

-- | We leverage the `AssertNoSum` type family to prevent consumers
-- from deriving instances for sum types. Sum types should use a manual instance
-- or derive one via `ShowInstance`.
--
-- @since 0.0.5.0
instance (AssertNoSumRecordInstance Display a, Generic a, GDisplay1 (Rep a)) => Display (RecordInstance a) where
  displayBuilder :: RecordInstance a -> Builder
displayBuilder = forall a. (Generic a, GDisplay1 (Rep a)) => a -> Builder
gdisplayBuilderDefault

-- | This type family is lifted from generic-data. We use it to prevent the user from
-- deriving a `RecordInstance` for sum types
--
-- @since 0.0.5.0
type family HasSum f where
  HasSum V1 = 'False
  HasSum U1 = 'False
  HasSum (K1 i c) = 'False
  HasSum (M1 i c f) = HasSum f
  HasSum (f :*: g) = HasSum f || HasSum g
  HasSum (f :+: g) = 'True

class Assert (pred :: Bool) (msg :: ErrorMessage)
instance Assert 'True msg
instance TypeError msg ~ '() => Assert 'False msg

-- | Constraint to prevent misuse of `RecordInstance` deriving via mechanism.
--
-- === Example
--
-- > data MySum = A | B | C deriving stock (Generic) deriving (Display) via (RecordInstance MySum)
--
-- >    • 🚫 Cannot derive Display instance for MySum via RecordInstance due to sum type
-- >      💡 Sum types should use a manual instance or derive one via ShowInstance.
-- >    • When deriving the instance for (Display MySum)
--
-- @since 0.0.5.0
type AssertNoSumRecordInstance (constraint :: Type -> Constraint) a =
  Assert
    (Not (HasSum (Rep a)))
    ( 'Text "🚫 Cannot derive "
        ':<>: 'ShowType constraint
        ':<>: 'Text " instance for "
        ':<>: 'ShowType a
        ':<>: 'Text " via RecordInstance due to sum type"
        ':$$: 'Text "💡 Sum types should use a manual instance or derive one via ShowInstance."
    )