pretty-types (empty) → 0.1.0.0
raw patch · 9 files changed
+654/−0 lines, 9 filesdep +basedep +hspecdep +pretty-typessetup-changed
Dependencies added: base, hspec, pretty-types
Files
- .gitignore +11/−0
- .travis.yml +24/−0
- LICENSE +30/−0
- README.md +76/−0
- Setup.hs +2/−0
- pretty-types.cabal +95/−0
- spec/PrettyTypesSpec.hs +119/−0
- src/Data/Type/Pretty.hs +230/−0
- stack.yaml +67/−0
+ .gitignore view
@@ -0,0 +1,11 @@+*.hi+*.o+*.swp+*.tag+*~+*_flymake.hs+.hsenv+.stack-work/+TAGS+/.idea/+/.dir-locals.el
+ .travis.yml view
@@ -0,0 +1,24 @@+language: c++sudo: false+cache:+ directories:+ - $HOME/.stack/++matrix:+ include:+ - env: CABALVER=1.24 GHCVER=8.0.1+ addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1],sources: [hvr-ghc]}}++before_install:+ - mkdir -p ~/.local/bin+ - export PATH=~/.local/bin:$PATH+ - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar -xzO --wildcards '*/stack' > ~/.local/bin/stack+ - chmod a+x ~/.local/bin/stack++install:+ - stack -j 2 setup --no-terminal --resolver nightly+ - stack -j 2 build --only-snapshot --no-terminal++script:+ - stack -j 2 test --no-terminal
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Sven Heyll (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,76 @@+[](https://travis-ci.org/sheyll/pretty-types)+[](http://hackage.haskell.org/package/pretty-types)++# Type Level Pretty Printing++A eDSL for type level pretty printing.++This Example will 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|+ +-------+-----+------------+++From this code:++ module Main (main) where++ import Data.Type.Pretty+ import GHC.TypeLits+ import Data.Kind+ import Data.Proxy++ main :: IO ()+ main = putStrLn $ showPretty (Proxy :: Proxy TestTable)++ 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]+ ]++ data MyTable = MyTable [Type] [Type]+ data MyCol :: Symbol -> Nat -> Type+ data MyRow :: [Nat] -> Type+++ 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)++ type family TableHeading (cols :: [Type]) :: [PrettyType]+ type instance TableHeading '[] = '[]+ type instance 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 '[]
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ pretty-types.cabal view
@@ -0,0 +1,95 @@+name: pretty-types+version: 0.1.0.0+synopsis: A small pretty printing DSL for complex types.+description: Please see README.md+homepage: https://github.com/sheyll/pretty-types#readme+license: BSD3+license-file: LICENSE+author: Sven Heyll+maintainer: sven.heyll@gmail.com+copyright: 2016 Sven Heyll+category: Codec+build-type: Simple+extra-source-files: README.md+ , stack.yaml+ , .travis.yml+ , .gitignore+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Data.Type.Pretty+ build-depends: base >= 4.9 && < 5+ default-language: Haskell2010+ ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind+ default-extensions: BangPatterns+ , ConstraintKinds+ , CPP+ , DataKinds+ , DefaultSignatures+ , DeriveDataTypeable+ , DeriveFunctor+ , DeriveGeneric+ , FlexibleInstances+ , FlexibleContexts+ , FunctionalDependencies+ , GADTs+ , GeneralizedNewtypeDeriving+ , KindSignatures+ , MultiParamTypeClasses+ , OverloadedStrings+ , QuasiQuotes+ , RecordWildCards+ , RankNTypes+ , ScopedTypeVariables+ , StandaloneDeriving+ , TemplateHaskell+ , TupleSections+ , TypeFamilies+ , TypeInType+ , TypeOperators+ , TypeSynonymInstances++test-suite spec+ type: exitcode-stdio-1.0+ ghc-options: -Wall+ hs-source-dirs: spec+ default-language: Haskell2010+ main-is: PrettyTypesSpec.hs+ build-depends: base >= 4.9 && < 5+ , hspec+ , pretty-types+ default-language: Haskell2010+ default-extensions: BangPatterns+ , ConstraintKinds+ , CPP+ , DataKinds+ , DefaultSignatures+ , DeriveDataTypeable+ , DeriveFunctor+ , DeriveGeneric+ , FlexibleInstances+ , FlexibleContexts+ , FunctionalDependencies+ , GADTs+ , GeneralizedNewtypeDeriving+ , KindSignatures+ , MultiParamTypeClasses+ , OverloadedStrings+ , QuasiQuotes+ , RecordWildCards+ , RankNTypes+ , ScopedTypeVariables+ , StandaloneDeriving+ , TemplateHaskell+ , TupleSections+ , TypeFamilies+ , TypeInType+ , TypeOperators+ , TypeSynonymInstances+ ghc-options: -Wall -O0 -j +RTS -A256m -n2m -RTS+ -fwarn-unused-binds -fno-warn-unused-do-bind -fno-warn-missing-signatures++source-repository head+ type: git+ location: https://github.com/sheyll/pretty-types
+ spec/PrettyTypesSpec.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE UndecidableInstances #-}+module Main (main) where++import Data.Type.Pretty+import Test.Hspec+import GHC.TypeLits+import Data.Kind++main :: IO ()+main = hspec spec++-- shorter Proxy+data PX (k :: a) = PX++spec :: Spec+spec = describe "rendering" $ do++ describe "PrettyNat" $ do+ it "renders (PutNat 123) as 123" $+ ptShow (PX :: PX (PutNat 123)) `shouldBe` "123"+ it "renders ('PrettyNat ('PrettyPadded 10) ('PrettyPrecision 5) 'PrettyDec 123) as \" 00123\"" $+ ptShow (PX :: PX ('PrettyNat ('PrettyPadded 10) ('PrettyPrecision 5) 'PrettyDec 123))+ `shouldBe` " 00123"+ it "renders (PutHex8 123) as 7b" $+ ptShow (PX :: PX (PutHex8 123)) `shouldBe` "7b"+ it "renders (PutHeX8 123) as 7B" $+ ptShow (PX :: PX (PutHeX8 123)) `shouldBe` "7B"+ it "renders (PutHeX64 123) as 000000000000007B" $+ ptShow (PX :: PX (PutHeX64 123)) `shouldBe` "000000000000007B"+ it "renders (PutBits16 123) as 0000000001111011" $+ ptShow (PX :: PX (PutBits16 123)) `shouldBe` "0000000001111011"+ it "renders (PutBits32 123) as 00000000000000000000000001111011" $+ ptShow (PX :: PX (PutBits32 123)) `shouldBe` "00000000000000000000000001111011"++ describe "PrettySymbol" $ do+ it "renders (PutStr \"hello\") as \"hello\"" $+ ptShow (PX :: PX (PutStr "hello")) `shouldBe` "hello"+ it "renders ('PrettySymbol ('PrettyPadded 10) ('PrettyPrecision 2) \"hello\") as \" he\"" $+ ptShow (PX :: PX ('PrettySymbol ('PrettyPadded 10) ('PrettyPrecision 2) "hello"))+ `shouldBe` " he"++ describe "PrettySeperated" $ do+ it "renders (PutNat 0 <++> PutNat 1) as \"01\"" $+ ptShow (PX :: PX (PutNat 0 <++> PutNat 1)) `shouldBe` "01"+ it "renders (PutNat 0 <+> PutNat 1) as \"0 1\"" $+ ptShow (PX :: PX (PutNat 0 <+> PutNat 1)) `shouldBe` "0 1"+ it "renders (PutNat 0 <$$> PutNat 1) as \"0\\n1\"" $+ ptShow (PX :: PX (PutNat 0 <$$> PutNat 1)) `shouldBe` "0\n1"+ it "renders (PutNat 0 <++> PutNat 1 <+> PutNat 2 <$$> PutNat 3 <+> PutNat 4) as \"01 2\\n3 4\"" $+ ptShow (PX :: PX (PutNat 0 <++> PutNat 1 <+> PutNat 2 <$$> PutNat 3 <+> PutNat 4))+ `shouldBe` "01 2\n3 4"+ it "renders (PutNat 0 <++> 'PrettySpace) as \"0 \"" $+ ptShow (PX :: PX (PutNat 0 <++> 'PrettySpace)) `shouldBe` "0 "+ it "renders (PutNat 0 <++> 'PrettyEmpty) as \"0\"" $+ ptShow (PX :: PX (PutNat 0 <++> 'PrettyEmpty)) `shouldBe` "0"+ it "renders ('PrettyEmpty <++> PutNat 0) as \"0\"" $+ ptShow (PX :: PX ('PrettyEmpty <++> PutNat 0)) `shouldBe` "0"+ it "renders (PutNat 0 <++> 'PrettyEmpty <++> PutNat 1) as \"01\"" $+ ptShow (PX :: PX (PutNat 0 <++> 'PrettyEmpty <++> PutNat 1)) `shouldBe` "01"+ it "renders (PrettyOften 7 (PutStr \".\") as \".......\"" $+ ptShow (PX :: PX (PrettyOften 7 (PutStr "."))) `shouldBe` "......."+ it "renders (PrettyMany (PutNat 777) '[]) as \"\"" $+ ptShow (PX :: PX (PrettyMany (PutNat 777) '[])) `shouldBe` ""+ it "renders (PrettyMany (PutNat 777) '[PutStr \".\"]) as \".\"" $+ ptShow (PX :: PX (PrettyMany (PutNat 777) '[PutStr "."])) `shouldBe` "."+ it "renders (PrettyMany (PutNat 777) '[PutStr \".\", PutNat 3, PutNat 4]) as \".77737774\"" $+ ptShow (PX :: PX (PrettyMany (PutNat 777) '[PutStr ".", PutNat 3, PutNat 4])) `shouldBe` ".77737774"++ describe "ToPretty" $ do+ it "renders a custom type" $ do+ putStrLn $ showPretty (PX :: PX TestTable)+ 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+-------+-----+------------+"+++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]+ ]++data MyTable = MyTable [Type] [Type]+data MyCol :: Symbol -> Nat -> Type+data MyRow :: [Nat] -> Type+++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)++type family TableHeading (cols :: [Type]) :: [PrettyType]+type instance TableHeading '[] = '[]+type instance 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 '[]
+ src/Data/Type/Pretty.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE UndecidableInstances #-}+-- | Type Level Pretty Printing+module Data.Type.Pretty where++import GHC.TypeLits+import Data.Proxy+import Text.Printf++-- * Printing Custom Types++-- | Pretty print a type for which a 'ToPretty' instance was defined, that+-- converts the type to a 'PrettyType'. If you want to roll your own converter+-- for your type to 'PrettyType', just do that and call 'ptShow' directly.+showPretty+ :: forall proxy t . PrettyTypeShow (ToPretty t)+ => proxy t -- ^ A proxy to the type to print. A 'ToPretty' instance for t must exists.+ -> String+showPretty _ = ptShow (Proxy :: Proxy (ToPretty t))++-- | Write an instance of this for converting your type (preferrable of your+-- kind also) to a promoted 'PrettyType'. NOTE: It might be helpful to turn on+-- 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++-- | A 'PrettyType' for a string.+type PutStr str = 'PrettySymbol 'PrettyUnpadded 'PrettyPrecise str++-- | A 'PrettyType' for a string with the exact given width.+type PutStrW width str =+ 'PrettySymbol ('PrettyPadded width) ('PrettyPrecision width) str++-- | A 'PrettyType' for a string with a newline character at the end.+type PutStrLn str = PutStr str <++> PutStr "\n"++-- | A 'PrettyType' for a number.+type PutNat x = 'PrettyNat 'PrettyUnpadded 'PrettyPrecise 'PrettyDec x++-- | A 'PrettyType' for a number with a width.+type PutNatW width x = 'PrettyNat ('PrettyPadded width) 'PrettyPrecise 'PrettyDec x++-- | Concatenate two 'PrettyType'.+type (<++>) l r = 'PrettySeperated 'PrettyEmpty l r+infixl 6 <++>++-- | Concatenate two 'PrettyType' using a 'PrettySpace'.+type (<+>) l r = 'PrettySeperated 'PrettySpace l r+infixl 5 <+>++-- | Concatenate two 'PrettyType' using a 'PrettyNewline'.+type (<$$>) l r = 'PrettySeperated 'PrettyNewline l r+infixl 4 <$$>++-- | Surround a pretty with parens+type PrettyParens doc = PrettySurrounded (PutStr "(") (PutStr ")") doc++-- | Surround a pretty with some pretties+type PrettySurrounded open close doc =+ open <++> doc <++> close++-- | Combine a (type level) list of 'PrettyType's next to each other using+-- 'PrettySpace'+type PrettyWide docs = PrettyMany 'PrettySpace docs++-- | Combine a (type level) list of 'PrettyType's below each other using+-- 'PrettyNewline'+type PrettyHigh docs = PrettyMany 'PrettyNewline docs++-- | A combination of 'PrettySpace' and 'PrettyMany',+-- e.g. @PrettyManyIn (PutStr "|") '[PutStr "a", PutStr "b"] => "|a|b|"@+type PrettyManyIn sep docs =+ PrettySurrounded sep sep (PrettyMany sep docs)++-- | Combine a (type level) list of 'PrettyType's seperated by a seperation+-- element.+type family+ PrettyMany (sep :: PrettyType)(docs :: [PrettyType]) :: PrettyType where+ PrettyMany sep '[] = 'PrettyEmpty+ PrettyMany sep '[singleOne] = singleOne+ PrettyMany sep (next ': rest) = next <++> sep <++> PrettyMany sep rest++-- | Repeat a 'PrettyType' @n@-times and append the copies.+type family PrettyOften (n :: Nat) (doc :: PrettyType) :: PrettyType where+ PrettyOften 0 doc = 'PrettyEmpty+ PrettyOften n doc = doc <++> PrettyOften (n-1) doc++-- | 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+-- | Create 'PrettyType' from a 'Nat' formatted as 16 bit hex number using+-- lower-case letters for the hex digits.+type PutHex16 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 4) 'PrettyHex x+-- | Create 'PrettyType' from a 'Nat' formatted as 32 bit hex number using+-- lower-case letters for the hex digits.+type PutHex32 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 8) 'PrettyHex x+-- | 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 8 bit hex number using+-- uppercase letters for the hex digits.+type PutHeX8 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 2) 'PrettyHexU x+-- | Create 'PrettyType' from a 'Nat' formatted as 16 bit hex number using+-- uppercase letters for the hex digits.+type PutHeX16 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 4) 'PrettyHexU x+-- | Create 'PrettyType' from a 'Nat' formatted as 32 bit hex number using+-- uppercase letters for the hex digits.+type PutHeX32 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 8) 'PrettyHexU x+-- | Create 'PrettyType' from a 'Nat' formatted as 64 bit hex number using+-- uppercase letters for the hex digits.+type PutHeX64 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 16) 'PrettyHexU x++-- | Create 'PrettyType' from a 'Nat' formatted as 8-bit bit representation,+-- i.e. @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"@+type PutBits16 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 16) 'PrettyBit x+-- | Create 'PrettyType' from a 'Nat' formatted as 32-bit bit representation,+-- i.e. @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"@+type PutBits64 x = 'PrettyNat 'PrettyUnpadded ('PrettyPrecision 64) 'PrettyBit x++-- * Low-Level Rendering++-- | In order to actually print anything from the promoted constructors of+-- 'PrettyTypeShow', a type class as common interface is required.+class PrettyTypeShow (p :: PrettyType) where+ ptShow :: proxy p -> String++-- | Print nothing.+instance PrettyTypeShow 'PrettyEmpty where ptShow _ = ""+-- | Print a single space character.+instance PrettyTypeShow 'PrettySpace where ptShow _ = " "+-- | Print a single newline character.+instance PrettyTypeShow 'PrettyNewline where ptShow _ = "\n"++-- | Print a 'Symbol' using the 'printf' and the given format parameters.+instance forall t pad prec.+ (KnownSymbol t, PrintfArgModifier pad, PrintfArgModifier prec)+ => PrettyTypeShow ('PrettySymbol pad prec t) where+ ptShow _ = printf ("%" ++ toPrintfArgModifier (Proxy :: Proxy pad)+ ++ toPrintfArgModifier (Proxy :: Proxy prec)+ ++ "s")+ (symbolVal (Proxy :: Proxy t))++-- | Print a 'Nat' using the 'printf' and the given format parameters.+instance forall fmt x pad prec.+ (KnownNat x, PrintfArgModifier fmt, PrintfArgModifier pad, PrintfArgModifier prec)+ => PrettyTypeShow ('PrettyNat pad prec fmt x) where+ ptShow _ = printf ("%" ++ toPrintfArgModifier (Proxy :: Proxy pad)+ ++ toPrintfArgModifier (Proxy :: Proxy prec)+ ++ toPrintfArgModifier (Proxy :: Proxy fmt))+ (natVal (Proxy :: Proxy x))++-- | Concatenate two 'PrettyType's. If one of them is empty print the other+-- without any seperation character.+instance forall l r sep .+ (PrettyTypeShow sep, PrettyTypeShow l, PrettyTypeShow r)+ => PrettyTypeShow ('PrettySeperated sep l r) where+ ptShow _ =+ let rstr = ptShow (Proxy :: Proxy r)+ lstr = ptShow (Proxy :: Proxy l)+ sepStr = ptShow (Proxy :: Proxy sep)+ in if lstr == "" then rstr+ else if rstr == "" then lstr+ else lstr ++ sepStr ++ rstr++-- | Internal 'printf' format generation. Used internally by 'PrettyTypeShow'+-- instances to generate the format string piece by piece with the values for+-- the instances of e.g. 'PrettyPrecise', 'PrettyNatFormat', or 'PrettyEmpty'.+class PrintfArgModifier a where+ -- | Generate a piece of a 'printf' format string from a proxy for a type.+ toPrintfArgModifier :: p a -> String++-- | Translation of 'PrettyHex' to 'printf' format character: @"x"@+instance PrintfArgModifier 'PrettyHex where toPrintfArgModifier _ = "x"+-- | Translation of 'PrettyHexU' to 'printf' format character: @"X"@+instance PrintfArgModifier 'PrettyHexU where toPrintfArgModifier _ = "X"+-- | Translation of 'PrettyDec' to 'printf' format character: @"d"@+instance PrintfArgModifier 'PrettyDec where toPrintfArgModifier _ = "d"+-- | Translation of 'PrettyBit' to 'printf' format character: @"b"@+instance PrintfArgModifier 'PrettyBit where toPrintfArgModifier _ = "b"+-- | Translation of 'PrettyUnpadded' to an empty modifier string+instance PrintfArgModifier 'PrettyUnpadded where toPrintfArgModifier _ = ""+-- | Translation of 'PrettyPadded' to a string with the numeric padding value.+instance forall p. KnownNat p => PrintfArgModifier ('PrettyPadded p) where+ toPrintfArgModifier _ = show (natVal (Proxy :: Proxy p))+-- | Translation of 'PrettyPrecise' to an empty modifier string+instance PrintfArgModifier 'PrettyPrecise where toPrintfArgModifier _ = ""+-- | Translation of 'PrettyPadded' to a string with the numeric precision value,+-- prependen by a dot @"."@.+instance forall p. KnownNat p => PrintfArgModifier ('PrettyPrecision p) where+ toPrintfArgModifier _ = "." ++ show (natVal (Proxy :: Proxy p))
+ stack.yaml view
@@ -0,0 +1,67 @@+# This file was automatically generated by 'stack init'+#+# Some commonly used options have been documented as comments in this file.+# For advanced use and comprehensive documentation of the format, please see:+# http://docs.haskellstack.org/en/stable/yaml_configuration/++# Resolver to choose a 'specific' stackage snapshot or a compiler version.+# A snapshot resolver dictates the compiler version and the set of packages+# to be used for project dependencies. For example:+#+# resolver: lts-3.5+# resolver: nightly-2015-09-21+# resolver: ghc-7.10.2+# resolver: ghcjs-0.1.0_ghc-7.10.2+# resolver:+# name: custom-snapshot+# location: "./custom-snapshot.yaml"+resolver: nightly-2016-07-30++# User packages to be built.+# Various formats can be used as shown in the example below.+#+# packages:+# - some-directory+# - https://example.com/foo/bar/baz-0.0.2.tar.gz+# - location:+# git: https://github.com/commercialhaskell/stack.git+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a+# extra-dep: true+# subdirs:+# - auto-update+# - wai+#+# A package marked 'extra-dep: true' will only be built if demanded by a+# non-dependency (i.e. a user package), and its test suites and benchmarks+# will not be run. This is useful for tweaking upstream packages.+packages:+- '.'++# Dependency packages to be pulled from upstream that are not in the resolver+# (e.g., acme-missiles-0.3)+extra-deps: []++# Override default flag values for local packages and extra-deps+flags: {}++# Extra package databases containing global packages+extra-package-dbs: []++# Control whether we use the GHC we find on the path+# system-ghc: true+#+# Require a specific version of stack, using version ranges+# require-stack-version: -any # Default+# require-stack-version: ">=1.1"+#+# Override the architecture used by stack, especially useful on Windows+# arch: i386+# arch: x86_64+#+# Extra directories used by stack for building+# extra-include-dirs: [/path/to/dir]+# extra-lib-dirs: [/path/to/dir]+#+# Allow a newer minor version of GHC than the snapshot specifies+# compiler-check: newer-minor