----------------------------------------------------------------------------
-- |
-- Module      :  Prettyprinter.Show
-- Copyright   :  (c) Sergey Vinokurov 2018
-- License     :  Apache-2.0 (see LICENSE)
-- Maintainer  :  serg.foo@gmail.com
----------------------------------------------------------------------------

{-# LANGUAGE CPP               #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}

module Prettyprinter.Show
  ( ppShow
  , PPShow(..)
  -- * Reexports
  , 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(..))

-- $setup
-- >>> :set -XDerivingVia
-- >>> import Data.IntMap (IntMap)
-- >>> import Data.Map.Strict (Map)
-- >>> import Data.Set (Set)

-- | Helper to use 'Show'-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 (Show)
--   deriving Pretty via PPShow (TestWithDeriving a b)
-- :}
--
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