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

-- |
-- Module      :   Grisette.Internal.TH.Derivation.DerivePPrint
-- 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.DerivePPrint
  ( derivePPrint,
    derivePPrint1,
    derivePPrint2,
  )
where

import Data.Maybe (fromMaybe)
import Data.String (IsString (fromString))
import GHC.Show (appPrec1)
import Grisette.Internal.Internal.Decl.Core.Data.Class.PPrint
  ( PPrint (pformatList, pformatPrec),
    PPrint1 (liftPFormatList, liftPFormatPrec),
    PPrint2 (liftPFormatList2, liftPFormatPrec2),
    align,
    condEnclose,
    flatAlt,
    group,
    groupedEnclose,
    nest,
    pformatWithConstructorNoAlign,
    vcat,
    vsep,
    (<+>),
  )
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,
    Exp (ListE),
    Fixity (Fixity),
    Name,
    defaultFixity,
    listE,
    nameBase,
    stringE,
  )
import Language.Haskell.TH.Datatype
  ( ConstructorVariant (InfixConstructor, NormalConstructor, RecordConstructor),
    reifyFixityCompat,
  )
import Language.Haskell.TH.Syntax (Q)

pprintConfig :: UnaryOpClassConfig
pprintConfig :: UnaryOpClassConfig
pprintConfig =
  UnaryOpClassConfig
    { unaryOpConfigs :: [UnaryOpConfig]
unaryOpConfigs =
        [ UnaryOpFieldConfig -> [Name] -> UnaryOpConfig
forall config.
UnaryOpFunConfig config =>
config -> [Name] -> UnaryOpConfig
UnaryOpConfig
            UnaryOpFieldConfig
              { extraPatNames :: [[Char]]
extraPatNames = [[Char]
"prec"],
                extraLiftedPatNames :: Int -> [[Char]]
extraLiftedPatNames = \Int
i -> ([[Char]
"pl" | 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
                  let initExps :: [Q Exp]
initExps =
                        ( \Exp
e ->
                            [|
                              $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
e)
                                <> (fromString ",")
                                <> flatAlt (fromString "") (fromString " ")
                              |]
                        )
                          (Exp -> Q Exp) -> [Exp] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Exp] -> [Exp]
forall a. HasCallStack => [a] -> [a]
init [Exp]
exps
                      lastExp :: Q Exp
lastExp = [|$(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
forall a. HasCallStack => [a] -> a
last [Exp]
exps)|]
                      commaSeped :: [Q Exp]
commaSeped = [Q Exp]
initExps [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. [a] -> [a] -> [a]
++ [Q Exp
lastExp]
                  case (ConstructorVariant
variant, [Exp]
exps) of
                    (ConstructorVariant
NormalConstructor, []) -> do
                      r <- [|fromString $([Char] -> Q Exp
forall (m :: * -> *). Quote m => [Char] -> m Exp
stringE ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
nameBase Name
conName)|]
                      return (r, [False])
                    (ConstructorVariant
NormalConstructor, [Exp
exp]) -> do
                      r <-
                        [|
                          pformatWithConstructorNoAlign
                            $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
prec)
                            (fromString $([Char] -> Q Exp
forall (m :: * -> *). Quote m => [Char] -> m Exp
stringE ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
nameBase Name
conName))
                            [$(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
                      r <-
                        [|
                          groupedEnclose (fromString "(") (fromString ")") $
                            vcat $
                              $([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [Q Exp]
commaSeped)
                          |]
                      return (r, [False])
                    (ConstructorVariant
NormalConstructor, [Exp]
_) -> do
                      r <-
                        [|
                          pformatWithConstructorNoAlign
                            $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
prec)
                            (fromString $([Char] -> Q Exp
forall (m :: * -> *). Quote m => [Char] -> m Exp
stringE ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
nameBase Name
conName))
                            [vsep $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
ListE [Exp]
exps)]
                          |]
                      return (r, [True])
                    (RecordConstructor [Name]
_, [Exp]
_) -> do
                      r <-
                        [|
                          pformatWithConstructorNoAlign
                            $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
prec)
                            (fromString $([Char] -> Q Exp
forall (m :: * -> *). Quote m => [Char] -> m Exp
stringE ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
nameBase Name
conName))
                            [ groupedEnclose (fromString "{") (fromString "}") $
                                vcat $
                                  $([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [Q Exp]
commaSeped)
                            ]
                          |]
                      return (r, [True])
                    (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 <-
                        [|
                          group
                            $ condEnclose
                              ($(return prec) > $(integerE conPrec))
                              (fromString "(")
                              (fromString ")")
                            $ nest 2
                            $ vsep
                              [ align $ $(return l),
                                fromString $(stringE $ nameBase conName)
                                  <+> $(return r)
                              ]
                          |]
                      return (r, [True])
                    (ConstructorVariant, [Exp])
_ ->
                      [Char] -> Q (Exp, [Bool])
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"derivePPrint: 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 makePPrintField :: a -> Q Exp
makePPrintField a
p =
                        [|
                          $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
fieldFun)
                            $(a -> Q Exp
forall a. Integral a => a -> Q Exp
integerE a
p)
                            $(Exp -> Q Exp
forall a. a -> Q 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 a. Integral a => a -> Q Exp
makePPrintField 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 a. Integral a => a -> Q Exp
makePPrintField Int
appPrec1
                    RecordConstructor [Name]
names ->
                      Q Exp -> Q (Exp, [Bool])
forall {a}. Q a -> Q (a, [Bool])
attachUsedInfo
                        [|
                          fromString $([Char] -> Q Exp
forall (m :: * -> *). Quote m => [Char] -> m Exp
stringE ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
nameBase ([Name]
names [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
pos) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" = ")
                            <> $(Integer -> Q Exp
forall a. Integral a => a -> Q Exp
makePPrintField 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 $ makePPrintField (conPrec + 1),
                fieldFunExp :: FieldFunExp
fieldFunExp =
                  [Name] -> [Name] -> FieldFunExp
showPrintFieldFunExp
                    ['pformatPrec, 'liftPFormatPrec, 'liftPFormatPrec2]
                    ['pformatList, 'liftPFormatList, 'liftPFormatList2]
              }
            ['pformatPrec, 'liftPFormatPrec, 'liftPFormatPrec2]
        ],
      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 [],
      unaryOpInstanceNames :: [Name]
unaryOpInstanceNames = [''PPrint, ''PPrint1, ''PPrint2],
      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 'PPrint' instance for a data type.
derivePPrint :: DeriveConfig -> Name -> Q [Dec]
derivePPrint :: DeriveConfig -> Name -> Q [Dec]
derivePPrint DeriveConfig
deriveConfig = DeriveConfig -> UnaryOpClassConfig -> Int -> Name -> Q [Dec]
genUnaryOpClass DeriveConfig
deriveConfig UnaryOpClassConfig
pprintConfig Int
0

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

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