diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,11 @@ +*.hi +*.o +*.swp +*.tag +*~ +*_flymake.hs +.hsenv +.stack-work/ +TAGS +/.idea/ +/.dir-locals.el diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,76 @@ +[![Build Status](https://travis-ci.org/sheyll/pretty-types.svg?branch=master)](https://travis-ci.org/sheyll/pretty-types) +[![Hackage](https://img.shields.io/badge/hackage-pretty-types-green.svg?style=flat)](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 '[] diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/pretty-types.cabal b/pretty-types.cabal new file mode 100644 --- /dev/null +++ b/pretty-types.cabal @@ -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 diff --git a/spec/PrettyTypesSpec.hs b/spec/PrettyTypesSpec.hs new file mode 100644 --- /dev/null +++ b/spec/PrettyTypesSpec.hs @@ -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 '[] diff --git a/src/Data/Type/Pretty.hs b/src/Data/Type/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Data/Type/Pretty.hs @@ -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)) diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -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