diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/portray-prettyprinter.cabal b/portray-prettyprinter.cabal --- a/portray-prettyprinter.cabal +++ b/portray-prettyprinter.cabal @@ -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 backend for along with derivable 'Pretty' instances for types with 'Portray' instances. . - This started out as a copy of + This started out as a fork of , 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 diff --git a/src/Data/Portray/Prettyprinter.hs b/src/Data/Portray/Prettyprinter.hs --- a/src/Data/Portray/Prettyprinter.hs +++ b/src/Data/Portray/Prettyprinter.hs @@ -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) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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