portray-prettyprinter 0.1.0 → 0.2.0

raw patch · 4 files changed

+559/−113 lines, 4 filesdep +QuickCheckdep +prettyprinter-ansi-terminaldep +test-framework-quickcheck2dep ~portraydep ~prettyprinterPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, prettyprinter-ansi-terminal, test-framework-quickcheck2

Dependency ranges changed: portray, prettyprinter

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• portray-prettyprinter.cabal +19/−10
• src/Data/Portray/Prettyprinter.hs +370/−57
• test/Main.hs +162/−46

@@ -1,3 +1,11 @@ # 0.1.0  Initial version.++# 0.2.0++* Update to portray-0.2.0.+* Add colorized pretty-printing for `pp` and `ppd`.+* Fix records/lists/tuples putting initial elements on their own lines.+* Flow string literals onto multiple lines, preferring to break after `\n`s.+* Support configurable string escaping, to allow printing Unicode in strings.

@@ -4,24 +4,29 @@ -- -- see: https://github.com/sol/hpack ----- hash: c09be156b143855f336e4a1cb5847e88d29f06163780223de49dd8ec74711e3d+-- hash: 9a1c9decccd042e10d029755324f91da86d55e74574de17e95f313f00dd9a59b  name:           portray-prettyprinter-version:        0.1.0+version:        0.2.0 synopsis:       A portray backend using the prettyprinter package. description:    This provides a                 <https://hackage.haskell.org/package/prettyprinter prettyprinter> backend for                 <https://hackage.haskell.org/package/portray portray> along with derivable                 'Pretty' instances for types with 'Portray' instances.                 .-                This started out as a copy of+                This started out as a fork of                 <https://hackage.haskell.org/package/portray-pretty portray-pretty>, and is                 still very similar.  However, @prettyprinter@ gives more flexibility to                 documents at the cost of requiring more behavior to be specified explicitly.-                As such, some formats can be nicer with the @prettyprinter@ backend, but as-                of the initial release, this backend is less mature and hasn't been used in-                practice, so there are likely more formatting bugs.  Please do file bugs on-                the GitHub issue tracker if you find anything that seems obviously wrong!+                As such, some formats are nicer with the @prettyprinter@ backend,+                configurable syntax highlighting is supported, and unicode escaping is+                configurable.  However, this backend is less mature and hasn't been used as+                much in practice, so there are likely more formatting bugs than in+                @portray-pretty@.  Please do file bugs on the GitHub issue tracker if you+                find anything that seems obviously wrong!+                .+                Try using 'pp' as the print function in GHCi:+                @:set -interactive-print=Data.Portray.Prettyprinter.pp@! category:       Text homepage:       https://github.com/google/hs-portray#readme bug-reports:    https://github.com/google/hs-portray/issues@@ -48,9 +53,10 @@       src   build-depends:       base >=4.12 && <4.16-    , portray >=0.1 && <0.2+    , portray >=0.2 && <0.3     , portray-diff >=0.1 && <0.2-    , prettyprinter+    , prettyprinter >=1.7 && <1.8+    , prettyprinter-ansi-terminal >=1.1.2 && <1.2     , text >=0.1 && <1.3   default-language: Haskell2010 @@ -63,12 +69,15 @@       test   build-depends:       HUnit+    , QuickCheck     , base >=4.12 && <4.16     , portray     , portray-diff >=0.1 && <0.2     , portray-prettyprinter-    , prettyprinter+    , prettyprinter >=1.7 && <1.8+    , prettyprinter-ansi-terminal >=1.1.2 && <1.2     , test-framework     , test-framework-hunit+    , test-framework-quickcheck2     , text >=0.1 && <1.3   default-language: Haskell2010

@@ -37,6 +37,11 @@ -- example = 'showPortrayal' (MyRecord 2 ...) -- @ --+-- This usage provides colorized pretty-printing by default with 'pp'.  Note if+-- you don't like the default choice of colors or don't want colors at all, you+-- can roll your own 'pp' function with 'portray', 'toDocAssocPrec' and your+-- @prettyprinter@ rendering backend of choice.+-- -- The second usage is to use @portray@'s generic deriving to provide derived -- 'Pretty' instances, in a codebase that uses 'Pretty' as the preferred -- typeclass for pretty-printable values.  With this usage, things you want to@@ -69,6 +74,10 @@ --   deriving Portray via Wrapped Generic MyRecord -- @ --+-- Since the 'Pretty' class requires a universally-quantified annotation type,+-- its instances cannot provide any annotations.  As such, this usage cannot+-- provide automatic colorization.+-- -- This module also exports the underlying rendering functionality in a variety -- of forms for more esoteric uses. @@ -85,46 +94,66 @@          , showDiff, ppd            -- * DerivingVia wrapper          , WrappedPortray(..)-           -- * Rendering Functions+           -- * Rendering+           -- ** Configuration+         , Config, defaultConfig+           -- *** Escape Sequences+         , setShouldEscapeChar, escapeNonASCII, escapeSpecialOnly+           -- ** Colorization+         , SyntaxClass(..), LitKind(..)+         , defaultStyling, subtleStyling, noStyling            -- ** With Associativity          , DocAssocPrec, toDocAssocPrecF, toDocAssocPrec-           -- ** With Precedence-         , portrayalToDocPrecF, portrayalToDocPrec            -- ** Convenience Functions          , portrayalToDoc-         , prettyShowPortrayal+         , styleShowPortrayal, prettyShowPortrayal, basicShowPortrayal          ) where +import Data.Char (isAscii, isDigit, isPrint)+import Data.Function ((&)) import Data.Functor ((<&>)) import Data.Text (Text)+import qualified Data.Text as T import qualified Data.Text.IO as T (putStrLn)+import GHC.Show (showLitChar)  import Prettyprinter (Doc, Pretty(..))+import qualified Prettyprinter.Render.Terminal as A -- for ANSI import qualified Prettyprinter as P-import qualified Prettyprinter.Render.Text as R  import Data.Portray          ( Assoc(..), Infixity(..), FactorPortrayal(..)+         , Ident(..), IdentKind(..)          , Portray, Portrayal(..), PortrayalF(..)          , cata, portray          ) import Data.Portray.Diff (Diff(..))  -- | Pretty-print a value to stdout using its 'Portray' instance.+--+-- This uses ANSI color codes, so take care not to use it in contexts where it+-- might output to something other than a terminal. pp :: Portray a => a -> IO ()-pp = T.putStrLn . showPortrayal+pp = T.putStrLn . prettyShowPortrayal . portray  -- | Pretty-print a value using its 'Portray' instance.+--+-- This uses no ANSI terminal escape codes and escapes all non-ASCII characters. showPortrayal :: Portray a => a -> Text-showPortrayal = prettyShowPortrayal . portray+showPortrayal = basicShowPortrayal . portray  -- | Pretty-print a diff between two values to stdout using a 'Diff' instance.+--+-- This uses ANSI color codes, so take care not to use it in contexts where it+-- might output to something other than a terminal. ppd :: Diff a => a -> a -> IO ()-ppd x = T.putStrLn . showDiff x+ppd x = T.putStrLn . maybe "_" prettyShowPortrayal . diff x  -- | Pretty-print a diff between two values using a 'Diff' instance.+--+-- This uses no ANSI terminal escape codes and escapes all non-ASCII characters. showDiff :: Diff a => a -> a -> Text-showDiff x = maybe "_" prettyShowPortrayal . diff x+showDiff x = maybe "_" basicShowPortrayal . diff x  -- | A 'Doc' that varies according to associativity and precedence context. type DocAssocPrec ann = Assoc -> Rational -> Doc ann@@ -140,13 +169,115 @@   | ctx == assoc = ctx   | otherwise = AssocNope +-- | The particular kind of literal represented by a 'Literal'.+data LitKind = IntLit | RatLit | CharLit | StrLit++-- | The kind of syntactic element represented by an annotated 'Doc'.+data SyntaxClass+  = Identifier IdentKind+    -- ^ Identifiers, whether alphanumeric names or operators.+  | Literal LitKind+    -- ^ Literals, including integers, floats/rationals, chars, and strings.+  | EscapeSequence+    -- ^ Escaped characters in strings and char literals.+  | Keyword+    -- ^ Alphanumeric keywords, e.g. @case@.+  | Bracket+    -- ^ Matched pairs of symbols that denote nesting, e.g. parens.+  | Separator+    -- ^ Syntactic separators/terminators, e.g. @,@ and @;@.+  | Structural+    -- ^ Other fixed syntactic symbols, e.g. @::@, @\@@, @->@, @\\@.++-- | A fairly arbitrary colorization style based on what looked good to me.+--+-- To use a custom color mapping, define it the same way this function is+-- defined, then use it as an argument to 'styleShowPortrayal'.+-- Consider also wrapping that up into a custom 'pp' function for use at the+-- REPL or even as the interactive print function.+defaultStyling :: SyntaxClass -> Maybe A.AnsiStyle+defaultStyling = Just . \case+  Identifier k -> case k of+    OpConIdent -> A.color A.Magenta+    OpIdent -> A.colorDull A.Yellow+    ConIdent -> mempty+    VarIdent -> mempty+  Literal k -> case k of+    StrLit -> A.colorDull A.Blue+    _      -> A.colorDull A.Cyan+  EscapeSequence -> A.colorDull A.Red+  Keyword -> A.colorDull A.Green+  Bracket -> mempty+  Separator -> mempty+  Structural -> A.colorDull A.Green++-- | A subtler style that colorizes only operators (blue) and literals (cyan).+subtleStyling :: SyntaxClass -> Maybe A.AnsiStyle+subtleStyling = Just . \case+  Identifier k -> case k of+    OpConIdent -> A.colorDull A.Blue+    OpIdent -> A.colorDull A.Blue+    _ -> mempty+  Literal _ -> A.colorDull A.Cyan+  EscapeSequence -> A.colorDull A.Cyan+  _ -> mempty++-- | Disable all syntax highlighting.+noStyling :: SyntaxClass -> Maybe A.AnsiStyle+noStyling = const Nothing++-- | An escape-sequence predicate to escape any non-ASCII character.+escapeNonASCII :: Char -> Bool+escapeNonASCII = not . isAscii++-- | An escape-sequence predicate to escape as little as possible.+escapeSpecialOnly :: Char -> Bool+escapeSpecialOnly = const False++-- | Configuration for the conversion to 'Doc'.+--+-- Includes the following:+--+-- * 'setShouldEscapeChar', a function determining whether an escapable+-- character should be escaped in a string or character literal.  Unprintable+-- characters, backslashes, and the relevant quote for the current literal type+-- are always escaped, and anything that wouldn't be escaped by 'Show' is never+-- escaped.+--+-- For forwards-compatibility reasons, the field selectors and constructor of+-- this type are hidden; use the provided setters to build a config.  For+-- example:+--+-- @+-- config =+--   defaultConfig+--     & setShouldEscapeChar (const True) -- Escape everything we can.+-- @+data Config = Config+  { _shouldEscapeChar :: Char -> Bool+  }++-- | Set the predicate for whether to escape a given character; see 'Config'.+setShouldEscapeChar :: (Char -> Bool) -> Config -> Config+setShouldEscapeChar f _ = Config f++-- | A sensible default configuration to build on.+--+-- Uses 'escapeNonASCII'.+defaultConfig :: Config+defaultConfig = Config escapeNonASCII+ -- | Convert a 'Portrayal' to a 'Doc'.-portrayalToDoc :: Portrayal -> Doc ann-portrayalToDoc t = portrayalToDocPrec t (-1)+portrayalToDoc :: Config -> Portrayal -> Doc SyntaxClass+portrayalToDoc cfg t = toDocAssocPrec cfg t AssocNope (-1) +parens :: Doc SyntaxClass -> Doc SyntaxClass+parens d =+  P.annotate Bracket (char '(') <> d <> P.annotate Bracket (char ')')+ -- Conditionally wrap a document in parentheses.-maybeParens :: Bool -> Doc ann -> Doc ann-maybeParens = \case True -> P.parens; False -> id+maybeParens :: Bool -> Doc SyntaxClass -> Doc SyntaxClass+maybeParens = \case True -> parens; False -> id  -- Convert Text to a document; 'pretty' specialized to 'Text'. text :: Text -> Doc ann@@ -156,34 +287,206 @@ char :: Char -> Doc ann char = pretty +ppInfix :: Ident -> Doc SyntaxClass+ppInfix (Ident k nm) = case k of+  OpConIdent -> nmDoc+  OpIdent -> nmDoc+  VarIdent -> wrappedNm+  ConIdent -> wrappedNm+ where+  backquote = P.annotate Structural (char '`')+  nmDoc = P.annotate (Identifier k) (text nm)+  wrappedNm = backquote <> nmDoc <> backquote++ppPrefix :: Ident -> Doc SyntaxClass+ppPrefix (Ident k nm) = case k of+  OpConIdent -> wrappedNm+  OpIdent -> wrappedNm+  VarIdent -> nmDoc+  ConIdent -> nmDoc+ where+  nmDoc = P.annotate (Identifier k) (text nm)+  wrappedNm = parens nmDoc+ ppBinop-  :: Text+  :: Ident   -> Infixity-  -> DocAssocPrec ann -> DocAssocPrec ann -> DocAssocPrec ann+  -> DocAssocPrec SyntaxClass+  -> DocAssocPrec SyntaxClass+  -> DocAssocPrec SyntaxClass ppBinop nm fx@(Infixity assoc opPrec) x y lr p =   maybeParens (not $ fixityCompatible fx lr p) $ P.nest 2 $ P.sep-    [ x (matchCtx AssocL assoc) opPrec P.<+> text nm+    [ x (matchCtx AssocL assoc) opPrec P.<+> ppInfix nm     , y (matchCtx AssocR assoc) opPrec     ]  ppBulletList-  :: Doc ann -- ^ Open brace,  e.g. {  [  {  (-  -> Doc ann -- ^ Separator,   e.g. ;  ,  ,  ,-  -> Doc ann -- ^ Close brace, e.g. }  ]  }  )-  -> [Doc ann]-  -> Doc ann-ppBulletList opener _         closer []         = opener <> closer-ppBulletList opener separator closer (doc:docs) =-  P.group $-    P.concatWith (\x y -> x <> P.group (P.line' <> y))-      (opener <> P.flatAlt " " "" <> doc :-        zipWith (P.<+>) (repeat separator) docs) <>-    P.line' <> closer+  :: Doc SyntaxClass -- ^ Open brace,  e.g. {  [  {  (+  -> Doc SyntaxClass -- ^ Separator,   e.g. ;  ,  ,  ,+  -> Doc SyntaxClass -- ^ Close brace, e.g. }  ]  }  )+  -> [Doc SyntaxClass]+  -> Doc SyntaxClass+ppBulletList o s c = \case+  []         -> opener <> closer+  (doc:docs) ->+    P.group $+      foldl01+        (\x y -> x <> P.group (P.line' <> y))+        id+        mempty+        (opener <> P.flatAlt " " "" <> doc :+          zipWith (P.<+>) (repeat separator) docs) <>+      P.line' <> closer+ where+  opener = P.annotate Bracket o+  separator = P.annotate Separator s+  closer = P.annotate Bracket c +foldl01 :: (b -> a -> b) -> (a -> b) -> b -> [a] -> b+foldl01 f g z = \case+  [] -> z+  (x:xs) -> foldl f (g x) xs++-- 'T.words' coalesces adjacent spaces, so it's not suitable for use in+-- 'ppStrLit'; roll our own that preserves the whitespace between words.+wordsSep :: Text -> [(Text, Text)]+wordsSep "" = []+wordsSep s =+  let isWhitespace = (`elem` [' ', '\t'])+      (word, rest) = T.break isWhitespace s+      (sep, rest') = T.span isWhitespace rest+  in  (word, sep) : wordsSep rest'++-- 'T.lines' also fails to distinguish trailing newlines... ugh.+linesSep :: Text -> [Text]+linesSep "" = []+linesSep s0 = go s0+ where+  go s =+    let (line, rest) = T.break (== '\n') s+    in  line : if T.null rest then [] else go (T.tail rest)++-- Returns True for characters that must always be escaped regardless of+-- configuration; this is unprintable characters and backlashes.+charAlwaysEscaped :: Char -> Bool+charAlwaysEscaped c = not (isPrint c) || c == '\\'++shouldEscapeChar :: Config -> Char -> Bool+shouldEscapeChar cfg c = charAlwaysEscaped c || _shouldEscapeChar cfg c++showLitEscapesChar :: Char -> Bool+showLitEscapesChar c = [c] /= showLitChar c ""++litCharIsEscaped :: Config -> Char -> Bool+litCharIsEscaped cfg = \case+  '\'' -> True+  c    -> showLitEscapesChar c && shouldEscapeChar cfg c++strCharIsEscaped :: Config -> Char -> Bool+strCharIsEscaped cfg = \case+  '"' -> True+  c   -> showLitEscapesChar c && shouldEscapeChar cfg c++-- Between a numeric escape and a digit, or between \SO and H, we need a \& to+-- terminate the escape; detect whether we're in one of those cases.+needsEmptyEscape :: Config -> Char -> Char -> Bool+needsEmptyEscape cfg c0 c1 =+  strCharIsEscaped cfg c0 &&+  case showLitChar c0 "" of+    "\\SO" -> c1 == 'H'+    ('\\' : c : _) -> isDigit c && isDigit c1+    _ -> False++escapeChar :: Config -> Char -> Text+escapeChar cfg c+  | shouldEscapeChar cfg c = T.pack (showLitChar c "")+  | otherwise              = T.singleton c++escapeLitChar :: Config -> Char -> Text+escapeLitChar cfg = \case+  '\'' -> "\\'"+  c -> escapeChar cfg c++escapeStrChar :: Config -> Char -> Text+escapeStrChar cfg = \case+  '"' -> "\\\""+  c -> escapeChar cfg c++ppStrLit :: Config -> Text -> Doc SyntaxClass+ppStrLit cfg unescaped =+  P.annotate (Literal StrLit) $+  P.group $ -- Prefer putting the whole thing on this line whenever possible.+  P.enclose "\"" "\"" $+  -- Then prefer breaking on newlines when the next line doesn't fit.+  foldl01+    (\x l ->+      x <> P.group (P.flatAlt (nl <> backslashBreak <> l) (nl <> l)))+    id+    mempty+    (ppLine <$> escapedLinesOfWords)+ where+  nl = P.annotate EscapeSequence "\\n"++  ppWord :: Text -> Doc SyntaxClass+  ppWord "" = mempty+  ppWord w =+    let (toEscape, rest) = T.span (strCharIsEscaped cfg) w+        (plain, rest') = T.break (strCharIsEscaped cfg) rest+        sep =+          -- Do we need to insert a \& to separate a numeric escape from a+          -- following digit?+          if not (T.null toEscape) &&+               not (T.null plain) &&+               needsEmptyEscape cfg (T.last toEscape) (T.head plain)+             then "\\&"+             else mempty+        escaped = pretty (T.concatMap (escapeStrChar cfg) toEscape) <> sep+    in  P.annotate EscapeSequence escaped <> text plain <> ppWord rest'++  escapedLinesOfWords :: [[(Doc SyntaxClass, Doc SyntaxClass)]]+  escapedLinesOfWords =+    map+        (\ (w, ws) -> (ppWord w, ppWhitespace ws)) .+      wordsSep <$>+    linesSep unescaped++  ppWhitespace :: Text -> Doc SyntaxClass+  ppWhitespace =+    P.annotate EscapeSequence .+    text . T.concatMap (escapeStrChar cfg)++  ppLine :: [(Doc SyntaxClass, Doc SyntaxClass)] -> Doc SyntaxClass+  ppLine ws =+    -- Finally, break at word boundaries if the next word doesn't fit.+    P.group $ uncurry (<>) $ foldl01+      (\(line, space) (w, space') ->+        ( line <> P.group (P.flatAlt (space <> backslashBreak) space <> w)+        , space'+        ))+      id+      mempty+      ws++  backslashBreak = P.annotate EscapeSequence $ "\\" <> P.line' <> "\\"+ -- | Render one layer of 'PortrayalF' to 'DocAssocPrec'.-toDocAssocPrecF :: PortrayalF (DocAssocPrec ann) -> DocAssocPrec ann-toDocAssocPrecF = \case-  AtomF txt -> \_ _ -> text txt+toDocAssocPrecF+  :: Config+  -> PortrayalF (DocAssocPrec SyntaxClass)+  -> DocAssocPrec SyntaxClass+toDocAssocPrecF cfg = \case+  NameF nm -> \_ _ -> ppPrefix nm+  LitIntF x -> \_ _ -> P.annotate (Literal IntLit) $ pretty x+  LitRatF x -> \_ _ ->+    P.annotate (Literal RatLit) $ pretty (fromRational x :: Double)+  LitStrF x -> \_ _ -> ppStrLit cfg x+  LitCharF x -> \_ _ ->+    -- Likewise Char+    P.annotate (Literal CharLit) $+    P.enclose "'" "'" $+    (if litCharIsEscaped cfg x then P.annotate EscapeSequence else id) $+    text $ escapeLitChar cfg x+  OpaqueF txt -> \_ _ -> text txt   ApplyF fn [] -> \_ _ -> fn AssocL 10   ApplyF fn xs -> \lr p ->     maybeParens (not $ fixityCompatible (Infixity AssocL 10) lr p) $@@ -197,10 +500,10 @@   LambdaCaseF xs -> \_ p ->     maybeParens (p >= 10) $       P.nest 2 $ P.sep-        [ "\\case"+        [ P.annotate Structural "\\" <> P.annotate Keyword "case"         , ppBulletList "{" ";" "}"             [ P.nest 2 $ P.sep $-                [ pat AssocNope 0 P.<+> "->"+                [ pat AssocNope 0 P.<+> P.annotate Structural "->"                 , val AssocNope 0                 ]             | (pat, val) <- xs@@ -211,48 +514,57 @@     _  -> P.nest 2 $ P.sep       [ con AssocNope 10       , ppBulletList "{" "," "}"-          [ P.nest 2 $ P.sep-              [ text sel P.<+> "="+          [ P.nest 4 $ P.sep+              [ ppPrefix sel P.<+> P.annotate Structural "="               , val AssocNope 0               ]           | FactorPortrayal sel val <- sels           ]       ]   TyAppF val ty -> \_ _ ->-    P.nest 2 $ P.sep [val AssocNope 10, "@" <> ty AssocNope 10]+    P.nest 2 $ P.sep+      [ val AssocNope 10+      , P.annotate Structural "@" <> ty AssocNope 10+      ]   TySigF val ty -> \_ p -> maybeParens (p >= 0) $-    P.nest 2 $ P.sep [val AssocNope 0, "::" P.<+> ty AssocNope 0]+    P.nest 2 $ P.sep+      [ val AssocNope 0+      , P.annotate Structural "::" P.<+> ty AssocNope 0+      ]   QuotF nm content -> \_ _ ->     P.nest 2 $ P.sep-      [ char '[' <> text nm <> char '|'+      [ P.annotate Structural "[" <>+          P.annotate (Identifier VarIdent) (text nm) <>+          P.annotate Structural "|"       , content AssocNope (-1)-      , "|]"+      , P.annotate Structural "|]"       ]   UnlinesF ls -> \_ _ -> P.vcat (ls <&> \l -> l AssocNope (-1))   NestF n x -> \_ _ -> P.nest n (x AssocNope (-1)) -toDocPrec :: DocAssocPrec ann -> Rational -> Doc ann-toDocPrec dap = dap AssocNope . subtract 1---- | Render a 'PortrayalF' to a 'Doc'.-portrayalToDocPrecF-  :: PortrayalF (DocAssocPrec ann) -> Rational -> Doc ann-portrayalToDocPrecF = toDocPrec . toDocAssocPrecF- -- | Render a 'Portrayal' to a 'Doc' with support for operator associativity.-toDocAssocPrec :: Portrayal -> DocAssocPrec ann-toDocAssocPrec = cata toDocAssocPrecF . unPortrayal+toDocAssocPrec :: Config -> Portrayal -> DocAssocPrec SyntaxClass+toDocAssocPrec cfg = cata (toDocAssocPrecF cfg) . unPortrayal --- | Render a 'Portrayal' to a 'Doc' with only operator precedence.-portrayalToDocPrec :: Portrayal -> Rational -> Doc ann-portrayalToDocPrec = toDocPrec . toDocAssocPrec+-- | Convenience function for rendering a 'Portrayal' to a 'Text'.+basicShowPortrayal :: Portrayal -> Text+basicShowPortrayal = styleShowPortrayal defaultConfig (const mempty) --- | Convenience function for rendering a 'Portrayal' to a 'String'.+-- | Convenience function for rendering a 'Portrayal' to colorized 'Text'. prettyShowPortrayal :: Portrayal -> Text-prettyShowPortrayal p =-  R.renderStrict $ P.layoutPretty P.defaultLayoutOptions $-  toDocAssocPrec p AssocNope (-1)+prettyShowPortrayal =+  styleShowPortrayal+    (defaultConfig & setShouldEscapeChar escapeSpecialOnly)+    defaultStyling +-- | Convenience function for rendering a 'Portrayal' to stylized 'Text'.+styleShowPortrayal+  :: Config -> (SyntaxClass -> Maybe A.AnsiStyle) -> Portrayal -> Text+styleShowPortrayal cfg style p =+  A.renderStrict $ P.alterAnnotationsS style $+  P.layoutPretty P.defaultLayoutOptions $+  toDocAssocPrec cfg p AssocNope (-1)+ -- | A newtype providing a 'Pretty' instance via 'Portray', for @DerivingVia@. -- -- Sadly we can't use @Wrapped@ since it would be an orphan instance.  Oh well.@@ -263,4 +575,5 @@  -- | Provide an instance for 'Pretty' by way of 'Portray'. instance Portray a => Pretty (WrappedPortray a) where-  pretty x = portrayalToDocPrec (portray $ unWrappedPortray x) 0+  pretty x =+    P.unAnnotate $ portrayalToDoc defaultConfig (portray $ unWrappedPortray x)

@@ -15,80 +15,150 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-}  module Main where +import Data.Function ((&))+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Read (readLitChar)+import GHC.Show (showLitChar)++import qualified Prettyprinter as P+import qualified Prettyprinter.Render.Text as R import Test.Framework (defaultMain, testGroup) import Test.Framework.Providers.HUnit (testCase)+import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit ((@?=))+import Test.QuickCheck ((===), Property)  import Data.Portray import Data.Portray.Prettyprinter +-- 'read' doesn't implement this feature of Haskell string literals, so strip+-- it out ourselves.+stripEscapedWhitespace :: String -> String+stripEscapedWhitespace = \case+  [] -> []+  '\\' : c : rest+    | c `elem` [' ', '\t', '\n'] ->+        stripEscapedWhitespace $ tail $ dropWhile (/= '\\') rest+  -- showLitChar doesn't have to escape '"', but we do.+  ('\\' : '"' : rest) -> '\\' : '"' : stripEscapedWhitespace rest+  ('\\' : s) | ((c, rest):_) <- readLitChar ('\\' : s) ->+        showLitChar c (stripEscapedWhitespace rest)+  c:rest -> c : stripEscapedWhitespace rest++showPortrayalCfg :: Portray a => Config -> a -> Text+showPortrayalCfg cfg x =+  R.renderStrict $ P.layoutPretty P.defaultLayoutOptions $+  toDocAssocPrec cfg (portray x) AssocNope (-1)++propTextRoundTrips :: Config -> String -> Property+propTextRoundTrips cfg t =+  t ===+    read (stripEscapedWhitespace $ T.unpack $ showPortrayalCfg cfg $ T.pack t)++propStringRoundTrips :: Config -> String -> Property+propStringRoundTrips cfg t =+  t === read (stripEscapedWhitespace $ T.unpack $ showPortrayalCfg cfg t)++propCharRoundTrips :: Config -> Char -> Property+propCharRoundTrips cfg c = c === read (T.unpack $ showPortrayalCfg cfg c)+ main :: IO () main = defaultMain   [ testGroup "Atom"-      [ testCase "()" $ prettyShowPortrayal "()" @?= "()"-      , testCase "2" $ prettyShowPortrayal "2" @?= "2"+      [ testCase "()" $ basicShowPortrayal (Tuple []) @?= "()"+      , testCase "2" $ basicShowPortrayal (LitInt 2) @?= "2"       ]    , testGroup "Apply"       [ testCase "nullary" $-          prettyShowPortrayal (Apply "Nothing" []) @?= "Nothing"+          basicShowPortrayal (Apply (Name "Nothing") []) @?= "Nothing"       , testCase "nullary 2" $-          prettyShowPortrayal (Apply "id" [Apply "Nothing" []]) @?= "id Nothing"+          basicShowPortrayal+              (Apply (Name "id") [Apply (Name "Nothing") []]) @?=+            "id Nothing"       , testCase "unary" $-          prettyShowPortrayal (Apply "Just" ["2"]) @?= "Just 2"+          basicShowPortrayal (Apply (Name "Just") [LitInt 2]) @?= "Just 2"       , testCase "parens" $-          prettyShowPortrayal (Apply "Just" [Apply "Just" ["2"]]) @?=+          basicShowPortrayal+              (Apply (Name "Just") [Apply (Name "Just") [LitInt 2]]) @?=             "Just (Just 2)"       , testCase "binary" $-          prettyShowPortrayal (Apply "These" ["2", "4"]) @?=+          basicShowPortrayal (Apply (Name "These") [LitInt 2, LitInt 4]) @?=             "These 2 4"       , testCase "nested" $-          prettyShowPortrayal (Apply (Apply "These" ["2"]) ["4"]) @?=+          basicShowPortrayal+              (Apply (Apply (Name "These") [LitInt 2]) [LitInt 4]) @?=             "These 2 4"       ]    , testGroup "Binop"       [ testCase "operator" $-          prettyShowPortrayal (Binop ":|" (infixr_ 5) "5" (List [])) @?=+          basicShowPortrayal+              (Binop ":|" (infixr_ 5) (LitInt 5) (List [])) @?=             "5 :| []"        , testCase "con" $-          prettyShowPortrayal (Binop "`InfixCon`" (infixl_ 9) "2" "True") @?=+          basicShowPortrayal+              (Binop+                (Ident ConIdent "InfixCon")+                (infixl_ 9)+                (LitInt 2)+                (Name "True")) @?=             "2 `InfixCon` True"        , testCase "nest prec" $-          prettyShowPortrayal-              (Binop "+" (infixl_ 6) (Binop "*" (infixl_ 7) "2" "4") "6") @?=+          basicShowPortrayal+              (Binop+                "+"+                (infixl_ 6)+                (Binop "*" (infixl_ 7) (LitInt 2) (LitInt 4))+                (LitInt 6)) @?=             "2 * 4 + 6"        , testCase "nest anti-prec" $-          prettyShowPortrayal-              (Binop "*" (infixl_ 7) (Binop "+" (infixl_ 6) "2" "4") "6") @?=+          basicShowPortrayal+              (Binop+                "*"+                (infixl_ 7)+                (Binop "+" (infixl_ 6) (LitInt 2) (LitInt 4))+                (LitInt 6)) @?=             "(2 + 4) * 6"        , testCase "nest assoc" $-          prettyShowPortrayal-              (Binop "+" (infixl_ 6) (Binop "+" (infixl_ 6) "2" "4") "6") @?=+          basicShowPortrayal+              (Binop+                "+"+                (infixl_ 6)+                (Binop "+" (infixl_ 6) (LitInt 2) (LitInt 4))+                (LitInt 6)) @?=             "2 + 4 + 6"        , testCase "nest anti-assoc" $-          prettyShowPortrayal-              (Binop "+" (infixl_ 6) "2" (Binop "+" (infixl_ 6) "4" "6")) @?=+          basicShowPortrayal+              (Binop+                "+"+                (infixl_ 6)+                (LitInt 2)+                (Binop "+" (infixl_ 6) (LitInt 4) (LitInt 6))) @?=             "2 + (4 + 6)"       ]    , testGroup "Tuple"       [ testCase "pair" $-          prettyShowPortrayal (Tuple ["2", "4"]) @?= "(2, 4)"+          basicShowPortrayal (Tuple [LitInt 2, LitInt 4]) @?= "(2, 4)"       , testCase "triple" $-          prettyShowPortrayal (Tuple ["2", "4", "6"]) @?= "(2, 4, 6)"+          basicShowPortrayal (Tuple [LitInt 2, LitInt 4, LitInt 6]) @?=+            "(2, 4, 6)"       , testCase "line-break" $-          prettyShowPortrayal (Tuple ["222", strAtom (replicate 80 '2')]) @?=+          basicShowPortrayal+              (Tuple [strAtom "222", strAtom (replicate 80 '2')]) @?=             "( 222\n\             \, 2222222222222222222222222222222222222222222222222222222222222\             \2222222222222222222\n\@@ -96,48 +166,59 @@       ]    , testGroup "List"-      [ testCase "empty" $ prettyShowPortrayal (List []) @?= "[]"-      , testCase "singleton" $ prettyShowPortrayal (List ["2"]) @?= "[2]"+      [ testCase "empty" $ basicShowPortrayal (List []) @?= "[]"+      , testCase "singleton" $ basicShowPortrayal (List [LitInt 2]) @?=+          "[2]"       ]    , testGroup "LambdaCase"-      [ testCase "empty" $ prettyShowPortrayal (LambdaCase []) @?= "\\case {}"+      [ testCase "empty" $ basicShowPortrayal (LambdaCase []) @?= "\\case {}"       , testCase "singleton" $-          prettyShowPortrayal (LambdaCase [("()", "2")]) @?=+          basicShowPortrayal (LambdaCase [(Tuple [], LitInt 2)]) @?=             "\\case {() -> 2}"       , testCase "two" $-          prettyShowPortrayal (LambdaCase [("True", "2"), ("False", "4")]) @?=+          basicShowPortrayal+              (LambdaCase+                [(Name "True", LitInt 2), (Name "False", LitInt 4)]) @?=             "\\case {True -> 2; False -> 4}"       , testCase "line-break" $-          prettyShowPortrayal+          basicShowPortrayal               (LambdaCase-                [ ("True", strAtom (replicate 40 '2'))-                , ("False", strAtom (replicate 40 '4'))+                [ (Name "True", strAtom (replicate 40 '2'))+                , (Name "False", strAtom (replicate 40 '4'))                 ]) @?=             "\\case\n\             \  { True -> 2222222222222222222222222222222222222222\n\             \  ; False -> 4444444444444444444444444444444444444444\n\             \  }"       , testCase "no-parens" $-          prettyShowPortrayal-              (LambdaCase [(Apply "Just" ["2"], Apply "Just" ["4"])]) @?=+          basicShowPortrayal+              (LambdaCase+                [( Apply (Name "Just") [LitInt 2]+                 , Apply (Name "Just") [LitInt 4]+                 )]) @?=             "\\case {Just 2 -> Just 4}"       ]    , testGroup "Record"-      [ testCase "empty" $ prettyShowPortrayal (Record "Nothing" []) @?=+      [ testCase "empty" $ basicShowPortrayal (Record (Name "Nothing") []) @?=           "Nothing"       , testCase "singleton" $-            prettyShowPortrayal (Record "Just" [FactorPortrayal "it" "2"]) @?=+            basicShowPortrayal+              (Record+                (Name "Just")+                [FactorPortrayal "it" (LitInt 2)]) @?=           "Just {it = 2}"       , testCase "two" $-            prettyShowPortrayal-              (Record "These"-                [FactorPortrayal "l" "2", FactorPortrayal "r" "4"]) @?=+            basicShowPortrayal+              (Record (Name "These")+                [ FactorPortrayal "l" (LitInt 2)+                , FactorPortrayal "r" (LitInt 4)+                ]) @?=           "These {l = 2, r = 4}"       , testCase "line-break" $-            prettyShowPortrayal-              (Record "These"+            basicShowPortrayal+              (Record (Name "These")                 [ FactorPortrayal "l" (portray @[Int] [0..10])                 , FactorPortrayal "r" (portray @[Int] [0..10])                 ]) @?=@@ -145,16 +226,29 @@           \  { l = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]\n\           \  , r = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]\n\           \  }"+      , testCase "break-equals" $+          basicShowPortrayal+              (Record (Name "These")+                [ FactorPortrayal+                    "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"+                    (Name "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")+                ]) @?=+            "These\n\+            \  { aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa =\n\+            \      aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\n\+            \  }"       ]    , testGroup "TyApp"       [ testCase "con" $-          prettyShowPortrayal (TyApp "typeRep" "Int") @?= "typeRep @Int"+          basicShowPortrayal (TyApp (Name "typeRep") (Name "Int")) @?=+            "typeRep @Int"       , testCase "parens" $-          prettyShowPortrayal (TyApp "typeRep" (Apply "Maybe" ["Int"])) @?=+          basicShowPortrayal+              (TyApp (Name "typeRep") (Apply (Name "Maybe") [Name "Int"])) @?=             "typeRep @(Maybe Int)"       , testCase "line-break" $-          prettyShowPortrayal+          basicShowPortrayal               (TyApp                 (strAtom $ replicate 50 'a')                 (strAtom $ replicate 50 'a')) @?=@@ -163,20 +257,42 @@       ]    , testGroup "TySig"-      [ testCase "con" $ prettyShowPortrayal (TySig "2" "Int") @?= "2 :: Int"+      [ testCase "con" $ basicShowPortrayal (TySig (LitInt 2) (Name "Int")) @?=+          "2 :: Int"       , testCase "no-parens" $-          prettyShowPortrayal-              (TySig (Apply "Just" ["2"]) (Apply "Maybe" ["Int"])) @?=+          basicShowPortrayal+              (TySig+                (Apply (Name "Just") [LitInt 2])+                (Apply (Name "Maybe") [Name "Int"])) @?=             "Just 2 :: Maybe Int"       , testCase "line-break" $-          prettyShowPortrayal+          basicShowPortrayal               (TySig                 (strAtom $ replicate 50 'a')                 (strAtom $ replicate 50 'a')) @?=             "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\n\             \  :: aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"       , testCase "parens" $-          prettyShowPortrayal (Apply "Just" [TySig "2" "Int"]) @?=+          basicShowPortrayal+              (Apply (Name "Just") [TySig (LitInt 2) (Name "Int")]) @?=             "Just (2 :: Int)"       ]++  , testGroup "StrLit"+      [ testProperty "Text round-trips ascii"+          (propTextRoundTrips defaultConfig)+      , testProperty "String round-trips ascii"+          (propStringRoundTrips defaultConfig)+      , testProperty "Char round-trips ascii"+          (propCharRoundTrips defaultConfig)++      , testProperty "Text round-trips unicode"+          (propTextRoundTrips unicodeConfig)+      , testProperty "String round-trips unicode"+          (propStringRoundTrips unicodeConfig)+      , testProperty "Char round-trips unicode"+          (propCharRoundTrips unicodeConfig)+      ]   ]+ where+  unicodeConfig = defaultConfig & setShouldEscapeChar escapeSpecialOnly