{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Grisette.Core.Data.Class.GPretty
( GPretty (..),
groupedEnclose,
condEnclose,
)
where
import Control.Monad.Except (ExceptT (ExceptT))
import Control.Monad.Identity
( Identity (Identity),
IdentityT (IdentityT),
)
import Control.Monad.Trans.Maybe (MaybeT (MaybeT))
import qualified Control.Monad.Writer.Lazy as WriterLazy
import qualified Control.Monad.Writer.Strict as WriterStrict
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import Data.Functor.Sum (Sum)
import Data.Int (Int16, Int32, Int64, Int8)
import Data.String (IsString (fromString))
import qualified Data.Text as T
import Data.Word (Word16, Word32, Word64, Word8)
import GHC.Generics
( C,
C1,
Constructor (conFixity, conIsRecord, conName),
D,
Fixity (Infix, Prefix),
Generic (Rep, from),
K1 (K1),
M1 (M1),
S,
Selector (selName),
U1 (U1),
V1,
type (:*:) ((:*:)),
type (:+:) (L1, R1),
)
import GHC.TypeLits (KnownNat, type (<=))
import Generics.Deriving (Default (Default, unDefault))
import Grisette.Core.Data.BV (IntN, SomeIntN, SomeWordN, WordN)
import Grisette.IR.SymPrim.Data.Prim.InternedTerm.Term
( LinkedRep,
SupportedPrim,
prettyPrintTerm,
)
import Grisette.IR.SymPrim.Data.SymPrim
( SomeSymIntN (SomeSymIntN),
SomeSymWordN (SomeSymWordN),
SymBool (SymBool),
SymIntN (SymIntN),
SymInteger (SymInteger),
SymWordN (SymWordN),
type (-~>) (SymGeneralFun),
type (=~>) (SymTabularFun),
)
#if MIN_VERSION_prettyprinter(1,7,0)
import Prettyprinter
( (<+>),
align,
encloseSep,
flatAlt,
group,
nest,
vcat,
viaShow,
vsep,
Doc,
Pretty(pretty),
)
#else
import Data.Text.Prettyprint.Doc
( (<+>),
align,
encloseSep,
flatAlt,
group,
nest,
vcat,
viaShow,
vsep,
Doc,
Pretty(pretty),
)
#endif
glist :: [Doc ann] -> Doc ann
glist :: forall ann. [Doc ann] -> Doc ann
glist [Doc ann]
l
| [Doc ann] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc ann]
l = Doc ann
"[]"
| [Doc ann] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Doc ann]
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Doc ann
"[" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall a. HasCallStack => [a] -> a
head [Doc ann]
l Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"]"
| Bool
otherwise = Doc ann -> Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
groupedEnclose Doc ann
"[" Doc ann
"]" (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
encloseSep Doc ann
"" Doc ann
"" (Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
flatAlt Doc ann
", " Doc ann
",") [Doc ann]
l
class GPretty a where
gpretty :: a -> Doc ann
gprettyPrec :: Int -> a -> Doc ann
gprettyList :: [a] -> Doc ann
gprettyList = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Doc ann -> Doc ann) -> ([a] -> Doc ann) -> [a] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
glist ([Doc ann] -> Doc ann) -> ([a] -> [Doc ann]) -> [a] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc ann) -> [a] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc ann
forall ann. a -> Doc ann
forall a ann. GPretty a => a -> Doc ann
gpretty
gpretty = Int -> a -> Doc ann
forall ann. Int -> a -> Doc ann
forall a ann. GPretty a => Int -> a -> Doc ann
gprettyPrec Int
0
gprettyPrec Int
_ = a -> Doc ann
forall ann. a -> Doc ann
forall a ann. GPretty a => a -> Doc ann
gpretty
{-# MINIMAL gpretty | gprettyPrec #-}
#define GPRETTY_SIMPLE(type) \
instance GPretty type where gprettyPrec = viaShowsPrec showsPrec
instance GPretty Char where
gpretty :: forall ann. Char -> Doc ann
gpretty = Char -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow
gprettyList :: forall ann. [Char] -> Doc ann
gprettyList [Char]
v = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Text -> Doc ann
pretty ([Char] -> Text
forall a. IsString a => [Char] -> a
fromString [Char]
v :: T.Text)
#if 1
GPRETTY_SIMPLE(Bool)
GPRETTY_SIMPLE(Integer)
GPRETTY_SIMPLE(Int)
GPRETTY_SIMPLE(Int8)
GPRETTY_SIMPLE(Int16)
GPRETTY_SIMPLE(Int32)
GPRETTY_SIMPLE(Int64)
GPRETTY_SIMPLE(Word)
GPRETTY_SIMPLE(Word8)
GPRETTY_SIMPLE(Word16)
GPRETTY_SIMPLE(Word32)
GPRETTY_SIMPLE(Word64)
GPRETTY_SIMPLE(SomeIntN)
GPRETTY_SIMPLE(SomeWordN)
#endif
instance GPretty B.ByteString where
gpretty :: forall ann. ByteString -> Doc ann
gpretty = [Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([Char] -> Doc ann)
-> (ByteString -> [Char]) -> ByteString -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
C.unpack
instance GPretty T.Text where
gpretty :: forall ann. Text -> Doc ann
gpretty = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Text -> Doc ann
pretty
instance (KnownNat n, 1 <= n) => GPretty (IntN n) where
gpretty :: forall ann. IntN n -> Doc ann
gpretty = IntN n -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow
instance (KnownNat n, 1 <= n) => GPretty (WordN n) where
gpretty :: forall ann. WordN n -> Doc ann
gpretty = WordN n -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow
instance GPretty () where
gpretty :: forall ann. () -> Doc ann
gpretty = () -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow
deriving via
(Default (Either a b))
instance
(GPretty a, GPretty b) => GPretty (Either a b)
deriving via
(Default (Maybe a))
instance
(GPretty a) => GPretty (Maybe a)
instance (GPretty a) => GPretty [a] where
gpretty :: forall ann. [a] -> Doc ann
gpretty = [a] -> Doc ann
forall ann. [a] -> Doc ann
forall a ann. GPretty a => [a] -> Doc ann
gprettyList
deriving via
(Default (a, b))
instance
(GPretty a, GPretty b) => GPretty (a, b)
deriving via
(Default (a, b, c))
instance
(GPretty a, GPretty b, GPretty c) => GPretty (a, b, c)
deriving via
(Default (a, b, c, d))
instance
( GPretty a,
GPretty b,
GPretty c,
GPretty d
) =>
GPretty (a, b, c, d)
deriving via
(Default (a, b, c, d, e))
instance
( GPretty a,
GPretty b,
GPretty c,
GPretty d,
GPretty e
) =>
GPretty (a, b, c, d, e)
deriving via
(Default (a, b, c, d, e, f))
instance
( GPretty a,
GPretty b,
GPretty c,
GPretty d,
GPretty e,
GPretty f
) =>
GPretty (a, b, c, d, e, f)
deriving via
(Default (a, b, c, d, e, f, g))
instance
( GPretty a,
GPretty b,
GPretty c,
GPretty d,
GPretty e,
GPretty f,
GPretty g
) =>
GPretty (a, b, c, d, e, f, g)
deriving via
(Default (a, b, c, d, e, f, g, h))
instance
( GPretty a,
GPretty b,
GPretty c,
GPretty d,
GPretty e,
GPretty f,
GPretty g,
GPretty h
) =>
GPretty (a, b, c, d, e, f, g, h)
deriving via
(Default (Sum f g a))
instance
(GPretty (f a), GPretty (g a)) =>
GPretty (Sum f g a)
instance
(GPretty (m (Maybe a))) =>
GPretty (MaybeT m a)
where
gprettyPrec :: forall ann. Int -> MaybeT m a -> Doc ann
gprettyPrec Int
_ (MaybeT m (Maybe a)
a) =
Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
[ Doc ann
"MaybeT",
Int -> m (Maybe a) -> Doc ann
forall ann. Int -> m (Maybe a) -> Doc ann
forall a ann. GPretty a => Int -> a -> Doc ann
gprettyPrec Int
11 m (Maybe a)
a
]
instance
(GPretty (m (Either e a))) =>
GPretty (ExceptT e m a)
where
gprettyPrec :: forall ann. Int -> ExceptT e m a -> Doc ann
gprettyPrec Int
_ (ExceptT m (Either e a)
a) =
Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
[ Doc ann
"ExceptT",
Int -> m (Either e a) -> Doc ann
forall ann. Int -> m (Either e a) -> Doc ann
forall a ann. GPretty a => Int -> a -> Doc ann
gprettyPrec Int
11 m (Either e a)
a
]
instance
(GPretty (m (a, w))) =>
GPretty (WriterLazy.WriterT w m a)
where
gprettyPrec :: forall ann. Int -> WriterT w m a -> Doc ann
gprettyPrec Int
_ (WriterLazy.WriterT m (a, w)
a) =
Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
[ Doc ann
"WriterT",
Int -> m (a, w) -> Doc ann
forall ann. Int -> m (a, w) -> Doc ann
forall a ann. GPretty a => Int -> a -> Doc ann
gprettyPrec Int
11 m (a, w)
a
]
instance
(GPretty (m (a, w))) =>
GPretty (WriterStrict.WriterT w m a)
where
gprettyPrec :: forall ann. Int -> WriterT w m a -> Doc ann
gprettyPrec Int
_ (WriterStrict.WriterT m (a, w)
a) =
Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
[ Doc ann
"WriterT",
Int -> m (a, w) -> Doc ann
forall ann. Int -> m (a, w) -> Doc ann
forall a ann. GPretty a => Int -> a -> Doc ann
gprettyPrec Int
11 m (a, w)
a
]
instance (GPretty a) => GPretty (Identity a) where
gprettyPrec :: forall ann. Int -> Identity a -> Doc ann
gprettyPrec Int
_ (Identity a
a) =
Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
[ Doc ann
"Identity",
Int -> a -> Doc ann
forall ann. Int -> a -> Doc ann
forall a ann. GPretty a => Int -> a -> Doc ann
gprettyPrec Int
11 a
a
]
instance (GPretty (m a)) => GPretty (IdentityT m a) where
gprettyPrec :: forall ann. Int -> IdentityT m a -> Doc ann
gprettyPrec Int
_ (IdentityT m a
a) =
Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
[ Doc ann
"IdentityT",
Int -> m a -> Doc ann
forall ann. Int -> m a -> Doc ann
forall a ann. GPretty a => Int -> a -> Doc ann
gprettyPrec Int
11 m a
a
]
#define GPRETTY_SYM_SIMPLE(symtype) \
instance GPretty symtype where \
gpretty (symtype t) = prettyPrintTerm t
#define GPRETTY_SYM_BV(symtype) \
instance (KnownNat n, 1 <= n) => GPretty (symtype n) where \
gpretty (symtype t) = prettyPrintTerm t
#define GPRETTY_SYM_FUN(op, cons) \
instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb)\
=> GPretty (sa op sb) where \
gpretty (cons t) = prettyPrintTerm t
#define GPRETTY_SYM_SOME_BV(symtype) \
instance GPretty symtype where \
gpretty (symtype t) = gpretty t
#if 1
GPRETTY_SYM_SIMPLE(SymBool)
GPRETTY_SYM_SIMPLE(SymInteger)
GPRETTY_SYM_BV(SymIntN)
GPRETTY_SYM_BV(SymWordN)
GPRETTY_SYM_FUN(=~>, SymTabularFun)
GPRETTY_SYM_FUN(-~>, SymGeneralFun)
GPRETTY_SYM_SOME_BV(SomeSymIntN)
GPRETTY_SYM_SOME_BV(SomeSymWordN)
#endif
instance (Generic a, GPretty' (Rep a)) => GPretty (Default a) where
gprettyPrec :: forall ann. Int -> Default a -> Doc ann
gprettyPrec Int
i Default a
v = Type -> Int -> Rep a Any -> Doc ann
forall c ann. Type -> Int -> Rep a c -> Doc ann
forall (a :: * -> *) c ann.
GPretty' a =>
Type -> Int -> a c -> Doc ann
gprettyPrec' Type
Pref Int
i (Rep a Any -> Doc ann) -> Rep a Any -> Doc ann
forall a b. (a -> b) -> a -> b
$ a -> Rep a Any
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from (a -> Rep a Any) -> a -> Rep a Any
forall a b. (a -> b) -> a -> b
$ Default a -> a
forall a. Default a -> a
unDefault Default a
v
data Type = Rec | Tup | Pref | Inf String Int
class GPretty' a where
gprettyPrec' :: Type -> Int -> a c -> Doc ann
isNullary :: a c -> Bool
isNullary = [Char] -> a c -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"generic gpretty (isNullary): unnecessary case"
instance GPretty' V1 where
gprettyPrec' :: forall c ann. Type -> Int -> V1 c -> Doc ann
gprettyPrec' Type
_ Int
_ V1 c
x = case V1 c
x of {}
instance GPretty' U1 where
gprettyPrec' :: forall c ann. Type -> Int -> U1 c -> Doc ann
gprettyPrec' Type
_ Int
_ U1 c
U1 = Doc ann
""
isNullary :: forall c. U1 c -> Bool
isNullary U1 c
_ = Bool
True
instance (GPretty c) => GPretty' (K1 i c) where
gprettyPrec' :: forall c ann. Type -> Int -> K1 i c c -> Doc ann
gprettyPrec' Type
_ Int
n (K1 c
a) = Int -> c -> Doc ann
forall ann. Int -> c -> Doc ann
forall a ann. GPretty a => Int -> a -> Doc ann
gprettyPrec Int
n c
a
isNullary :: forall c. K1 i c c -> Bool
isNullary K1 i c c
_ = Bool
False
groupedEnclose :: Doc ann -> Doc ann -> Doc ann -> Doc ann
groupedEnclose :: forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
groupedEnclose Doc ann
l Doc ann
r Doc ann
d = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [Doc ann
l Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
flatAlt Doc ann
" " Doc ann
"" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
d, Doc ann
r]
condEnclose :: Bool -> Doc ann -> Doc ann -> Doc ann -> Doc ann
condEnclose :: forall ann. Bool -> Doc ann -> Doc ann -> Doc ann -> Doc ann
condEnclose Bool
b = if Bool
b then Doc ann -> Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
groupedEnclose else (Doc ann -> Doc ann -> Doc ann)
-> Doc ann -> Doc ann -> Doc ann -> Doc ann
forall a b. a -> b -> a
const ((Doc ann -> Doc ann -> Doc ann)
-> Doc ann -> Doc ann -> Doc ann -> Doc ann)
-> (Doc ann -> Doc ann -> Doc ann)
-> Doc ann
-> Doc ann
-> Doc ann
-> Doc ann
forall a b. (a -> b) -> a -> b
$ (Doc ann -> Doc ann) -> Doc ann -> Doc ann -> Doc ann
forall a b. a -> b -> a
const Doc ann -> Doc ann
forall a. a -> a
id
instance (GPretty' a, Constructor c) => GPretty' (M1 C c a) where
gprettyPrec' :: forall c ann. Type -> Int -> M1 C c a c -> Doc ann
gprettyPrec' Type
_ Int
n c :: M1 C c a c
c@(M1 a c
x) =
case Type
t of
Type
Tup ->
Type -> Doc ann -> Doc ann
forall ann. Type -> Doc ann -> Doc ann
prettyBraces Type
t (Type -> Int -> a c -> Doc ann
forall c ann. Type -> Int -> a c -> Doc ann
forall (a :: * -> *) c ann.
GPretty' a =>
Type -> Int -> a c -> Doc ann
gprettyPrec' Type
t Int
0 a c
x)
Inf [Char]
_ Int
m ->
Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Bool -> Doc ann -> Doc ann -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann -> Doc ann -> Doc ann
condEnclose (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
m) Doc ann
"(" Doc ann
")" (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Type -> Int -> a c -> Doc ann
forall c ann. Type -> Int -> a c -> Doc ann
forall (a :: * -> *) c ann.
GPretty' a =>
Type -> Int -> a c -> Doc ann
gprettyPrec' Type
t Int
m a c
x
Type
_ ->
if a c -> Bool
forall c. a c -> Bool
forall (a :: * -> *) c. GPretty' a => a c -> Bool
isNullary a c
x
then [Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (M1 C c a c -> [Char]
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
(a :: k1).
t c f a -> [Char]
conName M1 C c a c
c)
else
Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
Bool -> Doc ann -> Doc ann -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann -> Doc ann -> Doc ann
condEnclose (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) Doc ann
"(" Doc ann
")" (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
[ [Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (M1 C c a c -> [Char]
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
(a :: k1).
t c f a -> [Char]
conName M1 C c a c
c),
Type -> Doc ann -> Doc ann
forall ann. Type -> Doc ann -> Doc ann
prettyBraces Type
t (Type -> Int -> a c -> Doc ann
forall c ann. Type -> Int -> a c -> Doc ann
forall (a :: * -> *) c ann.
GPretty' a =>
Type -> Int -> a c -> Doc ann
gprettyPrec' Type
t Int
11 a c
x)
]
where
prettyBraces :: Type -> Doc ann -> Doc ann
prettyBraces :: forall ann. Type -> Doc ann -> Doc ann
prettyBraces Type
Rec = Doc ann -> Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
groupedEnclose Doc ann
"{" Doc ann
"}"
prettyBraces Type
Tup = Doc ann -> Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
groupedEnclose Doc ann
"(" Doc ann
")"
prettyBraces Type
Pref = Doc ann -> Doc ann
forall a. a -> a
id
prettyBraces (Inf [Char]
_ Int
_) = Doc ann -> Doc ann
forall a. a -> a
id
fixity :: Fixity
fixity = M1 C c a c -> Fixity
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Fixity
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
(a :: k1).
t c f a -> Fixity
conFixity M1 C c a c
c
t :: Type
t
| M1 C c a c -> Bool
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Bool
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
(a :: k1).
t c f a -> Bool
conIsRecord M1 C c a c
c = Type
Rec
| M1 C c a c -> Bool
forall (f :: * -> *) p. C1 c f p -> Bool
conIsTuple M1 C c a c
c = Type
Tup
| Bool
otherwise = case Fixity
fixity of
Fixity
Prefix -> Type
Pref
Infix Associativity
_ Int
i -> [Char] -> Int -> Type
Inf (M1 C c a c -> [Char]
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
(a :: k1).
t c f a -> [Char]
conName M1 C c a c
c) Int
i
conIsTuple :: C1 c f p -> Bool
conIsTuple :: forall (f :: * -> *) p. C1 c f p -> Bool
conIsTuple C1 c f p
y = [Char] -> Bool
tupleName (C1 c f p -> [Char]
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
(a :: k1).
t c f a -> [Char]
conName C1 c f p
y)
where
tupleName :: [Char] -> Bool
tupleName (Char
'(' : Char
',' : [Char]
_) = Bool
True
tupleName [Char]
_ = Bool
False
instance (Selector s, GPretty' a) => GPretty' (M1 S s a) where
gprettyPrec' :: forall c ann. Type -> Int -> M1 S s a c -> Doc ann
gprettyPrec' Type
t Int
n s :: M1 S s a c
s@(M1 a c
x)
| M1 S s a c -> [Char]
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> [Char]
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
(a :: k1).
t s f a -> [Char]
selName M1 S s a c
s [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"" =
case Type
t of
Type
Pref -> Type -> Int -> a c -> Doc ann
forall c ann. Type -> Int -> a c -> Doc ann
forall (a :: * -> *) c ann.
GPretty' a =>
Type -> Int -> a c -> Doc ann
gprettyPrec' Type
t (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) a c
x
Type
_ -> Type -> Int -> a c -> Doc ann
forall c ann. Type -> Int -> a c -> Doc ann
forall (a :: * -> *) c ann.
GPretty' a =>
Type -> Int -> a c -> Doc ann
gprettyPrec' Type
t (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) a c
x
| Bool
otherwise =
[Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (M1 S s a c -> [Char]
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> [Char]
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
(a :: k1).
t s f a -> [Char]
selName M1 S s a c
s) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Type -> Int -> a c -> Doc ann
forall c ann. Type -> Int -> a c -> Doc ann
forall (a :: * -> *) c ann.
GPretty' a =>
Type -> Int -> a c -> Doc ann
gprettyPrec' Type
t Int
0 a c
x
isNullary :: forall c. M1 S s a c -> Bool
isNullary (M1 a c
x) = a c -> Bool
forall c. a c -> Bool
forall (a :: * -> *) c. GPretty' a => a c -> Bool
isNullary a c
x
instance (GPretty' a) => GPretty' (M1 D d a) where
gprettyPrec' :: forall c ann. Type -> Int -> M1 D d a c -> Doc ann
gprettyPrec' Type
t Int
n (M1 a c
x) = Type -> Int -> a c -> Doc ann
forall c ann. Type -> Int -> a c -> Doc ann
forall (a :: * -> *) c ann.
GPretty' a =>
Type -> Int -> a c -> Doc ann
gprettyPrec' Type
t Int
n a c
x
instance (GPretty' a, GPretty' b) => GPretty' (a :+: b) where
gprettyPrec' :: forall c ann. Type -> Int -> (:+:) a b c -> Doc ann
gprettyPrec' Type
t Int
n (L1 a c
x) = Type -> Int -> a c -> Doc ann
forall c ann. Type -> Int -> a c -> Doc ann
forall (a :: * -> *) c ann.
GPretty' a =>
Type -> Int -> a c -> Doc ann
gprettyPrec' Type
t Int
n a c
x
gprettyPrec' Type
t Int
n (R1 b c
x) = Type -> Int -> b c -> Doc ann
forall c ann. Type -> Int -> b c -> Doc ann
forall (a :: * -> *) c ann.
GPretty' a =>
Type -> Int -> a c -> Doc ann
gprettyPrec' Type
t Int
n b c
x
instance (GPretty' a, GPretty' b) => GPretty' (a :*: b) where
gprettyPrec' :: forall c ann. Type -> Int -> (:*:) a b c -> Doc ann
gprettyPrec' t :: Type
t@Type
Rec Int
n (a c
a :*: b c
b) =
[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
[ Type -> Int -> a c -> Doc ann
forall c ann. Type -> Int -> a c -> Doc ann
forall (a :: * -> *) c ann.
GPretty' a =>
Type -> Int -> a c -> Doc ann
gprettyPrec' Type
t Int
n a c
a,
Doc ann
"," Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Type -> Int -> b c -> Doc ann
forall c ann. Type -> Int -> b c -> Doc ann
forall (a :: * -> *) c ann.
GPretty' a =>
Type -> Int -> a c -> Doc ann
gprettyPrec' Type
t Int
n b c
b
]
gprettyPrec' t :: Type
t@(Inf [Char]
s Int
_) Int
n (a c
a :*: b c
b) =
Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
[ Type -> Int -> a c -> Doc ann
forall c ann. Type -> Int -> a c -> Doc ann
forall (a :: * -> *) c ann.
GPretty' a =>
Type -> Int -> a c -> Doc ann
gprettyPrec' Type
t Int
n a c
a,
[Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Char]
s Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Type -> Int -> b c -> Doc ann
forall c ann. Type -> Int -> b c -> Doc ann
forall (a :: * -> *) c ann.
GPretty' a =>
Type -> Int -> a c -> Doc ann
gprettyPrec' Type
t Int
n b c
b
]
gprettyPrec' t :: Type
t@Type
Tup Int
_ (a c
a :*: b c
b) =
[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
[ Type -> Int -> a c -> Doc ann
forall c ann. Type -> Int -> a c -> Doc ann
forall (a :: * -> *) c ann.
GPretty' a =>
Type -> Int -> a c -> Doc ann
gprettyPrec' Type
t Int
0 a c
a,
Doc ann
"," Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
flatAlt Doc ann
" " Doc ann
"" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Type -> Int -> b c -> Doc ann
forall c ann. Type -> Int -> b c -> Doc ann
forall (a :: * -> *) c ann.
GPretty' a =>
Type -> Int -> a c -> Doc ann
gprettyPrec' Type
t Int
0 b c
b
]
gprettyPrec' t :: Type
t@Type
Pref Int
n (a c
a :*: b c
b) =
[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
[ Type -> Int -> a c -> Doc ann
forall c ann. Type -> Int -> a c -> Doc ann
forall (a :: * -> *) c ann.
GPretty' a =>
Type -> Int -> a c -> Doc ann
gprettyPrec' Type
t (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) a c
a,
Type -> Int -> b c -> Doc ann
forall c ann. Type -> Int -> b c -> Doc ann
forall (a :: * -> *) c ann.
GPretty' a =>
Type -> Int -> a c -> Doc ann
gprettyPrec' Type
t (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) b c
b
]
isNullary :: forall c. (:*:) a b c -> Bool
isNullary (:*:) a b c
_ = Bool
False
viaShowsPrec :: (Int -> a -> ShowS) -> Int -> a -> Doc ann
viaShowsPrec :: forall a ann. (Int -> a -> ShowS) -> Int -> a -> Doc ann
viaShowsPrec Int -> a -> ShowS
f Int
n a
a = [Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> a -> ShowS
f Int
n a
a [Char]
"")