----------------------------------------------------------------------------
-- |
-- 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 { unPPShow :: a }

instance Show a => Pretty (PPShow a) where
  pretty = ppShow . unPPShow

ppShow :: Show a => a -> Doc ann
ppShow x =
  case parseValue y of
    Nothing -> pretty y
    Just y' -> mdPayload $ ppValue y'
  where
    y :: String
    y = show x

ppValue :: Value -> MetaDoc ann
ppValue = \case
  Con name args   ->
    constructorAppMetaDoc (atomicMetaDoc (pretty name)) (map ppValue args)
  InfixCons v xs  ->
    compositeMetaDoc $
    hsep (mdPayload (ppValue v) : concatMap (\(con, v') -> [pretty con, mdPayload (ppValue v')]) xs)
  Rec name fields ->
    compositeMetaDoc $
    ppDictHeader (pretty name) (map (\(field, v) -> T.pack field :-> mdPayload (ppValue v)) fields)
  Tuple xs        ->
    atomicMetaDoc $
    ppListWithDelim PP.lparen PP.rparen $ map (mdPayload . ppValue) xs
  List xs         ->
    atomicMetaDoc $
    ppListWith (mdPayload . ppValue) xs
  Neg x           -> atomicMetaDoc $ "-" <> mdPayload (ppValue x)
  Ratio x y       -> compositeMetaDoc $ mdPayload (ppValue x) <+> "%" <+> mdPayload (ppValue y)
  Integer x       -> stringMetaDoc x
  Float x         -> stringMetaDoc x
  Char x          -> stringMetaDoc x
  String x        -> stringMetaDoc x
#if MIN_VERSION_pretty_show (1, 10, 0)
  Date x          -> stringMetaDoc x
  Time x          -> stringMetaDoc x
  Quote x         -> stringMetaDoc x
#endif