{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Prettyprinter.Show
( ppShow
, PPShow(..)
, Pretty(..)
) where
import Data.Text qualified as T
import Prettyprinter
import Prettyprinter qualified as PP
import Prettyprinter.Combinators
import Prettyprinter.MetaDoc
import Text.Show.Pretty (parseValue, Value(..))
newtype PPShow a = PPShow { forall a. PPShow a -> a
unPPShow :: a }
instance Show a => Pretty (PPShow a) where
pretty :: forall ann. PPShow a -> Doc ann
pretty = a -> Doc ann
forall a ann. Show a => a -> Doc ann
ppShow (a -> Doc ann) -> (PPShow a -> a) -> PPShow a -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PPShow a -> a
forall a. PPShow a -> a
unPPShow
ppShow :: Show a => a -> Doc ann
ppShow :: forall a ann. Show a => a -> Doc ann
ppShow a
x =
case String -> Maybe Value
parseValue String
y of
Maybe Value
Nothing -> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
y
Just Value
y' -> MetaDoc ann -> Doc ann
forall ann. MetaDoc ann -> Doc ann
mdPayload (MetaDoc ann -> Doc ann) -> MetaDoc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Value -> MetaDoc ann
forall ann. Value -> MetaDoc ann
ppValue Value
y'
where
y :: String
y :: String
y = a -> String
forall a. Show a => a -> String
show a
x
ppValue :: Value -> MetaDoc ann
ppValue :: forall ann. Value -> MetaDoc ann
ppValue = \case
Con String
name [Value]
args ->
MetaDoc ann -> [MetaDoc ann] -> MetaDoc ann
forall ann. MetaDoc ann -> [MetaDoc ann] -> MetaDoc ann
constructorAppMetaDoc (Doc ann -> MetaDoc ann
forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc (String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
name)) ((Value -> MetaDoc ann) -> [Value] -> [MetaDoc ann]
forall a b. (a -> b) -> [a] -> [b]
map Value -> MetaDoc ann
forall ann. Value -> MetaDoc ann
ppValue [Value]
args)
InfixCons Value
v [(String, Value)]
xs ->
Doc ann -> MetaDoc ann
forall ann. Doc ann -> MetaDoc ann
compositeMetaDoc (Doc ann -> MetaDoc ann) -> Doc ann -> MetaDoc ann
forall a b. (a -> b) -> a -> b
$
[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep (MetaDoc ann -> Doc ann
forall ann. MetaDoc ann -> Doc ann
mdPayload (Value -> MetaDoc ann
forall ann. Value -> MetaDoc ann
ppValue Value
v) Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: ((String, Value) -> [Doc ann]) -> [(String, Value)] -> [Doc ann]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(String
con, Value
v') -> [String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
con, MetaDoc ann -> Doc ann
forall ann. MetaDoc ann -> Doc ann
mdPayload (Value -> MetaDoc ann
forall ann. Value -> MetaDoc ann
ppValue Value
v')]) [(String, Value)]
xs)
Rec String
name [(String, Value)]
fields ->
Doc ann -> MetaDoc ann
forall ann. Doc ann -> MetaDoc ann
compositeMetaDoc (Doc ann -> MetaDoc ann) -> Doc ann -> MetaDoc ann
forall a b. (a -> b) -> a -> b
$
Doc ann -> [MapEntry Text (Doc ann)] -> Doc ann
forall ann. Doc ann -> [MapEntry Text (Doc ann)] -> Doc ann
ppDictHeader (String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
name) (((String, Value) -> MapEntry Text (Doc ann))
-> [(String, Value)] -> [MapEntry Text (Doc ann)]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
field, Value
v) -> String -> Text
T.pack String
field Text -> Doc ann -> MapEntry Text (Doc ann)
forall k v. k -> v -> MapEntry k v
:-> MetaDoc ann -> Doc ann
forall ann. MetaDoc ann -> Doc ann
mdPayload (Value -> MetaDoc ann
forall ann. Value -> MetaDoc ann
ppValue Value
v)) [(String, Value)]
fields)
Tuple [Value]
xs ->
Doc ann -> MetaDoc ann
forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc (Doc ann -> MetaDoc ann) -> Doc ann -> MetaDoc ann
forall a b. (a -> b) -> a -> b
$
Doc ann -> Doc ann -> [Doc ann] -> Doc ann
forall (f :: * -> *) ann.
Foldable f =>
Doc ann -> Doc ann -> f (Doc ann) -> Doc ann
ppListWithDelim Doc ann
forall ann. Doc ann
PP.lparen Doc ann
forall ann. Doc ann
PP.rparen ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (Value -> Doc ann) -> [Value] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (MetaDoc ann -> Doc ann
forall ann. MetaDoc ann -> Doc ann
mdPayload (MetaDoc ann -> Doc ann)
-> (Value -> MetaDoc ann) -> Value -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> MetaDoc ann
forall ann. Value -> MetaDoc ann
ppValue) [Value]
xs
List [Value]
xs ->
Doc ann -> MetaDoc ann
forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc (Doc ann -> MetaDoc ann) -> Doc ann -> MetaDoc ann
forall a b. (a -> b) -> a -> b
$
(Value -> Doc ann) -> [Value] -> Doc ann
forall a ann. (a -> Doc ann) -> [a] -> Doc ann
ppListWith (MetaDoc ann -> Doc ann
forall ann. MetaDoc ann -> Doc ann
mdPayload (MetaDoc ann -> Doc ann)
-> (Value -> MetaDoc ann) -> Value -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> MetaDoc ann
forall ann. Value -> MetaDoc ann
ppValue) [Value]
xs
Neg Value
x -> Doc ann -> MetaDoc ann
forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc (Doc ann -> MetaDoc ann) -> Doc ann -> MetaDoc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
"-" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> MetaDoc ann -> Doc ann
forall ann. MetaDoc ann -> Doc ann
mdPayload (Value -> MetaDoc ann
forall ann. Value -> MetaDoc ann
ppValue Value
x)
Ratio Value
x Value
y -> Doc ann -> MetaDoc ann
forall ann. Doc ann -> MetaDoc ann
compositeMetaDoc (Doc ann -> MetaDoc ann) -> Doc ann -> MetaDoc ann
forall a b. (a -> b) -> a -> b
$ MetaDoc ann -> Doc ann
forall ann. MetaDoc ann -> Doc ann
mdPayload (Value -> MetaDoc ann
forall ann. Value -> MetaDoc ann
ppValue Value
x) 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
<+> MetaDoc ann -> Doc ann
forall ann. MetaDoc ann -> Doc ann
mdPayload (Value -> MetaDoc ann
forall ann. Value -> MetaDoc ann
ppValue Value
y)
Integer String
x -> String -> MetaDoc ann
forall ann. String -> MetaDoc ann
stringMetaDoc String
x
Float String
x -> String -> MetaDoc ann
forall ann. String -> MetaDoc ann
stringMetaDoc String
x
Char String
x -> String -> MetaDoc ann
forall ann. String -> MetaDoc ann
stringMetaDoc String
x
String String
x -> String -> MetaDoc ann
forall ann. String -> MetaDoc ann
stringMetaDoc String
x
#if MIN_VERSION_pretty_show (1, 10, 0)
Date String
x -> String -> MetaDoc ann
forall ann. String -> MetaDoc ann
stringMetaDoc String
x
Time String
x -> String -> MetaDoc ann
forall ann. String -> MetaDoc ann
stringMetaDoc String
x
Quote String
x -> String -> MetaDoc ann
forall ann. String -> MetaDoc ann
stringMetaDoc String
x
#endif