packages feed

shower 0.1 → 0.2

raw patch · 7 files changed

+176/−46 lines, 7 filesdep +QuickCheckdep +aesondep +tasty-quickcheck

Dependencies added: QuickCheck, aeson, tasty-quickcheck, text, unordered-containers, utf8-string, vector

Files

lib/Shower.hs view
@@ -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)
lib/Shower/Class.hs view
@@ -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 -}
lib/Shower/Parser.hs view
@@ -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)
lib/Shower/Printer.hs view
@@ -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"
shower.cabal view
@@ -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
tests/Main.hs view
@@ -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
+ tests/Property.hs view
@@ -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)