PPrinter 0.0.2 → 0.0.3
raw patch · 3 files changed
+131/−128 lines, 3 filesdep +QuickCheckdep +hspecdep +parsec
Dependencies added: QuickCheck, hspec, parsec
Files
- ChangeLog.md +5/−0
- PPrinter.cabal +8/−8
- Text/PPrinter.hs +118/−120
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for PPrinter++## 0.0.3 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
PPrinter.cabal view
@@ -6,17 +6,17 @@ -- The package version. See the Haskell package versioning policy (PVP) -- for standards guiding when and how versions should be incremented.--- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- https://wiki.haskell.org/Package_versioning_policy -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.0.2+version: 0.0.3 -- A short (one-line) description of the package.-synopsis: A derivable Haskell pretty printer.+synopsis: A generic derivable Haskell pretty printer -- A longer description of the package.-description: +description: A library that supports deriving of pretty printing functions on data types. .@@ -34,7 +34,7 @@ . The implementation of deriving part of API is based on that designed in the library: GenericPretty, the details are introduced here: - <https://hackage.haskell.org/package/GenericPretty> + <https://hackage.haskell.org/package/GenericPretty> -- The license under which the package is released. license: BSD3@@ -47,7 +47,7 @@ -- An email address to which users can send suggestions, bug reports, and -- patches.-maintainer: s1563190@inf.ed.ac.uk+maintainer: s1563190@sms.ed.ac.uk -- A copyright notice. -- copyright: @@ -58,7 +58,7 @@ -- Extra files to be distributed with the package, such as examples or a -- README.--- extra-source-files: +extra-source-files: ChangeLog.md -- Constraint on the version of Cabal needed to build this package. cabal-version: >=1.10@@ -75,7 +75,7 @@ other-extensions: TypeOperators, DeriveGeneric, FlexibleInstances, FlexibleContexts, DefaultSignatures -- Other library packages from which modules are imported.- build-depends: base >=4.8 && <4.9, containers >=0.5 && <0.6+ build-depends: base >=4.8 && <4.9, containers >=0.5 && <0.6, hspec >=2.2 && <2.3, QuickCheck >=2.8 && <2.9, parsec >=3.1 && <3.2 -- Directories containing source files. hs-source-dirs: ./
Text/PPrinter.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE TypeOperators, DeriveGeneric, FlexibleInstances, FlexibleContexts, DefaultSignatures #-}+{-# LANGUAGE TypeOperators, FlexibleInstances, FlexibleContexts, DefaultSignatures #-} ----------------------------------------------------------------------------- -- |--- Module : GHC.PPrinter+-- Module : Text.PPrinter -- Copyright : (c) The University of Edinburgh 2016 -- License : BSD-style (see the file LICENSE) --@@ -24,17 +24,18 @@ module Text.PPrinter ( Pretty(..),- + -- Instances for Pretty: (), Bool, Ordering, Int, Integer, Char, String, Float, Double- + -- Pretty support code- pprint, pshow,- (<>), nil, nest, text, line, group, parens,+ printer, printLen, fullPrinter,+ pprint, pshow, pretty,+ (<>), nil, nest, text, line, group, parens, layout, char, rep, Generic ) where -import Data.Map hiding (showTree, map, null)+import Data.Map hiding (showTree, map, null, foldr) import GHC.Generics import Data.List (null) import Data.Char@@ -63,8 +64,8 @@ nil = NIL x <> y = x :<> y x <+> y = x <> whiteSpace <> y-nest i x = NEST i x-text s = TEXT s+nest = NEST+text = TEXT line = LINE lpar = text "("@@ -74,7 +75,7 @@ parens s = lpar <> s <> rpar group x = flatten x :<|> x- + indent = 1 -- implementation@@ -122,14 +123,14 @@ data Type = Infixt String | Prefixt | Recordt class GPretty f where- + -- 'gpp' is the (*->*) kind equivalent of 'pp' gpp :: Type -- The type of fixity. Record, Infix or Prefix. -> Int -- The operator precedence -> Bool -- Flag that marks if the constructors was wrapped in parens- -> f a + -> f a -> [DOC] -- The result.- + -- 'nullary' marks nullary constructors nullary :: f x -> Bool @@ -154,23 +155,23 @@ where gppa = gpp t1 d flag a gppb = gpp t1 d flag b- + gpp t1@Prefixt d flag (a :*: b) = gppa ++ [line] ++ gppb where gppa = gpp t1 d flag a gppb = gpp t1 d flag b- + gpp t1@(Infixt s) d flag (a :*: b) = init gppa ++ [last gppa <+> text s] ++ addWhitespace gppb where gppa = gpp t1 d flag a gppb = gpp t1 d flag b- + -- add whitespace addWhitespace :: [DOC] -> [DOC] addWhitespace [] = [] addWhitespace s@(x:xs)- | flag = if flag then map (nest 1) ([line] ++ s) else ([line] ++ s)- | otherwise = map (nest $ white + 1 + (if flag then 1 else 0)) ([line] ++ s) + | flag = if flag then map (nest 1) (line : s) else line : s+ | otherwise = map (nest $ white + 1 + (if flag then 1 else 0)) (line : s) where len x = length (pretty oneLayout 1 x) sa = pretty oneLayout (len x) x@@ -190,31 +191,31 @@ -- data S : Tag for M1: record selector instance (GPretty f, Selector c) => GPretty (M1 S c f) where gpp t d b s@(M1 a)- | null selector = gpp t d b a + | null selector = gpp t d b a | otherwise = (text selector <+> char '=' <> whiteSpace) : map (nest $ length selector + 2) (gpp t 0 b a) where selector = selName s- + nullary (M1 x) = nullary x -- constructor, show prefix operators -- data C : Tag for M1: constructor instance (GPretty f, Constructor c) => GPretty (M1 C c f) where gpp _ d b c@(M1 a) =- case conFixity c of + case conFixity c of Prefix -> wrapParens checkIfWrap $ text (conName c) <> whiteSpace- : (addWhitespace checkIfWrap $ (wrapRecord (gpp t 11 b a))) -- always wrap parens+ : addWhitespace checkIfWrap (wrapRecord (gpp t 11 b a)) -- always wrap parens Infix _ l ->- wrapParens (d > l) $ (gpp t (l + 1) (d > l) a)+ wrapParens (d > l) $ gpp t (l + 1) (d > l) a where t = if conIsRecord c then Recordt else case conFixity c of Prefix -> Prefixt Infix _ _ -> Infixt (conName c)- - checkIfWrap = (not $ nullary a) && (d > 10)- ++ checkIfWrap = not (nullary a) && (d > 10)+ -- add whitespace addWhitespace :: Bool -- check if wrap parens -> [DOC]@@ -222,28 +223,26 @@ addWhitespace _ [] = [] addWhitespace b s | conIsRecord c = s | otherwise = map (nest $ length (conName c) + if b then 2 else 1) s- + -- add braces for record wrapRecord :: [DOC] -> [DOC] wrapRecord [] = [] wrapRecord s | conIsRecord c = wrapNest s | otherwise = s- where - wrapNest2 [] = [text "}"]- wrapNest2 (x:xs) = [nest (length (conName c) + 2) (x)] ++ (wrapNest2 xs)- wrapNest (x:xs) = [nest (length (conName c) + 1) (text "{" <> x)] ++ (wrapNest2 xs)- + where+ wrapNest2 = foldr (\x -> (++) [nest (length (conName c) + 2) x]) [text "}"]+ wrapNest (x:xs) = nest (length (conName c) + 1) (text "{" <> x) : wrapNest2 xs+ -- add Parens wrapParens :: Bool -- add parens or not- -> [DOC] -> [DOC]+ -> [DOC] wrapParens _ [] = [] wrapParens False s = s- wrapParens True (x:xs) = [lpar <> x] ++ wrapParens2 xs+ wrapParens True (x:xs) = lpar <> x : wrapParens2 xs where- wrapParens2 [] = [rpar]- wrapParens2 (x:xs) = x : wrapParens2 xs- + wrapParens2 = foldr (:) [rpar]+ nullary (M1 x) = nullary x -- | Conversion of values to pretty printable 'String's@@ -270,38 +269,38 @@ -- will produce the record-syntax form, with the fields given in the -- same order as the original declaration. --- + class Pretty a where -- | 'ppPrec' converts a value to a pretty printable DOC. -- ppPrec :: Int -- ^ the operator precedence of the enclosing context -> a -- ^ the value to be converted to a 'String'- -> DOC -- ^ the result + -> DOC -- ^ the result default ppPrec :: (Generic a, GPretty (Rep a)) => Int -> a -> DOC ppPrec n x = rep $ gpp Prefixt n False (from x)- + -- | 'pp' is the equivalent of 'Prelude.show'- -- + -- pp :: a -> DOC default pp :: (Generic a, GPretty (Rep a)) => a -> DOC pp x = rep $ gpp Prefixt 0 False (from x) - -- helper function for generating a DOC list + -- helper function for generating a DOC list genList :: [a] -> DOC genList [] = nil- genList (x:xs) = text "," <> + genList (x:xs) = text "," <> line <> whiteSpace <>- nest indent (pp x) <> + nest indent (pp x) <> genList xs- + -- | 'ppList' is the equivalent of 'Prelude.showList' -- ppList :: [a] -> DOC ppList [] = text "[]"- ppList (x:xs) = group $ - text "[" <> - nest indent (pp x) <> genList xs <> + ppList (x:xs) = group $+ text "[" <>+ nest indent (pp x) <> genList xs <> text "]" {-# MINIMAL ppPrec | pp #-} @@ -309,36 +308,36 @@ instance Pretty () where pp () = group $ text "()" ppPrec _ = pp- + instance Pretty Bool where pp b = text $ show b ppPrec _ = pp- + instance Pretty Ordering where pp o = text $ show o ppPrec _ = pp instance Pretty Int where- ppPrec n x - | n /= 0 && x < 0 = parens $ (text $ show x)+ ppPrec n x+ | n /= 0 && x < 0 = parens (text $ show x) | otherwise = text $ show x pp = ppPrec 0 instance Pretty Integer where- ppPrec n x - | n /= 0 && x < 0 = parens $ (text $ show x)+ ppPrec n x+ | n /= 0 && x < 0 = parens (text $ show x) | otherwise = text $ show x pp = ppPrec 0 instance Pretty Float where- ppPrec n x - | n /= 0 && x < 0 = parens $ (text $ show x)+ ppPrec n x+ | n /= 0 && x < 0 = parens (text $ show x) | otherwise = text $ show x pp = ppPrec 0 instance Pretty Double where- ppPrec n x - | n /= 0 && x < 0 = parens $ (text $ show x)+ ppPrec n x+ | n /= 0 && x < 0 = parens (text $ show x) | otherwise = text $ show x pp = ppPrec 0 @@ -354,101 +353,101 @@ ppPrec _ = pp instance (Pretty a, Pretty b) => Pretty (Map a b) where- pp m = group $ "fromList" <-> (pp $ toList m) + pp m = group $ "fromList" <-> pp (toList m) ppPrec _ = pp instance Pretty a => Pretty (Maybe a) where- ppPrec n Nothing = text "Nothing" - ppPrec n (Just x) + ppPrec n Nothing = text "Nothing"+ ppPrec n (Just x) | n /= 0 = parens s | otherwise = s- where + where s = "Just" <-> ppPrec 10 x pp = ppPrec 0- + instance (Pretty a, Pretty b) => Pretty (Either a b) where- ppPrec n (Left x) + ppPrec n (Left x) | n /= 0 = parens s | otherwise = s- where + where s = "Left" <-> ppPrec 10 x- ppPrec n (Right x) + ppPrec n (Right x) | n /= 0 = parens s | otherwise = s- where + where s = "Right" <-> ppPrec 10 x pp = ppPrec 0- + -- instances for the first few tuples instance (Pretty a, Pretty b) => Pretty (a, b) where pp (a, b) = group (parens $ sep [pp a <> comma, pp b])- ppPrec _ = pp - + ppPrec _ = pp+ instance (Pretty a, Pretty b, Pretty c) => Pretty (a, b, c) where pp (a, b, c) = group (parens $ sep [pp a <> comma, pp b <> comma, pp c])- ppPrec _ = pp + ppPrec _ = pp instance (Pretty a, Pretty b, Pretty c, Pretty d) => Pretty (a, b, c, d) where pp (a, b, c, d) = group (parens $ sep [pp a <> comma, pp b <> comma, pp c <> comma, pp d])- ppPrec _ = pp + ppPrec _ = pp instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e) => Pretty (a, b, c, d, e) where- pp (a, b, c, d, e) = group (parens $ sep [pp a <> comma, pp b <> comma, + pp (a, b, c, d, e) = group (parens $ sep [pp a <> comma, pp b <> comma, pp c <> comma, pp d <> comma, pp e])- ppPrec _ = pp - + ppPrec _ = pp+ instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f) => Pretty (a, b, c, d, e, f) where- pp (a, b, c, d, e, f) = group (parens $ sep [pp a <> comma, pp b <> comma, + pp (a, b, c, d, e, f) = group (parens $ sep [pp a <> comma, pp b <> comma, pp c <> comma, pp d <> comma, pp e <> comma, pp f]) ppPrec _ = pp- -instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g) ++instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g) => Pretty (a, b, c, d, e, f, g) where- pp (a, b, c, d, e, f, g) = group (parens $ sep [pp a <> comma, pp b <> comma, pp c <> comma, + pp (a, b, c, d, e, f, g) = group (parens $ sep [pp a <> comma, pp b <> comma, pp c <> comma, pp d <> comma, pp e <> comma, pp f <> comma, pp g])- ppPrec _ = pp - -instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g, Pretty h) + ppPrec _ = pp++instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g, Pretty h) => Pretty (a, b, c, d, e, f, g, h) where- pp (a, b, c, d, e, f, g, h) = group (parens $ sep [pp a <> comma, pp b <> comma, pp c <> comma, + pp (a, b, c, d, e, f, g, h) = group (parens $ sep [pp a <> comma, pp b <> comma, pp c <> comma, pp d <> comma, pp e <> comma, pp f <> comma, pp g <> comma, pp h])- ppPrec _ = pp - -instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g, Pretty h, Pretty i) + ppPrec _ = pp++instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g, Pretty h, Pretty i) => Pretty (a, b, c, d, e, f, g, h, i) where- pp (a, b, c, d, e, f, g, h, i) = group (parens $ sep [pp a <> comma, pp b <> comma, pp c <> comma, + pp (a, b, c, d, e, f, g, h, i) = group (parens $ sep [pp a <> comma, pp b <> comma, pp c <> comma, pp d <> comma, pp e <> comma, pp f <> comma, pp g <> comma, pp h <> comma, pp i])- ppPrec _ = pp + ppPrec _ = pp -instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g, Pretty h, Pretty i, - Pretty j) +instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g, Pretty h, Pretty i,+ Pretty j) => Pretty (a, b, c, d, e, f, g, h, i, j) where- pp (a, b, c, d, e, f, g, h, i, j) - = group (parens $ sep [pp a <> comma, pp b <> comma, pp c <> comma, pp d <> comma, - pp e <> comma, pp f <> comma, pp g <> comma, pp h <> comma, + pp (a, b, c, d, e, f, g, h, i, j)+ = group (parens $ sep [pp a <> comma, pp b <> comma, pp c <> comma, pp d <> comma,+ pp e <> comma, pp f <> comma, pp g <> comma, pp h <> comma, pp i <> comma, pp j])- ppPrec _ = pp - -instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g, Pretty h, Pretty i, - Pretty j, Pretty k) + ppPrec _ = pp++instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g, Pretty h, Pretty i,+ Pretty j, Pretty k) => Pretty (a, b, c, d, e, f, g, h, i, j, k) where- pp (a, b, c, d, e, f, g, h, i, j, k) - = group (parens $ sep [pp a <> comma, pp b <> comma, pp c <> comma, pp d <> comma, - pp e <> comma, pp f <> comma, pp g <> comma, pp h <> comma, + pp (a, b, c, d, e, f, g, h, i, j, k)+ = group (parens $ sep [pp a <> comma, pp b <> comma, pp c <> comma, pp d <> comma,+ pp e <> comma, pp f <> comma, pp g <> comma, pp h <> comma, pp i <> comma, pp j <> comma, pp k])- ppPrec _ = pp - -instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g, Pretty h, Pretty i, - Pretty j, Pretty k, Pretty l) + ppPrec _ = pp++instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g, Pretty h, Pretty i,+ Pretty j, Pretty k, Pretty l) => Pretty (a, b, c, d, e, f, g, h, i, j, k, l) where- pp (a, b, c, d, e, f, g, h, i, j, k, l) - = group (parens $ sep [pp a <> comma, pp b <> comma, pp c <> comma, pp d <> comma, - pp e <> comma, pp f <> comma, pp g <> comma, pp h <> comma, + pp (a, b, c, d, e, f, g, h, i, j, k, l)+ = group (parens $ sep [pp a <> comma, pp b <> comma, pp c <> comma, pp d <> comma,+ pp e <> comma, pp f <> comma, pp g <> comma, pp h <> comma, pp i <> comma, pp j <> comma, pp k <> comma, pp l]) ppPrec _ = pp @@ -462,7 +461,7 @@ -- helper functions for instance Pretty Pair and List -- generate n spaces-text' :: Int -> [Char]+text' :: Int -> String text' n | n == 0 = "" | otherwise = " " ++ text' (n - 1) @@ -473,19 +472,19 @@ -- helper function for reproducing the [DOC] to DOC rep :: [DOC] -> DOC rep [] = nil-rep (x:xs) = group $ (Prelude.foldl (<>) nil (x:xs))+rep (x:xs) = group $ Prelude.foldl (<>) nil (x:xs) sep :: [DOC] -> DOC sep [] = nil-sep (x:xs) = nest indent (x)+sep (x:xs) = nest indent x <> foldr1 (\l r -> l <> nil <> r) (map (\x -> nest indent (line <> x)) xs) x <-> y = text x <+> nest (length x + 1) y -pretty :: (Doc -> [Char]) -> Int -> DOC -> String+pretty :: (Doc -> String) -> Int -> DOC -> String pretty f w x = f (best w 0 x) -pshow :: Pretty a => (Doc -> [Char]) -> Int -> a -> String+pshow :: Pretty a => (Doc -> String) -> Int -> a -> String pshow f w x = pretty f w (pp x <> line) pprint :: Pretty a => Int -> a -> IO()@@ -495,31 +494,30 @@ -- Pretty Printer ------------------------------------------------------------- -data Mode = PageMode | NonIndentMode | OneLineMode+data Mode = DefaultMode | OneLineMode -- | A rendering style data Style = Style { mode :: Mode, -- ^ The redering mode lineLen :: Int -- ^ Length of line }- + styleMode :: Style -> Mode styleMode (Style mode length) = mode styleLen :: Style -> Int styleLen (Style mode length) = length- + -- | The default 'Style' style :: Style-style = Style {mode = PageMode, lineLen = 40}+style = Style {mode = DefaultMode, lineLen = 40} render :: Show a => Pretty a => a -> String fullRender :: Show a => Pretty a =>- Mode + Mode -> Int -> a -> String-fullRender PageMode w x = pshow layout w x-fullRender NonIndentMode _ x = show x+fullRender DefaultMode w x = pshow layout w x fullRender OneLineMode w x = pshow oneLayout w x -- use default style@@ -529,7 +527,7 @@ printer x = putStr (render x) printLen :: Show a => Pretty a => Int -> a -> IO()-printLen x = pprint x+printLen = pprint -- | The default Pretty Printer fullPrinter :: Show a => Pretty a => Style -> a -> IO()