----------------------------------------------------------------------------
-- |
-- 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) 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(..))

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