-- Copyright 2015 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{- | Like Show, but designed to be easy to read rather than unambiguous and
    complete.
-}
module Util.Pretty (
    module Util.Format
    , Pretty, pretty, format, formatList
    , prettys
    , formatted, pprint
    , char
    , improperRatio, fraction

    -- * generic derivation
    , formatG, formatG_, formatGCamel, formatGPrefix

    -- * formatting
    , textList, formattedList, delimitedList, record, recordTitle
    , formatMap
    , constructor
    -- * standalone
    , duration
    , bytes
    -- * misc
    , readWord
) where
import qualified Data.ByteString as ByteString
import qualified Data.Char as Char
import qualified Data.Dynamic as Dynamic
import qualified Data.Int as Int
import qualified Data.IntMap as IntMap
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Ratio as Ratio
import qualified Data.Set as Set
import qualified Data.Text as Text
import           Data.Text (Text)
import qualified Data.Text.Encoding as Encoding
import qualified Data.Text.IO as Text.IO
import qualified Data.Text.Lazy as Lazy
import qualified Data.Time as Time
import qualified Data.Time.Calendar as Calendar
import qualified Data.Tree as Tree
import qualified Data.Vector as Vector
import qualified Data.Vector.Storable as Storable
import qualified Data.Vector.Unboxed as Unboxed
import qualified Data.Word as Word

import qualified Foreign
import qualified Foreign.C as C
import qualified GHC.Generics as Generics
import           GHC.Generics ((:*:)((:*:)))
import qualified Text.ParserCombinators.ReadP as ReadP
import qualified Text.Read as Read

import qualified Util.Format as Format
import           Util.Format
    (Doc, indent, indentLine, indent_, render, string, text, withIndent,
     wrapWords, (<+/>), (<+>), (<//>), (</>))
import qualified Util.Lists as Lists
import qualified Util.Num as Num


defaultWidth :: Int
defaultWidth :: Int
defaultWidth = Int
75

-- | Format values in an eye-pleasing way.  Unlike Show, this isn't intended
-- to produce any kind of valid syntax, or even preserve information.
class Pretty a where
    {-# MINIMAL pretty | format #-}
    pretty :: a -> Text
    pretty = Text -> Text
Lazy.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Text
Format.renderFlat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Doc
format
    format :: a -> Doc
    format = Text -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Text
pretty
    formatList :: [a] -> Doc
    formatList = forall a. Pretty a => Char -> Char -> [a] -> Doc
formattedList Char
'[' Char
']'

prettys :: Pretty a => a -> String
prettys :: forall a. Pretty a => a -> String
prettys = Text -> String
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Text
pretty

-- | Render a Pretty value to the default width.
formatted :: Pretty a => a -> Text
formatted :: forall a. Pretty a => a -> Text
formatted = Text -> Text
Lazy.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int -> Doc -> Text
render Text
"    " Int
defaultWidth forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Doc
format

pprint :: Pretty a => a -> IO ()
pprint :: forall a. Pretty a => a -> IO ()
pprint = Text -> IO ()
Text.IO.putStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Text
formatted

instance Pretty Doc where format :: Doc -> Doc
format = forall a. a -> a
id

showt :: Show a => a -> Text
showt :: forall a. Show a => a -> Text
showt = String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

char :: Char -> Doc
char :: Char -> Doc
char = Text -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
Text.singleton


data GConfig = GConfig {
    GConfig -> String -> String
_modifyField :: String -> String
    }

gconfig :: GConfig
gconfig :: GConfig
gconfig = (String -> String) -> GConfig
GConfig forall a. a -> a
id

dropPrefix :: String -> GConfig
dropPrefix :: String -> GConfig
dropPrefix String
prefix = GConfig
gconfig
    { _modifyField :: String -> String
_modifyField = \String
field ->
        forall a. a -> Maybe a -> a
Maybe.fromMaybe String
field (forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix String
prefix String
field)
    }

dropCamel :: GConfig
dropCamel :: GConfig
dropCamel = GConfig
gconfig
    { _modifyField :: String -> String
_modifyField = String -> String
lower forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
Char.isDigit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
Char.isLower }
    where
    lower :: String -> String
lower (Char
c:String
cs) = Char -> Char
Char.toLower Char
c forall a. a -> [a] -> [a]
: String
cs
    lower [] = String
"<no-capital>"

dropUnderscore :: GConfig
dropUnderscore :: GConfig
dropUnderscore =
    GConfig
gconfig { _modifyField :: String -> String
_modifyField = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
==Char
'_') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/=Char
'_') }

class PrettyG f where
    prettyG :: GConfig -> f a -> [(Text, Doc)]

formatG :: (PrettyG (Generics.Rep a), Generics.Generic a) => a -> Doc
formatG :: forall a. (PrettyG (Rep a), Generic a) => a -> Doc
formatG = forall a. (PrettyG (Rep a), Generic a) => GConfig -> a -> Doc
formatGWith GConfig
gconfig

formatG_ :: (PrettyG (Generics.Rep a), Generics.Generic a) => a -> Doc
formatG_ :: forall a. (PrettyG (Rep a), Generic a) => a -> Doc
formatG_ = forall a. (PrettyG (Rep a), Generic a) => GConfig -> a -> Doc
formatGWith GConfig
dropUnderscore

formatGCamel :: (PrettyG (Generics.Rep a), Generics.Generic a) => a -> Doc
formatGCamel :: forall a. (PrettyG (Rep a), Generic a) => a -> Doc
formatGCamel = forall a. (PrettyG (Rep a), Generic a) => GConfig -> a -> Doc
formatGWith GConfig
dropCamel

formatGPrefix :: (PrettyG (Generics.Rep a), Generics.Generic a)
    => String -> a -> Doc
formatGPrefix :: forall a. (PrettyG (Rep a), Generic a) => String -> a -> Doc
formatGPrefix String
prefix = forall a. (PrettyG (Rep a), Generic a) => GConfig -> a -> Doc
formatGWith (String -> GConfig
dropPrefix String
prefix)

-- | Generic derivation for Pretty.  This works on single-constructor types,
-- records and positional.
formatGWith :: (PrettyG (Generics.Rep a), Generics.Generic a) => GConfig -> a
    -> Doc
formatGWith :: forall a. (PrettyG (Rep a), Generic a) => GConfig -> a -> Doc
formatGWith GConfig
config a
a = case forall {k} (f :: k -> *) (a :: k).
PrettyG f =>
GConfig -> f a -> [(Text, Doc)]
prettyG GConfig
config (forall a x. Generic a => a -> Rep a x
Generics.from a
a) of
    [(Text
"", Doc
doc)] -> Doc
doc
    -- TODO what causes this?
    [(Text, Doc)]
fields -> Doc -> [(Text, Doc)] -> Doc
record Doc
"??" [(Text, Doc)]
fields

instance (PrettyG f) => PrettyG (Generics.M1 Generics.D d f) where
    prettyG :: forall (a :: k). GConfig -> M1 D d f a -> [(Text, Doc)]
prettyG GConfig
config (Generics.M1 f a
x) = forall {k} (f :: k -> *) (a :: k).
PrettyG f =>
GConfig -> f a -> [(Text, Doc)]
prettyG GConfig
config f a
x

instance (PrettyG f, Generics.Constructor c) =>
        PrettyG (Generics.M1 Generics.C c f) where
    prettyG :: forall (a :: k). GConfig -> M1 C c f a -> [(Text, Doc)]
prettyG GConfig
config c :: M1 C c f a
c@(Generics.M1 f a
x)
        | forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Bool
Generics.conIsRecord M1 C c f a
c =
            [(Text
"", Doc -> [(Text, Doc)] -> Doc
record (Text -> Doc
text (String -> Text
Text.pack String
name)) (forall {k} (f :: k -> *) (a :: k).
PrettyG f =>
GConfig -> f a -> [(Text, Doc)]
prettyG GConfig
config f a
x))]
        | Bool
otherwise =
            [(Text
"", Text -> [Doc] -> Doc
constructor (String -> Text
Text.pack String
name) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (forall {k} (f :: k -> *) (a :: k).
PrettyG f =>
GConfig -> f a -> [(Text, Doc)]
prettyG GConfig
config f a
x)))]
        where name :: String
name = forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
Generics.conName M1 C c f a
c

instance (PrettyG f, Generics.Selector s) =>
        PrettyG (Generics.M1 Generics.S s f) where
    prettyG :: forall (a :: k). GConfig -> M1 S s f a -> [(Text, Doc)]
prettyG GConfig
config it :: M1 S s f a
it@(Generics.M1 f a
x) =
        forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. a -> [a]
repeat (String -> Text
Text.pack (GConfig -> String -> String
_modifyField GConfig
config (forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
Generics.selName M1 S s f a
it))))
            (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (forall {k} (f :: k -> *) (a :: k).
PrettyG f =>
GConfig -> f a -> [(Text, Doc)]
prettyG GConfig
config f a
x))

instance Pretty a => PrettyG (Generics.K1 t a) where
    prettyG :: forall (a :: k). GConfig -> K1 t a a -> [(Text, Doc)]
prettyG GConfig
_config (Generics.K1 a
x) = [(Text
"", forall a. Pretty a => a -> Doc
format a
x)]

-- instance PrettyG Generics.U1 where
--     prettyG Generics.U1 = []
instance (PrettyG f, PrettyG g) => PrettyG (f :*: g) where
    prettyG :: forall (a :: k). GConfig -> (:*:) f g a -> [(Text, Doc)]
prettyG GConfig
config (f a
xs :*: g a
ys) = forall {k} (f :: k -> *) (a :: k).
PrettyG f =>
GConfig -> f a -> [(Text, Doc)]
prettyG GConfig
config f a
xs forall a. [a] -> [a] -> [a]
++ forall {k} (f :: k -> *) (a :: k).
PrettyG f =>
GConfig -> f a -> [(Text, Doc)]
prettyG GConfig
config g a
ys
-- instance (PrettyG f, PrettyG g) => PrettyG (f :+: g) where
--     prettyG (Generics.L1 x) = prettyG x
--     prettyG (Generics.R1 x) = prettyG x

-- * standard types

instance Pretty a => Pretty [a] where format :: [a] -> Doc
format = forall a. Pretty a => [a] -> Doc
formatList
instance Pretty Char where
    format :: Char -> Doc
format Char
c = Text -> Doc
text forall a b. (a -> b) -> a -> b
$ Text
"'" forall a. Semigroup a => a -> a -> a
<> Char -> Text
Text.singleton Char
c forall a. Semigroup a => a -> a -> a
<> Text
"'"
    formatList :: String -> Doc
formatList = forall a. Pretty a => a -> Doc
format forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack

instance Pretty (a -> b) where pretty :: (a -> b) -> Text
pretty a -> b
_ = Text
"<function>"
instance Pretty () where pretty :: () -> Text
pretty () = Text
"()"
instance Pretty Bool where pretty :: Bool -> Text
pretty = forall a. Show a => a -> Text
showt
instance Pretty Int where pretty :: Int -> Text
pretty = forall a. Show a => a -> Text
showt
instance Pretty Int.Int8 where pretty :: Int8 -> Text
pretty = forall a. Show a => a -> Text
showt
instance Pretty Int.Int16 where pretty :: Int16 -> Text
pretty = forall a. Show a => a -> Text
showt
instance Pretty Int.Int32 where pretty :: Int32 -> Text
pretty = forall a. Show a => a -> Text
showt
instance Pretty Int.Int64 where pretty :: Int64 -> Text
pretty = forall a. Show a => a -> Text
showt
instance Pretty Integer where pretty :: Integer -> Text
pretty = forall a. Show a => a -> Text
showt
instance Pretty Word.Word8 where pretty :: Word8 -> Text
pretty = forall a. Show a => a -> Text
showt
instance Pretty Word.Word16 where pretty :: Word16 -> Text
pretty = forall a. Show a => a -> Text
showt
instance Pretty Word.Word32 where pretty :: Word32 -> Text
pretty = forall a. Show a => a -> Text
showt
instance Pretty Word.Word64 where pretty :: Word64 -> Text
pretty = forall a. Show a => a -> Text
showt
instance Pretty Double where pretty :: Double -> Text
pretty = forall a. RealFloat a => Bool -> Int -> a -> Text
Num.showFloatP Bool
False Int
3
instance Pretty Float where pretty :: Float -> Text
pretty = forall a. RealFloat a => Bool -> Int -> a -> Text
Num.showFloatP Bool
False Int
3

instance Pretty C.CChar where pretty :: CChar -> Text
pretty = forall a. Show a => a -> Text
showt
instance Pretty C.CInt where pretty :: CInt -> Text
pretty = forall a. Show a => a -> Text
showt
instance Pretty C.CFloat where pretty :: CFloat -> Text
pretty (C.CFloat Float
a) = forall a. Pretty a => a -> Text
pretty Float
a

instance (Integral a, Pretty a) => Pretty (Ratio.Ratio a) where
    pretty :: Ratio a -> Text
pretty Ratio a
r
        | Ratio a
r forall a. Eq a => a -> a -> Bool
== Ratio a
0 = Text
"0"
        | Ratio a
frac forall a. Eq a => a -> a -> Bool
== Ratio a
0 = forall a. Pretty a => a -> Text
pretty Integer
whole
        | Integer
whole forall a. Eq a => a -> a -> Bool
== Integer
0 = forall {a}. Pretty a => Ratio a -> Text
ratio Ratio a
frac
        | Bool
otherwise = forall a. Pretty a => a -> Text
pretty Integer
whole forall a. Semigroup a => a -> a -> a
<> Text
"+" forall a. Semigroup a => a -> a -> a
<> forall {a}. Pretty a => Ratio a -> Text
ratio Ratio a
frac
        where
        whole :: Integer
        (Integer
whole, Ratio a
frac) = forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction Ratio a
r
        ratio :: Ratio a -> Text
ratio Ratio a
r =
            forall a. Pretty a => a -> Text
pretty (forall a. Ratio a -> a
Ratio.numerator Ratio a
r) forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall a. Ratio a -> a
Ratio.denominator Ratio a
r)

-- | The default Pretty instance for Ratio reduces the fraction to k+n/d, which
-- is not always right.  This formats an improper fraction.
improperRatio :: (Eq a, Num a, Pretty a) => Ratio.Ratio a -> Text
improperRatio :: forall a. (Eq a, Num a, Pretty a) => Ratio a -> Text
improperRatio Ratio a
r
    | a
denom forall a. Eq a => a -> a -> Bool
== a
1 = forall a. Pretty a => a -> Text
pretty a
num
    | Bool
otherwise = forall a. Pretty a => a -> Text
pretty a
num forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty a
denom
    where
    (a
num, a
denom) = (forall a. Ratio a -> a
Ratio.numerator Ratio a
r, forall a. Ratio a -> a
Ratio.denominator Ratio a
r)

-- | If it looks like a low fraction, display it thus, rather than as
-- a decimal.  This is useful because e.g. meters in three will have lots of
-- repeating decimals.  I also use fractions for power of two denominators
-- which are just fine in decimal, but the fraction still takes up less space.
fraction :: (RealFrac a, Pretty a) => Bool -> a
    -- ^ If true, try an ASCII fraction if there are no unicode ones, otherwise
    -- always use decimal.
    -> Text
fraction :: forall a. (RealFrac a, Pretty a) => Bool -> a -> Text
fraction Bool
asciiFraction a
d
    | a
d forall a. Eq a => a -> a -> Bool
== a
0 = Text
"0"
    | Just Text
frac <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Rational
ratio Map Rational Text
fractions = Text
int_s forall a. Semigroup a => a -> a -> a
<> Text
frac
    | Bool
asciiFraction Bool -> Bool -> Bool
&& forall a. Ratio a -> a
Ratio.denominator Rational
ratio forall a. Ord a => a -> a -> Bool
<= Integer
12 =
        Text
int_s forall a. Semigroup a => a -> a -> a
<> Text
"+" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Rational
ratio
    | Bool
otherwise = forall a. Pretty a => a -> Text
pretty a
d
    where
    (Integer
int, a
frac) = forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction a
d
    int_s :: Text
int_s = if Integer
int forall a. Eq a => a -> a -> Bool
== Integer
0 then Text
"" else String -> Text
Text.pack (forall a. Show a => a -> String
show Integer
int)
    ratio :: Rational
ratio = forall a. RealFrac a => a -> a -> Rational
Ratio.approxRational a
frac a
0.0001
    fractions :: Map Rational Text
fractions = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (Rational
0 forall a. Fractional a => a -> a -> a
/ Rational
1, Text
"")
        , (Rational
1 forall a. Fractional a => a -> a -> a
/ Rational
4, Text
"¼"), (Rational
1 forall a. Fractional a => a -> a -> a
/ Rational
2, Text
"½"), (Rational
3 forall a. Fractional a => a -> a -> a
/ Rational
4, Text
"¾")
        , (Rational
1 forall a. Fractional a => a -> a -> a
/ Rational
3, Text
"⅓"), (Rational
2 forall a. Fractional a => a -> a -> a
/ Rational
3, Text
"⅔")
        , (Rational
1 forall a. Fractional a => a -> a -> a
/ Rational
5, Text
"⅕"), (Rational
2 forall a. Fractional a => a -> a -> a
/ Rational
5, Text
"⅖"), (Rational
3 forall a. Fractional a => a -> a -> a
/ Rational
5, Text
"⅗"), (Rational
4 forall a. Fractional a => a -> a -> a
/ Rational
5, Text
"⅘")
        , (Rational
1 forall a. Fractional a => a -> a -> a
/ Rational
6, Text
"⅙"), (Rational
5 forall a. Fractional a => a -> a -> a
/ Rational
6, Text
"⅚")
        , (Rational
1 forall a. Fractional a => a -> a -> a
/ Rational
8, Text
"⅛"), (Rational
3 forall a. Fractional a => a -> a -> a
/ Rational
8, Text
"⅜"), (Rational
5 forall a. Fractional a => a -> a -> a
/ Rational
8, Text
"⅝"), (Rational
7 forall a. Fractional a => a -> a -> a
/ Rational
8, Text
"⅞")
        ]

instance Pretty a => Pretty (Maybe a) where
    format :: Maybe a -> Doc
format Maybe a
Nothing = Text -> Doc
text Text
"Nothing"
    format (Just a
a) = forall a. Pretty a => a -> Doc
format a
a

instance (Pretty a, Pretty b) => Pretty (Either a b) where
    format :: Either a b -> Doc
format (Left a
a) = Text -> Doc
text Text
"Left" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
format a
a
    format (Right b
b) = Text -> Doc
text Text
"Right" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
format b
b

instance (Pretty a, Pretty b) => Pretty (a, b) where
    format :: (a, b) -> Doc
format (a
a, b
b) = forall a. Pretty a => Char -> Char -> [a] -> Doc
formattedList Char
'(' Char
')' [forall a. Pretty a => a -> Doc
format a
a, forall a. Pretty a => a -> Doc
format b
b]
instance (Pretty a, Pretty b, Pretty c) => Pretty (a, b, c) where
    format :: (a, b, c) -> Doc
format (a
a, b
b, c
c) = forall a. Pretty a => Char -> Char -> [a] -> Doc
formattedList Char
'(' Char
')' [forall a. Pretty a => a -> Doc
format a
a, forall a. Pretty a => a -> Doc
format b
b, forall a. Pretty a => a -> Doc
format c
c]
instance (Pretty a, Pretty b, Pretty c, Pretty d) => Pretty (a, b, c, d) where
    format :: (a, b, c, d) -> Doc
format (a
a, b
b, c
c, d
d) = forall a. Pretty a => Char -> Char -> [a] -> Doc
formattedList Char
'(' Char
')'
        [forall a. Pretty a => a -> Doc
format a
a, forall a. Pretty a => a -> Doc
format b
b, forall a. Pretty a => a -> Doc
format c
c, forall a. Pretty a => a -> Doc
format d
d]
instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e) =>
        Pretty (a, b, c, d, e) where
    format :: (a, b, c, d, e) -> Doc
format (a
a, b
b, c
c, d
d, e
e) = forall a. Pretty a => Char -> Char -> [a] -> Doc
formattedList Char
'(' Char
')'
        [forall a. Pretty a => a -> Doc
format a
a, forall a. Pretty a => a -> Doc
format b
b, forall a. Pretty a => a -> Doc
format c
c, forall a. Pretty a => a -> Doc
format d
d, forall a. Pretty a => a -> Doc
format e
e]
instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f) =>
        Pretty (a, b, c, d, e, f) where
    format :: (a, b, c, d, e, f) -> Doc
format (a
a, b
b, c
c, d
d, e
e, f
f) = forall a. Pretty a => Char -> Char -> [a] -> Doc
formattedList Char
'(' Char
')'
        [forall a. Pretty a => a -> Doc
format a
a, forall a. Pretty a => a -> Doc
format b
b, forall a. Pretty a => a -> Doc
format c
c, forall a. Pretty a => a -> Doc
format d
d, forall a. Pretty a => a -> Doc
format e
e, forall a. Pretty a => a -> Doc
format f
f]

-- ** containers

instance Pretty a => Pretty (Set.Set a) where
    format :: Set a -> Doc
format = forall a. Pretty a => Char -> Char -> [a] -> Doc
formattedList Char
'{' Char
'}' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList

instance (Pretty k, Pretty v) => Pretty (Map.Map k v) where
    format :: Map k v -> Doc
format = [(Doc, Doc)] -> Doc
formatMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(k
k, v
v) -> (forall a. Pretty a => a -> Doc
format k
k, forall a. Pretty a => a -> Doc
format v
v)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList

instance Pretty v => Pretty (IntMap.IntMap v) where
    format :: IntMap v -> Doc
format = forall a. Pretty a => Char -> Char -> [a] -> Doc
formattedList Char
'{' Char
'}' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Pretty a, Pretty b) => (a, b) -> Doc
pair forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IntMap a -> [(Int, a)]
IntMap.toList
        where pair :: (a, a) -> Doc
pair (a
k, a
v) = forall a. Pretty a => a -> Doc
format a
k Doc -> Doc -> Doc
</> (Doc
":" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
format a
v)

instance Pretty a => Pretty (Tree.Tree a) where
    format :: Tree a -> Doc
format (Tree.Node a
val [Tree a]
children) =
        Doc
"Node" forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
indent_ (Doc
"(" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
format a
val forall a. Semigroup a => a -> a -> a
<> Doc
")" Doc -> Doc -> Doc
<+/> forall a. Pretty a => a -> Doc
format [Tree a]
children)

-- ** other base types

instance Pretty Time.UTCTime where pretty :: UTCTime -> Text
pretty = forall a. Show a => a -> Text
showt
instance Pretty Time.NominalDiffTime where
    pretty :: NominalDiffTime -> Text
pretty NominalDiffTime
s = forall a. Pretty a => a -> Text
pretty (forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
s :: Double) forall a. Semigroup a => a -> a -> a
<> Text
"s"
instance Pretty Dynamic.Dynamic where pretty :: Dynamic -> Text
pretty = forall a. Show a => a -> Text
showt
instance Pretty Calendar.Day where pretty :: Day -> Text
pretty = forall a. Show a => a -> Text
showt

instance Pretty (Foreign.Ptr a) where pretty :: Ptr a -> Text
pretty = forall a. Show a => a -> Text
showt
instance Pretty (Foreign.ForeignPtr a) where pretty :: ForeignPtr a -> Text
pretty = forall a. Show a => a -> Text
showt

-- ** text

instance Pretty ByteString.ByteString where
    format :: ByteString -> Doc
format ByteString
bs = case ByteString -> Either UnicodeException Text
Encoding.decodeUtf8' ByteString
bs of
        -- If it's binary, quote like a string.  Unfortunately, show will add
        -- extra "s which format will then add again.
        Left UnicodeException
_ -> forall a. Pretty a => a -> Doc
format forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
Lists.dropEnd Int
1 forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
1 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ByteString
bs
        Right Text
txt -> forall a. Pretty a => a -> Doc
format Text
txt

instance Pretty Text where
    format :: Text -> Doc
format Text
t = Doc
"\"" forall a. Semigroup a => a -> a -> a
<> Text -> Doc
text Text
t forall a. Semigroup a => a -> a -> a
<> Doc
"\""

instance Pretty Lazy.Text where
    format :: Text -> Doc
format = forall a. Pretty a => a -> Doc
format forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Lazy.toStrict

-- * hackage types

instance Pretty a => Pretty (NonEmpty.NonEmpty a) where
    format :: NonEmpty a -> Doc
format = forall a. Pretty a => [a] -> Doc
formatList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NonEmpty.toList

instance (Unboxed.Unbox a, Pretty a) => Pretty (Unboxed.Vector a) where
    format :: Vector a -> Doc
format = forall a. Pretty a => Char -> Char -> [a] -> Doc
formattedList Char
'<' Char
'>' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Unbox a => Vector a -> [a]
Unboxed.toList
instance (Pretty a) => Pretty (Vector.Vector a) where
    format :: Vector a -> Doc
format = forall a. Pretty a => Char -> Char -> [a] -> Doc
formattedList Char
'<' Char
'>' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Vector a -> [a]
Vector.toList
instance (Storable.Storable a, Pretty a) => Pretty (Storable.Vector a) where
    format :: Vector a -> Doc
format = forall a. Pretty a => Char -> Char -> [a] -> Doc
formattedList Char
'<' Char
'>' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => Vector a -> [a]
Storable.toList

-- * local types

instance (Pretty a, Pretty b) => Pretty (Lists.Paired a b) where
    format :: Paired a b -> Doc
format (Lists.First a
a) = Doc
"First" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
format a
a
    format (Lists.Second b
b) = Doc
"Second" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
format b
b
    format (Lists.Both a
a b
b) = Doc
"Both" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
format a
a Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
format b
b


-- * formatters

-- | A list of strings, but without quotes around them.
textList :: [Text] -> Doc
textList :: [Text] -> Doc
textList = Bool -> Char -> Char -> [Doc] -> Doc
delimitedList Bool
False Char
'[' Char
']' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc
text

formattedList :: Pretty a => Char -> Char -> [a] -> Doc
formattedList :: forall a. Pretty a => Char -> Char -> [a] -> Doc
formattedList Char
left Char
right = Bool -> Char -> Char -> [Doc] -> Doc
delimitedList Bool
False Char
left Char
right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
format

record :: Doc -> [(Text, Doc)] -> Doc
record :: Doc -> [(Text, Doc)] -> Doc
record Doc
title [(Text, Doc)]
fields =
    Doc
title forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
indent_ (Bool -> Char -> Char -> [Doc] -> Doc
delimitedList Bool
True Char
'{' Char
'}' (forall a b. (a -> b) -> [a] -> [b]
map (Text, Doc) -> Doc
field [(Text, Doc)]
fields))
    where field :: (Text, Doc) -> Doc
field (Text
name, Doc
val) = Text -> Doc
text Text
name Doc -> Doc -> Doc
<+> Doc
"=" Doc -> Doc -> Doc
<+/> Doc
val
    -- The "name = val" is already indented due to delimitedList, so if it
    -- wraps it will already be at one level of indentation.

recordTitle :: Text -> [(Text, Doc)] -> Doc
recordTitle :: Text -> [(Text, Doc)] -> Doc
recordTitle = Doc -> [(Text, Doc)] -> Doc
record forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc
text

formatMap :: [(Doc, Doc)] -> Doc
formatMap :: [(Doc, Doc)] -> Doc
formatMap = forall a. Pretty a => Char -> Char -> [a] -> Doc
formattedList Char
'{' Char
'}' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Doc, Doc) -> Doc
pair
    where pair :: (Doc, Doc) -> Doc
pair (Doc
k, Doc
v) = Doc
k Doc -> Doc -> Doc
</> (Doc
":" Doc -> Doc -> Doc
<+> Doc
v)

constructor :: Text -> [Doc] -> Doc
constructor :: Text -> [Doc] -> Doc
constructor Text
name [] = Text -> Doc
text Text
name
constructor Text
name [Doc]
fields =
    Text -> Doc
text Text
name forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
indent_ ([Doc] -> Doc
wrapWords forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Char -> Char -> Doc -> Doc
surround Char
'(' Char
')') [Doc]
fields)
    where surround :: Char -> Char -> Doc -> Doc
surround Char
left Char
right Doc
x = Char -> Doc
char Char
left forall a. Semigroup a => a -> a -> a
<> Doc
x forall a. Semigroup a => a -> a -> a
<> Char -> Doc
char Char
right
    -- TODO only surround ()s if it has spaces in it

-- | Format a comma-separated list.  Try to put it on one line, but break
-- before commas if that's not possible.
delimitedList :: Bool -- ^ Always spaces around the delimiters.  Otherwise,
    -- they only get spaces if the list wraps.
    -> Char -> Char -> [Doc] -> Doc
delimitedList :: Bool -> Char -> Char -> [Doc] -> Doc
delimitedList Bool
spacedDelimiter Char
leftc Char
rightc [Doc]
xs = case [Doc]
xs of
    [] -> Doc
left Doc -> Doc -> Doc
<-> Doc
right
    Doc
x : [Doc]
xs -> Doc -> Doc -> Doc
Format.shortForm
        (Doc
left Doc -> Doc -> Doc
<-> Doc
x forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map (Doc
","<+>) [Doc]
xs) Doc -> Doc -> Doc
<-> Doc
right) forall a b. (a -> b) -> a -> b
$
        (Doc
left Doc -> Doc -> Doc
<+> Doc -> Doc
withIndent Doc
x) Doc -> Doc -> Doc
</> [Doc] -> Doc
Format.wrap (forall a b. (a -> b) -> [a] -> [b]
map Doc -> Doc
element [Doc]
xs)
            Doc -> Doc -> Doc
<//> Doc
right forall a. Semigroup a => a -> a -> a
<> Doc
"\n"
    where
    element :: Doc -> Doc
element Doc
x = Doc
"," Doc -> Doc -> Doc
<+> Doc -> Doc
withIndent Doc
x
    <-> :: Doc -> Doc -> Doc
(<->) = if Bool
spacedDelimiter then Doc -> Doc -> Doc
(<+>) else forall a. Semigroup a => a -> a -> a
(<>)
    left :: Doc
left = Text -> Doc
text forall a b. (a -> b) -> a -> b
$ Char -> Text
Text.singleton Char
leftc
    right :: Doc
right = Text -> Doc
text forall a b. (a -> b) -> a -> b
$ Char -> Text
Text.singleton Char
rightc


-- * standalone

duration :: Time.NominalDiffTime -> Text
duration :: NominalDiffTime -> Text
duration NominalDiffTime
secs0 = [Text] -> Text
Text.unwords forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [forall a. Show a => a -> Text
showt Integer
days forall a. Semigroup a => a -> a -> a
<> Text
"d" | Integer
days forall a. Ord a => a -> a -> Bool
> Integer
0]
    , [forall a. Show a => a -> Text
showt Integer
hours forall a. Semigroup a => a -> a -> a
<> Text
"h" | Integer
hours forall a. Ord a => a -> a -> Bool
> Integer
0]
    , [forall a. Show a => a -> Text
showt Integer
mins forall a. Semigroup a => a -> a -> a
<> Text
"m" | Integer
mins forall a. Ord a => a -> a -> Bool
> Integer
0]
    , [forall a. Pretty a => a -> Text
pretty NominalDiffTime
secs3]
    ]
    where
    (Integer
days, NominalDiffTime
secs1) = forall div mod.
(Integral div, RealFrac mod) =>
mod -> mod -> (div, mod)
Num.fDivMod NominalDiffTime
secs0 (NominalDiffTime
60forall a. Num a => a -> a -> a
*NominalDiffTime
60forall a. Num a => a -> a -> a
*NominalDiffTime
24)
    (Integer
hours, NominalDiffTime
secs2) = forall div mod.
(Integral div, RealFrac mod) =>
mod -> mod -> (div, mod)
Num.fDivMod NominalDiffTime
secs1 (NominalDiffTime
60forall a. Num a => a -> a -> a
*NominalDiffTime
60)
    (Integer
mins, NominalDiffTime
secs3) = forall div mod.
(Integral div, RealFrac mod) =>
mod -> mod -> (div, mod)
Num.fDivMod NominalDiffTime
secs2 NominalDiffTime
60

bytes :: Int -> Int -> Text
bytes :: Int -> Int -> Text
bytes Int
precision Int
bs = case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((forall a. Ord a => a -> a -> Bool
>=Double
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Double, Text)]
sizes of
    Just (Double
v, Text
s) -> forall a. RealFloat a => Int -> a -> Text
Num.showFloat Int
precision Double
v forall a. Semigroup a => a -> a -> a
<> Text
s
    Maybe (Double, Text)
Nothing -> forall a. Show a => a -> Text
showt Int
bs forall a. Semigroup a => a -> a -> a
<> Text
"b"
    where
    sizes :: [(Double, Text)]
sizes = [(Double
gb, Text
"gb"), (Double
mb, Text
"mb"), (Double
kb, Text
"kb")]
    kb :: Double
kb = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bs forall a. Fractional a => a -> a -> a
/ Double
1024
    mb :: Double
mb = Double
kb forall a. Fractional a => a -> a -> a
/ Double
1024
    gb :: Double
gb = Double
mb forall a. Fractional a => a -> a -> a
/ Double
1024

-- * Read

-- These don't really belong here, but this module has to do with reading and
-- showing, and as long as only have a few Read utilities I might as well put
-- them here.

-- | Read a space separated word.
readWord :: Read.ReadPrec String
readWord :: ReadPrec String
readWord = forall a. ReadP a -> ReadPrec a
Read.lift forall a b. (a -> b) -> a -> b
$ do
    ReadP ()
ReadP.skipSpaces
    String
w <- forall a. ReadP a -> ReadP [a]
ReadP.many1 ((Char -> Bool) -> ReadP Char
ReadP.satisfy (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
Char.isSpace))
    ReadP ()
ReadP.skipSpaces
    forall (m :: * -> *) a. Monad m => a -> m a
return String
w