module DebugPrint.Core
  ( DebugPrintRecord (..)
  , DebugPrintValue (..)
  , ToDebugPrintValue (..)
  , ToDebugPrintRecord (..)
  , ToDebugPrintValueRep
  , ToDebugPrintRecordRep
  , DebugInteger (..)
  , DebugShow (..)
  ) where

import Prelude

import Data.Foldable (toList)
import Data.Int
import Data.Kind (Type)
import Data.List.NonEmpty (NonEmpty)
import Data.Map (Map)
import Data.Map.Strict qualified as Map
import Data.Sequence (Seq)
import Data.String (IsString (..))
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Vector (Vector)
import Data.Vector qualified as V
import Data.Word
import GHC.Generics
import Numeric.Natural (Natural)

newtype DebugPrintRecord = DebugPrintRecord (Map Text DebugPrintValue)
  deriving newtype (Semigroup DebugPrintRecord
DebugPrintRecord
Semigroup DebugPrintRecord =>
DebugPrintRecord
-> (DebugPrintRecord -> DebugPrintRecord -> DebugPrintRecord)
-> ([DebugPrintRecord] -> DebugPrintRecord)
-> Monoid DebugPrintRecord
[DebugPrintRecord] -> DebugPrintRecord
DebugPrintRecord -> DebugPrintRecord -> DebugPrintRecord
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: DebugPrintRecord
mempty :: DebugPrintRecord
$cmappend :: DebugPrintRecord -> DebugPrintRecord -> DebugPrintRecord
mappend :: DebugPrintRecord -> DebugPrintRecord -> DebugPrintRecord
$cmconcat :: [DebugPrintRecord] -> DebugPrintRecord
mconcat :: [DebugPrintRecord] -> DebugPrintRecord
Monoid, NonEmpty DebugPrintRecord -> DebugPrintRecord
DebugPrintRecord -> DebugPrintRecord -> DebugPrintRecord
(DebugPrintRecord -> DebugPrintRecord -> DebugPrintRecord)
-> (NonEmpty DebugPrintRecord -> DebugPrintRecord)
-> (forall b.
    Integral b =>
    b -> DebugPrintRecord -> DebugPrintRecord)
-> Semigroup DebugPrintRecord
forall b. Integral b => b -> DebugPrintRecord -> DebugPrintRecord
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: DebugPrintRecord -> DebugPrintRecord -> DebugPrintRecord
<> :: DebugPrintRecord -> DebugPrintRecord -> DebugPrintRecord
$csconcat :: NonEmpty DebugPrintRecord -> DebugPrintRecord
sconcat :: NonEmpty DebugPrintRecord -> DebugPrintRecord
$cstimes :: forall b. Integral b => b -> DebugPrintRecord -> DebugPrintRecord
stimes :: forall b. Integral b => b -> DebugPrintRecord -> DebugPrintRecord
Semigroup)

data DebugPrintValue
  = DebugPrintValueInt Integer
  | DebugPrintValueText Text
  | DebugPrintValueBool Bool
  | DebugPrintValueVector (Vector DebugPrintValue)
  | DebugPrintValueRecord DebugPrintRecord

instance IsString DebugPrintValue where
  fromString :: String -> DebugPrintValue
fromString = Text -> DebugPrintValue
DebugPrintValueText (Text -> DebugPrintValue)
-> (String -> Text) -> String -> DebugPrintValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

---

class ToDebugPrintValue a where
  toDebugPrintValue :: a -> DebugPrintValue
  default toDebugPrintValue
    :: (Generic a, ToDebugPrintRecordRep (Rep a)) => a -> DebugPrintValue
  toDebugPrintValue = DebugPrintRecord -> DebugPrintValue
DebugPrintValueRecord (DebugPrintRecord -> DebugPrintValue)
-> (a -> DebugPrintRecord) -> a -> DebugPrintValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a Any -> DebugPrintRecord
forall a. Rep a a -> DebugPrintRecord
forall (f :: * -> *) a.
ToDebugPrintRecordRep f =>
f a -> DebugPrintRecord
gToRecord (Rep a Any -> DebugPrintRecord)
-> (a -> Rep a Any) -> a -> DebugPrintRecord
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from

instance ToDebugPrintValue DebugPrintValue where
  toDebugPrintValue :: DebugPrintValue -> DebugPrintValue
toDebugPrintValue = DebugPrintValue -> DebugPrintValue
forall a. a -> a
id

instance ToDebugPrintValue Integer where
  toDebugPrintValue :: Integer -> DebugPrintValue
toDebugPrintValue = Integer -> DebugPrintValue
DebugPrintValueInt

deriving via DebugInteger (Natural) instance ToDebugPrintValue Natural
deriving via DebugInteger (Int) instance ToDebugPrintValue Int
deriving via DebugInteger (Int8) instance ToDebugPrintValue Int8
deriving via DebugInteger (Int16) instance ToDebugPrintValue Int16
deriving via DebugInteger (Int32) instance ToDebugPrintValue Int32
deriving via DebugInteger (Int64) instance ToDebugPrintValue Int64
deriving via DebugInteger (Word) instance ToDebugPrintValue Word
deriving via DebugInteger (Word8) instance ToDebugPrintValue Word8
deriving via DebugInteger (Word16) instance ToDebugPrintValue Word16
deriving via DebugInteger (Word32) instance ToDebugPrintValue Word32
deriving via DebugInteger (Word64) instance ToDebugPrintValue Word64

instance ToDebugPrintValue Char where
  toDebugPrintValue :: Char -> DebugPrintValue
toDebugPrintValue = Text -> DebugPrintValue
DebugPrintValueText (Text -> DebugPrintValue)
-> (Char -> Text) -> Char -> DebugPrintValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton

instance ToDebugPrintValue T.Text where
  toDebugPrintValue :: Text -> DebugPrintValue
toDebugPrintValue = Text -> DebugPrintValue
DebugPrintValueText

instance ToDebugPrintValue TL.Text where
  toDebugPrintValue :: Text -> DebugPrintValue
toDebugPrintValue = Text -> DebugPrintValue
DebugPrintValueText (Text -> DebugPrintValue)
-> (Text -> Text) -> Text -> DebugPrintValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.toStrict

instance ToDebugPrintValue Bool where
  toDebugPrintValue :: Bool -> DebugPrintValue
toDebugPrintValue = Bool -> DebugPrintValue
DebugPrintValueBool

instance ToDebugPrintValue a => ToDebugPrintValue (Maybe a) where
  toDebugPrintValue :: Maybe a -> DebugPrintValue
toDebugPrintValue = [a] -> DebugPrintValue
forall a. ToDebugPrintValue a => a -> DebugPrintValue
toDebugPrintValue ([a] -> DebugPrintValue)
-> (Maybe a -> [a]) -> Maybe a -> DebugPrintValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> [a]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

instance ToDebugPrintValue a => ToDebugPrintValue [a] where
  toDebugPrintValue :: [a] -> DebugPrintValue
toDebugPrintValue = Vector a -> DebugPrintValue
forall a. ToDebugPrintValue a => a -> DebugPrintValue
toDebugPrintValue (Vector a -> DebugPrintValue)
-> ([a] -> Vector a) -> [a] -> DebugPrintValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Vector a
forall a. [a] -> Vector a
V.fromList

instance ToDebugPrintValue a => ToDebugPrintValue (NonEmpty a) where
  toDebugPrintValue :: NonEmpty a -> DebugPrintValue
toDebugPrintValue = [a] -> DebugPrintValue
forall a. ToDebugPrintValue a => a -> DebugPrintValue
toDebugPrintValue ([a] -> DebugPrintValue)
-> (NonEmpty a -> [a]) -> NonEmpty a -> DebugPrintValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

instance ToDebugPrintValue a => ToDebugPrintValue (Seq a) where
  toDebugPrintValue :: Seq a -> DebugPrintValue
toDebugPrintValue = [a] -> DebugPrintValue
forall a. ToDebugPrintValue a => a -> DebugPrintValue
toDebugPrintValue ([a] -> DebugPrintValue)
-> (Seq a -> [a]) -> Seq a -> DebugPrintValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq a -> [a]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

instance ToDebugPrintValue a => ToDebugPrintValue (Vector a) where
  toDebugPrintValue :: Vector a -> DebugPrintValue
toDebugPrintValue = Vector DebugPrintValue -> DebugPrintValue
DebugPrintValueVector (Vector DebugPrintValue -> DebugPrintValue)
-> (Vector a -> Vector DebugPrintValue)
-> Vector a
-> DebugPrintValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> DebugPrintValue) -> Vector a -> Vector DebugPrintValue
forall a b. (a -> b) -> Vector a -> Vector b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> DebugPrintValue
forall a. ToDebugPrintValue a => a -> DebugPrintValue
toDebugPrintValue

---

class ToDebugPrintRecord a where
  toDebugPrintRecord :: a -> DebugPrintRecord
  default toDebugPrintRecord
    :: (Generic a, ToDebugPrintRecordRep (Rep a)) => a -> DebugPrintRecord
  toDebugPrintRecord = Rep a Any -> DebugPrintRecord
forall a. Rep a a -> DebugPrintRecord
forall (f :: * -> *) a.
ToDebugPrintRecordRep f =>
f a -> DebugPrintRecord
gToRecord (Rep a Any -> DebugPrintRecord)
-> (a -> Rep a Any) -> a -> DebugPrintRecord
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from

instance ToDebugPrintRecord DebugPrintRecord where
  toDebugPrintRecord :: DebugPrintRecord -> DebugPrintRecord
toDebugPrintRecord = DebugPrintRecord -> DebugPrintRecord
forall a. a -> a
id

---

class ToDebugPrintValueRep (f :: Type -> Type) where
  gToValue :: f a -> DebugPrintValue

instance ToDebugPrintValue a => ToDebugPrintValueRep (K1 i a) where
  gToValue :: forall a. K1 i a a -> DebugPrintValue
gToValue (K1 a
x) = a -> DebugPrintValue
forall a. ToDebugPrintValue a => a -> DebugPrintValue
toDebugPrintValue a
x

---

class ToDebugPrintRecordRep (f :: Type -> Type) where
  gToRecord :: f a -> DebugPrintRecord

instance ToDebugPrintRecordRep U1 where
  gToRecord :: forall a. U1 a -> DebugPrintRecord
gToRecord U1 a
_ = Map Text DebugPrintValue -> DebugPrintRecord
DebugPrintRecord Map Text DebugPrintValue
forall a. Monoid a => a
mempty

instance
  (ToDebugPrintRecordRep f, ToDebugPrintRecordRep g)
  => ToDebugPrintRecordRep (f :*: g)
  where
  gToRecord :: forall a. (:*:) f g a -> DebugPrintRecord
gToRecord (f a
x :*: g a
y) = f a -> DebugPrintRecord
forall a. f a -> DebugPrintRecord
forall (f :: * -> *) a.
ToDebugPrintRecordRep f =>
f a -> DebugPrintRecord
gToRecord f a
x DebugPrintRecord -> DebugPrintRecord -> DebugPrintRecord
forall a. Semigroup a => a -> a -> a
<> g a -> DebugPrintRecord
forall a. g a -> DebugPrintRecord
forall (f :: * -> *) a.
ToDebugPrintRecordRep f =>
f a -> DebugPrintRecord
gToRecord g a
y

instance ToDebugPrintRecordRep f => ToDebugPrintRecordRep (D1 i f) where
  gToRecord :: forall a. D1 i f a -> DebugPrintRecord
gToRecord (M1 f a
x) = f a -> DebugPrintRecord
forall a. f a -> DebugPrintRecord
forall (f :: * -> *) a.
ToDebugPrintRecordRep f =>
f a -> DebugPrintRecord
gToRecord f a
x

instance ToDebugPrintRecordRep f => ToDebugPrintRecordRep (C1 i f) where
  gToRecord :: forall a. C1 i f a -> DebugPrintRecord
gToRecord (M1 f a
x) = f a -> DebugPrintRecord
forall a. f a -> DebugPrintRecord
forall (f :: * -> *) a.
ToDebugPrintRecordRep f =>
f a -> DebugPrintRecord
gToRecord f a
x

instance (Selector s, ToDebugPrintValueRep f) => ToDebugPrintRecordRep (S1 s f) where
  gToRecord :: forall a. S1 s f a -> DebugPrintRecord
gToRecord s1 :: S1 s f a
s1@(M1 f a
x) = Map Text DebugPrintValue -> DebugPrintRecord
DebugPrintRecord (Map Text DebugPrintValue -> DebugPrintRecord)
-> Map Text DebugPrintValue -> DebugPrintRecord
forall a b. (a -> b) -> a -> b
$ case f a -> DebugPrintValue
forall a. f a -> DebugPrintValue
forall (f :: * -> *) a.
ToDebugPrintValueRep f =>
f a -> DebugPrintValue
gToValue f a
x of
    DebugPrintValueText Text
y | Text -> Bool
T.null Text
y -> Map Text DebugPrintValue
forall k a. Map k a
Map.empty
    DebugPrintValueVector Vector DebugPrintValue
y | Vector DebugPrintValue -> Bool
forall a. Vector a -> Bool
V.null Vector DebugPrintValue
y -> Map Text DebugPrintValue
forall k a. Map k a
Map.empty
    DebugPrintValueRecord (DebugPrintRecord Map Text DebugPrintValue
y) | Map Text DebugPrintValue -> Bool
forall k a. Map k a -> Bool
Map.null Map Text DebugPrintValue
y -> Map Text DebugPrintValue
forall k a. Map k a
Map.empty
    DebugPrintValue
y -> Text -> DebugPrintValue -> Map Text DebugPrintValue
forall k a. k -> a -> Map k a
Map.singleton (String -> Text
T.pack (S1 s f a -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t s f a -> String
selName S1 s f a
s1)) DebugPrintValue
y

---

-- | For use with deriving-via, provides a simple 'ToDebugPrintValue'
--   instance based on 'Show' which renders as text
newtype DebugShow a = DebugShow a

instance Show a => ToDebugPrintValue (DebugShow a) where
  toDebugPrintValue :: DebugShow a -> DebugPrintValue
toDebugPrintValue (DebugShow a
x) =
    Text -> DebugPrintValue
forall a. ToDebugPrintValue a => a -> DebugPrintValue
toDebugPrintValue (Text -> DebugPrintValue) -> Text -> DebugPrintValue
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
x

---

-- | For use with deriving-via, provides a simple 'ToDebugPrintValue'
--   instance based on 'toInteger' which renders as an integer
newtype DebugInteger a = DebugInteger a

instance Integral a => ToDebugPrintValue (DebugInteger a) where
  toDebugPrintValue :: DebugInteger a -> DebugPrintValue
toDebugPrintValue (DebugInteger a
x) =
    Integer -> DebugPrintValue
forall a. ToDebugPrintValue a => a -> DebugPrintValue
toDebugPrintValue (Integer -> DebugPrintValue) -> Integer -> DebugPrintValue
forall a b. (a -> b) -> a -> b
$ a -> Integer
forall a. Integral a => a -> Integer
toInteger a
x