grisette-0.12.0.0: src/Grisette/Internal/TH/Derivation/DeriveShow.hs

{-# 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
    { unaryOpConfigs =
        [ UnaryOpConfig
            UnaryOpFieldConfig
              { extraPatNames = ["prec"],
                extraLiftedPatNames = \i -> (["sl" | i /= 0]),
                fieldCombineFun =
                  \_ _ variant conName [prec] exps -> do
                    case (variant, exps) of
                      (NormalConstructor, []) -> do
                        r <- [|showString $(stringE $ nameBase conName)|]
                        return (r, [False])
                      (NormalConstructor, [exp]) -> do
                        r <-
                          [|
                            showParen
                              ($(return prec) > $(integerE appPrec))
                              ( showString $(stringE $ nameBase conName)
                                  . showChar ' '
                                  . $(return exp)
                              )
                            |]
                        return (r, [True])
                      (NormalConstructor, _) | isNonUnitTuple conName -> do
                        let commaSeped =
                              List.intersperse [|showChar ','|] $
                                return <$> exps
                        r <-
                          [|
                            showChar '('
                              . foldr1 (.) $(listE commaSeped)
                              . showChar ')'
                            |]
                        return (r, [False])
                      (NormalConstructor, _) -> do
                        let spaceSeped =
                              List.intersperse [|showChar ' '|] $
                                return <$> exps
                        r <-
                          [|
                            showParen
                              ($(return prec) > $(integerE appPrec))
                              ( showString $(stringE $ nameBase conName)
                                  . showChar ' '
                                  . (foldr1 (.) $(listE spaceSeped))
                              )
                            |]
                        return (r, [True])
                      (RecordConstructor _, _) -> do
                        let commaSpaceSeped =
                              List.intersperse [|showString ", "|] $
                                return <$> exps
                        r <-
                          [|
                            showString $(stringE $ nameBase conName)
                              . showString " {"
                              . foldr1 (.) $(listE commaSpaceSeped)
                              . showString "}"
                            |]
                        return (r, [False])
                      (InfixConstructor, [l, r]) -> do
                        fi <-
                          fromMaybe defaultFixity `fmap` reifyFixityCompat conName
                        let conPrec = case fi of Fixity prec _ -> prec
                        r <-
                          [|
                            showParen
                              ($(return prec) > $(integerE conPrec))
                              ( $(return l)
                                  . showChar ' '
                                  . showString $(stringE $ nameBase conName)
                                  . showChar ' '
                                  . $(return r)
                              )
                            |]
                        return (r, [True])
                      _ ->
                        fail "deriveShow: unexpected constructor variant",
                fieldResFun = \variant conName _ pos fieldPat fieldFun -> do
                  let makeShowField p =
                        [|
                          $(return fieldFun)
                            $(litE $ integerL $ fromIntegral p)
                            $(return fieldPat)
                          |]
                  let attachUsedInfo = ((,[False]) <$>)
                  case variant of
                    NormalConstructor
                      | isNonUnitTuple conName ->
                          attachUsedInfo $ makeShowField 0
                    NormalConstructor ->
                      attachUsedInfo $ makeShowField appPrec1
                    RecordConstructor names ->
                      attachUsedInfo
                        [|
                          showString $(stringE $ nameBase (names !! pos) ++ " = ")
                            . $(makeShowField 0)
                          |]
                    InfixConstructor -> do
                      fi <-
                        fromMaybe defaultFixity `fmap` reifyFixityCompat conName
                      let conPrec = case fi of Fixity prec _ -> prec
                      attachUsedInfo $ makeShowField (conPrec + 1),
                fieldFunExp =
                  showPrintFieldFunExp
                    ['showsPrec, 'liftShowsPrec, 'liftShowsPrec2]
                    ['showList, 'liftShowList, 'liftShowList2]
              }
            ['showsPrec, 'liftShowsPrec, 'liftShowsPrec2]
        ],
      unaryOpInstanceNames = [''Show, ''Show1, ''Show2],
      unaryOpExtraVars = const $ return [],
      unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig,
      unaryOpAllowExistential = True,
      unaryOpContextNames = Nothing
    }

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

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

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