    --------------------------------------------------------------------------------
    -- |
    -- 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@(t1 :: Token
    t1,(p1 :: a
    p1,s1 :: String
    s1)) bs :: [(Token, (a, String))]
    bs =
        case [(Token, (a, String))]
    bs of
          (_t2 :: Token
    _t2,(_,s2 :: String
    s2)) : more :: [(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 t :: 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))
    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
    a = case String -> Maybe Value
    parseValue String
    txt of
                Just v :: Value
    v  -> Value -> Doc
    valToDoc Value
    v
                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 '[' ']' ([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 val :: Value
    val = case Value
    val of
      Con c :: String
    c vs :: [Value]
    vs         -> String -> [Value] -> Doc
    ppCon String
    c [Value]
    vs
      InfixCons v1 :: Value
    v1 cvs :: [(String, Value)]
    cvs -> [Doc] -> Doc
    hang_sep (Value -> [(String, Value)] -> [Doc]
    go Value
    v1 [(String, Value)]
    cvs)
        where
          go :: Value -> [(String, Value)] -> [Doc]
    go v :: Value
    v []            = [Value -> Doc
    ppInfixAtom Value
    v]
          go v :: Value
    v ((n :: String
    n,v2 :: Value
    v2):cvs' :: [(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 (x :: Doc
    x:xs :: [Doc]
    xs) = Doc -> Int -> Doc -> Doc
    hang Doc
    x 2 ([Doc] -> Doc
    sep [Doc]
    xs)
        -- hang (ppInfixAtom v1) 2 (sep [ text n <+> ppInfixAtom v | (n,v) <- cvs ])
      Rec c :: String
    c fs :: [(String, Value)]
    fs         -> Doc -> Int -> Doc -> Doc
    hang (String -> Doc
    text String
    c) 2 (Doc -> Doc) -> Doc -> Doc
    forall a b. (a -> b) -> a -> b
    $ Char -> Char -> [Doc] -> Doc
    block '{' '}' (((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 (x :: String
    x,v :: Value
    v) = Doc -> Int -> Doc -> Doc
    hang (String -> Doc
    text String
    x Doc -> Doc -> Doc
    <+> Char -> Doc
    char '=') 2 (Value -> Doc
    valToDoc Value
    v)

      List vs :: [Value]
    vs          -> Char -> Char -> [Doc] -> Doc
    block '[' ']' ((Value -> Doc) -> [Value] -> [Doc]
    forall a b. (a -> b) -> [a] -> [b]
    map Value -> Doc
    valToDoc [Value]
    vs)
      Tuple vs :: [Value]
    vs         -> Char -> Char -> [Doc] -> Doc
    block '(' ')' ((Value -> Doc) -> [Value] -> [Doc]
    forall a b. (a -> b) -> [a] -> [b]
    map Value -> Doc
    valToDoc [Value]
    vs)
      Neg v :: Value
    v            -> Char -> Doc
    char '-' Doc -> Doc -> Doc
    <> Value -> Doc
    ppAtom Value
    v
      Ratio x :: Value
    x y :: Value
    y        -> Doc -> Int -> Doc -> Doc
    hang (Value -> Doc
    ppAtom Value
    x Doc -> Doc -> Doc
    <+> String -> Doc
    text "%") 2 (Value -> Doc
    ppAtom Value
    y)
      Integer x :: String
    x        -> String -> Doc
    text String
    x
      Float x :: String
    x          -> String -> Doc
    text String
    x
      Char x :: String
    x           -> String -> Doc
    text String
    x
      String x :: String
    x         -> String -> Doc
    text String
    x
      Date x :: String
    x           -> String -> Doc
    text String
    x
      Time x :: String
    x           -> String -> Doc
    text String
    x
      Quote x :: 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 p :: Int
    p (PreProc f :: Value -> Value
    f a :: a
    a) cs :: String
    cs =
        case String -> Maybe Value
    parseValue String
    txt of
          Nothing -> String
    txt String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    cs
          Just v :: 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 ""
        wrap :: String -> String
    wrap t :: String
    t = case (String
    t,String
    txt) of
                  (h :: Char
    h:_,'(':_) | Char
    h Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= '(' -> '(' Char -> String -> String
    forall a. a -> [a] -> [a]
    : (String
    t String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ')' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    cs)
                  _ -> 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 p :: 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 p :: 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 v :: 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 v :: 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 "" vs :: [Value]
    vs = [Doc] -> Doc
    sep ((Value -> Doc) -> [Value] -> [Doc]
    forall a b. (a -> b) -> [a] -> [b]
    map Value -> Doc
    ppAtom [Value]
    vs)
    ppCon c :: String
    c vs :: [Value]
    vs  = Doc -> Int -> Doc -> Doc
    hang (String -> Doc
    text String
    c) 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 _ (_:_))  = Bool
    False
    isAtom (InfixCons {}) = Bool
    False
    isAtom (Ratio {})     = Bool
    False
    isAtom (Neg {})       = Bool
    False
    isAtom _              = 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 _              = 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 _ a :: Char
    a b :: Char
    b []      = Char -> Doc
    char Char
    a Doc -> Doc -> Doc
    <> Char -> Doc
    char Char
    b
    blockWith f :: [Doc] -> Doc
    f a :: Char
    a b :: Char
    b (d :: Doc
    d:ds :: [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 ',' Doc -> Doc -> Doc
    <+> Doc
    x | Doc
    x <- [Doc]
    ds ] [Doc] -> [Doc] -> [Doc]
    forall a. [a] -> [a] -> [a]
    ++ [ Char -> Doc
    char Char
    b ]