--------------------------------------------------------------------------------
-- |
-- Module      :  Text.Show.Pretty
-- Copyright   :  (c) Iavor S. Diatchki 2009
-- License     :  MIT
--
-- Maintainer  :  iavor.diatchki@gmail.com
-- Stability   :  provisional
-- Portability :  Haskell 98
--
-- Functions for human-readable derived 'Show' instances.
--------------------------------------------------------------------------------

{-# LANGUAGE CPP #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE PatternGuards #-}
module Text.Show.Pretty
  ( -- * Generic representation of values
    Value(..), Name
  , valToStr
  , valToDoc
  , valToHtmlPage

    -- * Values using the 'Show' class
  , parseValue, reify, ppDoc, ppShow, pPrint

  , -- * Working with listlike ("foldable") collections
    ppDocList, ppShowList, pPrintList

    -- * Values using the 'PrettyVal' class
  , dumpDoc, dumpStr, dumpIO, PrettyVal(..)

    -- * Rendering values to Html
  , valToHtml, HtmlOpts(..), defaultHtmlOpts, htmlPage, Html(..)

    -- * Get location of data files
  , getDataDir

  , -- * Preprocessing of values
    PreProc(..), ppHide, ppHideNested, hideCon

    -- * Deprecated
  , ppValue
  ) where

import Data.Char(isHexDigit)
import Text.PrettyPrint
import qualified Text.Show.Parser as P
import Text.Show.Value
import Text.Show.PrettyVal
import Text.Show.Html
import Data.Foldable(Foldable,toList)
import Language.Haskell.Lexer(rmSpace,lexerPass0,Token(..))
import Paths_pretty_show (getDataDir)

#if MIN_VERSION_base(4,11,0)
import Prelude hiding ( (<>) )
#else
import Prelude
#endif

{-# DEPRECATED ppValue "Please use `valToDoc` instead." #-}
ppValue :: Value -> Doc
ppValue :: Value -> Doc
ppValue = Value -> Doc
valToDoc

reify :: Show a => a -> Maybe Value
reify :: a -> Maybe Value
reify = String -> Maybe Value
parseValue (String -> Maybe Value) -> (a -> String) -> a -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

parseValue :: String -> Maybe Value
parseValue :: String -> Maybe Value
parseValue = [PosToken] -> Maybe Value
P.parseValue ([PosToken] -> Maybe Value)
-> (String -> [PosToken]) -> String -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PosToken] -> [PosToken]
rmSpace ([PosToken] -> [PosToken])
-> (String -> [PosToken]) -> String -> [PosToken]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PosToken -> [PosToken] -> [PosToken])
-> [PosToken] -> [PosToken] -> [PosToken]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr PosToken -> [PosToken] -> [PosToken]
forall a.
(Token, (a, String))
-> [(Token, (a, String))] -> [(Token, (a, String))]
joinTokens [] ([PosToken] -> [PosToken])
-> (String -> [PosToken]) -> String -> [PosToken]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [PosToken]
lexerPass0
  where

  -- Sometimes we join tokens that are next to each other, with no spaces.
  -- This improves the printing of some malformed inputs:
  --   * Hex numbers with no 0x:    "4ab"  instead of "4 ab"
  joinTokens :: (Token, (a, String))
-> [(Token, (a, String))] -> [(Token, (a, String))]
joinTokens a :: (Token, (a, String))
a@(Token
t1,(a
p1,String
s1)) [(Token, (a, String))]
bs =
    case [(Token, (a, String))]
bs of
      (Token
_t2,(a
_,String
s2)) : [(Token, (a, String))]
more
        | Token
IntLit <- Token
t1, (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isHexDigit String
s2 -> Token -> [(Token, (a, String))]
jn Token
IntLit
          where jn :: Token -> [(Token, (a, String))]
jn Token
t = (Token
t,(a
p1,String
s1String -> String -> String
forall a. [a] -> [a] -> [a]
++String
s2)) (Token, (a, String))
-> [(Token, (a, String))] -> [(Token, (a, String))]
forall a. a -> [a] -> [a]
: [(Token, (a, String))]
more

      [(Token, (a, String))]
_ -> (Token, (a, String))
a (Token, (a, String))
-> [(Token, (a, String))] -> [(Token, (a, String))]
forall a. a -> [a] -> [a]
: [(Token, (a, String))]
bs


-- | Convert a generic value into a pretty 'String', if possible.
ppShow :: Show a => a -> String
ppShow :: a -> String
ppShow = Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> (a -> Doc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc
forall a. Show a => a -> Doc
ppDoc

-- | Pretty print something that may be converted to a list as a list.
-- Each entry is on a separate line, which means that we don't do clever
-- pretty printing, and so this works well for large strucutures.
ppShowList :: (Foldable f, Show a) => f a -> String
ppShowList :: f a -> String
ppShowList = Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> (f a -> Doc) -> f a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> Doc
forall (f :: * -> *) a. (Foldable f, Show a) => f a -> Doc
ppDocList

-- | Try to show a value, prettily. If we do not understand the value, then we
--   just use its standard 'Show' instance.
ppDoc :: Show a => a -> Doc
ppDoc :: a -> Doc
ppDoc a
a = case String -> Maybe Value
parseValue String
txt of
            Just Value
v  -> Value -> Doc
valToDoc Value
v
            Maybe Value
Nothing -> String -> Doc
text String
txt
  where txt :: String
txt = a -> String
forall a. Show a => a -> String
show a
a

-- | Pretty print something that may be converted to a list as a list.
-- Each entry is on a separate line, which means that we don't do clever
-- pretty printing, and so this works well for large strucutures.
ppDocList :: (Foldable f, Show a) => f a -> Doc
ppDocList :: f a -> Doc
ppDocList = ([Doc] -> Doc) -> Char -> Char -> [Doc] -> Doc
blockWith [Doc] -> Doc
vcat Char
'[' Char
']' ([Doc] -> Doc) -> (f a -> [Doc]) -> f a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall a. Show a => a -> Doc
ppDoc ([a] -> [Doc]) -> (f a -> [a]) -> f a -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

-- | Pretty print a generic value to stdout. This is particularly useful in the
-- GHCi interactive environment.
pPrint :: Show a => a -> IO ()
pPrint :: a -> IO ()
pPrint = String -> IO ()
putStrLn (String -> IO ()) -> (a -> String) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
ppShow

-- | Pretty print something that may be converted to a list as a list.
-- Each entry is on a separate line, which means that we don't do clever
-- pretty printing, and so this works well for large strucutures.
pPrintList :: (Foldable f, Show a) => f a -> IO ()
pPrintList :: f a -> IO ()
pPrintList = String -> IO ()
putStrLn (String -> IO ()) -> (f a -> String) -> f a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> String
forall (f :: * -> *) a. (Foldable f, Show a) => f a -> String
ppShowList

-- | Render a value in the 'PrettyVal' class to a 'Doc'.
-- The benefit of this function is that 'PrettyVal' instances may
-- be derived automatically using generics.
dumpDoc :: PrettyVal a => a -> Doc
dumpDoc :: a -> Doc
dumpDoc = Value -> Doc
valToDoc (Value -> Doc) -> (a -> Value) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. PrettyVal a => a -> Value
prettyVal

-- | Render a value in the 'PrettyVal' class to a 'String'.
-- The benefit of this function is that 'PrettyVal' instances may
-- be derived automatically using generics.
dumpStr :: PrettyVal a => a -> String
dumpStr :: a -> String
dumpStr = Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> (a -> Doc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc
forall a. PrettyVal a => a -> Doc
dumpDoc

-- | Render a value using the 'PrettyVal' class and show it to standard out.
dumpIO :: PrettyVal a => a -> IO ()
dumpIO :: a -> IO ()
dumpIO = String -> IO ()
putStrLn (String -> IO ()) -> (a -> String) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. PrettyVal a => a -> String
dumpStr


-- | Pretty print a generic value. Our intention is that the result is
--   equivalent to the 'Show' instance for the original value, except possibly
--   easier to understand by a human.
valToStr :: Value -> String
valToStr :: Value -> String
valToStr = Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> (Value -> Doc) -> Value -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Doc
valToDoc

-- | Pretty print a generic value. Our intention is that the result is
--   equivalent to the 'Show' instance for the original value, except possibly
--   easier to understand by a human.
valToDoc :: Value -> Doc
valToDoc :: Value -> Doc
valToDoc Value
val = case Value
val of
  Con String
c [Value]
vs         -> String -> [Value] -> Doc
ppCon String
c [Value]
vs
  InfixCons Value
v1 [(String, Value)]
cvs -> [Doc] -> Doc
hang_sep (Value -> [(String, Value)] -> [Doc]
go Value
v1 [(String, Value)]
cvs)
    where
      go :: Value -> [(String, Value)] -> [Doc]
go Value
v []            = [Value -> Doc
ppInfixAtom Value
v]
      go Value
v ((String
n,Value
v2):[(String, Value)]
cvs') = (Value -> Doc
ppInfixAtom Value
v Doc -> Doc -> Doc
<+> String -> Doc
text String
n)Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:Value -> [(String, Value)] -> [Doc]
go Value
v2 [(String, Value)]
cvs'

      hang_sep :: [Doc] -> Doc
hang_sep [] = Doc
empty
      hang_sep (Doc
x:[Doc]
xs) = Doc -> Int -> Doc -> Doc
hang Doc
x Int
2 ([Doc] -> Doc
sep [Doc]
xs)
    -- hang (ppInfixAtom v1) 2 (sep [ text n <+> ppInfixAtom v | (n,v) <- cvs ])
  Rec String
c [(String, Value)]
fs         -> Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
c) Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> Char -> [Doc] -> Doc
block Char
'{' Char
'}' (((String, Value) -> Doc) -> [(String, Value)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String, Value) -> Doc
ppField [(String, Value)]
fs)
    where ppField :: (String, Value) -> Doc
ppField (String
x,Value
v) = Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
x Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'=') Int
2 (Value -> Doc
valToDoc Value
v)

  List [Value]
vs          -> Char -> Char -> [Doc] -> Doc
block Char
'[' Char
']' ((Value -> Doc) -> [Value] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Doc
valToDoc [Value]
vs)
  Tuple [Value]
vs         -> Char -> Char -> [Doc] -> Doc
block Char
'(' Char
')' ((Value -> Doc) -> [Value] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Doc
valToDoc [Value]
vs)
  Neg Value
v            -> Char -> Doc
char Char
'-' Doc -> Doc -> Doc
<> Value -> Doc
ppAtom Value
v
  Ratio Value
x Value
y        -> Doc -> Int -> Doc -> Doc
hang (Value -> Doc
ppAtom Value
x Doc -> Doc -> Doc
<+> String -> Doc
text String
"%") Int
2 (Value -> Doc
ppAtom Value
y)
  Integer String
x        -> String -> Doc
text String
x
  Float String
x          -> String -> Doc
text String
x
  Char String
x           -> String -> Doc
text String
x
  String String
x         -> String -> Doc
text String
x
  Date String
x           -> String -> Doc
text String
x
  Time String
x           -> String -> Doc
text String
x
  Quote String
x          -> String -> Doc
text String
x


-- | This type is used to allow pre-processing of values before showing them.
data PreProc a = PreProc (Value -> Value) a

instance Show a => Show (PreProc a) where
  showsPrec :: Int -> PreProc a -> String -> String
showsPrec Int
p (PreProc Value -> Value
f a
a) String
cs =
    case String -> Maybe Value
parseValue String
txt of
      Maybe Value
Nothing -> String
txt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cs
      Just Value
v  -> String -> String
wrap (Value -> String
valToStr (Value -> Value
f Value
v))
    where
    txt :: String
txt    = Int -> a -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
p a
a String
""
    wrap :: String -> String
wrap String
t = case (String
t,String
txt) of
              (Char
h:String
_,Char
'(':String
_) | Char
h Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'(' -> Char
'(' Char -> String -> String
forall a. a -> [a] -> [a]
: (String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
')' Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs)
              (String, String)
_ -> String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cs

-- | Hide the given constructors when showing a value.
ppHide :: (Name -> Bool) -> a -> PreProc a
ppHide :: (String -> Bool) -> a -> PreProc a
ppHide String -> Bool
p = (Value -> Value) -> a -> PreProc a
forall a. (Value -> Value) -> a -> PreProc a
PreProc (Bool -> (String -> Bool) -> Value -> Value
hideCon Bool
False String -> Bool
p)

-- | Hide the given constructors when showing a value.
-- In addition, hide values if all of their children were hidden.
ppHideNested :: (Name -> Bool) -> a -> PreProc a
ppHideNested :: (String -> Bool) -> a -> PreProc a
ppHideNested String -> Bool
p = (Value -> Value) -> a -> PreProc a
forall a. (Value -> Value) -> a -> PreProc a
PreProc (Bool -> (String -> Bool) -> Value -> Value
hideCon Bool
True String -> Bool
p)



-- Private ---------------------------------------------------------------------

ppAtom :: Value -> Doc
ppAtom :: Value -> Doc
ppAtom Value
v
  | Value -> Bool
isAtom Value
v  = Value -> Doc
valToDoc Value
v
  | Bool
otherwise = Doc -> Doc
parens (Value -> Doc
valToDoc Value
v)

ppInfixAtom :: Value -> Doc
ppInfixAtom :: Value -> Doc
ppInfixAtom Value
v
  | Value -> Bool
isInfixAtom Value
v = Value -> Doc
valToDoc Value
v
  | Bool
otherwise     = Doc -> Doc
parens (Value -> Doc
valToDoc Value
v)

ppCon :: Name -> [Value] -> Doc
ppCon :: String -> [Value] -> Doc
ppCon String
"" [Value]
vs = [Doc] -> Doc
sep ((Value -> Doc) -> [Value] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Doc
ppAtom [Value]
vs)
ppCon String
c [Value]
vs  = Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
c) Int
2 ([Doc] -> Doc
sep ((Value -> Doc) -> [Value] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Doc
ppAtom [Value]
vs))

isAtom               :: Value -> Bool
isAtom :: Value -> Bool
isAtom (Con String
_ (Value
_:[Value]
_))  = Bool
False
isAtom (InfixCons {}) = Bool
False
isAtom (Ratio {})     = Bool
False
isAtom (Neg {})       = Bool
False
isAtom Value
_              = Bool
True

-- Don't put parenthesis around constructors in infix chains
isInfixAtom          :: Value -> Bool
isInfixAtom :: Value -> Bool
isInfixAtom (InfixCons {}) = Bool
False
isInfixAtom (Ratio {})     = Bool
False
isInfixAtom (Neg {})       = Bool
False
isInfixAtom Value
_              = Bool
True

block :: Char -> Char -> [Doc] -> Doc
block :: Char -> Char -> [Doc] -> Doc
block = ([Doc] -> Doc) -> Char -> Char -> [Doc] -> Doc
blockWith [Doc] -> Doc
sep

blockWith :: ([Doc] -> Doc) -> Char -> Char -> [Doc] -> Doc
blockWith :: ([Doc] -> Doc) -> Char -> Char -> [Doc] -> Doc
blockWith [Doc] -> Doc
_ Char
a Char
b []      = Char -> Doc
char Char
a Doc -> Doc -> Doc
<> Char -> Doc
char Char
b
blockWith [Doc] -> Doc
f Char
a Char
b (Doc
d:[Doc]
ds)  = [Doc] -> Doc
f ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    (Char -> Doc
char Char
a Doc -> Doc -> Doc
<+> Doc
d) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: [ Char -> Doc
char Char
',' Doc -> Doc -> Doc
<+> Doc
x | Doc
x <- [Doc]
ds ] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [ Char -> Doc
char Char
b ]