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

{-# LANGUAGE ImportQualifiedPost #-}
{-# 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 :: a -> Doc ann
ppShow a
x =
  case String -> Maybe Value
parseValue String
y of
    Maybe Value
Nothing -> 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 :: 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 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 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 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
  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