GenericPretty (empty) → 0.1.0
raw patch · 7 files changed
+721/−0 lines, 7 filesdep +basedep +ghcdep +ghc-primsetup-changed
Dependencies added: base, ghc, ghc-prim
Files
- GenericPretty.cabal +71/−0
- LICENSE +30/−0
- README +75/−0
- Setup.hs +2/−0
- TestSuite/SimpleTest.hs +14/−0
- TestSuite/Tests.hs +175/−0
- Text/PrettyPrint/GenericPretty.hs +354/−0
+ GenericPretty.cabal view
@@ -0,0 +1,71 @@+-- GenericPretty.cabal auto-generated by cabal init. For additional +-- options, see +-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. +-- The name of the package. +Name: GenericPretty + +-- 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: 0.1.0 + +-- 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 provides support for automatic + derivation of pretty printing functions on user defined data types. + The Outputable library is used underneath, the work is done over SDoc types. + . + The output provided by the library functions is identical to that of Prelude.show, + except it has extra whitespace. + . + For more info and examples of usage please see the README file and the API. + +-- URL for the project homepage or repository. +Homepage: https://github.com/HaggisMcMutton/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: ranca.razvan@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 TestSuite\SimpleTest.hs TestSuite\Tests.hs + +-- Constraint on the version of Cabal needed to build this package. +Cabal-version: >=1.6 + + +Library + -- Modules exported by the library. + Exposed-modules: Text.PrettyPrint.GenericPretty + + -- Packages needed in order to build this package. + Build-depends: base >= 3 && < 5, ghc-prim, ghc >= 7.1.20110601 + + -- Modules not exported by this package. + -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + -- Build-tools: + +source-repository head + type: git + location: git@github.com:HaggisMcMutton/GenericPretty.git
+ LICENSE view
@@ -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.
+ README view
@@ -0,0 +1,75 @@+GenericPretty. A Generic, Derivable, Haskell Pretty Printer +=============================================================================== + +GenericPretty is a haskell library that provides support for automatic +derivation of pretty printing functions on user defined data types. + +The output provided by the library functions is identical to that of Prelude.show, +except it has extra whitespace. + +I find examples are the best aid in understanding. So, here is a possible +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 one must simply import it, derive 'Generic' +on the custom data type, and write an empty instance of 'Out'. + +Then one can use the pretty printing functions, such as 'pp' and 'prettyP'. + +Compiling and running the file is simple and gives the following result. +----------------------------- +$ ghc SimpleTest.hs +[1 of 1] Compiling Main ( SimpleTest.hs, SimpleTest.o ) +Linking SimpleTest.exe ... + +$ 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 = prettyP 30 1 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 maintaining correct indentation. + +------Note--------- +The defined pretty printing functions work with any type that implements +'Out' OR 'Outputable'. +This is so that if the data type that is using the deriving mechanism +relies on some other data type that can't, if the inner type implements +'Outputable', then the deriving still works. +------------------- + +The above 'Tree' example can be found in 'TestSuite/SimpleTest.hs'. +More involved examples integrated with QuickCheck can be found in 'TestSuite/Tests.hs'. + +Further information can be found in the haddock generated API at dist/doc/html +and in the source code itself. +=============================================================================== + +Please send any questions/suggestions to: +Razvan Ranca <ranca.razvan@gmail.com>
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ TestSuite/SimpleTest.hs view
@@ -0,0 +1,14 @@+{-# 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 = prettyP 30 1 tree1
+ TestSuite/Tests.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE DeriveGeneric #-} + +{- Tests.hs has a number of different custom data types. All of them implement 'Out' and 'Arbitrary'. +Properties are provided for each that specify that the output given by 'prettyStr' and that given +by 'show' should be identical except for the whitespace + +The different data types follow the same pattern of implementation and functions, so most of the +functions are only commented for the first data type -} + +import Text.PrettyPrint.GenericPretty +import Test.QuickCheck +import Control.Monad +import Data.Maybe +import Text.Printf + +-- used to make pretty printed and show output identical for comparing purposes +removeSpaces :: String -> String +removeSpaces [] = [] +removeSpaces (x:xs) + | x `elem` " \n" = removeSpaces xs + | otherwise = x : removeSpaces xs + +-- checks the output of a specific value +checkOutput :: (Out a, Show a) => a -> Bool +checkOutput a = removeSpaces (prettyStr a) == removeSpaces (show a) + +-- Finite State Machine Type +data FSM q = FSMCons ([q], Alphabet, q, [q], [Transition q]) deriving (Show, Generic) +type Alphabet = String +type Transition q = (q, Char, q) + +-- implement 'Out' so we can pretty print +instance (Out a) => Out (FSM a) + +--implementation needed for quickCheck generation of random values +instance Arbitrary a => Arbitrary (FSM a) where + arbitrary = liftM FSMCons arbitrary + +-- check wether 'Maybe Int' FSM's are outputed the same via prettyStr and show (modulo the whitespace) +checkFSM :: FSM (Maybe Int) -> FSM (Maybe Int) -> Bool +checkFSM _ a = removeSpaces (prettyStr a) == removeSpaces (show a) + +-- example of an FSM, you can check the output of this manually with 'checkOutput' +f :: FSM Int +f = FSMCons([0,1,2,3,4], + "ab", + 0, + [4], + [(0,'a',1), (0,'b',1), (0,'a',2), (0,'b',2), + (1,'b',4), (2,'a',3), (2,'b',3), (3,'b',4), + (4,'a',4), (4,'b',4)]) + +-- Binary Tree data type +data BinaryTree a = EmptyBTree | BNode a (BinaryTree a) (BinaryTree a) deriving (Show, Generic) +instance (Out a) => Out (BinaryTree a) + +instance (Arbitrary a) => Arbitrary (BinaryTree a) where + arbitrary = sized arbitTree + where + arbitTree 0 = return EmptyBTree + arbitTree n + | n>0 = oneof [return EmptyBTree, liftM3 BNode arbitrary subTree subTree] + | otherwise = error "tree size should never be < 0" + where + subTree = arbitTree (n `div` 2) + +checkBinaryTree :: BinaryTree Char -> BinaryTree Char -> Bool +checkBinaryTree _ a = removeSpaces (prettyStr a) == removeSpaces (show a) + +-- functions for the construction of BinaryTrees +singleton :: a -> BinaryTree a +singleton x = BNode x EmptyBTree EmptyBTree + +treeInsert :: (Ord a) => a -> BinaryTree a -> BinaryTree a +treeInsert x EmptyBTree = singleton x +treeInsert x (BNode a left right) + | x == a = BNode x left right + | x < a = BNode a (treeInsert x left) right + | x > a = BNode a left (treeInsert x right) + +nums :: [Int] +nums = [55555,99999,22222,77777,88888,11111,33333,44444,66666] + +-- mkBTree takes a list and creates a BinaryTree out of it +mkBTree :: (Ord a) => [a] -> BinaryTree a +mkBTree = foldr treeInsert EmptyBTree + +-- example BinaryTree +bt :: BinaryTree Int +bt = mkBTree nums + +-- Tree using record syntax +data RecordTree a = RNode {val :: a, children :: [RecordTree a]} deriving (Show, Generic) +instance (Out a) => Out (RecordTree a) + +instance (Arbitrary a) => Arbitrary (RecordTree a) where + arbitrary = sized arbitTree + where + arbitTree 0 = liftM2 RNode arbitrary (return []) + arbitTree n + | n>0 = liftM2 RNode arbitrary childList + | otherwise = error "tree size should never be < 0" + where + childList = resize (floor.sqrt.fromIntegral $ n) (listOf (arbitTree (n`div` 2)) ) + +checkRecordTree :: RecordTree String -> RecordTree String -> Bool +checkRecordTree _ a = removeSpaces (prettyStr a) == removeSpaces (show a) + +rt :: RecordTree Int +rt = RNode (-656565) [RNode 33344 [], RNode 98789 [RNode (-766444) [], RNode 454545 [], RNode 59996 []]] + +infixr 5 :*: +infixr 3 :+: +-- tree using infix notation +data InfixTree a = ILeaf a a | (InfixTree a) :*: (InfixTree a) | (InfixTree a) :+: (InfixTree a) + deriving (Show, Generic) +instance (Out a) => Out (InfixTree a) + +instance (Arbitrary a) => Arbitrary (InfixTree a) where + arbitrary = sized arbitTree + where + arbitTree 0 = liftM2 ILeaf arbitrary arbitrary + arbitTree n + | n>0 = oneof [ liftM2 (:*:) subTree subTree, liftM2 (:+:) subTree subTree] + | otherwise = error "tree size should never be < 0" + where + subTree = arbitTree (n `div` 2) + +nt :: InfixTree Int +nt = ILeaf 5454544 55 :*: (ILeaf 5375738 44 :+: ((ILeaf 699879 55 :*: ILeaf 2332323 66 :+: ILeaf 676765 77) + :*: ILeaf 99999 88) ) :+: ILeaf 555 666 + +checkInfixTree :: InfixTree (Either Int Char) -> InfixTree (Either Int Char) -> Bool +checkInfixTree _ a = removeSpaces (prettyStr a) == removeSpaces (show a) + +infixr 5 :^: +-- infix and record tree, also uses a second user defined type in it's definition, 'Wrap' +data InfixRecordTree a = IRLeaf (Wrap a) | (:^:) {left :: InfixRecordTree a, right :: InfixRecordTree a} + deriving (Show, Generic) +instance (Out a) => Out (InfixRecordTree a) + +instance (Arbitrary a) => Arbitrary (InfixRecordTree a) where + arbitrary = sized arbitTree + where + arbitTree 0 = liftM IRLeaf arbitrary + arbitTree n + | n>0 = liftM2 (:^:) subTree subTree + | otherwise = error "tree size should never be < 0" + where + subTree = arbitTree (n `div` 2) + +irt :: InfixRecordTree Int +irt = IRLeaf (Wrap 5454544) :^: (IRLeaf (Wrap (-5375738)) :^: ((IRLeaf (Wrap 699879) :^: + (IRLeaf (Wrap (-2332323)) :^: IRLeaf (Wrap 676765))) :^: IRLeaf (Wrap 99999))) + +checkInfixRecordTree :: InfixRecordTree Int -> InfixRecordTree Int -> Bool +checkInfixRecordTree _ a = removeSpaces (prettyStr a) == removeSpaces (show a) + +-- just a very simple user defined type that is used in IRTree +-- note, we could manually make 'Wrap' an instance of 'Outputable' instead of +-- deriving 'Out' and the code would still work, +-- but the output wouldn't be identical to show because of how 'Outputable' is implemented +data Wrap a = Wrap a deriving (Show, Generic) +instance Out a => Out (Wrap a) + +instance Arbitrary a => Arbitrary (Wrap a) where + arbitrary = liftM Wrap arbitrary + +allTests = [ ("FSM (Maybe Int)", quickCheck checkFSM), + ("BinaryTree (Char)", quickCheck checkBinaryTree), + ("RecordTree (String)", quickCheck checkRecordTree), + ("InfixTree (Either Int Char)", quickCheck checkInfixTree), + ("InfixRecordTree (Int)", quickCheck checkInfixRecordTree)] + +main = mapM_ (\(s,r) -> printf "%-30s: " s >> r) allTests
+ Text/PrettyPrint/GenericPretty.hs view
@@ -0,0 +1,354 @@+{-# LANGUAGE TypeOperators, FlexibleInstances, FlexibleContexts, DefaultSignatures, + OverlappingInstances, UndecidableInstances #-} + +{-| +GenericPretty is a haskell library that provides support for automatic +derivation of pretty printing functions on user defined data types. +The Outputable library is used underneath, the work is done over SDoc types. + +The output provided by the library functions is identical to that of Prelude.show, +except it has extra whitespace. + +For examples of usage please see the README file. -} + +module Text.PrettyPrint.GenericPretty(pp, prettyP, prettyStr, fullPP, outputTxt, outputStr, Generic, Out(..)) where + +import Data.List +import Outputable +import GHC.Generics +import Pretty (fullRender, Mode(..), TextDetails(..), Doc) +import FastString +import Data.Char + +-- | The class 'Out' is just a wrapper class for Outputable, which passes an extra parameter used to determine +-- when to wrap types up in parentheses +class Out a where + -- | 'out' is the equivalent of Prelude.showsPrec + -- it generates output identical to show, except for the extra whitespace + out :: Int -> a -> SDoc + -- default out method, converts the type into a sum of products and passes it on to the generic + -- pretty printing functions, finally it concatenates all of the SDoc's + default out :: (Generic a ,GOut (Rep a)) => Int -> a -> SDoc + out n x = sep $ out1 (from x) Pref n False + + -- | 'outList' mimics the behaviour of Prelude.showList + -- used mainly to output strings correctly, and not as lists of characters + outList :: Int -> [a] -> SDoc + outList n xs = brackets (fsep (punctuate comma (map (out n) xs))) + +-- user-defined types that directly implement Outputable are handled here +-- n marks wether the type needs to be surrounded by parens or not +instance (Outputable a) => Out a where + out n xs + | n > 0 = parens $ ppr xs + | otherwise = ppr xs + +instance Out a => Outputable a where + ppr = out 0 + +-- 'middle' return a list without it's first and last elements +-- except if the list has a single element, in which case it returns the list unchanged +middle :: [a] -> [a] +middle [] = [] +middle [x] = [x] +middle (x:xs) = init xs + +-- 'wrapParens' wraps the passed value in parens if the bool is true +-- we don't want a single paren to possibly take a whole line, so we concatenate them to the first +-- and last elements in the list, instead of just adding them to the list +wrapParens :: Bool -> [SDoc] -> [SDoc] +wrapParens _ [] = [] +wrapParens False s = s +wrapParens True s + | length s == 1 = [lparen <> head s <> rparen] + |otherwise = [lparen <> head s] ++ middle s ++ [last s <> rparen] + +-- The types of data we need to consider for product operator. Record, Prefix and Infix. +-- Tuples aren't considered since they're already instances of 'Out' and thus won't pass through that code. +data Type = Rec | Pref | Inf String + +--'GOut' is a helper class used to output the Sum-of-Products type, since it has kind *->*, +-- so can't be an instance of 'Out' +class GOut f where + -- |'out1' is the (*->*) kind equivalent of 'out' + out1 :: f x -- The sum of products representation of the user's custom type + -> Type -- The type of multiplication. Record, Prefix or Infix. + -> Int -- The operator precedence, determines wether to wrap stuff in parens. + -> Bool -- A flag, marks wether the constructor directly above was wrapped in parens. + -- Used to determine correct indentation + -> [SDoc] -- The result. Each SDoc could be on a newline, depending on available space. + -- |'isNullary' marks nullary constructors, so that we don't put parens around them + isNullary :: f x -> Bool + +-- if empty, output nothing, this is a null constructor +instance GOut U1 where + out1 _ _ _ _ = [empty] + isNullary _ = True + +-- ignore datatype meta-information +instance (GOut f, Datatype c) => GOut (M1 D c f) where + out1 (M1 a) = out1 a + isNullary (M1 a) = isNullary a + +-- if there is a selector, display it and it's value + appropriate white space +instance (GOut f, Selector c) => GOut (M1 S c f) where + out1 s@(M1 a) t d p + | selector == "" = out1 a t d p + | otherwise = (text selector <+> char '='):map (nest $ length selector + 3) (out1 a t 0 p) + where + selector = selName s + + isNullary (M1 a) = isNullary a + +-- constructor +-- here the real type and parens flag is set and propagated forward via t and n, the precedence factor is updated +instance (GOut f, Constructor c) => GOut (M1 C c f) where + out1 c@(M1 a) _ d p = + case fixity of + -- if prefix add the constructor name, nest the result and possibly put it in parens + Prefix -> wrapParens boolParens $ text name: makeMargins t boolParens (out1 a t 11 boolParens) + -- if infix possibly put in parens + Infix _ m -> wrapParens (d>m) $ out1 a t (m+1) (d>m) + where + boolParens = d>10 && (not $ isNullary a) + name = checkInfix $ conName c + fixity = conFixity c + -- get the type of the data, Record, Infix or Prefix. + t = if conIsRecord c then Rec else + case fixity of + Prefix -> Pref + Infix _ _ -> Inf (conName c) + + --add whitespace and possible braces for records + makeMargins :: Type -> Bool -> [SDoc] -> [SDoc] + makeMargins _ _ [] = [] + makeMargins Rec b s + | length s == 1 = [nest (length name + 1) (lbrace <> head s <> rbrace)] + | otherwise = nest (length name + 1) (lbrace <> head s) : + map (nest $ length name + 2) (middle s ++ [last s <> rbrace]) + makeMargins _ b s = map (nest $ length name + if b then 2 else 1) s + + -- check for infix operators that are acting like prefix ones due to records, put them in parens + checkInfix :: String -> String + checkInfix [] = [] + checkInfix (x:xs) + | fixity == Prefix && (isAlphaNum x || x == '_') = (x:xs) + | otherwise = "(" ++ (x:xs) ++ ")" + + isNullary (M1 a) = isNullary a + +-- ignore tagging, call out since these are concrete types +instance (Out f) => GOut (K1 t f) where + out1 (K1 a) _ d _ = [out d a] + isNullary _ = False + +-- just continue to the corresponding side of the OR +instance (GOut f, GOut g) => GOut (f :+: g) where + out1 (L1 a) t d p = out1 a t d p + out1 (R1 a) t d p = out1 a t d p + isNullary (L1 a) = isNullary a + isNullary (R1 a) = isNullary a + +-- output both sides of the product, possible separated by a comma or an infix operator +instance (GOut f, GOut g) => GOut (f :*: g) where + out1 (f :*: g) t@Rec d p = init pfn ++ [last pfn <> comma] ++ pgn + where + pfn = out1 f t d p + pgn = out1 g t d p + + -- if infix, nest the second value since it isn't nested in the constructor + out1 (f :*: g) t@(Inf s) d p = init pfn ++ [last pfn <+> text s] ++ checkIndent pgn + where + pfn = out1 f t d p + pgn = out1 g t d p + + -- if the second value of the :*: is in parens, nest it + -- needs to get the string representation of the first elements in the left and right SDoc lists + -- to be able to determine the correct indentation + checkIndent :: [SDoc] -> [SDoc] + checkIndent [] = [] + checkIndent m@(x:xs) + | parens == 0 = m + | otherwise = map (nest $ cons + 1 + parenSpace) m + where + parenSpace = if p then 1 else 0 + strG = showSDocOneLine x + strF = showSDocOneLine (head pfn) + parens = length $ takeWhile (== '(') strG + cons = length $ takeWhile( /= ' ') (dropWhile(== '(') strF) + + out1 (f :*: g) t@Pref n p = out1 f t n p ++ out1 g t n p + + isNullary _ = False + +-- | 'fullPP' is a fully customizable Pretty Printer. + +fullPP :: (Out a) => a -- ^The value to pretty print + -> PprStyle -- ^The Outputable library style to use /(default is defaultUserStyle)/ + -> Mode -- ^The 'Pretty' library style(mode) to use /(default is PageMode)/ + -> Int -- ^The maximum line length + -> Float -- ^The number of ribbons per line + -> (TextDetails -> b -> b) -- ^Function that handles the text conversion /(default is 'outputTxt')/ + -> b -- ^The end element of the result /( eg: "" or putChar('\n') )/ + -> b -- ^The pretty printed result +fullPP a pstyle mode len rib td end = fullRender mode len rib td end doc + where + doc = withPprStyleDoc pstyle (out 0 a) + +-- | 'outputTxt' transforms the text into strings and outputs it directly. +-- This is one example of a function that can handle the text conversion for 'fullPP'. +outputTxt :: TextDetails -> IO() -> IO() +outputTxt td act = do + putStr $ decode td + act + where + decode :: TextDetails -> String + decode (PStr s1) = unpackFS s1 + decode (LStr s1 _) = unpackLitString s1 + decode (Chr c) = [c] + decode (Str s) = s + +-- | 'outputStr' just leaves the text as a string. +-- Another example of a function that can handle the text conversion for 'fullPP'. +outputStr :: TextDetails -> String -> String +outputStr td str = decode td ++ str + where + decode :: TextDetails -> String + decode (PStr s1) = unpackFS s1 + decode (LStr s1 _) = unpackLitString s1 + decode (Chr c) = [c] + decode (Str s) = s + +-- | 'prettyStr' returns the result as a string. +-- The returned value is identical to one made by Prelude.show, except for the extra whitespace +prettyStr :: (Out a) => a -> String +prettyStr a = fullPP a defaultUserStyle PageMode 80 1.5 outputStr "" + +-- | 'prettyP' is a partly customizable Pretty Printer +-- It takes the line length and ribbons per line as parameters +prettyP :: (Out a) => Int -> Float -> a -> IO() +prettyP len rib a = fullPP a defaultUserStyle PageMode len rib outputTxt (putChar '\n') + +-- | 'pp' is the default Pretty Printer, +-- it uses a line length of 80 and 1.5 ribbons per line /(= 53 non-whitespace chars per line)/ +-- where ribbon is defined as the maximum length of text, excluding whitespace, on a single line +pp :: (Out a) => a -> IO() +pp = prettyP 80 1.5 + +-- define some instances of Out making sure to generate output identical to 'show' modulo the extra whitespace +instance Out Char where + out _ a = char '\'' <> (text.middle.show $ a) <> char '\'' + outList _ xs = text $ show xs + +instance Out Integer where + out n x + | n/=0 && x<0 = parens $ integer x + | otherwise = integer x + +instance Out a => Out [a] where + out = outList + +instance Out Bool where + out _ True = ptext (sLit "True") + out _ False = ptext (sLit "False") + +instance Out Int where + out n x + | n/=0 && x<0 = parens $ int x + | otherwise = int x + +instance Out a => Out (Maybe a) where + out n Nothing = ptext (sLit "Nothing") + out n (Just x) + | n/=0 = parens result + |otherwise = result + where + result = ptext (sLit "Just") <+> out 10 x + +instance (Out a, Out b) => Out (Either a b) where + out n (Left x) + | n/=0 = parens result + | otherwise = result + where + result = ptext (sLit "Left") <+> out 10 x + out n (Right y) + | n/=0 = parens result + | otherwise = result + where + result = ptext (sLit "Right") <+> out 10 y + +instance (Out a, Out b) => Out (a, b) where + out _ (a,b) = parens (sep [out 0 a <> comma, out 0 b]) + +instance (Out a, Out b, Out c) => Out (a, b, c) where + out _ (a,b,c) = parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c]) + +instance (Out a, Out b, Out c, Out d) => Out (a, b, c, d) where + out _ (a,b,c,d) = parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, out 0 d]) + +instance (Out a, Out b, Out c, Out d, Out e) => Out (a, b, c, d, e) where + out _ (a,b,c,d,e) = parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, out 0 d <> comma, out 0 e]) + +instance (Out a, Out b, Out c, Out d, Out e, Out f) + => Out (a, b, c, d, e, f) where + out _ (a, b, c, d, e, f) = + parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, + out 0 d <> comma, out 0 e <> comma, out 0 f]) + +instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g) + => Out (a, b, c, d, e, f, g) where + out _ (a, b, c, d, e, f, g) = + parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, + out 0 d <> comma, out 0 e <> comma, out 0 f <> comma, out 0 g]) + +instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h) + => Out (a, b, c, d, e, f, g, h) where + out _ (a, b, c, d, e, f, g, h) = + parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, + out 0 d <> comma, out 0 e <> comma, out 0 f <> comma, out 0 g <> comma, out 0 h]) + +instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h, Out i) + => Out (a, b, c, d, e, f, g, h, i) where + out _ (a, b, c, d, e, f, g, h, i) = + parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, out 0 d <> comma, + out 0 e <> comma, out 0 f <> comma, out 0 g <> comma, out 0 h <> comma, out 0 i]) + +instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h, Out i, Out j) + => Out (a, b, c, d, e, f, g, h, i, j) where + out _ (a, b, c, d, e, f, g, h, i, j) = + parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, out 0 d <> comma, + out 0 e <> comma, out 0 f <> comma, out 0 g <> comma, out 0 h <> comma, out 0 i <> comma, out 0 j]) + +instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h, Out i, Out j, Out k) + => Out (a, b, c, d, e, f, g, h, i, j, k) where + out _ (a, b, c, d, e, f, g, h, i, j, k) = + parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, out 0 d <> comma, out 0 e<> comma, + out 0 f <> comma, out 0 g <> comma, out 0 h <> comma, out 0 i <> comma, out 0 j <> comma, out 0 k]) + +instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h, Out i, Out j, Out k, Out l) + => Out (a, b, c, d, e, f, g, h, i, j, k, l) where + out _ (a, b, c, d, e, f, g, h, i, j, k, l) = + parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, out 0 d <> comma, out 0 e <> comma, + out 0 f <> comma, out 0 g <> comma, out 0 h <> comma, out 0 i <> comma, out 0 j <> comma, + out 0 k <> comma, out 0 l]) + +instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h, Out i, Out j, Out k, Out l, Out m) + => Out (a, b, c, d, e, f, g, h, i, j, k, l, m) where + out _ (a, b, c, d, e, f, g, h, i, j, k, l, m) = + parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, out 0 d <> comma, out 0 e <> comma, + out 0 f <> comma, out 0 g <> comma, out 0 h <> comma, out 0 i <> comma, out 0 j <> comma, + out 0 k <> comma, out 0 l <> comma, out 0 m]) + +instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h, Out i, Out j, Out k, Out l, Out m, Out n) + => Out (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where + out _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = + parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, out 0 d <> comma, out 0 e <> comma, + out 0 f <> comma, out 0 g <> comma, out 0 h <> comma, out 0 i <> comma, out 0 j <> comma, + out 0 k <> comma, out 0 l <> comma, out 0 m <> comma, out 0 n]) + +instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h, Out i, Out j, Out k, Out l, Out m, Out n, Out o) + => Out (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where + out _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = + parens (sep [out 0 a <> comma, out 0 b <> comma, out 0 c <> comma, out 0 d <> comma, out 0 e <> comma, + out 0 f <> comma, out 0 g <> comma, out 0 h <> comma, out 0 i <> comma, out 0 j <> comma, + out 0 k <> comma, out 0 l <> comma, out 0 m <> comma, out 0 n <> comma, out 0 o])