pretty-types 0.1.0.1 → 0.1.0.2
raw patch · 4 files changed
+207/−49 lines, 4 files
Files
- .gitignore +3/−0
- pretty-types.cabal +1/−1
- spec/PrettyTypesSpec.hs +13/−6
- src/Data/Type/Pretty.hs +190/−42
.gitignore view
@@ -9,3 +9,6 @@ TAGS /.idea/ /.dir-locals.el++src/highlight.js+src/style.css
pretty-types.cabal view
@@ -1,5 +1,5 @@ name: pretty-types-version: 0.1.0.1+version: 0.1.0.2 synopsis: A small pretty printing DSL for complex types. description: Please see README.md homepage: https://github.com/sheyll/pretty-types#readme
spec/PrettyTypesSpec.hs view
@@ -5,6 +5,7 @@ import Test.Hspec import GHC.TypeLits import Data.Kind+import Data.Proxy main :: IO () main = hspec spec@@ -68,9 +69,11 @@ describe "ToPretty" $ do it "renders a custom type" $ do- putStrLn $ showPretty (PX :: PX TestTable)+ putStrLn prettyTestTable showPretty (PX :: PX TestTable) `shouldBe` "+-------+-----+------------+\n| col 1|col 2| col 3|\n+-------+-----+------------+\n| 2423| 451| 21234|\n| 242322| 42| n/a|\n| 0| 4351| 623562|\n| 4351| n/a| n/a|\n| 0| 4351| 623562|\n+-------+-----+------------+" +prettyTestTable :: String+prettyTestTable = showPretty (Proxy :: Proxy TestTable) type TestTable = 'MyTable '[MyCol "col 1" 7, MyCol "col 2" 5, MyCol "col 3" 12]@@ -81,10 +84,14 @@ , MyRow '[0 ,4351 ,623562] ] +-- | A type with a list of columns and rows. data MyTable = MyTable [Type] [Type]-data MyCol :: Symbol -> Nat -> Type++-- | A row of a table, with a list of values, one each for every column. data MyRow :: [Nat] -> Type +-- | The column of a table. It has a width and a column title.+data MyCol :: Symbol -> Nat -> Type type instance ToPretty ('MyTable cols rows) = PrettyManyIn (PutStr "+") (RowSepLine cols)@@ -93,10 +100,10 @@ <$$> PrettyHigh (TableRows cols rows) <$$> PrettyManyIn (PutStr "+") (RowSepLine cols) -type family TableHeading (cols :: [Type]) :: [PrettyType]-type instance TableHeading '[] = '[]-type instance TableHeading (MyCol title width ': r) =- PutStrW width title ': TableHeading r+type family+ TableHeading (cols :: [Type]) :: [PrettyType] where+ TableHeading '[] = '[]+ TableHeading (MyCol title width ': r) = PutStrW width title ': TableHeading r type family RowSepLine (cols :: [Type]) :: [PrettyType] where
src/Data/Type/Pretty.hs view
@@ -1,5 +1,108 @@ {-# LANGUAGE UndecidableInstances #-}--- | Type Level Pretty Printing+-- |+-- = Type Pretty Printing+--+-- == Printing Custom Types+-- The main usecase is of course printing one own complex types.+--+-- Convert a custom type to the 'PrettyType' eDSL, then render it using+-- 'ptShow'.+--+-- 'ToPretty' is the hooks for pretty type printing custom types,+-- while 'showPretty' renders a type with a 'ToPretty' instance.+--+-- 'ToPretty' is an open type family, that maps types to `PrettyType`s. One way+-- to create 'PrettyType' /documents/ is to define instances for your types,+-- which construct a type of kind 'PrettyType' using the promoted constructors+-- of 'PrettyType'.+--+-- Use the type aliases to get rid of unticked or even ticked promoteds.+--+-- == Example+--+-- This example shows howto render this table:+--+-- > +-------+-----+------------++-- > | col 1|col 2| col 3|+-- > +-------+-----+------------++-- > | 2423| 451| 21234|+-- > | 242322| 42| n/a|+-- > | 0| 4351| 623562|+-- > | 4351| n/a| n/a|+-- > | 0| 4351| 623562|+-- > +-------+-----+------------++--+-- Assume a custom type for tables calles @MyTable@.+--+-- Rendering this table:+--+-- >type TestTable =+-- > 'MyTable '[MyCol "col 1" 7, MyCol "col 2" 5, MyCol "col 3" 12]+-- > '[ MyRow '[2423 ,451 ,21234]+-- > , MyRow '[242322 ,42]+-- > , MyRow '[0 ,4351 ,623562]+-- > , MyRow '[4351]+-- > , MyRow '[0 ,4351 ,623562]+-- > ]+-- >+--+-- Using this function:+--+-- @+-- prettyTestTable :: String+-- prettyTestTable = 'showPretty' (Proxy :: Proxy TestTable)+-- @+--+-- These are the data types. Note that only numbers can be stored in MyTable.+--+-- > -- | A type with a list of columns and rows.+-- > data MyTable = MyTable [Type] [Type]+-- >+-- > -- | A row of a table, with a list of values, one each for every column.+-- > data MyRow :: [Nat] -> Type+-- >+-- > -- | The column of a table. It has a width and a column title.+-- > data MyCol :: Symbol -> Nat -> Type+--+-- Here's the top-level 'ToPretty' instance:+--+-- @+-- type instance 'ToPretty' ('MyTable cols rows) =+-- 'PrettyManyIn' ('PutStr' "+") (RowSepLine cols)+-- '<$$>' 'PrettyManyIn' ('PutStr' "|") (TableHeading cols)+-- '<$$>' 'PrettyManyIn' ('PutStr' "+") (RowSepLine cols)+-- '<$$>' 'PrettyHigh' (TableRows cols rows)+-- '<$$>' 'PrettyManyIn' ('PutStr' "+") (RowSepLine cols)+-- @+--+-- It delegates to these:+--+-- @+-- type family+-- TableHeading (cols :: [Type]) :: ['PrettyType'] where+-- TableHeading '[] = '[]+-- TableHeading (MyCol title width ': r) = 'PutStrW' width title ': TableHeading r+--+-- type family+-- RowSepLine (cols :: [Type]) :: ['PrettyType'] where+-- RowSepLine '[] = '[]+-- RowSepLine (MyCol title width ': r) =+-- 'PrettyOften' width (PutStr "-") ': RowSepLine r+--+-- type family+-- TableRows (cols :: [Type]) (rows :: [Type]) :: ['PrettyType'] where+-- TableRows cols '[] = '[]+-- TableRows cols (MyRow cells ': rest ) =+-- 'PrettyManyIn' ('PutStr' "|") (TableCells cols cells) ': TableRows cols rest+--+-- type family+-- TableCells (cols :: [Type]) (cells :: [Nat]) :: ['PrettyType'] where+-- TableCells '[] cells = '[]+-- TableCells (MyCol title width ': cols) (value ': cells) =+-- 'PutNatW' width value ': TableCells cols cells+-- TableCells (MyCol title width ': cols) '[] =+-- 'PutStrW' width "n/a" ': TableCells cols '[]+-- @ module Data.Type.Pretty where import GHC.TypeLits@@ -22,41 +125,7 @@ -- UndecidableInstances and use the type like 'PutStr' aliases below. type family ToPretty (a :: k) :: PrettyType --- * Pretty Printing---- | Mini Type level eDSL for pretty printing via 'PrettyTypeShow'.------ To simplify things further, 'ToPretty' is provided, together with--- 'showPretty' which takes a proxy to the type to print, applies 'ToPretty'--- to it and then prints it using 'ptShow'.------ Use the type aliases to get rid of unticked or even ticked promoteds.-data PrettyType where- PrettyEmpty :: PrettyType- PrettySpace :: PrettyType- PrettyNewline :: PrettyType- PrettySymbol :: PrettyPadded -> PrettyPrecision -> Symbol -> PrettyType- PrettyNat :: PrettyPadded -> PrettyPrecision -> PrettyNatFormat -> Nat -> PrettyType- PrettySeperated :: PrettyType -> PrettyType -> PrettyType -> PrettyType---- | Padding for 'PrettyType's 'PrettySymbol' and 'PrettyNat'.-data PrettyPadded where- PrettyUnpadded :: PrettyPadded- PrettyPadded- :: Nat -- ^ Padding- -> PrettyPadded---- | The precision for 'PrettySymbol' and 'PrettyNat'.-data PrettyPrecision where- PrettyPrecise :: PrettyPrecision- PrettyPrecision- :: Nat -- ^ Precision, for 'Symbol's the maximum width,- -- for 'Nat's the minimum digits.- -> PrettyPrecision---- | 'Nat' formatting, e.g. "cafe", "CAFE", "51966" or "1100101011111110"-data PrettyNatFormat =- PrettyHex | PrettyHexU | PrettyDec | PrettyBit+-- * Building Pretty Type Documents -- | A 'PrettyType' for a string. type PutStr str = 'PrettySymbol 'PrettyUnpadded 'PrettyPrecise str@@ -101,8 +170,10 @@ -- 'PrettyNewline' type PrettyHigh docs = PrettyMany 'PrettyNewline docs --- | A combination of 'PrettySpace' and 'PrettyMany',--- e.g. @PrettyManyIn (PutStr "|") '[PutStr "a", PutStr "b"] => "|a|b|"@+-- | A combination of 'PrettySpace' and 'PrettyMany', e.g.:+--+-- >>> ptShow (Proxy :: Proxy (PrettyManyIn (PutStr "|") '[PutStr "a", PutStr "b"]))+-- "|a|b|" type PrettyManyIn sep docs = PrettySurrounded sep sep (PrettyMany sep docs) @@ -119,6 +190,9 @@ PrettyOften 0 doc = 'PrettyEmpty PrettyOften n doc = doc <++> PrettyOften (n-1) doc +-- | Create 'PrettyType' from a 'Nat' formatted as hex number using+-- lower-case letters for the hex digits.+type PutHex x = 'PrettyNat 'PrettyUnpadded 'PrettyPrecise 'PrettyHex x -- | Create 'PrettyType' from a 'Nat' formatted as 8 bit hex number using -- lower-case letters for the hex digits. type PutHex8 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 2) 'PrettyHex x@@ -131,6 +205,9 @@ -- | Create 'PrettyType' from a 'Nat' formatted as 64 bit hex number using -- lower-case letters for the hex digits. type PutHex64 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 16) 'PrettyHex x+-- | Create 'PrettyType' from a 'Nat' formatted as hex number using+-- lower-case letters for the hex digits.+type PutHeX x = 'PrettyNat 'PrettyUnpadded 'PrettyPrecise 'PrettyHexU x -- | Create 'PrettyType' from a 'Nat' formatted as 8 bit hex number using -- uppercase letters for the hex digits. type PutHeX8 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 2) 'PrettyHexU x@@ -144,18 +221,89 @@ -- uppercase letters for the hex digits. type PutHeX64 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 16) 'PrettyHexU x +-- | Create 'PrettyType' from a 'Nat' formatted as bit representation,+--+-- >>> ptShow (Proxy :: Proxy (PutBits 5))+-- "101"+type PutBits x = 'PrettyNat 'PrettyUnpadded 'PrettyPrecise 'PrettyBit x -- | Create 'PrettyType' from a 'Nat' formatted as 8-bit bit representation,--- i.e. @5 => "00000101"@+--+-- >>> ptShow (Proxy :: Proxy (PutBits8 5))+-- "00000101" type PutBits8 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 8) 'PrettyBit x -- | Create 'PrettyType' from a 'Nat' formatted as 16-bit bit representation,--- i.e. @5 => "00000000000000101"@+--+-- >>> ptShow (Proxy :: Proxy (PutBits16 5))+-- "00000000000000101" type PutBits16 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 16) 'PrettyBit x -- | Create 'PrettyType' from a 'Nat' formatted as 32-bit bit representation,--- i.e. @5 => "00000000000000000000000000000000101"@+--+-- >>> ptShow (Proxy :: Proxy (PutBits32 5))+-- "00000000000000000000000000000000101" type PutBits32 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 32) 'PrettyBit x -- | Create 'PrettyType' from a 'Nat' formatted as 64-bit bit representation,--- i.e. @5 => "00000000000000000000000000000000000000000000000000000000000000000000101"@+--+-- >>> ptShow (Proxy :: Proxy (PutBits64 5))+-- "00000000000000000000000000000000000000000000000000000000000000000000101" type PutBits64 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 64) 'PrettyBit x++-- | Combinators for /type documents/.+--+-- The basis for pretty printing is this eDSL. It is rendered via the+-- 'PrettyTypeShow' instances for its promoted constructors.+--+-- Only the promoted constructors are used, only they have instances for that+-- class.+data PrettyType where+ PrettyEmpty :: PrettyType+ PrettySpace :: PrettyType+ PrettyNewline :: PrettyType+ PrettySymbol :: PrettyPadded -> PrettyPrecision -> Symbol -> PrettyType+ PrettyNat :: PrettyPadded -> PrettyPrecision -> PrettyNatFormat -> Nat -> PrettyType+ PrettySeperated :: PrettyType -> PrettyType -> PrettyType -> PrettyType++-- | Padding for 'PrettyType's 'PrettySymbol' and 'PrettyNat'.+data PrettyPadded where+ -- | No minimum or fixed width+ PrettyUnpadded :: PrettyPadded+ -- | Pad a 'PrettySymbol' or 'PrettyNat' with spaces or zeros.+ -- __NOTE__ `PrettyNat`s will never be shorter than the minimum+ -- number of digits, regardless of this padding.+ PrettyPadded :: Nat -> PrettyPadded++-- | The precision for 'PrettySymbol' and 'PrettyNat'.+data PrettyPrecision where+ -- | No minimum precision.+ PrettyPrecise :: PrettyPrecision+ -- | Precision, for 'Symbol's the maximum width, for 'Nat's the minimum+ -- digits.+ -- __NOTE__`PrettyNat`s will never be shorter than the minimum+ -- number of digits, wheres `PrettySymbol`s will be truncated if they are+ -- longer than the precision.+ PrettyPrecision :: Nat-> PrettyPrecision++-- | 'PrettyNat' formatting options.+data PrettyNatFormat =+ -- | Hexa decimal rendering:+ --+ -- >>> ptShow (Proxy::Proxy (PrettyNat PrettyUnpadded PrettyPrecise PrettyHex 51966))+ -- "cafe"+ PrettyHex+ -- | Hexa decimal rendering (upper case):+ --+ -- >>> ptShow (Proxy::Proxy (PrettyNat PrettyUnpadded PrettyPrecise PrettyHexU 51966))+ -- "CAFE"+ | PrettyHexU+ -- | Decimal rendering:+ --+ -- >>> ptShow (Proxy::Proxy (PrettyNat PrettyUnpadded PrettyPrecise PrettyHexU 51966))+ -- "51966"+ | PrettyDec+ -- | Binary rendering:+ --+ -- >>> ptShow (Proxy::Proxy (PrettyNat PrettyUnpadded PrettyPrecise PrettyHexU 51966))+ -- "1100101011111110"+ | PrettyBit -- * Low-Level Rendering