{-# LANGUAGE UndecidableInstances #-}
-- |
-- = Type Pretty Printing
--
-- == Printing Custom Types
--
-- The main usecase of this library is rendering one's own complex types to
-- pretty 'String' values, e.g. for debugging and tracing purposes.
--
-- One way to create 'PrettyType' /documents/ is to define 'ToPretty' instances
-- for your types by combining the promoted constructors of 'PrettyType'.
--
-- If `UndecidableInstances` isn't holding you back, use the type aliases like
-- 'PutStr', 'PutNat', 'PrettyInfix', etc in these instance definitions.
--
-- 'ToPretty' is an open type family, that converts a custom type to a
-- `PrettyType`.
--
-- 'showPretty' eventually crafts a 'String' value from a proxy to the custom
-- type.
--
-- It might be helpful to overcome egoistic needs for guaranteed compiler
-- termination (i.e. allowing UndecidableInstances) in order to be able to use
-- type aliases like 'PutStr', 'PutNat', etc.
--
-- == Example
--
-- Let's start with the output:
--
-- > +-------+-----+------------+
-- > |  col 1|col 2|       col 3|
-- > +-------+-----+------------+
-- > |   2423|  451|       21234|
-- > | 242322|   42|         n/a|
-- > |      0| 4351|      623562|
-- > |   4351|  n/a|         n/a|
-- > |      0| 4351|      623562|
-- > +-------+-----+------------+
--
-- ... of rendering this table:
--
-- >type TestTable =
-- >  'MyTable         '[MyCol "col 1" 7, MyCol "col 2" 5, MyCol "col 3" 12]
-- >          '[ MyRow '[2423           ,451             ,21234]
-- >           , MyRow '[242322         ,42]
-- >           , MyRow '[0              ,4351            ,623562]
-- >           , MyRow '[4351]
-- >           , MyRow '[0              ,4351            ,623562]
-- >           ]
-- >
--
-- ...using this function:
--
-- @
-- prettyTestTable :: String
-- prettyTestTable = 'showPretty' (Proxy :: Proxy TestTable)
-- @
--
-- ...from these data types:
--
-- > -- | A type with a list of columns and rows.
-- > data MyTable = MyTable [Type] [Type]
-- >
-- > -- | A row of a table, with a list of numbers, one each for every column.
-- > data MyRow :: [Nat] -> Type
-- >
-- > -- | The column of a table. It has a width and a column title.
-- > data MyCol :: Symbol -> Nat -> Type
--
-- ...converted to 'PrettyType' using this 'ToPretty' instance:
--
-- @
-- type instance 'ToPretty' ('MyTable cols rows) =
--            'PrettyManyIn' ('PutStr' "+") (RowSepLine cols)
--       '<$$>' 'PrettyManyIn' ('PutStr' "|") (TableHeading cols)
--       '<$$>' 'PrettyManyIn' ('PutStr' "+") (RowSepLine cols)
--       '<$$>' 'PrettyHigh'   (TableRows cols rows)
--       '<$$>' 'PrettyManyIn' ('PutStr' "+") (RowSepLine cols)
--
-- type family
--   TableHeading (cols :: [Type]) :: ['PrettyType'] where
--   TableHeading '[]                      = '[]
--   TableHeading (MyCol title width ': r) = 'PutStrW' width title  ': TableHeading  r
--
-- type family
--    RowSepLine (cols :: [Type]) :: ['PrettyType'] where
--    RowSepLine '[] = '[]
--    RowSepLine (MyCol title width ': r) =
--      'PrettyOften' width (PutStr "-") ': RowSepLine  r
--
-- type family
--   TableRows (cols :: [Type]) (rows :: [Type]) :: ['PrettyType'] where
--   TableRows cols '[] = '[]
--   TableRows cols (MyRow cells ': rest ) =
--     'PrettyManyIn' ('PutStr' "|") (TableCells cols cells) ': TableRows cols rest
--
-- type family
--   TableCells (cols :: [Type]) (cells :: [Nat]) :: ['PrettyType'] where
--   TableCells '[] cells = '[]
--   TableCells (MyCol title width ': cols) (value ': cells) =
--     'PutNatW' width value ':  TableCells cols cells
--   TableCells (MyCol title width ': cols) '[] =
--     'PutStrW' width "n/a" ':  TableCells cols '[]
-- @
module Data.Type.Pretty where

import Control.Monad.RWS hiding (tell)
import qualified Control.Monad.RWS
import GHC.TypeLits
import Data.Proxy
import Text.Printf
import Data.Word
import Data.Int
import Data.Tagged
import Data.Kind (type Type)

-- * Pretty Printing Types

-- | Pretty print either types of kind 'PrettyType' or any other type with a
-- 'ToPretty' instance.
showPretty
  :: forall k proxy (t :: k) . PrettyTypeShow (ToPretty t)
  => proxy t  -- ^ A proxy to the type to print. A 'ToPretty' instance for t must exists.
  -> String
showPretty :: proxy t -> String
showPretty proxy t
_ = ((), String) -> String
forall a b. (a, b) -> b
snd (((), String) -> String) -> ((), String) -> String
forall a b. (a -> b) -> a -> b
$ RWS Indentation String PTRenderState ()
-> Indentation -> PTRenderState -> ((), String)
forall r w s a. RWS r w s a -> r -> s -> (a, w)
evalRWS (Proxy (ToPretty t) -> RWS Indentation String PTRenderState ()
forall (p :: PrettyType) (proxy :: PrettyType -> *).
PrettyTypeShow p =>
proxy p -> RWS Indentation String PTRenderState ()
ptShow (Proxy (ToPretty t)
forall k (t :: k). Proxy t
Proxy :: Proxy (ToPretty t))) Indentation
0 PTRenderState
AtBeginningOfLine

-- | Create a 'PrettyType' from a type.
--
-- This is a type-level equivalent of the 'Show' class.
--
-- Write an instance of this for converting your type (preferrable of your
-- kind also) to a promoted 'PrettyType'.
type family ToPretty (a :: k) :: PrettyType

-- | A type of kind 'PrettyType' has a trivial @id@-like'ToPretty' instance.
type instance ToPretty (t :: PrettyType) = t

-- ** ToPretty instances for uninhabited types

-- | A type of kind 'Symbol' is translated to 'PutStr'.
--
-- @since 0.2.1.0
type instance ToPretty (t :: Symbol) = PutStr t

-- | A type of kind 'Nat' is translated to 'PutNat'.
--
-- @since 0.2.1.0
type instance ToPretty (t :: Nat) = PutNat t

-- | Render 'True' as @'PutStr' "'True"@
--
-- @since 0.2.1.0
type instance ToPretty 'True = PutStr "'True"

-- | Render 'False' as @'PutStr' "'False"@
--
-- @since 0.2.1.0
type instance ToPretty 'False = PutStr "'False"

-- | Render a type of kind 'Maybe'.
--
-- @since 0.2.1.0
type instance ToPretty (t :: Maybe x) = ToPrettyMaybe t

-- | Render a type of kind 'Maybe'.
--
-- @since 0.2.1.0
type family ToPrettyMaybe (t :: Maybe x) :: PrettyType where
  ToPrettyMaybe 'Nothing = 'PrettyEmpty
  ToPrettyMaybe ('Just x) = ToPretty x

-- ** ToPretty instances for inhabited types

-- | Render 'Word8' as @'PutStr' "Word8"@
--
-- @since 0.2.1.0
type instance ToPretty Word8 = PutStr "Word8"

-- | Render 'Word16' as @'PutStr' "Word16"@
--
-- @since 0.2.1.0
type instance ToPretty Word16 = PutStr "Word16"

-- | Render 'Word32' as @'PutStr' "Word32"@
--
-- @since 0.2.1.0
type instance ToPretty Word32 = PutStr "Word32"

-- | Render 'Word64' as @'PutStr' "Word64"@
--
-- @since 0.2.1.0
type instance ToPretty Word64 = PutStr "Word64"

-- | Render 'Int8' as @'PutStr' "Int8"@
--
-- @since 0.2.1.0
type instance ToPretty Int8 = PutStr "Int8"

-- | Render 'Int16' as @'PutStr' "Int16"@
--
-- @since 0.2.1.0
type instance ToPretty Int16 = PutStr "Int16"

-- | Render 'Int32' as @'PutStr' "Int32"@
--
-- @since 0.2.1.0
type instance ToPretty Int32 = PutStr "Int32"

-- | Render 'Int64' as @'PutStr' "Int64"@
--
-- @since 0.2.1.0
type instance ToPretty Int64 = PutStr "Int64"

-- | Render 'Int' as @'PutStr' "Int"@
--
-- @since 0.2.1.0
type instance ToPretty Int = PutStr "Int"

-- | Render 'Integer' as @'PutStr' "Integer"@
--
-- @since 0.2.1.0
type instance ToPretty Integer = PutStr "Integer"

-- | Render 'Bool' as @'PutStr' "Bool"@
--
-- @since 0.2.1.0
type instance ToPretty Bool = PutStr "Bool"

-- | Render 'Float' as @'PutStr' "Float"@
--
-- @since 0.2.1.0
type instance ToPretty Float = PutStr "Float"

-- | Render 'Double' as @'PutStr' "Double"@
--
-- @since 0.2.1.0
type instance ToPretty Double = PutStr "Double"

-- * Pretty Printing

-- ** Pretty Printing Strings ('Symbol')

-- | A 'PrettyType' for a string.
type PutStr str = 'PrettySymbol 'PrettyUnpadded 'PrettyPrecise str

-- | A 'PrettyType' for a string with the exact given width.
type PutStrW width str =
  'PrettySymbol ('PrettyPadded width) ('PrettyPrecision width) str

-- | A 'PrettyType' for a string with a newline character at the end.
type PutStrLn str = PutStr str <++> PutStr "\n"

-- ** Pretty Printing Numbers ('Nat')

-- | A 'PrettyType' for a number.
type PutNat x = 'PrettyNat 'PrettyUnpadded 'PrettyPrecise 'PrettyDec x

-- | A 'PrettyType' for a number with a width.
type PutNatW width x = 'PrettyNat ('PrettyPadded width) 'PrettyPrecise 'PrettyDec x

-- | Create 'PrettyType' from a 'Nat' formatted as hex number using
-- lower-case letters for the hex digits.
type PutHex x = 'PrettyNat 'PrettyUnpadded 'PrettyPrecise 'PrettyHex x
-- | Create 'PrettyType' from a 'Nat' formatted as 8 bit hex number using
-- lower-case letters for the hex digits.
type PutHex8 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 2) 'PrettyHex x
-- | Create 'PrettyType' from a 'Nat' formatted as 16 bit hex number using
-- lower-case letters for the hex digits.
type PutHex16 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 4) 'PrettyHex x
-- | Create 'PrettyType' from a 'Nat' formatted as 32 bit hex number using
-- lower-case letters for the hex digits.
type PutHex32 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 8) 'PrettyHex x
-- | Create 'PrettyType' from a 'Nat' formatted as 64 bit hex number using
-- lower-case letters for the hex digits.
type PutHex64 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 16) 'PrettyHex x
-- | Create 'PrettyType' from a 'Nat' formatted as hex number using
-- lower-case letters for the hex digits.
type PutHeX x = 'PrettyNat 'PrettyUnpadded 'PrettyPrecise 'PrettyHexU x
-- | Create 'PrettyType' from a 'Nat' formatted as 8 bit hex number using
-- uppercase letters for the hex digits.
type PutHeX8 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 2) 'PrettyHexU x
-- | Create 'PrettyType' from a 'Nat' formatted as 16 bit hex number using
-- uppercase letters for the hex digits.
type PutHeX16 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 4) 'PrettyHexU x
-- | Create 'PrettyType' from a 'Nat' formatted as 32 bit hex number using
-- uppercase letters for the hex digits.
type PutHeX32 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 8) 'PrettyHexU x
-- | Create 'PrettyType' from a 'Nat' formatted as 64 bit hex number using
-- uppercase letters for the hex digits.
type PutHeX64 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 16) 'PrettyHexU x

-- | Create 'PrettyType' from a 'Nat' formatted as bit representation,
--
-- >>> showPretty (Proxy :: Proxy (PutBits 5))
-- "101"
type PutBits x = 'PrettyNat 'PrettyUnpadded 'PrettyPrecise 'PrettyBit x
-- | Create 'PrettyType' from a 'Nat' formatted as 8-bit bit representation,
--
-- >>> showPretty (Proxy :: Proxy (PutBits8 5))
-- "00000101"
type PutBits8 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 8) 'PrettyBit x
-- | Create 'PrettyType' from a 'Nat' formatted as 16-bit bit representation,
--
-- >>> showPretty (Proxy :: Proxy (PutBits16 5))
-- "00000000000000101"
type PutBits16 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 16) 'PrettyBit x
-- | Create 'PrettyType' from a 'Nat' formatted as 32-bit bit representation,
--
-- >>> showPretty (Proxy :: Proxy (PutBits32 5))
-- "00000000000000000000000000000000101"
type PutBits32 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 32) 'PrettyBit x
-- | Create 'PrettyType' from a 'Nat' formatted as 64-bit bit representation,
--
-- >>> showPretty (Proxy :: Proxy (PutBits64 5))
-- "00000000000000000000000000000000000000000000000000000000000000000000101"
type PutBits64 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 64) 'PrettyBit x

-- ** Composing Pretty Printers

-- | A label followed by a colon and space @: @ followed by another element.
--
-- @since 0.2.0.0
--
-- >>> showPretty (Proxy :: Proxy ("foo" <:> PutStr "bar"))
-- @
-- foo: bar
-- @
type (<:>) label body = 'PrettySuffix (PutStr ":") (PutStr label) <+> body
infixl 5 <:>
-- | Like '<:>' but begin the body on a new line.
--
-- @since 0.2.0.0
--
-- >>> showPretty (Proxy :: Proxy (PutStr "foo" <:$$> PutStr "bar"))
-- @
-- foo:
-- bar
-- @
type (<:$$>) label body = 'PrettySuffix (PutStr ":") (PutStr label) <$$> body
infixl 5 <:$$>

-- | Like '<:$$__>' but indent the body with two spaces.
--
-- @since 0.2.0.0
--
-- >>> showPretty (Proxy :: Proxy (PutStr "foo" <:$$--> PutStr "bar"))
-- @
-- foo:
--   bar
-- @
type (<:$$-->) label body = 'PrettySuffix (PutStr ":") (PutStr label) <$$--> body
infixl 3 <:$$-->

-- | Concatenate two 'PrettyType'.
type (<++>) l r = 'PrettyInfix 'PrettyEmpty l r
infixl 6 <++>

-- | Concatenate two 'PrettyType' using a 'PrettySpace'.
type (<+>) l r = 'PrettyInfix 'PrettySpace l r
infixl 5 <+>

-- | Choose the first non-empty from two 'PrettyType's.
--
-- @since 0.2.0.0
type (<||>) l r = 'PrettyAlternative l r
infixl 5 <||>

-- | Concatenate two 'PrettyType' using a 'PrettyNewline'.
type (<$$>) l r = 'PrettyInfix 'PrettyNewline l r
infixl 4 <$$>

-- | Concatenate two 'PrettyType' using a 'PrettyNewline' and indent the second.
--
-- @since 0.2.0.0
type (<$$-->) l r = 'PrettyInfix 'PrettyNewline l ('PrettyIndent 2 r)
infixl 3 <$$-->

-- | Surround a pretty with parens
type PrettyParens doc = PrettySurrounded (PutStr "(") (PutStr ")") doc

-- | Surround a pretty with some pretties
type PrettySurrounded open close doc  =
  open <++> doc <++> close

-- *** Pretty Printing Lists

-- | Combine a (type level) list of 'PrettyType's next to each other using
-- 'PrettySpace'
type PrettyWide docs = PrettyMany 'PrettySpace docs

-- | Combine a (type level) list of 'PrettyType's below each other using
-- 'PrettyNewline'
type PrettyHigh docs = PrettyMany 'PrettyNewline docs

-- | A combination of 'PrettySpace' and 'PrettyMany', e.g.:
--
-- >>> showPretty (Proxy :: Proxy (PrettyManyIn (PutStr "|") '[PutStr "a", PutStr "b"]))
-- "|a|b|"
type PrettyManyIn sep docs =
  PrettySurrounded sep sep (PrettyMany sep docs)

-- | Combine a (type level) list of 'PrettyType's seperated by a seperation
-- element.
type family
  PrettyMany (sep :: PrettyType)(docs :: [PrettyType]) :: PrettyType where
  PrettyMany sep '[]            = 'PrettyEmpty
  PrettyMany sep '[singleOne]   = singleOne
  PrettyMany sep (next ': rest) = next <++> sep <++> PrettyMany sep rest

-- | Repeat a 'PrettyType' @n@-times and append the copies.
type family PrettyOften (n :: Nat) (doc :: PrettyType) :: PrettyType where
  PrettyOften 0 doc = 'PrettyEmpty
  PrettyOften n doc = doc <++> PrettyOften (n-1) doc

-- *** Pretty Printing 'Tagged' Values

-- | Pretty print a 'Tagged' value.
--
-- @since 0.2.2.0
type instance ToPretty (Tagged s b) = ToPretty b <+> PrettyParens (ToPretty s)

-- * Basic Building Blocks

-- | Combinators for /type documents/.
--
-- The basis for pretty printing is this eDSL. It is rendered via the
-- 'PrettyTypeShow' instances for its promoted constructors.
--
-- Only the promoted constructors are used, only they have instances for that
-- class.
data PrettyType where
  PrettyEmpty :: PrettyType
  PrettySpace :: PrettyType
  -- | Begin a newline. Always use this otherwise indentation will not work!
  PrettyNewline :: PrettyType
  PrettySymbol :: PrettyPadded -> PrettyPrecision -> Symbol -> PrettyType
  PrettyNat :: PrettyPadded -> PrettyPrecision -> PrettyNatFormat -> Nat -> PrettyType
  -- | Prefix the second with the first argument, but only if it (the second) has content.
  --
  -- @since 0.2.0.0
  PrettyPrefix :: PrettyType -> PrettyType -> PrettyType
  -- | Combine the last to arguments with the first in between them, but only if both have content.
  PrettyInfix :: PrettyType -> PrettyType -> PrettyType -> PrettyType
  -- | Add a the first argument as suffix to the second argument, but only if the second has content.
  --
  -- @since 0.2.0.0
  PrettySuffix :: PrettyType -> PrettyType -> PrettyType
  -- | Indentation. Prefix any line using the given number of 'PrettySpace'.
  --
  -- @since 0.2.0.0
  PrettyIndent :: Nat -> PrettyType -> PrettyType
  -- | Alternative rendering, if the first document ist empty the second will be rendered.
  --
  -- @since 0.2.0.0
  PrettyAlternative :: PrettyType -> PrettyType -> PrettyType

-- | Padding for 'PrettyType's 'PrettySymbol' and 'PrettyNat'.
data PrettyPadded where
  -- | No minimum or fixed width
  PrettyUnpadded :: PrettyPadded
  -- | Pad a 'PrettySymbol' or 'PrettyNat' with spaces or zeros.
  -- __NOTE__ `PrettyNat`s will never be  shorter than the minimum
  -- number of digits, regardless of this padding.
  PrettyPadded :: Nat -> PrettyPadded

-- | The precision for 'PrettySymbol' and 'PrettyNat'.
data PrettyPrecision where
  -- | No minimum precision.
  PrettyPrecise :: PrettyPrecision
  -- | Precision, for 'Symbol's the maximum width, for 'Nat's the minimum
  -- digits.
  -- __NOTE__`PrettyNat`s will never be  shorter than the minimum
  -- number of digits, wheres `PrettySymbol`s will be  truncated if they are
  -- longer than the precision.
  PrettyPrecision :: Nat-> PrettyPrecision

-- | 'PrettyNat' formatting options.
data PrettyNatFormat =
    -- | Hexa decimal rendering:
    --
    -- >>> showPretty (Proxy::Proxy (PrettyNat PrettyUnpadded PrettyPrecise PrettyHex 51966))
    -- "cafe"
    PrettyHex
    -- | Hexa decimal rendering (upper case):
    --
    -- >>> showPretty (Proxy::Proxy (PrettyNat PrettyUnpadded PrettyPrecise PrettyHexU 51966))
    -- "CAFE"
  | PrettyHexU
    -- | Decimal rendering:
    --
    -- >>> showPretty (Proxy::Proxy (PrettyNat PrettyUnpadded PrettyPrecise PrettyHexU 51966))
    -- "51966"
  | PrettyDec
    -- | Binary rendering:
    --
    -- >>> showPretty (Proxy::Proxy (PrettyNat PrettyUnpadded PrettyPrecise PrettyHexU 51966))
    -- "1100101011111110"
  | PrettyBit

-- * 'PrettyType' Functions

-- | /Kind/ of 'Prettifier' data types.
--
-- The type that all data types share, such that they can be passed to
-- 'PrettifyWith'.
--
-- Sometimes it is desirable to pass around __pretty-printing functions__ called
-- 'Prettifier' in this library. A 'Prettifier' is a __parameterized pretty-printer__
-- that accepts a parameter of a specific kind.
--
-- For example:
--
-- @
-- data PutStrIsh :: Prettifies Symbol
--
-- type instance PrettifyWith PutStrIsh str = PutStr str <++> PutStr "ish"
-- @
--
-- >>> showPretty (Proxy @(PrettifyWith PutStrIsh "That's pretty okay"))
-- "That's pretty okayish"
--
-- @since 0.2.3.0
type Prettifies t = Prettifier t -> Type

-- | An abstract declaration of a __pretty-printing (type-)function__ that takes
-- a specific kind of types as parameter.
--
-- @since 0.2.3.0
data Prettifier :: Type -> Type

-- | Apply a 'Prettifier' to a type in order to get a 'PrettyType'
--
-- @since 0.2.3.0
type family PrettifyWith (f :: Prettifies k) (x :: k) :: PrettyType

-- ** Basic 'Prettifier's

-- | Write a title and print the indented, 'ToPretty'-fied body starting on the
-- next line.
--
-- @since 0.2.3.0
data PrettyTitled (title :: PrettyType) (indentation :: Nat) :: Prettifies t

type instance PrettifyWith (PrettyTitled title indentation) body =
  'PrettyInfix 'PrettyNewline title ('PrettyIndent indentation (ToPretty body))

-- *  Pretty Rendering

-- | An __internal__ type class for rendering the types of /kind/ 'PrettyType'.
class PrettyTypeShow (p :: PrettyType) where
  -- | Given any proxy to a promoted constructor of 'PrettyType', generate a
  -- String.
  ptShow :: proxy p -> PTM ()
  -- | Return 'True' if contents would be writting to the output of rendered via 'ptShow'
  --
  -- @since 0.2.0.0
  ptHasContent :: proxy p -> PTM Bool
  ptHasContent proxy p
_ = Bool -> PTM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- | The monad used by 'ptShow' to keep track of indentation.
--
-- @since 0.2.0.0
type PTM a = RWS Indentation String PTRenderState a

-- | Internal; write a possibly indented string, and update the 'PTRenderState' accordingly.
--
-- @since 0.2.0.0
writeIndented :: String -> PTM ()
writeIndented :: String -> RWS Indentation String PTRenderState ()
writeIndented String
s = do
    PTRenderState
st <- RWST Indentation String PTRenderState Identity PTRenderState
forall s (m :: * -> *). MonadState s m => m s
get
    case PTRenderState
st of
        PTRenderState
AtBeginningOfLine -> do
            Indentation
i <- RWST Indentation String PTRenderState Identity Indentation
forall r (m :: * -> *). MonadReader r m => m r
ask
            String -> RWS Indentation String PTRenderState ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
Control.Monad.RWS.tell (Indentation -> Char -> String
forall a. Indentation -> a -> [a]
replicate Indentation
i Char
' ')
            PTRenderState -> RWS Indentation String PTRenderState ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put PTRenderState
AlreadyIndented
        PTRenderState
AlreadyIndented -> () -> RWS Indentation String PTRenderState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    String -> RWS Indentation String PTRenderState ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
Control.Monad.RWS.tell String
s

-- | Internal type of the indentation used by 'ptShow' in 'PTM'
--
-- @since 0.2.0.0
type Indentation = Int

-- | Internal state used by 'ptShow' in 'PTM'
--
-- @since 0.2.0.0
data PTRenderState = AtBeginningOfLine | AlreadyIndented

-- | Print nothing.
instance PrettyTypeShow 'PrettyEmpty where
  ptShow :: proxy 'PrettyEmpty -> RWS Indentation String PTRenderState ()
ptShow proxy 'PrettyEmpty
_ = () -> RWS Indentation String PTRenderState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  ptHasContent :: proxy 'PrettyEmpty -> PTM Bool
ptHasContent proxy 'PrettyEmpty
_ = Bool -> PTM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | Print a single space character.
instance PrettyTypeShow 'PrettySpace where
  ptShow :: proxy 'PrettySpace -> RWS Indentation String PTRenderState ()
ptShow proxy 'PrettySpace
_ = String -> RWS Indentation String PTRenderState ()
writeIndented String
" "

-- | Print a single newline character.
instance PrettyTypeShow 'PrettyNewline where
    ptShow :: proxy 'PrettyNewline -> RWS Indentation String PTRenderState ()
ptShow proxy 'PrettyNewline
_ = do
        PTRenderState -> RWS Indentation String PTRenderState ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put PTRenderState
AtBeginningOfLine
        String -> RWS Indentation String PTRenderState ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
Control.Monad.RWS.tell String
"\n"

-- | Print a 'Symbol' using the 'printf' and the given format parameters.
instance forall t pad prec . (KnownSymbol t, PrintfArgModifier pad, PrintfArgModifier prec) =>
         PrettyTypeShow ('PrettySymbol pad prec t) where
    ptShow :: proxy ('PrettySymbol pad prec t)
-> RWS Indentation String PTRenderState ()
ptShow proxy ('PrettySymbol pad prec t)
_ = String -> RWS Indentation String PTRenderState ()
writeIndented (String -> RWS Indentation String PTRenderState ())
-> String -> RWS Indentation String PTRenderState ()
forall a b. (a -> b) -> a -> b
$
        String -> String -> String
forall r. PrintfType r => String -> r
printf (String
"%" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                    Proxy pad -> String
forall k (a :: k) (p :: k -> *).
PrintfArgModifier a =>
p a -> String
toPrintfArgModifier (Proxy pad
forall k (t :: k). Proxy t
Proxy :: Proxy pad)
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Proxy prec -> String
forall k (a :: k) (p :: k -> *).
PrintfArgModifier a =>
p a -> String
toPrintfArgModifier (Proxy prec
forall k (t :: k). Proxy t
Proxy :: Proxy prec)
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"s")
               (Proxy t -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy t
forall k (t :: k). Proxy t
Proxy :: Proxy t))
    ptHasContent :: proxy ('PrettySymbol pad prec t) -> PTM Bool
ptHasContent proxy ('PrettySymbol pad prec t)
_ = Bool -> PTM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Proxy t -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy t
forall k (t :: k). Proxy t
Proxy :: Proxy t) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"")

-- | Print a 'Nat' using the 'printf' and the given format parameters.
instance forall fmt x pad prec . (KnownNat x, PrintfArgModifier fmt, PrintfArgModifier pad, PrintfArgModifier prec) =>
         PrettyTypeShow ('PrettyNat pad prec fmt x) where
    ptShow :: proxy ('PrettyNat pad prec fmt x)
-> RWS Indentation String PTRenderState ()
ptShow proxy ('PrettyNat pad prec fmt x)
_ = String -> RWS Indentation String PTRenderState ()
writeIndented (String -> RWS Indentation String PTRenderState ())
-> String -> RWS Indentation String PTRenderState ()
forall a b. (a -> b) -> a -> b
$
        String -> Integer -> String
forall r. PrintfType r => String -> r
printf (String
"%" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                    Proxy pad -> String
forall k (a :: k) (p :: k -> *).
PrintfArgModifier a =>
p a -> String
toPrintfArgModifier (Proxy pad
forall k (t :: k). Proxy t
Proxy :: Proxy pad)
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Proxy prec -> String
forall k (a :: k) (p :: k -> *).
PrintfArgModifier a =>
p a -> String
toPrintfArgModifier (Proxy prec
forall k (t :: k). Proxy t
Proxy :: Proxy prec)
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ Proxy fmt -> String
forall k (a :: k) (p :: k -> *).
PrintfArgModifier a =>
p a -> String
toPrintfArgModifier (Proxy fmt
forall k (t :: k). Proxy t
Proxy :: Proxy fmt))
               (Proxy x -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy x
forall k (t :: k). Proxy t
Proxy :: Proxy x))

-- | Concatenate two 'PrettyType's. If one of them is empty print the other
-- without any seperation character.
instance forall l r sep . (PrettyTypeShow sep, PrettyTypeShow l, PrettyTypeShow r) =>
         PrettyTypeShow ('PrettyInfix sep l r) where
    ptShow :: proxy ('PrettyInfix sep l r)
-> RWS Indentation String PTRenderState ()
ptShow proxy ('PrettyInfix sep l r)
_ = do
        Bool
leftHasContent <- Proxy l -> PTM Bool
forall (p :: PrettyType) (proxy :: PrettyType -> *).
PrettyTypeShow p =>
proxy p -> PTM Bool
ptHasContent (Proxy l
forall k (t :: k). Proxy t
Proxy :: Proxy l)
        Bool
rightHasContent <- Proxy r -> PTM Bool
forall (p :: PrettyType) (proxy :: PrettyType -> *).
PrettyTypeShow p =>
proxy p -> PTM Bool
ptHasContent (Proxy r
forall k (t :: k). Proxy t
Proxy :: Proxy r)
        Bool
-> RWS Indentation String PTRenderState ()
-> RWS Indentation String PTRenderState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
leftHasContent (Proxy l -> RWS Indentation String PTRenderState ()
forall (p :: PrettyType) (proxy :: PrettyType -> *).
PrettyTypeShow p =>
proxy p -> RWS Indentation String PTRenderState ()
ptShow (Proxy l
forall k (t :: k). Proxy t
Proxy :: Proxy l))
        Bool
-> RWS Indentation String PTRenderState ()
-> RWS Indentation String PTRenderState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
leftHasContent Bool -> Bool -> Bool
&& Bool
rightHasContent) (Proxy sep -> RWS Indentation String PTRenderState ()
forall (p :: PrettyType) (proxy :: PrettyType -> *).
PrettyTypeShow p =>
proxy p -> RWS Indentation String PTRenderState ()
ptShow (Proxy sep
forall k (t :: k). Proxy t
Proxy :: Proxy sep))
        Bool
-> RWS Indentation String PTRenderState ()
-> RWS Indentation String PTRenderState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
rightHasContent (Proxy r -> RWS Indentation String PTRenderState ()
forall (p :: PrettyType) (proxy :: PrettyType -> *).
PrettyTypeShow p =>
proxy p -> RWS Indentation String PTRenderState ()
ptShow (Proxy r
forall k (t :: k). Proxy t
Proxy :: Proxy r))

    ptHasContent :: proxy ('PrettyInfix sep l r) -> PTM Bool
ptHasContent proxy ('PrettyInfix sep l r)
_ =
      Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool)
-> PTM Bool
-> RWST Indentation String PTRenderState Identity (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy l -> PTM Bool
forall (p :: PrettyType) (proxy :: PrettyType -> *).
PrettyTypeShow p =>
proxy p -> PTM Bool
ptHasContent (Proxy l
forall k (t :: k). Proxy t
Proxy :: Proxy l)
          RWST Indentation String PTRenderState Identity (Bool -> Bool)
-> PTM Bool -> PTM Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Proxy r -> PTM Bool
forall (p :: PrettyType) (proxy :: PrettyType -> *).
PrettyTypeShow p =>
proxy p -> PTM Bool
ptHasContent (Proxy r
forall k (t :: k). Proxy t
Proxy :: Proxy r)

-- | Prefix a 'PrettyType' to x, but only if 'ptHasContent' of 'x' holds.
instance forall x sep . (PrettyTypeShow sep, PrettyTypeShow x) =>
         PrettyTypeShow ('PrettyPrefix sep x) where
    ptShow :: proxy ('PrettyPrefix sep x)
-> RWS Indentation String PTRenderState ()
ptShow proxy ('PrettyPrefix sep x)
_ = do
        Bool
hasContent <- Proxy x -> PTM Bool
forall (p :: PrettyType) (proxy :: PrettyType -> *).
PrettyTypeShow p =>
proxy p -> PTM Bool
ptHasContent (Proxy x
forall k (t :: k). Proxy t
Proxy :: Proxy x)
        Bool
-> RWS Indentation String PTRenderState ()
-> RWS Indentation String PTRenderState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasContent (RWS Indentation String PTRenderState ()
 -> RWS Indentation String PTRenderState ())
-> RWS Indentation String PTRenderState ()
-> RWS Indentation String PTRenderState ()
forall a b. (a -> b) -> a -> b
$ do
          Proxy sep -> RWS Indentation String PTRenderState ()
forall (p :: PrettyType) (proxy :: PrettyType -> *).
PrettyTypeShow p =>
proxy p -> RWS Indentation String PTRenderState ()
ptShow (Proxy sep
forall k (t :: k). Proxy t
Proxy :: Proxy sep)
          Proxy x -> RWS Indentation String PTRenderState ()
forall (p :: PrettyType) (proxy :: PrettyType -> *).
PrettyTypeShow p =>
proxy p -> RWS Indentation String PTRenderState ()
ptShow (Proxy x
forall k (t :: k). Proxy t
Proxy :: Proxy x)

    ptHasContent :: proxy ('PrettyPrefix sep x) -> PTM Bool
ptHasContent proxy ('PrettyPrefix sep x)
_ = Proxy x -> PTM Bool
forall (p :: PrettyType) (proxy :: PrettyType -> *).
PrettyTypeShow p =>
proxy p -> PTM Bool
ptHasContent (Proxy x
forall k (t :: k). Proxy t
Proxy :: Proxy x)

-- | Add a 'PrettyType' suffix to x, but only if 'ptHasContent' holds.
--
-- @since 0.2.0.0
instance forall x sep . (PrettyTypeShow sep, PrettyTypeShow x) =>
         PrettyTypeShow ('PrettySuffix sep x) where
    ptShow :: proxy ('PrettySuffix sep x)
-> RWS Indentation String PTRenderState ()
ptShow proxy ('PrettySuffix sep x)
_ = do
        Bool
hasContent <- Proxy x -> PTM Bool
forall (p :: PrettyType) (proxy :: PrettyType -> *).
PrettyTypeShow p =>
proxy p -> PTM Bool
ptHasContent (Proxy x
forall k (t :: k). Proxy t
Proxy :: Proxy x)
        Bool
-> RWS Indentation String PTRenderState ()
-> RWS Indentation String PTRenderState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasContent (RWS Indentation String PTRenderState ()
 -> RWS Indentation String PTRenderState ())
-> RWS Indentation String PTRenderState ()
-> RWS Indentation String PTRenderState ()
forall a b. (a -> b) -> a -> b
$ do
          Proxy x -> RWS Indentation String PTRenderState ()
forall (p :: PrettyType) (proxy :: PrettyType -> *).
PrettyTypeShow p =>
proxy p -> RWS Indentation String PTRenderState ()
ptShow (Proxy x
forall k (t :: k). Proxy t
Proxy :: Proxy x)
          Proxy sep -> RWS Indentation String PTRenderState ()
forall (p :: PrettyType) (proxy :: PrettyType -> *).
PrettyTypeShow p =>
proxy p -> RWS Indentation String PTRenderState ()
ptShow (Proxy sep
forall k (t :: k). Proxy t
Proxy :: Proxy sep)

    ptHasContent :: proxy ('PrettySuffix sep x) -> PTM Bool
ptHasContent proxy ('PrettySuffix sep x)
_ = Proxy x -> PTM Bool
forall (p :: PrettyType) (proxy :: PrettyType -> *).
PrettyTypeShow p =>
proxy p -> PTM Bool
ptHasContent (Proxy x
forall k (t :: k). Proxy t
Proxy :: Proxy x)

-- | Render the first document, and if it is empty, the second
--
-- @since 0.2.0.0
instance forall l r . (PrettyTypeShow l, PrettyTypeShow r) =>
         PrettyTypeShow ('PrettyAlternative l r) where
    ptShow :: proxy ('PrettyAlternative l r)
-> RWS Indentation String PTRenderState ()
ptShow proxy ('PrettyAlternative l r)
_ = do
        Bool
leftHasContent <- Proxy l -> PTM Bool
forall (p :: PrettyType) (proxy :: PrettyType -> *).
PrettyTypeShow p =>
proxy p -> PTM Bool
ptHasContent (Proxy l
forall k (t :: k). Proxy t
Proxy :: Proxy l)
        if Bool
leftHasContent
          then Proxy l -> RWS Indentation String PTRenderState ()
forall (p :: PrettyType) (proxy :: PrettyType -> *).
PrettyTypeShow p =>
proxy p -> RWS Indentation String PTRenderState ()
ptShow (Proxy l
forall k (t :: k). Proxy t
Proxy :: Proxy l)
          else Proxy r -> RWS Indentation String PTRenderState ()
forall (p :: PrettyType) (proxy :: PrettyType -> *).
PrettyTypeShow p =>
proxy p -> RWS Indentation String PTRenderState ()
ptShow (Proxy r
forall k (t :: k). Proxy t
Proxy :: Proxy r)

    ptHasContent :: proxy ('PrettyAlternative l r) -> PTM Bool
ptHasContent proxy ('PrettyAlternative l r)
_ =
      Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool)
-> PTM Bool
-> RWST Indentation String PTRenderState Identity (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy l -> PTM Bool
forall (p :: PrettyType) (proxy :: PrettyType -> *).
PrettyTypeShow p =>
proxy p -> PTM Bool
ptHasContent (Proxy l
forall k (t :: k). Proxy t
Proxy :: Proxy l)
          RWST Indentation String PTRenderState Identity (Bool -> Bool)
-> PTM Bool -> PTM Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Proxy r -> PTM Bool
forall (p :: PrettyType) (proxy :: PrettyType -> *).
PrettyTypeShow p =>
proxy p -> PTM Bool
ptHasContent (Proxy r
forall k (t :: k). Proxy t
Proxy :: Proxy r)


-- | Render an indented, nested type.
--
-- @since 0.2.0.0
instance forall n r . (PrettyTypeShow r, KnownNat n) =>
         PrettyTypeShow ('PrettyIndent n r) where

    ptShow :: proxy ('PrettyIndent n r)
-> RWS Indentation String PTRenderState ()
ptShow proxy ('PrettyIndent n r)
_ = (Indentation -> Indentation)
-> RWS Indentation String PTRenderState ()
-> RWS Indentation String PTRenderState ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Indentation -> Indentation -> Indentation
forall a. Num a => a -> a -> a
+ (Integer -> Indentation
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy n))))
                     (Proxy r -> RWS Indentation String PTRenderState ()
forall (p :: PrettyType) (proxy :: PrettyType -> *).
PrettyTypeShow p =>
proxy p -> RWS Indentation String PTRenderState ()
ptShow (Proxy r
forall k (t :: k). Proxy t
Proxy :: Proxy r))

    ptHasContent :: proxy ('PrettyIndent n r) -> PTM Bool
ptHasContent proxy ('PrettyIndent n r)
_ =  Proxy r -> PTM Bool
forall (p :: PrettyType) (proxy :: PrettyType -> *).
PrettyTypeShow p =>
proxy p -> PTM Bool
ptHasContent (Proxy r
forall k (t :: k). Proxy t
Proxy :: Proxy r)

-- | Internal 'printf' format generation. Used internally by 'PrettyTypeShow'
-- instances to generate the format string piece by piece with the values for
-- the instances of e.g. 'PrettyPrecise', 'PrettyNatFormat', or 'PrettyEmpty'.
class PrintfArgModifier a where
  -- | Generate a piece of a 'printf' format string from a proxy for a type.
  toPrintfArgModifier :: p a -> String

-- | Translation of 'PrettyHex' to 'printf' format character: @x@
instance PrintfArgModifier 'PrettyHex where toPrintfArgModifier :: p 'PrettyHex -> String
toPrintfArgModifier p 'PrettyHex
_  = String
"x"
-- | Translation of 'PrettyHexU' to 'printf' format character: @X@
instance PrintfArgModifier 'PrettyHexU where toPrintfArgModifier :: p 'PrettyHexU -> String
toPrintfArgModifier p 'PrettyHexU
_ = String
"X"
-- | Translation of 'PrettyDec' to 'printf' format character: @d@
instance PrintfArgModifier 'PrettyDec where toPrintfArgModifier :: p 'PrettyDec -> String
toPrintfArgModifier p 'PrettyDec
_  = String
"d"
-- | Translation of 'PrettyBit' to 'printf' format character: @b@
instance PrintfArgModifier 'PrettyBit where toPrintfArgModifier :: p 'PrettyBit -> String
toPrintfArgModifier p 'PrettyBit
_  = String
"b"
-- | Translation of 'PrettyUnpadded' to an empty modifier string
instance PrintfArgModifier 'PrettyUnpadded where toPrintfArgModifier :: p 'PrettyUnpadded -> String
toPrintfArgModifier p 'PrettyUnpadded
_ = String
""
-- | Translation of 'PrettyPadded' to a string with the numeric padding value.
instance forall p. KnownNat p => PrintfArgModifier ('PrettyPadded p) where
    toPrintfArgModifier :: p ('PrettyPadded p) -> String
toPrintfArgModifier p ('PrettyPadded p)
_ = Integer -> String
forall a. Show a => a -> String
show (Proxy p -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy p
forall k (t :: k). Proxy t
Proxy :: Proxy p))
-- | Translation of 'PrettyPrecise' to an empty modifier string
instance PrintfArgModifier 'PrettyPrecise where toPrintfArgModifier :: p 'PrettyPrecise -> String
toPrintfArgModifier p 'PrettyPrecise
_ = String
""
-- | Translation of 'PrettyPadded' to a string with the numeric precision value,
-- prependen by a  dot @"."@.
instance forall p. KnownNat p => PrintfArgModifier ('PrettyPrecision p) where
    toPrintfArgModifier :: p ('PrettyPrecision p) -> String
toPrintfArgModifier p ('PrettyPrecision p)
_ = String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show (Proxy p -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy p
forall k (t :: k). Proxy t
Proxy :: Proxy p))