diff --git a/lib/Shower.hs b/lib/Shower.hs --- a/lib/Shower.hs +++ b/lib/Shower.hs @@ -1,5 +1,7 @@ +-- | Pretty-print 'Show' output and JSON. module Shower ( shower, + printer, showerString ) where @@ -8,6 +10,22 @@ import Shower.Parser (pShower) import Shower.Printer (showerRender) +-- | A drop-in replacement for @print@ that has nice layout. +-- Use it in GHCi with @-interactive-print=Shower.printer@: +-- +-- @ +-- ghci> :set -interactive-print=Shower.printer +-- ghci> ([1..15], ['a'..'z']) +-- ([1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15], +-- "abcdefghijklmnopqrstuvwxyz") +-- @ +-- +-- NB: does not handle infinite data structures at the moment. +printer :: Show a => a -> IO () +printer a = putStrLn (shower a) + +-- | A drop-in replacement for @show@ that has nice layout. +-- NB: does not handle infinite data structures at the moment. shower :: Show a => a -> String shower a = case showerString s of @@ -16,6 +34,7 @@ where s = show a +-- | Parse and pretty-print 'show' output or @JSON@. showerString :: String -> Either String String showerString s = bimap errorBundlePretty showerRender (parse (pShower <* eof) "" s) diff --git a/lib/Shower/Class.hs b/lib/Shower/Class.hs --- a/lib/Shower/Class.hs +++ b/lib/Shower/Class.hs @@ -1,21 +1,49 @@ +{- | + +This module defines the representation of data that the parser produces and the +pretty-printer consumes. + +-} module Shower.Class where --- A tagless final encoding for a result builder (ShowS, Doc, Html, etc). +-- | A tagless final encoding for a result builder (@ShowS@, @Doc@, @Html@, etc). -- -- Note that 'showerStringLit' and 'showerCharLit' take exact uninterpreted --- strings to avoid losing information (e.g. "\n" vs. "\10"). +-- strings to avoid losing information (e.g. @"\\n"@ vs. @"\\10"@). class Shower a where - -- { x = 24, y = 42 } - showerRecord :: [(a, a)] -> a - -- [1, 2, 3] - showerList :: [a] -> a - -- (1, 2, 3) - showerTuple :: [a] -> a - -- "hello, (world)" + -- | A record, @{ x = 24, y = 42 }@ or @{ "a": null, "b": 13 }@. + showerRecord :: [ShowerComma (a, ShowerFieldSep, a)] -> a + -- | A list, @[1, 2, 3]@. + showerList :: [ShowerComma a] -> a + -- | A tuple, @(1, 2, 3)@. + showerTuple :: [ShowerComma a] -> a + -- | A string literal, @"hello, (world)"@. showerStringLit :: String -> a - -- '(' + -- | A character literal, @'('@. showerCharLit :: String -> a - -- variable names, numeric literals, etc + -- | Variable names, numeric literals, and so on. showerAtom :: String -> a - -- whitespace-separated + -- | Whitespace-separated elements. showerSpace :: [a] -> a + +-- | A field separator used in records, either @\'=\'@ for Haskell records or +-- @\':\'@ for JSON. +data ShowerFieldSep = + ShowerFieldSepEquals {- ^ An equality sign, @\'=\'@ -} | + ShowerFieldSepColon {- ^ A colon, @\':\'@ -} + +{- | Either a comma or an element. + +For example, the tuple section @(,a,,b)@ is represented like this: + +@ +[ ShowerCommaSep, + ShowerCommaElement "a", + ShowerCommaSep, + ShowerCommaSep, + ShowerCommaElement "b" ] +@ +-} +data ShowerComma a = + ShowerCommaSep {- ^ A comma, @\',\'@ -} | + ShowerCommaElement a {- ^ An element -} diff --git a/lib/Shower/Parser.hs b/lib/Shower/Parser.hs --- a/lib/Shower/Parser.hs +++ b/lib/Shower/Parser.hs @@ -1,3 +1,4 @@ +-- | A @megaparsec@ implementation of a parser for 'Shower'. module Shower.Parser (pShower) where import Data.Void @@ -12,12 +13,18 @@ pLexeme :: Parser a -> Parser a pLexeme p = p <* space -pShower :: Shower a => Parser a +-- | Parser for 'Shower' expressions. +pShower :: Shower a => Parsec Void String a pShower = space *> pExpr pExpr :: Shower a => Parser a pExpr = showerSpace <$> some pPart +pCommaSep :: Parser a -> Parser [ShowerComma a] +pCommaSep p = many $ + ShowerCommaSep <$ pLexeme (char ',') <|> + ShowerCommaElement <$> p + pPart :: Shower a => Parser a pPart = pRecord <|> @@ -25,59 +32,67 @@ pTuple <|> pStringLit <|> pCharLit <|> - pAtom + pAtom "()[]{},=" pRecord :: Shower a => Parser a pRecord = do _ <- pLexeme (char '{') - fields <- pField `sepBy` pLexeme (char ',') + fields <- pCommaSep pField _ <- pLexeme (char '}') return (showerRecord fields) -pField :: Shower a => Parser (a, a) +pFieldName :: Shower a => Parser a +pFieldName = + pStringLit <|> + pAtom "()[]{},=:" + +pField :: Shower a => Parser (a, ShowerFieldSep, a) pField = do - name <- pExpr - _ <- pLexeme (char '=') + name <- pFieldName + sep <- pLexeme $ + ShowerFieldSepEquals <$ char '=' <|> + ShowerFieldSepColon <$ char ':' value <- pExpr - return (name, value) + return (name, sep, value) pList :: Shower a => Parser a pList = do _ <- pLexeme (char '[') - elements <- pExpr `sepBy` pLexeme (char ',') + elements <- pCommaSep pExpr _ <- pLexeme (char ']') return (showerList elements) pTuple :: Shower a => Parser a pTuple = do _ <- pLexeme (char '(') - elements <- pExpr `sepBy` pLexeme (char ',') + elements <- pCommaSep pExpr _ <- pLexeme (char ')') return (showerTuple elements) -pStringLit :: Shower a => Parser a -pStringLit = +pQuotedLit :: Char -> Parser String +pQuotedLit quote = pLexeme $ do - _ <- char '"' - s <- manyTill pStringPart (char '"') - return (showerStringLit (concat s)) + _ <- char quote + s <- manyTill pSymbol (char quote) + return (concat s) where - pStringPart = string "\\\"" <|> ((:[]) <$> anySingle) + pSymbol = + string ['\\', '\\'] <|> + string ['\\', quote] <|> + ((:[]) <$> anySingle) +pStringLit :: Shower a => Parser a +pStringLit = showerStringLit <$> pQuotedLit '"' + pCharLit :: Shower a => Parser a -pCharLit = - pLexeme $ try $ do - _ <- char '\'' - c <- string "\\'" <|> ((:[]) <$> anySingle) - _ <- char '\'' - return (showerCharLit c) +pCharLit = showerCharLit <$> pQuotedLit '\'' -pAtom :: Shower a => Parser a -pAtom = +pAtom :: Shower a => [Char] -> Parser a +pAtom disallowed = pLexeme $ do s <- some (satisfy atomChar) return (showerAtom s) where atomChar c = - not (c `elem` "()[]{},=") && + not (c `elem` disallowed) && not (isSpace c) diff --git a/lib/Shower/Printer.hs b/lib/Shower/Printer.hs --- a/lib/Shower/Printer.hs +++ b/lib/Shower/Printer.hs @@ -1,10 +1,12 @@ -module Shower.Printer where +-- | A @pretty@ implementation of a pretty-printer for 'Shower'. +module Shower.Printer (ShowerDoc(SD), showerRender) where import Data.Coerce import qualified Text.PrettyPrint as PP import Shower.Class +-- | A @pretty@ document, with a 'Shower' instance. newtype ShowerDoc = SD PP.Doc instance Shower ShowerDoc where @@ -16,24 +18,35 @@ showerSpace = coerce showerSpace' showerAtom = coerce showerAtom' -showerRecord' :: [(PP.Doc, PP.Doc)] -> PP.Doc +showerPunctuate :: (a -> PP.Doc) -> [ShowerComma a] -> [PP.Doc] +showerPunctuate showerElem = go + where + go [] = [] + go (ShowerCommaElement x : ShowerCommaSep : xs) = + (showerElem x PP.<> PP.char ',') : go xs + go (ShowerCommaElement x : xs) = showerElem x : go xs + go (ShowerCommaSep : xs) = PP.char ',' : go xs + +showerRecord' :: [ShowerComma (PP.Doc, ShowerFieldSep, PP.Doc)] -> PP.Doc showerRecord' fields = PP.braces (PP.nest 2 (showerFields fields)) where - showerFields = PP.sep . PP.punctuate PP.comma . map showerField - showerField (name, x) = PP.hang (name PP.<+> PP.equals) 2 x + showerFields = PP.sep . showerPunctuate showerField + showerField (name, sep, x) = PP.hang (ppSep name sep) 2 x + ppSep name ShowerFieldSepEquals = name PP.<+> PP.char '=' + ppSep name ShowerFieldSepColon = name PP.<> PP.char ':' -showerList' :: [PP.Doc] -> PP.Doc +showerList' :: [ShowerComma PP.Doc] -> PP.Doc showerList' elements = PP.brackets (PP.nest 2 (showerElements elements)) where - showerElements = PP.sep . PP.punctuate PP.comma + showerElements = PP.sep . showerPunctuate id -showerTuple' :: [PP.Doc] -> PP.Doc +showerTuple' :: [ShowerComma PP.Doc] -> PP.Doc showerTuple' elements = PP.parens (PP.nest 2 (showerElements elements)) where - showerElements = PP.sep . PP.punctuate PP.comma + showerElements = PP.sep . showerPunctuate id showerSpace' :: [PP.Doc] -> PP.Doc showerSpace' (x:xs) = PP.hang x 2 (PP.sep xs) @@ -48,6 +61,7 @@ showerCharLit' :: String -> PP.Doc showerCharLit' = PP.quotes . PP.text +-- | Render a @ShowerDoc@ with the default style. showerRender :: ShowerDoc -> String showerRender (SD showerDoc) = PP.renderStyle PP.style{ PP.lineLength = 80 } showerDoc ++ "\n" diff --git a/shower.cabal b/shower.cabal --- a/shower.cabal +++ b/shower.cabal @@ -1,5 +1,5 @@ name: shower -version: 0.1 +version: 0.2 synopsis: Clean up the formatting of 'show' output -- description: license: BSD3 @@ -42,16 +42,25 @@ test-suite shower-tests main-is: Main.hs + other-modules: + Property type: exitcode-stdio-1.0 build-depends: base >=4.10 && <4.13, + aeson, tasty, tasty-golden, + tasty-quickcheck, + QuickCheck, containers, + unordered-containers, + vector, + text, filepath, directory, process, temporary, + utf8-string, shower hs-source-dirs: tests default-language: Haskell2010 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -23,12 +23,17 @@ import Test.Tasty.Golden.Advanced import Shower +import Property (propertyTests) main :: IO () main = do inOutTests <- mkInOutTests defaultMain $ - testGroup "Shower" [inOutTests] + testGroup "Shower" [inOutTests, propertyTests] + +---------------------------------------------------------------------------- +-- Golden tests +---------------------------------------------------------------------------- mkInOutTests :: IO TestTree mkInOutTests = do diff --git a/tests/Property.hs b/tests/Property.hs new file mode 100644 --- /dev/null +++ b/tests/Property.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Property where + +import qualified Data.Text as Text +import qualified Data.Vector as Vector +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy.UTF8 as UTF8 + +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck + +import Shower + +-- | 'Aeson.Value' generator, stolen from @api-tools@. +genJSON :: Gen Aeson.Value +genJSON = sized $ \size -> oneof [ + Aeson.Object . HashMap.fromList <$> + resize (size `div` 2) (listOf ((,) <$> (Text.pack <$> arbitrary) <*> genJSON)), + Aeson.Array . Vector.fromList <$> resize (size `div` 2) (listOf genJSON), + Aeson.String . Text.pack <$> arbitrary, + Aeson.Number . fromInteger <$> arbitrary, + Aeson.Bool <$> arbitrary, + pure Aeson.Null ] + +-- | Test that formatting always works on JSON and never changes it. +prop_JSON :: Property +prop_JSON = forAll genJSON $ \original -> + let reformatted = + Aeson.eitherDecode . UTF8.fromString =<< + showerString (UTF8.toString (Aeson.encode original)) + in reformatted === Right original + +return [] + +-- | All property tests. +propertyTests :: TestTree +propertyTests = testProperties "" $(allProperties)