{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UnboxedSums #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UnliftedNewtypes #-}

module Debug.TraceEmbrace.ShowTh where

import GHC.Exts
import Language.Haskell.TH
import Prelude hiding (Show (..))

-- | Levity polymorphic version 'P.Show'.
class Show (t :: TYPE r) where
  show :: t -> String

-- | https://gitlab.haskell.org/ghc/ghc/-/issues/25776
deriveShowTuple1 :: Name -> Q [Dec]
deriveShowTuple1 :: Name -> Q [Dec]
deriveShowTuple1 Name
a = [d|
  instance Show (# $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
a) #) where
    show (# a# #) = "(# " <> show a# <> " #)"
  |]

deriveShowTuple2 :: Name -> Name -> Q [Dec]
deriveShowTuple2 :: Name -> Name -> Q [Dec]
deriveShowTuple2 Name
a Name
b = [d|
  instance Show (# $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
a), $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
b) #) where
    show (# a#, b# #) = "(# " <> show a# <> ", " <> show b# <> " #)"
  |]

deriveShowTuple3 :: Name -> Name -> Name -> Q [Dec]
deriveShowTuple3 :: Name -> Name -> Name -> Q [Dec]
deriveShowTuple3 Name
a Name
b Name
c = [d|
  instance Show (# $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
a), $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
b), $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
c) #) where
    show (# a#, b#, c# #) = "(# " <> show a# <> ", " <> show b# <> ", " <> show c# <> " #)"
  |]

deriveShowTuple4 :: Name -> Name -> Name -> Name -> Q [Dec]
deriveShowTuple4 :: Name -> Name -> Name -> Name -> Q [Dec]
deriveShowTuple4 Name
a Name
b Name
c Name
d = [d|
  instance Show (# $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
a), $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
b), $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
c), $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
d) #) where
    show (# a#, b#, c#, d# #) = "(# " <> show a# <> ", " <> show b# <> ", " <> show c# <> ", " <> show d# <> " #)"
  |]

deriveShowSum2 :: Name -> Name -> Q [Dec]
deriveShowSum2 :: Name -> Name -> Q [Dec]
deriveShowSum2 Name
a Name
b = [d|
  instance Show (# $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
a) | $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
b) #) where
    show (# a# | #) = "(# " <> show a# <> " | #)"
    show (# | b# #) = "(# | " <> show b# <> " #)"
  |]

deriveShowSum3 :: Name -> Name -> Name -> Q [Dec]
deriveShowSum3 :: Name -> Name -> Name -> Q [Dec]
deriveShowSum3 Name
a Name
b Name
c = [d|
  instance Show (# $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
a) | $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
b) | $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
c) #) where
    show (# x# | | #) = "(# " <> show x# <> " | | #)"
    show (# | x# | #) = "(# | " <> show x# <> " | #)"
    show (# | | x# #) = "(# | | " <> show x# <> " #)"
  |]

deriveShowSum4 :: Name -> Name -> Name -> Name -> Q [Dec]
deriveShowSum4 :: Name -> Name -> Name -> Name -> Q [Dec]
deriveShowSum4 Name
a Name
b Name
c Name
d = [d|
  instance Show (# $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
a) | $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
b) | $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
c) | $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
d) #) where
    show (# x# | | | #) = "(# " <> show x# <> " | | | #)"
    show (# | x# | | #) = "(# | " <> show x# <> " | | #)"
    show (# | | x# | #) = "(# | | " <> show x# <> " | #)"
    show (# | | | x# #) = "(# | | | " <> show x# <> " #)"
  |]

unTypes :: [Name]
unTypes :: [Name]
unTypes = [''Int#, ''Char#, ''Double#, ''Float#, ''Addr#]