diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Razvan Ranca + +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 Razvan Ranca 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 b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,269 @@ +******************************************************************************* +* GenericPretty +* A Generic, Derivable, Haskell Pretty Printer +******************************************************************************* + +=============================================================================== +========================== Description ======================================== +=============================================================================== + +GenericPretty is a Haskell library that supports automatic +derivation of pretty printing functions on user defined data +types. + +The form of geenrics used is based on that introduced in the paper: +Magalhaes, Dijkstra, Jeuring, and Loh, +A Generic Deriving Mechanism for Haskell, +3'rd ACM Symposium on Haskell, pp. 37-48, September 2010, + http://dx.doi.org/10.1145/1863523.1863529. +Changes from the original paper in the GHC implementation +are described here: + http://www.haskell.org/haskellwiki/GHC.Generics#Changes_from_the_paper. + +This package requires the use of the new GHC.Generics features: + http://www.haskell.org/haskellwiki/GHC.Generics +present from GHC 7.2. +Use of these features is indicated by the DeriveGeneric pragma +or the flag -XDeriveGeneric. + +Pretty printing produces values of type Text.PrettyPrint.Doc, using +the Text.PrettyPrint library + http://www.haskell.org/ghc/docs/latest/html/libraries/pretty-1.1.1.0/Text-PrettyPrint.html. + +The output provided is a pretty printed version of that provided by +Prelude.show. That is, rendering the document provided by this pretty +printer yields an output identical to that of Prelude.show, except +for extra whitespace. + +The generics mechanism works on all haskell datatypes except for +constrained datatypes. +That is to say, datatypes which have a context will fail. +For instance, + data (Eq a) => Constr a = Constr a deriving (Generic) +will fail because of the (Eq a) context. + +=============================================================================== +===================== Installation Instructions =============================== +=============================================================================== + +The package is installed in the same way as any other package. +If you have cabal, you can simply do: + $ cabal update + $ cabal install GenericPretty + +Otherwise, the steps are: + 0. Make sure you have a version of ghc >= 7.4 installed and that you can + use the 'runhaskell' command from the command line. + 1. Download and unpack "GenericPretty-1.2.0.tar.gz" + 2. Move to the correct directory: + $ cd GenericPretty-1.2.0 + 3. Run the following haskell commands to install the library globally: + $ runhaskell Setup configure + $ runhaskell Setup build + $ runhaskell Setup install + + The last command requires root access, so you might need to run is as: + $ sudo runhaskell Setup install + +If something went wrong, you can check this page for more info, +look at manual installation: + http://www.haskell.org/haskellwiki/Cabal/How_to_install_a_Cabal_package + +=============================================================================== +============================== Basic Example ================================== +=============================================================================== + +Here is a haskell source file, called 'SimpleTest.hs' +---------------------------------------------------- +{-# LANGUAGE DeriveGeneric #-} + +import Text.PrettyPrint.GenericPretty + +data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Generic) + +instance (Out a) => Out (Tree a) + +tree1 :: Tree Int +tree1 = Node (Node (Leaf 333333) (Leaf (-555555)))(Node (Node(Node(Leaf 888888) + (Leaf 57575757))(Leaf (-14141414)))(Leaf 7777777)) + +main = pp tree1 +------------------------------------------------ +The flag DeriveGeneric must be given to GHC. This can be done as above, +in a 'LANGUAGE' pragma, or manually by compiling with 'ghc -XDeriveGeneric'. + +As can be seen, to use the library you must simply import it, derive Generic +on the custom data type by typing + "deriving (Generic)" +and writing an empty instance of Out. + +Then you can use the pretty printing functions, such as 'pp' and 'pretty'. + +Compiling and running the file is simple and gives the following result. +----------------------------- +$ ghc SimpleTest.hs +$ SimpleTest + +Node (Node (Leaf 333333) (Leaf (-555555))) + (Node (Node (Node (Leaf 888888) (Leaf 57575757)) + (Leaf (-14141414))) + (Leaf 7777777)) +--------------------------- +If we replaced the main function with 'main = ppLen 30 tree1', +the result would instead be: +----------------------------- +Node (Node (Leaf 333333) + (Leaf (-555555))) + (Node (Node (Node (Leaf 888888) + (Leaf 57575757)) + (Leaf (-14141414))) + (Leaf 7777777)) +------------------------------- +In this case the output tries to remain under 30 characters/line, +if possible, while always maintaining correct indentation. + +=============================================================================== +================= The 'ppStyle' and 'prettyStyle' functions =================== +=============================================================================== + +The 'ppStyle' function lets you further customize the output +by giving a 'Style' which consists of the line length, the number of ribbons +per line and the mode to use. + +The 'prettyStyle' function does the same thing except it outputs a String +instead of an IO() operation. + +A ribbon length is the maximum length of non-indentation text per line. +So if I used a line length of 80 and 2 ribbons per line than I would have a +maximum of 40 non-indentation characters on any line. + +The mode tells 'Pretty' how to render the result. There are 4 options: + 1. PageMode - the default rendering + 2. ZigZagMode - zig-zag cuts + 3. LeftMode - there is no indentation and no maximum line length + 4. OneLineMode - everything is put on one line + +The most interesting one is the ZigZagMode. +Modifying the running example we get: +-------------------------------------- +{-# LANGUAGE DeriveGeneric #-} + +import Text.PrettyPrint.GenericPretty +import Text.PrettyPrint + +data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Generic) + +instance (Out a) => Out (Tree a) + +tree1 :: Tree Int +tree1 = Node (Node (Leaf 333333) (Leaf (-555555)))(Node (Node(Node(Leaf 888888) + (Leaf 57575757))(Leaf (-14141414)))(Leaf 7777777)) + +zigStyle :: Style +zigStyle = Style {mode = ZigZagMode, lineLength = 30, ribbonsPerLine = 1.5} + +main = ppStyle zigStyle tree1 +-------------------------------------- +We import "Text.PrettyPrint" to gain access to the "Style" functionality. +Then we proceed to define the 'zigStyle' using a maximum line length of 30, +1.5 ribbonsPerLine and the ZigZagMode. + +Running the program, we get: +------------------------------------- +Node (Node (Leaf 333333) + +///// + (Leaf (-555555))) +(Node (Node (Node (Leaf 888888) + +///// + (Leaf 57575757)) + (Leaf (-14141414))) + (Leaf 7777777)) +------------------------------------- +Notice that the "/" show us the direction in which the rows below have been +moved (left in this case) and the number of "/"s indicate the number of +characters that the rows were moved(in this case 5 characters to the left). + +So the last 3 lines are 10 characters to the left compared to where they +would be if we had no maximum line length. + +=============================================================================== +======================= Full Customization Example ============================ +=============================================================================== + +While the previous approach provides us some with some options as to the +format of the pretty printed result, sometimes you need even more control. + +Fully customizing the pretty printed results is straightforward, as in the +following example called 'CustomTest.hs' +---------------------------- +{-# LANGUAGE DeriveGeneric #-} + +import Text.PrettyPrint.GenericPretty +import Text.PrettyPrint + +data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Generic) + +instance (Out a) => Out (Tree a) where + doc (Leaf a) = parens $ text "customLeaf" <+> doc a + doc (Node a b) = parens $ text "customNode" $$ nest 1 (doc a) + $$ nest 1 (doc b) + docPrec _ = doc + +tree1 :: Tree Int +tree1 = Node (Node (Leaf 333333) (Leaf (-555555)))(Node (Node(Node(Leaf 888888) + (Leaf 57575757))(Leaf (-14141414)))(Leaf 7777777)) + +main = pp tree1 +------------------------------ +Here we import the library 'Text.PrettyPrint' and use it directly to define doc. +We then define 'docPrec' in terms of 'doc', ignoring the precedence parameter. +We could have manually defined 'docList' as well if we wanted. As it is now, +'docList' is inferred from 'doc'. + +*****Note***** +As opposed to the 'Show' class, 'doc' and 'docPrec' are NOT defined in term +of one another. This means that even after giving a custom definition for +one of them, the other will retain the default behaviour. +If both are to be used, then custom definitions must be provided for both. + +For instance, in the above example, if we had ommited 'docPrec's definition, +the result would have been identical to that of 'SimpleTest.hs'. + +By running the above custom definition we get a tree with little indentation: +----------------------------------- +(customNode + (customNode + (customLeaf 333333) + (customLeaf -555555)) + (customNode + (customNode + (customNode + (customLeaf 888888) + (customLeaf 57575757)) + (customLeaf -14141414)) + (customLeaf 7777777))) +----------------------------------- +The details of the syntax used above can be found in the +Text.PrettyPrint library: + http://www.haskell.org/ghc/docs/latest/html/libraries/pretty-1.1.1.0/Text-PrettyPrint.html + +=============================================================================== +========================= Further Info ======================================== +=============================================================================== + +The above 'Tree' examples can be found in 'TestSuite/SimpleTest.hs', +'TestSuite.ZigZagTest.hs' and 'TestSuite/CustomTest.hs'. More involved +examples integrated with QuickCheck can be found in 'TestSuite/Tests.hs'. + +Further information can be found in the API: + http://hackage.haskell.org/packages/archive/GenericPretty/latest/doc/html/Text-PrettyPrint-GenericPretty.html +and in the source code itself. + +=============================================================================== +============================ Contact ========================================== +=============================================================================== + +Please send any questions/suggestions/issues to: + Razvan Ranca - ranca.razvan@gmail.com 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/src/Text/PrettyPrint/GenericPretty.hs b/src/Text/PrettyPrint/GenericPretty.hs new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint/GenericPretty.hs @@ -0,0 +1,305 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +{-| + GenericPretty is a Haskell library that supports automatic + derivation of pretty printing functions on user defined data + types. + + The output provided is a pretty printed version of that provided by + 'Prelude.show'. That is, rendering the document provided by this pretty + printer yields an output identical to that of 'Prelude.show', except + for extra whitespace. + + For examples of usage please see the README file included in the package. + + For more information see the HackageDB project page: +-} +module Text.PrettyPrint.GenericPretty + ( Pretty(..) + , Generic + , displayPrettyL + , displayPretty + , displayPrettyLenL + , displayPrettyLen + , displayPrettyPrefixL + , displayPrettyPrefix + ) where + +import qualified Data.HashMap.Strict +import qualified Data.IntMap.Strict +import Data.IxSet.Typed (Indexable) +import qualified Data.IxSet.Typed +import qualified Data.Map.Strict +import Data.String.Conversions (cs) +import qualified Data.Text as T +import Data.Text.Lazy (Text, fromStrict) +import Data.Time +import GHC.Generics +import Protolude hiding (Text, bool, + (<$>), (<>)) +import Text.PrettyPrint.Leijen.Text hiding (Pretty (..), + (<>)) +import qualified Text.PrettyPrint.Leijen.Text as PP + +-- | The class 'Pretty' is the equivalent of 'Prelude.Show' +-- +-- It provides conversion of values to pretty printable Pretty.Doc's. +-- +class Pretty a where + pretty :: a -> Doc + default pretty :: (Generic a, GPretty (Rep a)) => + a -> Doc + pretty x = + case (gpretty . from) x of + (o:[]) -> o + os -> PP.list os + +--'GPretty' is a helper class used to output the Sum-of-Products type, since it has kind *->*, +-- so can't be an instance of 'Pretty' +class GPretty f + -- |'gpretty' is the (*->*) kind equivalent of 'docPrec' + where + gpretty :: f x -> [Doc] + +-- if empty, output nothing, this is a null constructor +instance GPretty U1 where + gpretty _ = [] + +-- ignore datatype meta-information +instance (GPretty f) => + GPretty (M1 D c f) where + gpretty (M1 a) = gpretty a + +instance (GPretty f, Selector c) => + GPretty (M1 S c f) where + gpretty s@(M1 a) + | selector == "" = gpretty a + | otherwise = + if null components + then [] + else [ nest + prefixLength + (string (cs selector) <+> char '=' <+> cat components) + ] + where + selector = selName s + components = gpretty a + prefixLength = length selector + 3 + +-- | otherwise = Just PP.empty +-- constructor +-- here the real type and parens flag is set and propagated forward via t and n, the precedence factor is updated +-- let prefixLength = (succ . succ . length . conName) c +-- let prefixLength = (succ . succ . length . conName) c +-- let prefixLength = 1 +-- in [nest prefixLength ( parens ((string . cs . conName) c <+> (align . sep) components))] +instance (GPretty f, Constructor c) => + GPretty (M1 C c f) where + gpretty c@(M1 a) + | null components = [(string . cs . conName) c] + | conIsRecord c = + let prefixLength = 1 + in [ nest + prefixLength + ((string . cs . conName) c <$> + (braces . nest 1 . fillSep . punctuate comma) components) + ] + | otherwise = + [parens ((string . cs . conName) c <+> (align . sep) components)] + where + components = gpretty a + +-- ignore tagging, call docPrec since these are concrete types +instance (Pretty f) => + GPretty (K1 t f) where + gpretty (K1 a) = [(pretty a)] + +-- output both sides of the product, possible separated by a comma or an infix operator +instance (GPretty a, GPretty b) => + GPretty (a :*: b) where + gpretty (x :*: y) = xs ++ ys + where + xs = gpretty x + ys = gpretty y + +-- just continue to the corresponding side of the OR +instance (GPretty a, GPretty b) => + GPretty (a :+: b) where + gpretty (L1 x) = gpretty x + gpretty (R1 x) = gpretty x + +instance Pretty Char where + pretty = squotes . char + +instance Pretty Text where + pretty = dquotes . string + +instance Pretty T.Text where + pretty = pretty . fromStrict + +instance Pretty Int where + pretty i = + if i < 0 + then (parens . int) i + else int i + +instance Pretty Integer where + pretty i = + if i < 0 + then (parens . integer) i + else integer i + +instance Pretty Float where + pretty i = + if i < 0 + then (parens . float) i + else float i + +instance Pretty Double where + pretty i = + if i < 0 + then (parens . double) i + else double i + +instance Pretty Rational where + pretty = rational + +instance Pretty Bool where + pretty = bool + +instance Pretty ByteString where + pretty = (pretty :: Text -> Doc) . cs + +instance Pretty a => + Pretty [a] where + pretty = brackets . align . fillCat . punctuate comma . fmap pretty + +-- pretty (Just x) = nest 3 (text "Just" <$> pretty x) +instance Pretty a => + Pretty (Maybe a) where + pretty Nothing = text "Nothing" + pretty (Just x) = nest 5 (text "Just" <+> pretty x) + +-- pretty (Left x) = nest 3 ( text "Left" <$> pretty x) +-- pretty (Right y) = nest 3 ( text "Right" <$> pretty y) +instance (Pretty a, Pretty b) => + Pretty (Either a b) where + pretty (Left x) = nest 5 (text "Left" <$> pretty x) + pretty (Right y) = nest 5 (text "Right" <$> pretty y) + +instance (Pretty a, Pretty b) => + Pretty (a, b) where + pretty (a, b) = tupled [pretty a, pretty b] + +instance (Pretty a, Pretty b, Pretty c) => + Pretty (a, b, c) where + pretty (a, b, c) = tupled [pretty a, pretty b, pretty c] + +instance (Pretty a, Pretty b, Pretty c, Pretty d) => + Pretty (a, b, c, d) where + pretty (a, b, c, d) = tupled [pretty a, pretty b, pretty c, pretty d] + +instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e) => + Pretty (a, b, c, d, e) where + pretty (a, b, c, d, e) = + tupled [pretty a, pretty b, pretty c, pretty d, pretty e] + +instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f) => + Pretty (a, b, c, d, e, f) where + pretty (a, b, c, d, e, f) = + tupled [pretty a, pretty b, pretty c, pretty d, pretty e, pretty f] + +instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g) => + Pretty (a, b, c, d, e, f, g) where + pretty (a, b, c, d, e, f, g) = + tupled + [pretty a, pretty b, pretty c, pretty d, pretty e, pretty f, pretty g] + +instance (Pretty a, Pretty b) => + Pretty (Data.Map.Strict.Map a b) where + pretty v = text "fromList" <+> (pretty . Data.Map.Strict.toList) v + +instance (Pretty a) => + Pretty (Data.IntMap.Strict.IntMap a) where + pretty v = text "fromList" <+> (pretty . Data.IntMap.Strict.toList) v + +instance (Pretty a, Pretty b) => + Pretty (Data.HashMap.Strict.HashMap a b) where + pretty v = text "fromList" <+> (pretty . Data.HashMap.Strict.toList) v + +instance Pretty UTCTime where +-- pretty = text . cs . formatTime defaultTimeLocale rfc822DateFormat +-- though the above looks better, the below can be read back + pretty = text . cs . formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S %Z" + +instance (Show a, Indexable ixs a) => + Pretty (Data.IxSet.Typed.IxSet ixs a) where + pretty = text . show + +instance Pretty Word where + pretty = (pretty :: Integer -> Doc) . fromIntegral + +instance Pretty Word8 where + pretty = (pretty :: Integer -> Doc) . fromIntegral + +instance Pretty Word16 where + pretty = (pretty :: Integer -> Doc) . fromIntegral + +instance Pretty Word32 where + pretty = (pretty :: Integer -> Doc) . fromIntegral + +instance Pretty Word64 where + pretty = (pretty :: Integer -> Doc) . fromIntegral + +instance Pretty Int8 where + pretty = (pretty :: Integer -> Doc) . fromIntegral + +instance Pretty Int16 where + pretty = (pretty :: Integer -> Doc) . fromIntegral + +instance Pretty Int32 where + pretty = (pretty :: Integer -> Doc) . fromIntegral + +instance Pretty Int64 where + pretty = (pretty :: Integer -> Doc) . fromIntegral + +displayPrettyLenL + :: Pretty a + => Int -> a -> Text +displayPrettyLenL l = PP.displayT . PP.renderPretty 1.0 l . pretty + +displayPrettyLen + :: Pretty a + => Int -> a -> T.Text +displayPrettyLen l = toStrict . displayPrettyLenL l + +displayPrettyL + :: Pretty a + => a -> Text +displayPrettyL = displayPrettyLenL 70 + +-- displayPretty +-- :: (Show a, Pretty a) +-- => a -> T.Text +-- displayPretty = toStrict . displayPrettyL . (\x -> trace ("calling displayPretty: " ++ show x) x) +displayPretty + :: Pretty a + => a -> T.Text +displayPretty = toStrict . displayPrettyL + +displayPrettyPrefixL + :: (Pretty a, Pretty b) + => a -> b -> Text +displayPrettyPrefixL prefix = + PP.displayT . PP.renderPretty 1.0 70 . (PP.<>) (pretty prefix) . pretty + +displayPrettyPrefix + :: (Pretty a, Pretty b) + => a -> b -> T.Text +displayPrettyPrefix prefix = toStrict . displayPrettyPrefixL prefix diff --git a/src/Text/PrettyPrint/GenericPrettyStructure.hs b/src/Text/PrettyPrint/GenericPrettyStructure.hs new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint/GenericPrettyStructure.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Text.PrettyPrint.GenericPrettyStructure + ( PrettyStructure(..) + , Generic + , displayPrettyStructure + , prettyStructure + ) where + +import qualified Data.HashMap.Strict +import qualified Data.IntMap +import Data.IxSet.Typed (Indexable) +import qualified Data.IxSet.Typed +import qualified Data.Map +import Data.String.Conversions (cs) +import qualified Data.Text as T +import Data.Text.Lazy (Text, append, + fromStrict, + intercalate, singleton, + unlines, unwords) +import Data.Time +import GHC.Generics +import Protolude hiding (Text, bool, + intercalate, + intersperse) +import Text.PrettyPrint.Leijen.Text hiding (Pretty (..), + (<$>), (<>)) +import qualified Text.PrettyPrint.Leijen.Text as PP + +-- | The class 'PrettyStructure' is the equivalent of 'Prelude.Show' +-- +-- It provides conversion of values to prettyStructure printable PrettyStructure.Text's. +-- +class PrettyStructure a where + prettyStructure :: a -> Doc + default prettyStructure :: (Generic a, GPrettyStructure (Rep a)) => + a -> Doc + prettyStructure x = + string "prettyStructure begin" PP.<$> + nest 3 (fillSep ((gprettyStructure . from) x)) PP.<$> + string "prettyStructure end" + +-- prettyStructure x = case (gprettyStructure . from) x of +-- (o:[]) -> o +-- os -> PP.list os +--'GPrettyStructure' is a helper class used to output the Sum-of-Products type, since it has kind *->*, +-- so can't be an instance of 'PrettyStructure' +class GPrettyStructure f + -- |'gprettyStructure' is the (*->*) kind equivalent of 'docPrec' + where + gprettyStructure :: f x -> [Doc] + +-- if empty, output nothing, this is a null constructor +instance GPrettyStructure U1 where + gprettyStructure _ = [string "M1 U Begin" PP.<> string "M1 U End"] + +-- , append "datatypeName: " ((show . datatypeName) a) +-- , append "moduleName: " ((cs . moduleName) d) +-- , append "packageName: " ((cs . packageName) d) +-- , append "isNewtype: " ((show . isNewtype) d) +-- ignore datatype meta-information +instance (GPrettyStructure f) => + GPrettyStructure (M1 D c f) where + gprettyStructure (M1 a) = + [ (string "M1 D Begin") PP.<$> + ((nest 3 . fillSep) (gprettyStructure a)) PP.<$> (string "M1 D End") + ] + +instance (GPrettyStructure f, Selector c) => + GPrettyStructure (M1 S c f) where + gprettyStructure s@(M1 a) = + [string "M1 S Begin" PP.<$> + (nest 3 . fillSep) [ string ("selName: " <> (cs . selName) s) + , fillSep (gprettyStructure a)] + PP.<$> string "M1 S End" + ] + +-- constructor +-- here the real type and parens flag is set and propagated forward via t and n, the precedence factor is updated +instance (GPrettyStructure f, Constructor c) => + GPrettyStructure (M1 C c f) where + gprettyStructure c@(M1 a) = + [ string "M1 C Begin" PP.<$> + (nest 3 . fillSep)[ + string ("conName: " <> (cs . conName) c) + , string ("conFixity: " <> (show . conFixity) c) + , string ("conIsRecord: " <> (show . conIsRecord) c) + , fillSep (gprettyStructure a) + ] + PP.<$> string "M1 C End" + ] + +-- ignore tagging, call docPrec since these are concrete types +instance (PrettyStructure f) => + GPrettyStructure (K1 t f) where + gprettyStructure (K1 a) = +-- [string "M1 K Begin" <+> (nest 3 . prettyStructure) a PP.<+> string "M1 K End"] + [string "M1 K Begin" PP.<$> (nest 3 . prettyStructure) a PP.<$> string "M1 K End"] + +-- just continue to the corresponding side of the OR +instance (GPrettyStructure a, GPrettyStructure b) => + GPrettyStructure (a :+: b) where + gprettyStructure (L1 x) = + [ string "M1 :+: L1 Begin" PP.<$> + (nest 3 . fillSep) (gprettyStructure x) + PP.<$> string "M1 :+: L1 End" + ] +-- [ vcat [ string "M1 :+: L1 Begin" +-- , (nest 1 . nest 3 . fillSep) (gprettyStructure x) +-- , string "\nM1 :+: L1 End"] +-- ] +-- [ string "M1 :+: L1 Begin" <+> +-- (nest 3 . fillSep) (gprettyStructure x) +-- PP.<> string "\nM1 :+: L1 End" +-- ] + gprettyStructure (R1 x) = + [ string "M1 :*: R1 Begin" PP.<$> + (nest 3 . fillSep) (gprettyStructure x) + PP.<$> string "M1 :*: R1 End" + ] + +-- output both sides of the product, possible separated by a comma or an infix operator +instance (GPrettyStructure a, GPrettyStructure b) => + GPrettyStructure (a :*: b) where + gprettyStructure (x :*: y) = + [ sep + [ string "M1 :*: Begin" + , (nest 1 . sep) (gprettyStructure x) + , string ":*:" + , (nest 1 . sep) (gprettyStructure y) + , string "M1 :*: End" + ] + ] + +instance PrettyStructure Char where + prettyStructure = char + +instance PrettyStructure Text where + prettyStructure = string + +instance PrettyStructure T.Text where + prettyStructure = string . fromStrict + +instance PrettyStructure Int where + prettyStructure = int + +instance PrettyStructure Integer where + prettyStructure = integer + +instance PrettyStructure Float where + prettyStructure = float + +instance PrettyStructure Double where + prettyStructure = double + +instance PrettyStructure Rational where + prettyStructure = rational + +instance PrettyStructure Bool where + prettyStructure = bool + +instance PrettyStructure ByteString where + prettyStructure = string . cs + +instance PrettyStructure a => + PrettyStructure [a] where + prettyStructure = PP.list . fmap prettyStructure + +instance PrettyStructure a => + PrettyStructure (Maybe a) where + prettyStructure Nothing = "Nothing" + prettyStructure (Just x) = sep [string "Just", prettyStructure x] + +instance (PrettyStructure a, PrettyStructure b) => + PrettyStructure (Either a b) where + prettyStructure (Left x) = sep [string "Left", prettyStructure x] + prettyStructure (Right y) = sep [string "Right", prettyStructure y] + +instance (PrettyStructure a, PrettyStructure b) => + PrettyStructure (a, b) where + prettyStructure (a, b) = tupled [prettyStructure a, prettyStructure b] + +instance (PrettyStructure a, PrettyStructure b) => + PrettyStructure (Data.Map.Map a b) where + prettyStructure v = + sep [string "fromList ", (prettyStructure . Data.Map.toList) v] + +instance PrettyStructure UTCTime where + prettyStructure = text . cs . formatTime defaultTimeLocale rfc822DateFormat + +instance (Show a, Indexable ixs a) => + PrettyStructure (Data.IxSet.Typed.IxSet ixs a) where + prettyStructure = text . show + +instance PrettyStructure Word where + prettyStructure = (prettyStructure :: Integer -> Doc) . fromIntegral + +instance PrettyStructure Word8 where + prettyStructure = (prettyStructure :: Integer -> Doc) . fromIntegral + +instance PrettyStructure Word16 where + prettyStructure = (prettyStructure :: Integer -> Doc) . fromIntegral + +instance PrettyStructure Word32 where + prettyStructure = (prettyStructure :: Integer -> Doc) . fromIntegral + +instance PrettyStructure Word64 where + prettyStructure = (prettyStructure :: Integer -> Doc) . fromIntegral + +instance PrettyStructure Int8 where + prettyStructure = (prettyStructure :: Integer -> Doc) . fromIntegral + +instance PrettyStructure Int16 where + prettyStructure = (prettyStructure :: Integer -> Doc) . fromIntegral + +instance PrettyStructure Int32 where + prettyStructure = (prettyStructure :: Integer -> Doc) . fromIntegral + +instance PrettyStructure Int64 where + prettyStructure = (prettyStructure :: Integer -> Doc) . fromIntegral + +displayPrettyStructureL + :: PrettyStructure a + => a -> Text +displayPrettyStructureL = PP.displayT . PP.renderPretty 1.0 70 . prettyStructure + +displayPrettyStructure + :: PrettyStructure a + => a -> T.Text +displayPrettyStructure = toStrict . displayPrettyStructureL diff --git a/src/Text/PrettyPrint/GenericStructure.hs b/src/Text/PrettyPrint/GenericStructure.hs new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint/GenericStructure.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Text.PrettyPrint.GenericStructure + ( Structure(..) + , Generic + , displayStructure + , structure + ) where + +import qualified Data.HashMap.Strict +import qualified Data.IntMap +import Data.IxSet.Typed (Indexable) +import qualified Data.IxSet.Typed +import qualified Data.Map +import Data.String.Conversions (cs) +import qualified Data.Text as T +import Data.Text.Lazy (Text, append, fromStrict, + intercalate, singleton, + unlines, unwords) +import Data.Time +import GHC.Generics +import Protolude hiding (Text, bool, + intercalate, intersperse) + +-- | The class 'Structure' is the equivalent of 'Prelude.Show' +-- +-- It provides conversion of values to structure printable Structure.Text's. +-- +class Structure a where + structure :: a -> Text + default structure :: (Generic a, GStructure (Rep a)) => + a -> Text + structure x = + intercalate + "\n" + [ "structure begin" + , intercalate "\n" ((gstructure . from) x) + , "structure end" + ] + +-- structure x = case (gstructure . from) x of +-- (o:[]) -> o +-- os -> PP.list os +--'GStructure' is a helper class used to output the Sum-of-Products type, since it has kind *->*, +-- so can't be an instance of 'Structure' +class GStructure f + -- |'gstructure' is the (*->*) kind equivalent of 'docPrec' + where + gstructure :: f x -> [Text] + +-- if empty, output nothing, this is a null constructor +instance GStructure U1 where + gstructure _ = ["M1 U Begin" <> "M1 U End"] + +-- , append "datatypeName: " ((show . datatypeName) a) +-- , append "moduleName: " ((cs . moduleName) d) +-- , append "packageName: " ((cs . packageName) d) +-- , append "isNewtype: " ((show . isNewtype) d) +instance (GStructure f) => + GStructure (M1 D c f) where + gstructure (M1 a) = + [ intercalate + "\n" + ["M1 D Begin", intercalate "\n" (gstructure a), "M1 D End"] + ] + +instance (GStructure f, Selector c) => + GStructure (M1 S c f) where + gstructure s@(M1 a) = + [ intercalate + "\n" + [ "M1 S Begin" + , "selName: " <> (cs . selName) s + , intercalate "\n" (gstructure a) + , "M1 S End" + ] + ] + +-- constructor +-- here the real type and parens flag is set and propagated forward via t and n, the precedence factor is updated +instance (GStructure f, Constructor c) => + GStructure (M1 C c f) where + gstructure c@(M1 a) = + [ intercalate + "\n" + [ "M1 C Begin" + , "conName: " <> (cs . conName) c + , "conFixity: " <> (show . conFixity) c + , "conIsRecord: " <> (show . conIsRecord) c + , intercalate "\n" (gstructure a) + , "M1 C End" + ] + ] + +-- ignore tagging, call docPrec since these are concrete types +instance (Structure f) => + GStructure (K1 t f) where + gstructure (K1 a) = [intercalate "\n" ["M1 K Begin", structure a, "M1 K End"]] + +-- just continue to the corresponding side of the OR +instance (GStructure a, GStructure b) => + GStructure (a :+: b) where + gstructure (L1 x) = + [ intercalate + "\n" + ["M1 :+: L1 Begin", intercalate "\n" (gstructure x), "M1 :+: L1 End"] + ] + gstructure (R1 x) = + [ intercalate + "\n" + ["M1 :*: R1 Begin", intercalate "\n" (gstructure x), "M1 :*: R1 End"] + ] + +-- output both sides of the product, possible separated by a comma or an infix operator +instance (GStructure a, GStructure b) => + GStructure (a :*: b) where + gstructure (x :*: y) = + [ intercalate + "\n" + [ "M1 :*: Begin" + , intercalate "\n" (gstructure x) + , ":*:" + , intercalate "\n" (gstructure y) + , "M1 :*: End" + ] + ] + +instance Structure Char where + structure = singleton + +instance Structure Text where + structure = identity + +instance Structure T.Text where + structure = fromStrict + +instance Structure Int where + structure = show + +instance Structure Integer where + structure = show + +instance Structure Float where + structure = show + +instance Structure Double where + structure = show + +instance Structure Rational where + structure = show + +instance Structure Bool where + structure = show + +instance Structure ByteString where + structure = cs + +instance Structure a => + Structure [a] where + structure = show . fmap structure + +instance Structure a => + Structure (Maybe a) where + structure Nothing = "Nothing" + structure (Just x) = "Just " <> structure x + +instance (Structure a, Structure b) => + Structure (Either a b) where + structure (Left x) = "Left " <> structure x + structure (Right y) = "Right " <> structure y + +instance (Structure a, Structure b) => + Structure (a, b) where + structure (a, b) = + "(" <> show (structure a) <> " , " <> show (structure b) <> ")" + +instance (Structure a, Structure b) => + Structure (Data.Map.Map a b) where + structure v = "fromList " <> structure v + +instance Structure UTCTime where + structure = cs . formatTime defaultTimeLocale rfc822DateFormat + +instance (Show a, Indexable ixs a) => + Structure (Data.IxSet.Typed.IxSet ixs a) where + structure = show + +instance Structure Word where + structure = (structure :: Integer -> Text) . fromIntegral + +instance Structure Word8 where + structure = (structure :: Integer -> Text) . fromIntegral + +instance Structure Word16 where + structure = (structure :: Integer -> Text) . fromIntegral + +instance Structure Word32 where + structure = (structure :: Integer -> Text) . fromIntegral + +instance Structure Word64 where + structure = (structure :: Integer -> Text) . fromIntegral + +instance Structure Int8 where + structure = (structure :: Integer -> Text) . fromIntegral + +instance Structure Int16 where + structure = (structure :: Integer -> Text) . fromIntegral + +instance Structure Int32 where + structure = (structure :: Integer -> Text) . fromIntegral + +instance Structure Int64 where + structure = (structure :: Integer -> Text) . fromIntegral + +displayStructure + :: Structure a + => a -> T.Text +displayStructure = toStrict . structure diff --git a/src/Text/PrettyPrint/TestGenericPretty.hs b/src/Text/PrettyPrint/TestGenericPretty.hs new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint/TestGenericPretty.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +{-| + GenericPretty is a Haskell library that supports automatic + derivation of pretty printing functions on user defined data + types. + + The output provided is a pretty printed version of that provided by + 'Prelude.show'. That is, rendering the document provided by this pretty + printer yields an output identical to that of 'Prelude.show', except + for extra whitespace. + + For examples of usage please see the README file included in the package. + + For more information see the HackageDB project page: +-} +module Text.PrettyPrint.TestGenericPretty + ( Pretty(..) + , Generic + , displayPrettyL + , displayPretty + , displayPrettyLenL + , displayPrettyLen + ) where + +import qualified Data.HashMap.Strict +import qualified Data.IntMap +import Data.IxSet.Typed (Indexable) +import qualified Data.IxSet.Typed +import qualified Data.Map +import Data.String.Conversions (cs) +import qualified Data.Text as T +import Data.Text.Lazy (Text, fromStrict) +import Data.Time +import GHC.Generics +import Protolude hiding (Text, bool, + (<>)) +import Text.PrettyPrint.Leijen.Text hiding (Pretty (..), + (<$>), (<>)) +import qualified Text.PrettyPrint.Leijen.Text as PP + +-- | The class 'Pretty' is the equivalent of 'Prelude.Show' +-- +-- It provides conversion of values to pretty printable Pretty.Doc's. +-- +class Pretty a where + pretty :: a -> Doc + default pretty :: (Generic a, GPretty (Rep a)) => + a -> Doc + pretty x = case (gpretty . from) x of + (o:[]) -> o + os -> PP.list os + +--'GPretty' is a helper class used to output the Sum-of-Products type, since it has kind *->*, +-- so can't be an instance of 'Pretty' +class GPretty f + -- |'gpretty' is the (*->*) kind equivalent of 'docPrec' + where + gpretty :: f x -> [Doc] + +-- if empty, output nothing, this is a null constructor +instance GPretty U1 where + gpretty _ = [] + +-- ignore datatype meta-information +instance (GPretty f) => + GPretty (M1 D c f) where + gpretty (M1 a) = gpretty a + +instance (GPretty f, Selector c) => + GPretty (M1 S c f) where + gpretty s@(M1 a) + | selector == "" = gpretty a + | otherwise = + if null components + then [] + else [string (cs selector) <+> string "=" <+> cat components] + where + selector = selName s + components = fmap (nest (length selector + 3)) (gpretty a) + +-- | otherwise = Just PP.empty +-- constructor +-- here the real type and parens flag is set and propagated forward via t and n, the precedence factor is updated +instance (GPretty f, Constructor c) => + GPretty (M1 C c f) where + gpretty c@(M1 a) + | null components = [(string . cs . conName) c] + | conIsRecord c = + [(string . cs . conName) c <+> (braces . align . fillSep . punctuate comma) components] + | otherwise = + [parens ((string . cs . conName) c <+> (align . sep) components)] + where components = gpretty a + +-- ignore tagging, call docPrec since these are concrete types +instance (Pretty f) => + GPretty (K1 t f) where + gpretty (K1 a) = [(pretty a)] + +-- output both sides of the product, possible separated by a comma or an infix operator +instance (GPretty a, GPretty b) => + GPretty (a :*: b) where + gpretty (x :*: y) = xs ++ ys + where xs = gpretty x + ys = gpretty y + +-- just continue to the corresponding side of the OR +instance (GPretty a, GPretty b) => + GPretty (a :+: b) where + gpretty (L1 x) = gpretty x + gpretty (R1 x) = gpretty x + +instance Pretty Char where + pretty = char + +instance Pretty Text where + pretty = string + +instance Pretty T.Text where + pretty = string . fromStrict + +instance Pretty Int where + pretty i = if i < 0 + then (parens . int) i + else int i + +instance Pretty Integer where + pretty i = if i < 0 + then (parens . integer) i + else integer i + +instance Pretty Float where + pretty i = if i < 0 + then (parens . float) i + else float i + +instance Pretty Double where + pretty i = if i < 0 + then (parens . double) i + else double i + +instance Pretty Rational where + pretty = rational + +instance Pretty Bool where + pretty = bool + +instance Pretty ByteString where + pretty = string . cs + +instance Pretty a => + Pretty [a] where + pretty = PP.list . fmap pretty + +instance Pretty a => + Pretty (Maybe a) where + pretty Nothing = text "Nothing" + pretty (Just x) = text "Just" <+> pretty x + +instance (Pretty a, Pretty b) => + Pretty (Either a b) where + pretty (Left x) = text "Left" <+> pretty x + pretty (Right y) = text "Right" <+> pretty y + +instance (Pretty a, Pretty b) => + Pretty (a, b) where + pretty (a, b) = tupled [pretty a, pretty b] + +instance (Pretty a, Pretty b, Pretty c) => + Pretty (a, b, c) where + pretty (a, b, c) = tupled [pretty a, pretty b, pretty c] + +instance (Pretty a, Pretty b, Pretty c, Pretty d) => + Pretty (a, b, c, d) where + pretty (a, b, c, d) = tupled [pretty a, pretty b, pretty c, pretty d] + +instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e) => + Pretty (a, b, c, d, e) where + pretty (a, b, c, d, e) = + tupled [pretty a, pretty b, pretty c, pretty d, pretty e] + +instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f) => + Pretty (a, b, c, d, e, f) where + pretty (a, b, c, d, e, f) = + tupled [pretty a, pretty b, pretty c, pretty d, pretty e, pretty f] + +instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g) => + Pretty (a, b, c, d, e, f, g) where + pretty (a, b, c, d, e, f, g) = + tupled + [pretty a, pretty b, pretty c, pretty d, pretty e, pretty f, pretty g] + +instance (Pretty a, Pretty b) => + Pretty (Data.Map.Map a b) where + pretty v = text "fromList " <+> pretty v + +instance (Pretty a) => + Pretty (Data.IntMap.IntMap a) where + pretty v = text "fromList " <+> pretty v + +instance (Pretty a, Pretty b) => + Pretty (Data.HashMap.Strict.HashMap a b) where + pretty v = text "fromList " <+> pretty v + +instance Pretty UTCTime where + pretty = text . cs . formatTime defaultTimeLocale rfc822DateFormat + +instance (Show a, Indexable ixs a) => + Pretty (Data.IxSet.Typed.IxSet ixs a) where + pretty = text . show + +instance Pretty Word where + pretty = (pretty :: Integer -> Doc) . fromIntegral + +instance Pretty Word8 where + pretty = (pretty :: Integer -> Doc) . fromIntegral + +instance Pretty Word16 where + pretty = (pretty :: Integer -> Doc) . fromIntegral + +instance Pretty Word32 where + pretty = (pretty :: Integer -> Doc) . fromIntegral + +instance Pretty Word64 where + pretty = (pretty :: Integer -> Doc) . fromIntegral + +instance Pretty Int8 where + pretty = (pretty :: Integer -> Doc) . fromIntegral + +instance Pretty Int16 where + pretty = (pretty :: Integer -> Doc) . fromIntegral + +instance Pretty Int32 where + pretty = (pretty :: Integer -> Doc) . fromIntegral + +instance Pretty Int64 where + pretty = (pretty :: Integer -> Doc) . fromIntegral + +displayPrettyL + :: Pretty a + => a -> Text +displayPrettyL = PP.displayT . PP.renderPretty 1.0 70 . pretty + +displayPretty + :: Pretty a + => a -> T.Text +displayPretty = toStrict . displayPrettyL + +displayPrettyLenL + :: Pretty a + => Int -> a -> Text +displayPrettyLenL l = PP.displayT . PP.renderPretty 1.0 l . pretty + +displayPrettyLen + :: Pretty a + => Int -> a -> T.Text +displayPrettyLen l = toStrict . displayPrettyLenL l diff --git a/test/GenericPretty/Tests.hs b/test/GenericPretty/Tests.hs new file mode 100644 --- /dev/null +++ b/test/GenericPretty/Tests.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} + +module GenericPretty.Tests + ( tests + ) where + +import Protolude hiding (Product, Sum, empty) +import Test.Tasty +import Test.Tasty.HUnit + +import qualified K1 +import qualified Product +import qualified Sum +import qualified TestData +import qualified U1 + +-- got this idea from +-- https://jaspervdj.be/posts/2015-03-13-practical-testing-in-haskell.html +-- it would be cool to generate the data types using Arbitrary as GAST +-- supposedly did +-- testProperty "test U1" prop_U1 +tests :: TestTree +tests = + testGroup + "GenericPretty" + [ testCase "testU1" testU1 + , testCase "testSum" testSum + , testCase "testProduct" testProduct + , testCase "testK1" testK1 + , testCase "testDataTree1" testDataTree1 + , testCase "testDataTree2" testDataTree2 + , testCase "testDataTree3" testDataTree3 + , testCase "testDataTree4" testDataTree4 + , testCase "testDataAnimal1" testDataAnimal1 + , testCase "testHashMap" testHashMap + , testCase "testIntMap" testIntMap + , testCase "testMap" testMap + , testCase "testUTCTime" testUTCTime + ] + +testU1 :: Assertion +testU1 = U1.showAndRead U1.sample @?= Right U1.sample + +testSum :: Assertion +testSum = Sum.showAndRead Sum.sample @?= Right Sum.sample + +testProduct :: Assertion +testProduct = Product.showAndRead Product.sample @?= Right Product.sample + +testK1 :: Assertion +testK1 = K1.showAndRead K1.sample @?= Right K1.sample + +testDataTree1 :: Assertion +testDataTree1 = TestData.showAndReadTree TestData.tree1 @?= Right TestData.tree1 + +testDataTree2 :: Assertion +testDataTree2 = TestData.showAndReadTree TestData.tree2 @?= Right TestData.tree2 + +testDataTree3 :: Assertion +testDataTree3 = TestData.showAndReadTree TestData.tree3 @?= Right TestData.tree3 + +testDataTree4 :: Assertion +testDataTree4 = + TestData.showAndReadTree1 TestData.tree4 @?= Right TestData.tree4 + +testDataAnimal1 :: Assertion +testDataAnimal1 = + TestData.showAndReadAnimal1 TestData.animal1 @?= Right TestData.animal1 + +testHashMap :: Assertion +testHashMap = + TestData.showAndReadHashMap TestData.hashMapTest @?= Right TestData.hashMapTest + +testIntMap :: Assertion +testIntMap = + TestData.showAndReadIntMap TestData.intMapTest @?= Right TestData.intMapTest + +testMap :: Assertion +testMap = + TestData.showAndReadMap TestData.mapTest @?= Right TestData.mapTest + +testUTCTime :: Assertion +testUTCTime = + TestData.showAndReadUTCTime TestData.utcTimeTest @?= Right TestData.utcTimeTest diff --git a/test/K1.hs b/test/K1.hs new file mode 100644 --- /dev/null +++ b/test/K1.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module K1 where + +import Data.String.Conversions (cs) +import GHC.Base +import GHC.Generics +import Protolude hiding (K1) + +import Text.PrettyPrint.GenericPretty + +data Sample = + Sample ByteString + deriving (Eq, Read, Show, Generic, Pretty) + +sample :: Sample +sample = Sample "sample bytestring" + +showAndRead :: Sample -> Either GHC.Base.String Sample +showAndRead = readEither . cs . displayPretty diff --git a/test/Product.hs b/test/Product.hs new file mode 100644 --- /dev/null +++ b/test/Product.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Product where + +import Data.String.Conversions (cs) +import GHC.Base +import GHC.Generics +import Protolude hiding (Product) + +import Text.PrettyPrint.GenericPretty + +data Product = + Product Int + Integer + Char + Text + ByteString + deriving (Eq, Read, Show, Generic, Pretty) + +sample :: Product +sample = Product 1 10 'C' "sample text" "sample bytestring" + +showAndRead :: Product -> Either GHC.Base.String Product +showAndRead = readEither . cs . displayPretty diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Protolude +import Test.Tasty (defaultMain, testGroup) + +import qualified GenericPretty.Tests + +-- got this idea from +-- https://jaspervdj.be/posts/2015-03-13-practical-testing-in-haskell.html +main :: IO () +main = defaultMain $ testGroup "Tests" [GenericPretty.Tests.tests] diff --git a/test/Sum.hs b/test/Sum.hs new file mode 100644 --- /dev/null +++ b/test/Sum.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Sum where + +import Data.String.Conversions (cs) +import GHC.Base +import GHC.Generics +import Protolude hiding (Sum, empty) + +import Text.PrettyPrint.GenericPretty + +data Sum + = Cat + | Dog + | Rat + | Elephant + deriving (Eq, Read, Show, Generic, Pretty) + +sample :: Sum +sample = Elephant + +showAndRead :: Sum -> Either GHC.Base.String Sum +showAndRead = readEither . cs . displayPretty diff --git a/test/TestData.hs b/test/TestData.hs new file mode 100644 --- /dev/null +++ b/test/TestData.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module TestData where + +import Data.String.Conversions (cs) +import Data.Time +import GHC.Base +import GHC.Generics +import Protolude hiding (K1) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map.Strict as Map + +import Text.PrettyPrint.GenericPretty + +showAndReadTree :: Tree Int -> Either GHC.Base.String (Tree Int) +showAndReadTree = readEither . cs . displayPretty + +showAndReadTree1 :: Tree1 Int Text -> Either GHC.Base.String (Tree1 Int Text) +showAndReadTree1 = readEither . cs . displayPretty + +showAndReadAnimal1 :: Animal1 -> Either GHC.Base.String Animal1 +showAndReadAnimal1 = readEither . cs . displayPretty + +data Tree a + = Leaf a + | Node (Tree a) + (Tree a) + deriving (Eq, Read, Show, Generic, Pretty) + +data Tree1 a b + = Leaf1 a + b + | Node1 (Tree1 a b) + (Tree1 a b) + deriving (Eq, Read, Show, Generic, Pretty) + +tree1 :: Tree Int +tree1 = + Node + (Node (Leaf 333333) (Leaf (-555555))) + (Node + (Node (Node (Leaf 888888) (Leaf 57575757)) (Leaf (-14141414))) + (Leaf 7777777)) + +tree2 :: Tree Int +tree2 = Leaf 7777777 + +tree3 :: Tree Int +tree3 = Node (Leaf 7777777) (Leaf 5555555) + +tree4 :: Tree1 Int Text +tree4 = + Node1 + (Node1 (Leaf1 333333 "testing agan") (Leaf1 (-555555) "ntest")) + (Node1 + (Node1 + (Node1 (Leaf1 888888 "again") (Leaf1 57575757 "tisti")) + (Leaf1 (-14141414) "test")) + (Leaf1 7777777 "aointhk")) + +animal1 :: Animal1 +animal1 = + Animal1 10 "junk animal" "junk animal again" Dog tree1 'C' "test bytestring" + +data Animal + = Dog + | Cat + | Horse + | Elephant + deriving (Eq, Read, Show, Generic, Pretty, Enum) + +data Animal1 = Animal1 + { aType :: Int + , aName :: Text + , aNameAgain :: Text + , animal :: Animal + , aTree :: Tree Int + , aChar :: Char + , aBS :: ByteString + } deriving (Eq, Read, Show, Generic, Pretty) + +hashMapTest :: HashMap.HashMap Int Text +hashMapTest = HashMap.fromList [(1, "10")] + +showAndReadHashMap :: HashMap.HashMap Int Text -> Either GHC.Base.String ( HashMap.HashMap Int Text) +showAndReadHashMap = readEither . cs . displayPretty + +intMapTest :: IntMap.IntMap Text +intMapTest = IntMap.fromList [(1, "10")] + +showAndReadIntMap :: IntMap.IntMap Text -> Either GHC.Base.String ( IntMap.IntMap Text) +showAndReadIntMap = readEither . cs . displayPretty + +mapTest :: Map.Map Int Text +mapTest = Map.fromList [(1, "10")] + +showAndReadMap :: Map.Map Int Text -> Either GHC.Base.String ( Map.Map Int Text) +showAndReadMap = readEither . cs . displayPretty + +utcTimeTest :: UTCTime +utcTimeTest = UTCTime (ModifiedJulianDay 40587) 0 + +showAndReadUTCTime :: UTCTime -> Either GHC.Base.String UTCTime +showAndReadUTCTime = readEither . cs . displayPretty diff --git a/test/U1.hs b/test/U1.hs new file mode 100644 --- /dev/null +++ b/test/U1.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module U1 where + +import Data.String.Conversions (cs) +import GHC.Base +import GHC.Generics +import Protolude hiding (empty, get, put) + +import Text.PrettyPrint.GenericPretty + +data Empty = + Empty + deriving (Eq, Read, Show, Generic, Pretty) + +sample :: Empty +sample = Empty + +showAndRead :: Empty -> Either GHC.Base.String Empty +showAndRead = readEither . cs . displayPretty diff --git a/text-generic-pretty.cabal b/text-generic-pretty.cabal new file mode 100644 --- /dev/null +++ b/text-generic-pretty.cabal @@ -0,0 +1,138 @@ +-- The name of the package. +Name: text-generic-pretty + +-- The package version. See the Haskell package versioning policy +-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for +-- standards guiding when and how versions should be incremented. +Version: 1.2.1 + +-- A short (one-line) description of the package. +Synopsis: A generic, derivable, haskell pretty printer. + +-- A longer description of the package. +Description: + GenericPretty is a Haskell library that supports automatic + derivation of pretty printing functions on user defined data + types. + . + The form of geenrics used is based on that introduced in the paper: + Magalhaes, Dijkstra, Jeuring, and Loh, + A Generic Deriving Mechanism for Haskell, + 3'rd ACM Symposium on Haskell, pp. 37-48, September 2010, + . + Changes from the original paper in the GHC implementation + are described here: + . + . + This package requires the use of the new GHC.Generics features + , present from GHC 7.2. + Use of these features is indicated by the DeriveGeneric pragma. + or the flag -XDeriveGeneric. + . + Pretty printing produces values of type Text.PrettyPrint.Doc, using + the Text.PrettyPrint library + . + . + The output provided is a pretty printed version of that provided by + Prelude.show. That is, rendering the document provided by this pretty + printer yields an output identical to that of Prelude.show, except + for extra whitespace. + . + For information about the functions exported by the package please see + the API linked further down this page. + + For examples of usage, both basic and more complex see the README file and + the haskell source code files in the TestSuite folder, both included in the package. + + Finally for installation instructions also see the README file or this page: + + +-- URL for the project homepage or repository. +Homepage: https://github.com/joe9/GenericPretty + +-- The license under which the package is released. +License: BSD3 + +-- The file containing the license text. +License-file: LICENSE + +-- The package author(s). +Author: Razvan Ranca + +-- An email address to which users can send suggestions, bug reports, +-- and patches. +Maintainer: joe9mail@gmail.com + +-- A copyright notice. +-- Copyright: + +Category: Text, Generics, Pretty Printer + +Build-type: Simple + +-- Extra files to be distributed with the package, such as examples or +-- a README. +Extra-source-files: README + +-- Constraint on the version of Cabal needed to build this package. +Cabal-version: >=1.10 + + +Library + -- Modules exported by the library. + Exposed-modules: Text.PrettyPrint.GenericPretty Text.PrettyPrint.TestGenericPretty Text.PrettyPrint.GenericStructure Text.PrettyPrint.GenericPrettyStructure + + -- Packages needed in order to build this package. + Build-depends: base >= 3 && < 5 + , ghc-prim + , wl-pprint-text + , protolude + , text + , string-conversions + , QuickCheck + , containers + , unordered-containers + , time + , ixset-typed + , groom + + -- use Protolude instead of Prelude + ghc-options: -Wall + hs-source-dirs: src + default-language: Haskell2010 + + -- Modules not exported by this package. + -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + -- Build-tools: + +test-suite GenericPretty-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: GenericPretty.Tests + U1 + Sum + Product + K1 + TestData + build-tools: hsc2hs + build-depends: base + , protolude + , string-conversions + , tasty + , tasty-hunit + , tasty-quickcheck + , QuickCheck + , text-generic-pretty + , containers + , unordered-containers + , time + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + other-extensions: NoImplicitPrelude, OverloadedStrings + default-language: Haskell2010 + +source-repository head + type: git + location: git@github.com:joe9/GenericPretty.git