----------------------------------------------------------------------------
-- |
-- Module : Prettyprinter.Generics
-- Copyright : (c) Sergey Vinokurov 2018
-- License : Apache-2.0 (see LICENSE)
-- Maintainer : serg.foo@gmail.com
----------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Prettyprinter.Generics
( ppGeneric
, PPGeneric(..)
, PPGenericOverride(..)
-- * Reexports
, Pretty(..)
, Generic
) where
import Control.Applicative (ZipList(..))
import Data.Bimap (Bimap)
import Data.Bits qualified as Bits
import Data.ByteString.Char8 qualified as C8
import Data.ByteString.Lazy.Char8 qualified as CL8
import Data.ByteString.Short qualified as ShortBS
import Data.Coerce
import Data.Complex (Complex(..))
import Data.DList (DList)
import Data.DList qualified as DL
import Data.Fixed (Fixed(..))
import Data.Foldable
import Data.Functor.Compose
import Data.Functor.Identity (Identity(..))
import Data.HashMap.Strict (HashMap)
import Data.HashSet (HashSet)
import Data.Int
import Data.IntMap (IntMap)
import Data.IntSet (IntSet)
import Data.Kind
import Data.List.NonEmpty (NonEmpty)
import Data.Map (Map)
import Data.Monoid as Monoid
import Data.Ord
import Data.Proxy
import Data.Semigroup as Semigroup
import Data.Sequence (Seq)
import Data.Set (Set)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Time (UTCTime)
import Data.Tuple (Solo(..))
import Data.Vector (Vector)
import Data.Void
import Data.Word
import GHC.ForeignPtr (ForeignPtr(..))
import GHC.Generics
import GHC.Real (Ratio(..))
import GHC.Stack (CallStack)
import GHC.TypeLits
#ifdef HAVE_ENUMMAPSET
import Data.EnumMap (EnumMap)
import Data.EnumSet (EnumSet)
#endif
import Prettyprinter
import Prettyprinter qualified as PP
import Prettyprinter.Combinators
import Prettyprinter.MetaDoc
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Syntax qualified as TH
-- $setup
-- >>> :set -XDeriveGeneric
-- >>> :set -XDerivingVia
-- >>> :set -XImportQualifiedPost
-- >>> import Data.List.NonEmpty (NonEmpty(..))
-- >>> import Data.List.NonEmpty qualified as NonEmpty
-- >>> import Data.IntMap (IntMap)
-- >>> import Data.IntMap qualified as IntMap
-- >>> import Data.IntSet (IntSet)
-- >>> import Data.IntSet qualified as IntSet
-- >>> import Data.Map.Strict (Map)
-- >>> import Data.Map.Strict qualified as Map
-- >>> import Data.Set (Set)
-- >>> import Data.Set qualified as Set
-- >>> import Data.Vector (Vector)
-- >>> import Data.Vector qualified as Vector
-- >>> import GHC.Generics (Generic)
--
-- >>> :{
-- data Test = Test
-- { testSet :: Maybe (Set Int)
-- , testMap :: Map String (Set Double)
-- , testIntSet :: IntSet
-- , testIntMap :: IntMap String
-- , testInt :: Int
-- , testComplexMap :: Map (Maybe (Set Int)) (IntMap (Set String))
-- , testComplexMap2 :: Map (Maybe (Set Int)) (Map (NonEmpty Int) (Vector String))
-- } deriving (Generic)
-- :}
-- | Helper to use 'GHC.Generics.Generic'-based prettyprinting with DerivingVia.
--
-- >>> :{
-- data TestWithDeriving a b = TestWithDeriving
-- { testSet :: Maybe (Set a)
-- , testB :: b
-- , testIntMap :: IntMap String
-- , testComplexMap :: Map (Maybe (Set Int)) (IntMap (Set String))
-- }
-- deriving (Generic)
-- deriving Pretty via PPGeneric (TestWithDeriving a b)
-- :}
--
-- With -XDerivingVia
-- >>> :{
-- data TestWithDeriving a b = TestWithDeriving
-- { testSet :: Maybe (Set a)
-- , testB :: b
-- , testIntMap :: IntMap String
-- , testComplexMap :: Map (Maybe (Set Int)) (IntMap (Set String))
-- }
-- deriving (Generic)
-- deriving via PPGeneric (TestWithDeriving a b) instance (Pretty a, Pretty b) => Pretty (TestWithDeriving a b)
-- :}
newtype PPGeneric a = PPGeneric { unPPGeneric :: a }
instance (Generic a, GPretty (Rep a)) => Pretty (PPGeneric a) where
pretty = ppGeneric . unPPGeneric
-- | Prettyprint using 'GHC.Generics.Generic' instance.
--
-- >>> :{
-- test = Test
-- { testSet = Just $ Set.fromList [1..3]
-- , testMap =
-- Map.fromList [("foo", Set.fromList [1.5]), ("foo", Set.fromList [2.5, 3, 4])]
-- , testIntSet = IntSet.fromList [1, 2, 4, 5, 7]
-- , testIntMap = IntMap.fromList $ zip [1..] ["3", "2foo", "11"]
-- , testInt = 42
-- , testComplexMap = Map.fromList
-- [ ( Nothing
-- , IntMap.fromList $ zip [0..] $ map Set.fromList
-- [ ["foo", "bar"]
-- , ["baz"]
-- , ["quux", "frob"]
-- ]
-- )
-- , ( Just (Set.fromList [1])
-- , IntMap.fromList $ zip [0..] $ map Set.fromList
-- [ ["quux"]
-- , ["fizz", "buzz"]
-- ]
-- )
-- , ( Just (Set.fromList [3, 4])
-- , IntMap.fromList $ zip [0..] $ map Set.fromList
-- [ ["quux", "5"]
-- , []
-- , ["fizz", "buzz"]
-- ]
-- )
-- ]
-- , testComplexMap2 =
-- Map.singleton
-- (Just (Set.fromList [1..5]))
-- (Map.fromList
-- [ (NonEmpty.fromList [1, 2], Vector.fromList ["foo", "bar", "baz"])
-- , (NonEmpty.fromList [3], Vector.fromList ["quux"])
-- , (NonEmpty.fromList [4..10], Vector.fromList ["must", "put", "something", "in", "here"])
-- ])
-- }
-- :}
--
-- >>> ppGeneric test
-- Test
-- { testSet -> Just ({1, 2, 3})
-- , testMap -> {foo -> {2.5, 3.0, 4.0}}
-- , testIntSet -> {1, 2, 4, 5, 7}
-- , testIntMap -> {1 -> 3, 2 -> 2foo, 3 -> 11}
-- , testInt -> 42
-- , testComplexMap ->
-- { Nothing -> {0 -> {bar, foo}, 1 -> {baz}, 2 -> {frob, quux}}
-- , Just ({1}) -> {0 -> {quux}, 1 -> {buzz, fizz}}
-- , Just ({3, 4}) -> {0 -> {5, quux}, 1 -> {}, 2 -> {buzz, fizz}}
-- }
-- , testComplexMap2 ->
-- { Just ({1, 2, 3, 4, 5}) ->
-- { [1, 2] -> [foo, bar, baz]
-- , [3] -> [quux]
-- , [4, 5, 6, 7, 8, 9, 10] -> [must, put, something, in, here]
-- } }
-- }
ppGeneric :: (Generic a, GPretty (Rep a)) => a -> Doc ann
ppGeneric = mdPayload . gpretty . from
class GPretty (a :: Type -> Type) where
gpretty :: a ix -> MetaDoc ann
instance GPretty V1 where
gpretty _ = error "gpretty for V1"
instance GPretty U1 where
gpretty U1 = mempty
instance (GPretty f, GPretty g) => GPretty (f :+: g) where
gpretty = \case
L1 x -> gpretty x
R1 y -> gpretty y
-- 'PPGenericDeriving' to give it a chance to fire before standard 'Pretty'.
instance PPGenericOverride a => GPretty (K1 i a) where
{-# INLINE gpretty #-}
gpretty = ppGenericOverride . unK1
-- | A class to override 'Pretty' when calling 'ppGeneric' without introducing
-- orphans for standard types.
class PPGenericOverride a where
ppGenericOverride :: a -> MetaDoc ann
default ppGenericOverride :: (Generic a, GPretty (Rep a)) => a -> MetaDoc ann
ppGenericOverride = gpretty . from
ppGenericOverrideDoc :: PPGenericOverride a => a -> Doc ann
ppGenericOverrideDoc = mdPayload . ppGenericOverride
newtype PPGenericOverrideToPretty a = PPGenericOverrideToPretty { unPPGenericOverrideToPretty :: a }
instance PPGenericOverride a => Pretty (PPGenericOverrideToPretty a) where
pretty = ppGenericOverrideDoc . unPPGenericOverrideToPretty
-- | Fall back to standard 'Pretty' instance when no override is available.
instance Pretty a => PPGenericOverride a where
ppGenericOverride = compositeMetaDoc . pretty
instance {-# OVERLAPS #-} PPGenericOverride Int where
{-# INLINE ppGenericOverride #-}
ppGenericOverride = metaDocInt
instance {-# OVERLAPS #-} PPGenericOverride Float where
{-# INLINE ppGenericOverride #-}
ppGenericOverride = metaDocFloat
instance {-# OVERLAPS #-} PPGenericOverride Double where
{-# INLINE ppGenericOverride #-}
ppGenericOverride = metaDocDouble
instance {-# OVERLAPS #-} PPGenericOverride Integer where
{-# INLINE ppGenericOverride #-}
ppGenericOverride = metaDocInteger
instance {-# OVERLAPS #-} PPGenericOverride Natural where
{-# INLINE ppGenericOverride #-}
ppGenericOverride = metaDocNatural
instance {-# OVERLAPS #-} PPGenericOverride Word where
{-# INLINE ppGenericOverride #-}
ppGenericOverride = metaDocWord
instance {-# OVERLAPS #-} PPGenericOverride Word8 where
{-# INLINE ppGenericOverride #-}
ppGenericOverride = metaDocWord8
instance {-# OVERLAPS #-} PPGenericOverride Word16 where
{-# INLINE ppGenericOverride #-}
ppGenericOverride = metaDocWord16
instance {-# OVERLAPS #-} PPGenericOverride Word32 where
{-# INLINE ppGenericOverride #-}
ppGenericOverride = metaDocWord32
instance {-# OVERLAPS #-} PPGenericOverride Word64 where
{-# INLINE ppGenericOverride #-}
ppGenericOverride = metaDocWord64
instance {-# OVERLAPS #-} PPGenericOverride Int8 where
{-# INLINE ppGenericOverride #-}
ppGenericOverride = metaDocInt8
instance {-# OVERLAPS #-} PPGenericOverride Int16 where
{-# INLINE ppGenericOverride #-}
ppGenericOverride = metaDocInt16
instance {-# OVERLAPS #-} PPGenericOverride Int32 where
{-# INLINE ppGenericOverride #-}
ppGenericOverride = metaDocInt32
instance {-# OVERLAPS #-} PPGenericOverride Int64 where
{-# INLINE ppGenericOverride #-}
ppGenericOverride = metaDocInt64
instance {-# OVERLAPS #-} PPGenericOverride () where
{-# INLINE ppGenericOverride #-}
ppGenericOverride = metaDocUnit
instance {-# OVERLAPS #-} PPGenericOverride Bool where
{-# INLINE ppGenericOverride #-}
ppGenericOverride = metaDocBool
instance {-# OVERLAPS #-} PPGenericOverride Char where
{-# INLINE ppGenericOverride #-}
ppGenericOverride = metaDocChar
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Ratio a) where
{-# INLINABLE ppGenericOverride #-}
ppGenericOverride (x :% y) =
ppGenericOverride x <> atomicMetaDoc "/" <> ppGenericOverride y
(<++>) :: MetaDoc ann -> MetaDoc ann -> MetaDoc ann
(<++>) x y = x <> atomicMetaDoc PP.space <> y
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Complex a) where
{-# INLINABLE ppGenericOverride #-}
ppGenericOverride (x :+ y) =
ppGenericOverride x <++> atomicMetaDoc ":+" <++> ppGenericOverride y
instance {-# OVERLAPS #-} PPGenericOverride CallStack where
{-# INLINE ppGenericOverride #-}
ppGenericOverride =
compositeMetaDoc . ppCallStack
instance {-# OVERLAPS #-} PPGenericOverride (Doc Void) where
{-# INLINE ppGenericOverride #-}
ppGenericOverride =
compositeMetaDoc . fmap absurd
instance {-# OVERLAPS #-} PPGenericOverride String where
{-# INLINE ppGenericOverride #-}
ppGenericOverride = stringMetaDoc
instance {-# OVERLAPS #-} PPGenericOverride T.Text where
{-# INLINE ppGenericOverride #-}
ppGenericOverride = strictTextMetaDoc
instance {-# OVERLAPS #-} PPGenericOverride TL.Text where
{-# INLINE ppGenericOverride #-}
ppGenericOverride = lazyTextMetaDoc
instance {-# OVERLAPS #-} PPGenericOverride C8.ByteString where
{-# INLINE ppGenericOverride #-}
ppGenericOverride = strictByteStringMetaDoc
instance {-# OVERLAPS #-} PPGenericOverride CL8.ByteString where
{-# INLINE ppGenericOverride #-}
ppGenericOverride = lazyByteStringMetaDoc
instance {-# OVERLAPS #-} PPGenericOverride ShortBS.ShortByteString where
{-# INLINE ppGenericOverride #-}
ppGenericOverride = shortByteStringMetaDoc
instance {-# OVERLAPS #-} PPGenericOverride (ForeignPtr a) where
ppGenericOverride = atomicMetaDoc . pretty . show
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (TH.TyVarBndr a)
instance {-# OVERLAPS #-} PPGenericOverride TH.OccName
instance {-# OVERLAPS #-} PPGenericOverride TH.NameFlavour
instance {-# OVERLAPS #-} PPGenericOverride TH.PkgName
instance {-# OVERLAPS #-} PPGenericOverride TH.NameSpace
instance {-# OVERLAPS #-} PPGenericOverride TH.ModName
instance {-# OVERLAPS #-} PPGenericOverride TH.Name
instance {-# OVERLAPS #-} PPGenericOverride TH.TyLit
instance {-# OVERLAPS #-} PPGenericOverride TH.Type
instance {-# OVERLAPS #-} PPGenericOverride TH.SourceUnpackedness
instance {-# OVERLAPS #-} PPGenericOverride TH.SourceStrictness
instance {-# OVERLAPS #-} PPGenericOverride TH.Bang
instance {-# OVERLAPS #-} PPGenericOverride TH.Con
instance {-# OVERLAPS #-} PPGenericOverride TH.Lit
instance {-# OVERLAPS #-} PPGenericOverride TH.Bytes
instance {-# OVERLAPS #-} PPGenericOverride TH.Stmt
instance {-# OVERLAPS #-} PPGenericOverride TH.Guard
instance {-# OVERLAPS #-} PPGenericOverride TH.Body
instance {-# OVERLAPS #-} PPGenericOverride TH.Match
instance {-# OVERLAPS #-} PPGenericOverride TH.Range
instance {-# OVERLAPS #-} PPGenericOverride TH.Exp
instance {-# OVERLAPS #-} PPGenericOverride TH.Pat
instance {-# OVERLAPS #-} PPGenericOverride TH.Clause
instance {-# OVERLAPS #-} PPGenericOverride TH.DerivStrategy
instance {-# OVERLAPS #-} PPGenericOverride TH.DerivClause
instance {-# OVERLAPS #-} PPGenericOverride TH.FunDep
instance {-# OVERLAPS #-} PPGenericOverride TH.Overlap
instance {-# OVERLAPS #-} PPGenericOverride TH.Callconv
instance {-# OVERLAPS #-} PPGenericOverride TH.Safety
instance {-# OVERLAPS #-} PPGenericOverride TH.Foreign
instance {-# OVERLAPS #-} PPGenericOverride TH.FixityDirection
instance {-# OVERLAPS #-} PPGenericOverride TH.Fixity
instance {-# OVERLAPS #-} PPGenericOverride TH.Inline
instance {-# OVERLAPS #-} PPGenericOverride TH.RuleMatch
instance {-# OVERLAPS #-} PPGenericOverride TH.Phases
instance {-# OVERLAPS #-} PPGenericOverride TH.RuleBndr
instance {-# OVERLAPS #-} PPGenericOverride TH.AnnTarget
instance {-# OVERLAPS #-} PPGenericOverride TH.Pragma
instance {-# OVERLAPS #-} PPGenericOverride TH.TySynEqn
instance {-# OVERLAPS #-} PPGenericOverride TH.FamilyResultSig
instance {-# OVERLAPS #-} PPGenericOverride TH.InjectivityAnn
instance {-# OVERLAPS #-} PPGenericOverride TH.TypeFamilyHead
instance {-# OVERLAPS #-} PPGenericOverride TH.Role
instance {-# OVERLAPS #-} PPGenericOverride TH.PatSynArgs
instance {-# OVERLAPS #-} PPGenericOverride TH.PatSynDir
instance {-# OVERLAPS #-} PPGenericOverride TH.Dec
instance {-# OVERLAPS #-} PPGenericOverride TH.Info
instance {-# OVERLAPS #-} PPGenericOverride TH.Specificity
#if MIN_VERSION_template_haskell(2, 21, 0)
instance {-# OVERLAPS #-} PPGenericOverride TH.BndrVis
#endif
#if MIN_VERSION_template_haskell(2, 22, 0)
instance {-# OVERLAPS #-} PPGenericOverride TH.NamespaceSpecifier
#endif
ppConstructorApp :: forall proxy b a ann. (Coercible a b, PPGenericOverride b) => proxy b -> Doc ann -> a -> MetaDoc ann
ppConstructorApp _ constructor x = constructorAppMetaDoc (atomicMetaDoc constructor) [ppGenericOverride @b (coerce x)]
instance {-# OVERLAPS #-} PPGenericOverride (Proxy a)
instance {-# OVERLAPS #-} PPGenericOverride (Fixed n) where ppGenericOverride = ppConstructorApp (Proxy @Integer) "Fixed"
instance {-# OVERLAPS #-} PPGenericOverride Semigroup.Any where ppGenericOverride = ppConstructorApp (Proxy @Bool) "Any"
instance {-# OVERLAPS #-} PPGenericOverride Semigroup.All where ppGenericOverride = ppConstructorApp (Proxy @Bool) "All"
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Bits.And a) where ppGenericOverride = ppConstructorApp (Proxy @a) "And"
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Bits.Iff a) where ppGenericOverride = ppConstructorApp (Proxy @a) "Iff"
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Bits.Ior a) where ppGenericOverride = ppConstructorApp (Proxy @a) "Ior"
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Bits.Xor a) where ppGenericOverride = ppConstructorApp (Proxy @a) "Xor"
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Down a) where ppGenericOverride = ppConstructorApp (Proxy @a) "Down"
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Identity a) where ppGenericOverride = ppConstructorApp (Proxy @a) "Identity"
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Monoid.Dual a) where ppGenericOverride = ppConstructorApp (Proxy @a) "Dual"
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Monoid.First a) where ppGenericOverride = ppConstructorApp (Proxy @(Maybe a)) "First"
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Monoid.Last a) where ppGenericOverride = ppConstructorApp (Proxy @(Maybe a)) "Last"
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Monoid.Product a) where ppGenericOverride = ppConstructorApp (Proxy @a) "Product"
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Monoid.Sum a) where ppGenericOverride = ppConstructorApp (Proxy @a) "Sum"
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Semigroup.First a) where ppGenericOverride = ppConstructorApp (Proxy @a) "First"
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Semigroup.Last a) where ppGenericOverride = ppConstructorApp (Proxy @a) "Last"
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Semigroup.Max a) where ppGenericOverride = ppConstructorApp (Proxy @a) "Max"
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Semigroup.Min a) where ppGenericOverride = ppConstructorApp (Proxy @a) "Min"
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Semigroup.WrappedMonoid a) where ppGenericOverride = ppConstructorApp (Proxy @a) "WrappedMonoid"
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (ZipList a) where ppGenericOverride = ppConstructorApp (Proxy @[a]) "ZipList"
instance {-# OVERLAPS #-} PPGenericOverride (f a) => PPGenericOverride (Monoid.Alt f a) where ppGenericOverride = ppConstructorApp (Proxy @(f a)) "Alt"
instance {-# OVERLAPS #-} PPGenericOverride (f a) => PPGenericOverride (Monoid.Ap f a) where ppGenericOverride = ppConstructorApp (Proxy @(f a)) "Ap"
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Solo a) where
ppGenericOverride = ppConstructorApp (Proxy @a) "Solo" . unpackSolo
where
#if MIN_VERSION_base(4, 18, 0)
unpackSolo (MkSolo x) = x
#endif
#if !MIN_VERSION_base(4, 18, 0)
unpackSolo (Solo x) = x
#endif
instance {-# OVERLAPS #-}
( PPGenericOverride a
, PPGenericOverride b
) => PPGenericOverride (a, b) where
ppGenericOverride (a, b) = atomicMetaDoc $ pretty
( PPGenericOverrideToPretty a
, PPGenericOverrideToPretty b
)
instance {-# OVERLAPS #-}
( PPGenericOverride a
, PPGenericOverride b
, PPGenericOverride c
) => PPGenericOverride (a, b, c) where
ppGenericOverride (a, b, c) = atomicMetaDoc $ pretty
( PPGenericOverrideToPretty a
, PPGenericOverrideToPretty b
, PPGenericOverrideToPretty c
)
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Maybe a) where
ppGenericOverride =
gpretty . from . fmap PPGenericOverrideToPretty
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride [a] where
ppGenericOverride =
atomicMetaDoc . ppListWith ppGenericOverrideDoc
instance {-# OVERLAPS #-} (PPGenericOverride k, PPGenericOverride v) => PPGenericOverride [(k, v)] where
ppGenericOverride =
atomicMetaDoc . ppAssocListWith ppGenericOverrideDoc ppGenericOverrideDoc
instance {-# OVERLAPS #-} PPGenericOverride k => PPGenericOverride (NonEmpty k) where
ppGenericOverride =
atomicMetaDoc . ppNEWith ppGenericOverrideDoc
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Vector a) where
ppGenericOverride =
atomicMetaDoc . ppVectorWith ppGenericOverrideDoc
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (DList a) where
ppGenericOverride =
atomicMetaDoc . ppDListWith ppGenericOverrideDoc
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Seq a) where
ppGenericOverride =
atomicMetaDoc . ppSeqWith ppGenericOverrideDoc
instance {-# OVERLAPS #-} (PPGenericOverride k, PPGenericOverride v) => PPGenericOverride (Map k v) where
ppGenericOverride =
atomicMetaDoc . ppMapWith ppGenericOverrideDoc ppGenericOverrideDoc
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Set a) where
ppGenericOverride =
atomicMetaDoc . ppSetWith ppGenericOverrideDoc
instance {-# OVERLAPS #-} (PPGenericOverride k, PPGenericOverride v) => PPGenericOverride (Bimap k v) where
ppGenericOverride =
atomicMetaDoc . ppBimapWith ppGenericOverrideDoc ppGenericOverrideDoc
instance {-# OVERLAPS #-} PPGenericOverride IntSet where
ppGenericOverride =
atomicMetaDoc . ppIntSetWith ppGenericOverrideDoc
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (IntMap a) where
ppGenericOverride =
atomicMetaDoc . ppIntMapWith ppGenericOverrideDoc ppGenericOverrideDoc
#ifdef HAVE_ENUMMAPSET
instance {-# OVERLAPS #-} (Enum a, PPGenericOverride a) => PPGenericOverride (EnumSet a) where
ppGenericOverride =
atomicMetaDoc . ppEnumSetWith ppGenericOverrideDoc
instance {-# OVERLAPS #-} (Enum k, PPGenericOverride k, PPGenericOverride v) => PPGenericOverride (EnumMap k v ) where
ppGenericOverride =
atomicMetaDoc . ppEnumMapWith ppGenericOverrideDoc ppGenericOverrideDoc
#endif
instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (HashSet a) where
ppGenericOverride =
atomicMetaDoc . ppHashSetWith ppGenericOverrideDoc
instance {-# OVERLAPS #-} (PPGenericOverride k, PPGenericOverride v) => PPGenericOverride (HashMap k v) where
ppGenericOverride =
atomicMetaDoc . ppHashMapWith ppGenericOverrideDoc ppGenericOverrideDoc
instance {-# OVERLAPS #-} PPGenericOverride (f (g a)) => PPGenericOverride (Compose f g a) where
ppGenericOverride =
ppGenericOverride . getCompose
instance {-# OVERLAPS #-} PPGenericOverride UTCTime where
ppGenericOverride =
atomicMetaDoc . ppUTCTimeISO8601
instance (GPretty f, GPretty g) => GPretty (f :*: g) where
gpretty (x :*: y) =
compositeMetaDoc $ mdPayload x' <+> mdPayload y'
where
x' = gpretty x
y' = gpretty y
instance GPretty x => GPretty (M1 D ('MetaData a b c d) x) where
gpretty = gpretty . unM1
instance GPretty x => GPretty (M1 S ('MetaSel 'Nothing b c d) x) where
gpretty = gpretty . unM1
instance (KnownSymbol name, GFields x) => GPretty (M1 C ('MetaCons name _fixity 'False) x) where
gpretty (M1 x) =
constructorAppMetaDoc constructor args
where
constructor :: MetaDoc ann
constructor = atomicMetaDoc $ pretty $ symbolVal $ Proxy @name
args :: [MetaDoc ann]
args = toList $ gfields x
class GFields a where
gfields :: a ix -> DList (MetaDoc ann)
instance GFields U1 where
{-# INLINE gfields #-}
gfields = const mempty
instance GPretty x => GFields (M1 S ('MetaSel a b c d) x) where
gfields = DL.singleton . gpretty . unM1
instance (GFields f, GFields g) => GFields (f :*: g) where
gfields (f :*: g) = gfields f <> gfields g
instance (KnownSymbol name, GCollectRecord f) => GPretty (M1 C ('MetaCons name _fixity 'True) f) where
gpretty (M1 x) =
compositeMetaDoc $
ppDictHeader
(pretty (symbolVal (Proxy @name)))
(map (fmap mdPayload) (toList (gcollectRecord x)))
class GCollectRecord a where
gcollectRecord :: a ix -> DList (MapEntry Text (MetaDoc ann))
instance (KnownSymbol name, GPretty a) => GCollectRecord (M1 S ('MetaSel ('Just name) su ss ds) a) where
gcollectRecord (M1 x) =
DL.singleton (T.pack (symbolVal (Proxy @name)) :-> gpretty x)
instance (GCollectRecord f, GCollectRecord g) => GCollectRecord (f :*: g) where
gcollectRecord (f :*: g) = gcollectRecord f <> gcollectRecord g
instance GCollectRecord U1 where
{-# INLINE gcollectRecord #-}
gcollectRecord = const mempty