FiniteCategories-0.6.5.1: src/Math/IO/PrettyPrint.hs
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DefaultSignatures#-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-| Module : FiniteCategories
Description : A simple typeclass for things to be pretty printed.
Copyright : Guillaume Sabbagh 2022
License : GPL-3
Maintainer : guillaumesabbagh@protonmail.com
Stability : experimental
Portability : portable
A simple typeclass for things to be pretty printed. Categories objects and arrows should be pretty printable to be exported with graphviz.
Different objects should be pretty printed into different strings or the graphviz export might be wrong.
-}
module Math.IO.PrettyPrint
(
PrettyPrint(..),
pp,
ppi,
indentation,
pprintFunction
)
where
import Data.List (intercalate)
import qualified Data.Set as Set
import qualified Data.WeakSet as WSet
import qualified Data.WeakMap as WMap
import qualified Data.Text as Text
import Data.Int
import Data.Word
import Data.Simplifiable
import GHC.Generics
import Numeric.Natural
-- | The typeclass of things that can be pretty printed.
--
-- 'pprint' takes a level of verbosity as its first argument from the less verbose 'pprint 0' to the most verbose 'pprint n'.
class PrettyPrint a where
-- | Pretty print an element of type 'a' with a given verbosity level. 0 is the less verbose possible.
pprint :: Int -> a -> String
-- | Pretty print with a given level of indentation an element of type 'a' with a given verbosity level. See 'pprintIndent' for usage.
pprintWithIndentations :: Int -- ^ The current verbosity level
-> Int -- ^ Original verbosity level
-> String -- ^ The indentation used
-> a -- ^ The object to pretty print
-> String
-- | Pretty print with indentation an element of type 'a' with a given verbosity level.
pprintIndent :: Int -> a -> String
pprintIndent v a = pprintWithIndentations v v "| " a
default pprint :: (Generic a, GPrettyPrint (Rep a)) => Int -> a -> String
pprint v a = gpprint v (from a)
default pprintWithIndentations :: (Generic a, GPrettyPrint (Rep a)) => Int -> Int -> String -> a -> String
pprintWithIndentations cv ov indent a = gpprintWithIndentations cv ov indent (from a)
-- | PutStrLn composed with pprint. Takes a verbosity level as its first argument.
pp :: (PrettyPrint a) => Int -> a -> IO ()
pp v a = putStrLn $ pprint v a
-- | PutStrLn composed with pprintIndent. Takes a verbosity level as its first argument.
ppi :: (PrettyPrint a) => Int -> a -> IO ()
ppi v a = putStrLn $ pprintIndent v a
-- | Add indentation at the begining of a string.
indentation :: Int -> String -> String
indentation i s = concat $ replicate i s
class GPrettyPrint f where
gpprint :: Int -> f a -> String
gpprintWithIndentations :: Int -> Int -> String -> f a -> String
instance GPrettyPrint U1 where
gpprint _ U1 = []
gpprintWithIndentations _ _ _ U1 = []
instance (GPrettyPrint a, GPrettyPrint b) => GPrettyPrint (a :*: b) where
-- gpprint 0 _ = "..."
gpprint v (a :*: b) = gpprint v a ++ ", " ++ gpprint v b
-- gpprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
gpprintWithIndentations cv ov indent (a :*: b) = gpprintWithIndentations cv ov indent a ++ gpprintWithIndentations cv ov indent b
instance (GPrettyPrint a, GPrettyPrint b) => GPrettyPrint (a :+: b) where
-- gpprint 0 _ = "..."
gpprint v (L1 a) = gpprint v a
gpprint v (R1 b) = gpprint v b
-- gpprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
gpprintWithIndentations cv ov indent (L1 a) = gpprintWithIndentations cv ov indent a
gpprintWithIndentations cv ov indent (R1 b) = gpprintWithIndentations cv ov indent b
instance (GPrettyPrint a) => GPrettyPrint (S1 c a) where
-- gpprint 0 _ = "..."
gpprint v (M1 x) = gpprint v x
-- gpprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
gpprintWithIndentations cv ov indent (M1 x) = gpprintWithIndentations cv ov indent x
instance (GPrettyPrint a) => GPrettyPrint (D1 c a) where
-- gpprint 0 _ = "..."
gpprint v (M1 x) = gpprint v x
-- gpprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
gpprintWithIndentations cv ov indent (M1 x) = gpprintWithIndentations cv ov indent x
instance (Constructor c, GPrettyPrint a) => GPrettyPrint (C1 c a) where
gpprint v c@(M1 x)
| null innerString = conName c
| otherwise = conName c ++ "("++ innerString ++")"
where
innerString = gpprint v x
gpprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
gpprintWithIndentations cv ov indent c@(M1 x)
| null innerString = indentation (ov - cv) indent ++ conName c ++ "\n"
| otherwise = indentation (ov - cv) indent ++ conName c ++ "\n" ++ innerString
where
innerString = gpprintWithIndentations cv ov indent x
instance (PrettyPrint a) => GPrettyPrint (K1 i a) where
gpprint 0 _ = "..."
gpprint v (K1 x) = pprint (v - 1) x
gpprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
gpprintWithIndentations cv ov indent (K1 x) = pprintWithIndentations (cv-1) ov indent x
instance (PrettyPrint a) => PrettyPrint [a] where
-- pprint 0 _ = "..."
pprint v xs = "[" ++ intercalate "," (pprint (v) <$> xs) ++ "]"
pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent xs = indentation (ov - cv) indent ++ "[\n" ++ intercalate ",\n" (init <$> pprintWithIndentations (cv-1) ov indent <$> xs) ++ "\n" ++ indentation (ov - cv) indent ++ "]\n"
instance (PrettyPrint a) => PrettyPrint (Maybe a) where
-- pprint 0 _ = "..."
pprint _ Nothing = "Nothing"
pprint v (Just x) = pprint v x
-- pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent Nothing = indentation (ov - cv) indent ++ "Nothing\n"
pprintWithIndentations cv ov indent (Just x) = pprintWithIndentations cv ov indent x ++ "\n"
instance (PrettyPrint a, PrettyPrint b) => PrettyPrint (Either a b) where
pprint 0 _ = "..."
pprint v (Left a) = pprint v a
pprint v (Right a) = pprint v a
pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent (Left a) = pprintWithIndentations cv ov indent a ++"\n"
pprintWithIndentations cv ov indent (Right a) = pprintWithIndentations cv ov indent a ++"\n"
instance (PrettyPrint a, PrettyPrint b) => PrettyPrint (a,b) where
pprint 0 _ = "..."
pprint v (a,b) = "(" ++ pprint (v-1) a ++ "," ++ pprint (v-1) b ++ ")"
pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent (a,b) = indentation (ov - cv) indent ++ "(\n" ++ init (pprintWithIndentations (cv-1) ov indent a) ++ ",\n" ++ pprintWithIndentations (cv-1) ov indent b ++ indentation (ov - cv) indent ++ ")\n"
instance (PrettyPrint a, PrettyPrint b, PrettyPrint c) => PrettyPrint (a,b,c) where
pprint 0 _ = "..."
pprint v (a,b,c) = "(" ++ pprint (v-1) a ++ "," ++ pprint (v-1) b ++ "," ++ pprint (v-1) c ++ ")"
pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent (a,b,c) = indentation (ov - cv) indent ++ "(\n" ++ init (pprintWithIndentations (cv-1) ov indent a) ++ ",\n" ++ init (pprintWithIndentations (cv-1) ov indent b) ++ ",\n" ++ pprintWithIndentations (cv-1) ov indent c ++ indentation (ov - cv) indent ++ ")\n"
instance (PrettyPrint a, PrettyPrint b, PrettyPrint c, PrettyPrint d) => PrettyPrint (a,b,c,d) where
pprint 0 _ = "..."
pprint v (a,b,c,d) = "(" ++ pprint (v-1) a ++ "," ++ pprint (v-1) b ++ "," ++ pprint (v-1) c ++ "," ++ pprint (v-1) d ++ ")"
pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent (a,b,c,d) = indentation (ov - cv) indent ++ "(\n" ++ init (pprintWithIndentations (cv-1) ov indent a) ++ ",\n" ++ init (pprintWithIndentations (cv-1) ov indent b) ++ ",\n" ++ init (pprintWithIndentations (cv-1) ov indent c) ++ ",\n" ++ pprintWithIndentations (cv-1) ov indent d ++ indentation (ov - cv) indent ++ ")\n"
instance (PrettyPrint a, PrettyPrint b, PrettyPrint c, PrettyPrint d, PrettyPrint e) => PrettyPrint (a,b,c,d,e) where
pprint 0 _ = "..."
pprint v (a,b,c,d,e) = "(" ++ pprint (v-1) a ++ "," ++ pprint (v-1) b ++ "," ++ pprint (v-1) c ++","++ pprint (v-1) d ++ "," ++ pprint (v-1) e ++ ")"
pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent (a,b,c,d,e) = indentation (ov - cv) indent ++ "(\n" ++ init (pprintWithIndentations (cv-1) ov indent a) ++ ",\n" ++ init (pprintWithIndentations (cv-1) ov indent b) ++ ",\n" ++ init (pprintWithIndentations (cv-1) ov indent c) ++ ",\n" ++ init (pprintWithIndentations (cv-1) ov indent d) ++ ",\n" ++ pprintWithIndentations (cv-1) ov indent e ++ indentation (ov - cv) indent ++ ")\n"
instance (PrettyPrint a) => PrettyPrint (Set.Set a) where
-- pprint 0 _ = "..."
pprint v xs = "{" ++ intercalate "," (pprint (v) <$> (Set.toList xs)) ++ "}"
pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent xs = indentation (ov - cv) indent ++ "{\n" ++ intercalate ",\n" (init <$> pprintWithIndentations (cv-1) ov indent <$> (Set.toList xs)) ++ "\n" ++ indentation (ov - cv) indent ++ "}\n"
instance (PrettyPrint a, Eq a) => PrettyPrint (WSet.Set a) where
-- pprint 0 _ = "..."
pprint v xs = "{" ++ intercalate "," (pprint (v) <$> (WSet.setToList xs)) ++ "}"
pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent xs = indentation (ov - cv) indent ++ "{\n" ++ intercalate ",\n" (init <$> pprintWithIndentations (cv-1) ov indent <$> (WSet.setToList xs)) ++ "\n" ++ indentation (ov - cv) indent ++ "}\n"
instance (PrettyPrint a, Eq a, PrettyPrint b, Eq b) => PrettyPrint (WMap.Map a b) where
-- pprint 0 _ = "..."
pprint verbosity m = "{" ++ intercalate "," ((\(k,v) -> (pprint (verbosity) k) ++ "->" ++ (pprint (verbosity) v)) <$> (WMap.mapToList m)) ++ "}"
pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent xs = indentation (ov - cv) indent ++ "{\n" ++ intercalate ",\n" (init <$> pprintWithIndentations (cv-1) ov indent <$> (WMap.mapToList xs)) ++ "\n" ++ indentation (ov - cv) indent ++ "}\n"
instance PrettyPrint Bool where
-- pprint 0 = (const "...")
pprint _ = show
-- pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent x = indentation (ov - cv) indent ++ show x ++ "\n"
instance PrettyPrint Char where
-- pprint 0 = (const "...")
pprint _ = (:[])
-- pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent x = indentation (ov - cv) indent ++ [x] ++ "\n"
instance PrettyPrint Double where
-- pprint 0 = (const "...")
pprint _ = show
-- pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent x = indentation (ov - cv) indent ++ show x ++ "\n"
instance PrettyPrint Float where
-- pprint 0 = (const "...")
pprint _ = show
-- pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent x = indentation (ov - cv) indent ++ show x ++ "\n"
instance PrettyPrint Int where
-- pprint 0 = (const "...")
pprint _ = show
-- pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent x = indentation (ov - cv) indent ++ show x ++ "\n"
instance PrettyPrint Int8 where
-- pprint 0 = (const "...")
pprint _ = show
-- pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent x = indentation (ov - cv) indent ++ show x ++ "\n"
instance PrettyPrint Int16 where
-- pprint 0 = (const "...")
pprint _ = show
-- pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent x = indentation (ov - cv) indent ++ show x ++ "\n"
instance PrettyPrint Int32 where
-- pprint 0 = (const "...")
pprint _ = show
-- pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent x = indentation (ov - cv) indent ++ show x ++ "\n"
instance PrettyPrint Int64 where
-- pprint 0 = (const "...")
pprint _ = show
-- pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent x = indentation (ov - cv) indent ++ show x ++ "\n"
instance PrettyPrint Integer where
-- pprint 0 = (const "...")
pprint _ = show
-- pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent x = indentation (ov - cv) indent ++ show x ++ "\n"
instance PrettyPrint Natural where
-- pprint 0 = (const "...")
pprint _ = show
-- pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent x = indentation (ov - cv) indent ++ show x ++ "\n"
instance PrettyPrint Ordering where
-- pprint 0 = (const "...")
pprint _ = show
-- pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent x = indentation (ov - cv) indent ++ show x ++ "\n"
instance PrettyPrint Word where
-- pprint 0 = (const "...")
pprint _ = show
-- pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent x = indentation (ov - cv) indent ++ show x ++ "\n"
instance PrettyPrint Word8 where
-- pprint 0 = (const "...")
pprint _ = show
-- pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent x = indentation (ov - cv) indent ++ show x ++ "\n"
instance PrettyPrint Word16 where
-- pprint 0 = (const "...")
pprint _ = show
pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent x = indentation (ov - cv) indent ++ show x ++ "\n"
instance PrettyPrint Word32 where
-- pprint 0 = (const "...")
pprint _ = show
-- pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent x = indentation (ov - cv) indent ++ show x ++ "\n"
instance PrettyPrint Word64 where
-- pprint 0 = (const "...")
pprint _ = show
-- pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent x = indentation (ov - cv) indent ++ show x ++ "\n"
instance PrettyPrint () where
-- pprint 0 = (const "...")
pprint _ = show
-- pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent x = indentation (ov - cv) indent ++ show x ++ "\n"
instance PrettyPrint Text.Text where
-- pprint 0 = (const "...")
pprint _ = Text.unpack
-- pprintWithIndentations 0 ov indent _ = indentation ov indent ++ "...\n"
pprintWithIndentations cv ov indent x = indentation (ov - cv) indent ++ show x ++ "\n"
-- | Pretty print a function on a specific domain.
pprintFunction :: (PrettyPrint a, PrettyPrint b) =>
Int -> (a -> b) -> [a] -> String
pprintFunction 0 _ _ = "..."
pprintFunction v f xs = intercalate "\n" [pprint (v-1) x ++" -> " ++ pprint (v-1) (f x) | x <- xs]
instance Simplifiable Text.Text where
simplify = id