{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}

-- |
-- Module      :   Grisette.Internal.TH.Derivation.DeriveShow
-- Copyright   :   (c) Sirui Lu 2024
-- License     :   BSD-3-Clause (see the LICENSE file)
--
-- Maintainer  :   siruilu@cs.washington.edu
-- Stability   :   Experimental
-- Portability :   GHC only
module Grisette.Internal.TH.Derivation.DeriveShow
  ( deriveShow,
    deriveShow1,
    deriveShow2,
  )
where

import Data.Functor.Classes
  ( Show1 (liftShowList, liftShowsPrec),
    Show2 (liftShowList2, liftShowsPrec2),
  )
import qualified Data.List as List
import Data.Maybe (fromMaybe)
import GHC.Show (appPrec, appPrec1)
import Grisette.Internal.TH.Derivation.Common (DeriveConfig)
import Grisette.Internal.TH.Derivation.ShowPPrintCommon (showPrintFieldFunExp)
import Grisette.Internal.TH.Derivation.UnaryOpCommon
  ( UnaryOpClassConfig
      ( UnaryOpClassConfig,
        unaryOpAllowExistential,
        unaryOpConfigs,
        unaryOpContextNames,
        unaryOpExtraVars,
        unaryOpInstanceNames,
        unaryOpInstanceTypeFromConfig
      ),
    UnaryOpConfig (UnaryOpConfig),
    UnaryOpFieldConfig
      ( UnaryOpFieldConfig,
        extraLiftedPatNames,
        extraPatNames,
        fieldCombineFun,
        fieldFunExp,
        fieldResFun
      ),
    defaultUnaryOpInstanceTypeFromConfig,
    genUnaryOpClass,
  )
import Grisette.Internal.TH.Util (integerE, isNonUnitTuple)
import Language.Haskell.TH
  ( Dec,
    Fixity (Fixity),
    Name,
    Q,
    defaultFixity,
    integerL,
    listE,
    litE,
    nameBase,
    stringE,
  )
import Language.Haskell.TH.Datatype
  ( ConstructorVariant (InfixConstructor, NormalConstructor, RecordConstructor),
    reifyFixityCompat,
  )

showConfig :: UnaryOpClassConfig
showConfig :: UnaryOpClassConfig
showConfig =
  UnaryOpClassConfig
    { unaryOpConfigs :: [UnaryOpConfig]
unaryOpConfigs =
        [ UnaryOpFieldConfig -> [Name] -> UnaryOpConfig
forall config.
UnaryOpFunConfig config =>
config -> [Name] -> UnaryOpConfig
UnaryOpConfig
            UnaryOpFieldConfig
              { extraPatNames :: [String]
extraPatNames = [String
"prec"],
                extraLiftedPatNames :: Int -> [String]
extraLiftedPatNames = \Int
i -> ([String
"sl" | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0]),
                fieldCombineFun :: Int
-> Int
-> ConstructorVariant
-> Name
-> [Exp]
-> [Exp]
-> Q (Exp, [Bool])
fieldCombineFun =
                  \Int
_ Int
_ ConstructorVariant
variant Name
conName [Exp
prec] [Exp]
exps -> do
                    case (ConstructorVariant
variant, [Exp]
exps) of
                      (ConstructorVariant
NormalConstructor, []) -> do
                        r <- [|showString $(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
conName)|]
                        return (r, [False])
                      (ConstructorVariant
NormalConstructor, [Exp
exp]) -> do
                        r <-
                          [|
                            showParen
                              ($(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
prec) > $(Int -> Q Exp
forall a. Integral a => a -> Q Exp
integerE Int
appPrec))
                              ( showString $(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
conName)
                                  . showChar ' '
                                  . $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
exp)
                              )
                            |]
                        return (r, [True])
                      (ConstructorVariant
NormalConstructor, [Exp]
_) | Name -> Bool
isNonUnitTuple Name
conName -> do
                        let commaSeped :: [Q Exp]
commaSeped =
                              Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
List.intersperse [|showChar ','|] ([Q Exp] -> [Q Exp]) -> [Q Exp] -> [Q Exp]
forall a b. (a -> b) -> a -> b
$
                                Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> [Exp] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Exp]
exps
                        r <-
                          [|
                            showChar '('
                              . foldr1 (.) $([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [Q Exp]
commaSeped)
                              . showChar ')'
                            |]
                        return (r, [False])
                      (ConstructorVariant
NormalConstructor, [Exp]
_) -> do
                        let spaceSeped :: [Q Exp]
spaceSeped =
                              Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
List.intersperse [|showChar ' '|] ([Q Exp] -> [Q Exp]) -> [Q Exp] -> [Q Exp]
forall a b. (a -> b) -> a -> b
$
                                Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> [Exp] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Exp]
exps
                        r <-
                          [|
                            showParen
                              ($(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
prec) > $(Int -> Q Exp
forall a. Integral a => a -> Q Exp
integerE Int
appPrec))
                              ( showString $(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
conName)
                                  . showChar ' '
                                  . (foldr1 (.) $([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [Q Exp]
spaceSeped))
                              )
                            |]
                        return (r, [True])
                      (RecordConstructor [Name]
_, [Exp]
_) -> do
                        let commaSpaceSeped :: [Q Exp]
commaSpaceSeped =
                              Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
List.intersperse [|showString ", "|] ([Q Exp] -> [Q Exp]) -> [Q Exp] -> [Q Exp]
forall a b. (a -> b) -> a -> b
$
                                Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> [Exp] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Exp]
exps
                        r <-
                          [|
                            showString $(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
conName)
                              . showString " {"
                              . foldr1 (.) $([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [Q Exp]
commaSpaceSeped)
                              . showString "}"
                            |]
                        return (r, [False])
                      (ConstructorVariant
InfixConstructor, [Exp
l, Exp
r]) -> do
                        fi <-
                          Fixity -> Maybe Fixity -> Fixity
forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity (Maybe Fixity -> Fixity) -> Q (Maybe Fixity) -> Q Fixity
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> Q (Maybe Fixity)
reifyFixityCompat Name
conName
                        let conPrec = case Fixity
fi of Fixity Int
prec FixityDirection
_ -> Int
prec
                        r <-
                          [|
                            showParen
                              ($(return prec) > $(integerE conPrec))
                              ( $(return l)
                                  . showChar ' '
                                  . showString $(stringE $ nameBase conName)
                                  . showChar ' '
                                  . $(return r)
                              )
                            |]
                        return (r, [True])
                      (ConstructorVariant, [Exp])
_ ->
                        String -> Q (Exp, [Bool])
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"deriveShow: unexpected constructor variant",
                fieldResFun :: ConstructorVariant
-> Name -> [Exp] -> Int -> Exp -> Exp -> Q (Exp, [Bool])
fieldResFun = \ConstructorVariant
variant Name
conName [Exp]
_ Int
pos Exp
fieldPat Exp
fieldFun -> do
                  let makeShowField :: a -> m Exp
makeShowField a
p =
                        [|
                          $(Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
fieldFun)
                            $(Lit -> m Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> m Exp) -> Lit -> m Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
integerL (Integer -> Lit) -> Integer -> Lit
forall a b. (a -> b) -> a -> b
$ a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
p)
                            $(Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
fieldPat)
                          |]
                  let attachUsedInfo :: Q a -> Q (a, [Bool])
attachUsedInfo = ((,[Bool
False]) (a -> (a, [Bool])) -> Q a -> Q (a, [Bool])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
                  case ConstructorVariant
variant of
                    ConstructorVariant
NormalConstructor
                      | Name -> Bool
isNonUnitTuple Name
conName ->
                          Q Exp -> Q (Exp, [Bool])
forall {a}. Q a -> Q (a, [Bool])
attachUsedInfo (Q Exp -> Q (Exp, [Bool])) -> Q Exp -> Q (Exp, [Bool])
forall a b. (a -> b) -> a -> b
$ Integer -> Q Exp
forall {m :: * -> *} {a}. (Quote m, Integral a) => a -> m Exp
makeShowField Integer
0
                    ConstructorVariant
NormalConstructor ->
                      Q Exp -> Q (Exp, [Bool])
forall {a}. Q a -> Q (a, [Bool])
attachUsedInfo (Q Exp -> Q (Exp, [Bool])) -> Q Exp -> Q (Exp, [Bool])
forall a b. (a -> b) -> a -> b
$ Int -> Q Exp
forall {m :: * -> *} {a}. (Quote m, Integral a) => a -> m Exp
makeShowField Int
appPrec1
                    RecordConstructor [Name]
names ->
                      Q Exp -> Q (Exp, [Bool])
forall {a}. Q a -> Q (a, [Bool])
attachUsedInfo
                        [|
                          showString $(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase ([Name]
names [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
pos) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = ")
                            . $(Integer -> Q Exp
forall {m :: * -> *} {a}. (Quote m, Integral a) => a -> m Exp
makeShowField Integer
0)
                          |]
                    ConstructorVariant
InfixConstructor -> do
                      fi <-
                        Fixity -> Maybe Fixity -> Fixity
forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity (Maybe Fixity -> Fixity) -> Q (Maybe Fixity) -> Q Fixity
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> Q (Maybe Fixity)
reifyFixityCompat Name
conName
                      let conPrec = case Fixity
fi of Fixity Int
prec FixityDirection
_ -> Int
prec
                      attachUsedInfo $ makeShowField (conPrec + 1),
                fieldFunExp :: FieldFunExp
fieldFunExp =
                  [Name] -> [Name] -> FieldFunExp
showPrintFieldFunExp
                    ['showsPrec, 'liftShowsPrec, 'liftShowsPrec2]
                    ['showList, 'liftShowList, 'liftShowList2]
              }
            ['showsPrec, 'liftShowsPrec, 'liftShowsPrec2]
        ],
      unaryOpInstanceNames :: [Name]
unaryOpInstanceNames = [''Show, ''Show1, ''Show2],
      unaryOpExtraVars :: DeriveConfig -> Q [(Type, Type)]
unaryOpExtraVars = Q [(Type, Type)] -> DeriveConfig -> Q [(Type, Type)]
forall a b. a -> b -> a
const (Q [(Type, Type)] -> DeriveConfig -> Q [(Type, Type)])
-> Q [(Type, Type)] -> DeriveConfig -> Q [(Type, Type)]
forall a b. (a -> b) -> a -> b
$ [(Type, Type)] -> Q [(Type, Type)]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [],
      unaryOpInstanceTypeFromConfig :: DeriveConfig -> [(Type, Type)] -> [(Type, Type)] -> Name -> Q Type
unaryOpInstanceTypeFromConfig = DeriveConfig -> [(Type, Type)] -> [(Type, Type)] -> Name -> Q Type
defaultUnaryOpInstanceTypeFromConfig,
      unaryOpAllowExistential :: Bool
unaryOpAllowExistential = Bool
True,
      unaryOpContextNames :: Maybe [Name]
unaryOpContextNames = Maybe [Name]
forall a. Maybe a
Nothing
    }

-- | Derive 'Show' instance for a data type.
deriveShow :: DeriveConfig -> Name -> Q [Dec]
deriveShow :: DeriveConfig -> Name -> Q [Dec]
deriveShow DeriveConfig
deriveConfig = DeriveConfig -> UnaryOpClassConfig -> Int -> Name -> Q [Dec]
genUnaryOpClass DeriveConfig
deriveConfig UnaryOpClassConfig
showConfig Int
0

-- | Derive 'Show1' instance for a data type.
deriveShow1 :: DeriveConfig -> Name -> Q [Dec]
deriveShow1 :: DeriveConfig -> Name -> Q [Dec]
deriveShow1 DeriveConfig
deriveConfig = DeriveConfig -> UnaryOpClassConfig -> Int -> Name -> Q [Dec]
genUnaryOpClass DeriveConfig
deriveConfig UnaryOpClassConfig
showConfig Int
1

-- | Derive 'Show2' instance for a data type.
deriveShow2 :: DeriveConfig -> Name -> Q [Dec]
deriveShow2 :: DeriveConfig -> Name -> Q [Dec]
deriveShow2 DeriveConfig
deriveConfig = DeriveConfig -> UnaryOpClassConfig -> Int -> Name -> Q [Dec]
genUnaryOpClass DeriveConfig
deriveConfig UnaryOpClassConfig
showConfig Int
2