----------------------------------------------------------------------------
-- |
-- 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(..)
  ) 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 = forall a ann. Show a => a -> Doc ann
ppShow forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> forall a ann. Pretty a => a -> Doc ann
pretty String
y
    Just Value
y' -> forall ann. MetaDoc ann -> Doc ann
mdPayload forall a b. (a -> b) -> a -> b
$ forall ann. Value -> MetaDoc ann
ppValue Value
y'
  where
    y :: String
    y :: String
y = 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   ->
    forall ann. MetaDoc ann -> [MetaDoc ann] -> MetaDoc ann
constructorAppMetaDoc (forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc (forall a ann. Pretty a => a -> Doc ann
pretty String
name)) (forall a b. (a -> b) -> [a] -> [b]
map forall ann. Value -> MetaDoc ann
ppValue [Value]
args)
  InfixCons Value
v [(String, Value)]
xs  ->
    forall ann. Doc ann -> MetaDoc ann
compositeMetaDoc forall a b. (a -> b) -> a -> b
$
    forall ann. [Doc ann] -> Doc ann
hsep (forall ann. MetaDoc ann -> Doc ann
mdPayload (forall ann. Value -> MetaDoc ann
ppValue Value
v) forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(String
con, Value
v') -> [forall a ann. Pretty a => a -> Doc ann
pretty String
con, forall ann. MetaDoc ann -> Doc ann
mdPayload (forall ann. Value -> MetaDoc ann
ppValue Value
v')]) [(String, Value)]
xs)
  Rec String
name [(String, Value)]
fields ->
    forall ann. Doc ann -> MetaDoc ann
compositeMetaDoc forall a b. (a -> b) -> a -> b
$
    forall ann. Doc ann -> [MapEntry Text (Doc ann)] -> Doc ann
ppDictHeader (forall a ann. Pretty a => a -> Doc ann
pretty String
name) (forall a b. (a -> b) -> [a] -> [b]
map (\(String
field, Value
v) -> String -> Text
T.pack String
field forall k v. k -> v -> MapEntry k v
:-> forall ann. MetaDoc ann -> Doc ann
mdPayload (forall ann. Value -> MetaDoc ann
ppValue Value
v)) [(String, Value)]
fields)
  Tuple [Value]
xs        ->
    forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) ann.
Foldable f =>
Doc ann -> Doc ann -> f (Doc ann) -> Doc ann
ppListWithDelim forall ann. Doc ann
PP.lparen forall ann. Doc ann
PP.rparen forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall ann. MetaDoc ann -> Doc ann
mdPayload forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Value -> MetaDoc ann
ppValue) [Value]
xs
  List [Value]
xs         ->
    forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc forall a b. (a -> b) -> a -> b
$
    forall a ann. (a -> Doc ann) -> [a] -> Doc ann
ppListWith (forall ann. MetaDoc ann -> Doc ann
mdPayload forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Value -> MetaDoc ann
ppValue) [Value]
xs
  Neg Value
x           -> forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc forall a b. (a -> b) -> a -> b
$ Doc ann
"-" forall a. Semigroup a => a -> a -> a
<> forall ann. MetaDoc ann -> Doc ann
mdPayload (forall ann. Value -> MetaDoc ann
ppValue Value
x)
  Ratio Value
x Value
y       -> forall ann. Doc ann -> MetaDoc ann
compositeMetaDoc forall a b. (a -> b) -> a -> b
$ forall ann. MetaDoc ann -> Doc ann
mdPayload (forall ann. Value -> MetaDoc ann
ppValue Value
x) forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"%" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. MetaDoc ann -> Doc ann
mdPayload (forall ann. Value -> MetaDoc ann
ppValue Value
y)
  Integer String
x       -> forall ann. String -> MetaDoc ann
stringMetaDoc String
x
  Float String
x         -> forall ann. String -> MetaDoc ann
stringMetaDoc String
x
  Char String
x          -> forall ann. String -> MetaDoc ann
stringMetaDoc String
x
  String String
x        -> forall ann. String -> MetaDoc ann
stringMetaDoc String
x
#if MIN_VERSION_pretty_show (1, 10, 0)
  Date String
x          -> forall ann. String -> MetaDoc ann
stringMetaDoc String
x
  Time String
x          -> forall ann. String -> MetaDoc ann
stringMetaDoc String
x
  Quote String
x         -> forall ann. String -> MetaDoc ann
stringMetaDoc String
x
#endif