packages feed

shower (empty) → 0.1

raw patch · 9 files changed

+398/−0 lines, 9 filesdep +basedep +containersdep +directorysetup-changed

Dependencies added: base, containers, directory, filepath, megaparsec, pretty, process, shower, tasty, tasty-golden, temporary

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2018, Monadfix++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Monadfix nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ exe/Main.hs view
@@ -0,0 +1,11 @@+module Main where++import Shower (showerString)+import Control.Exception (evaluate)+import System.Exit (die)++main :: IO ()+main = do+  s <- getContents+  _ <- evaluate (length s) -- strict 'getContents'+  either die putStrLn $ showerString s
+ lib/Shower.hs view
@@ -0,0 +1,21 @@+module Shower+  ( shower,+    showerString+  ) where++import Data.Bifunctor (bimap)+import Text.Megaparsec (parse, errorBundlePretty, eof)+import Shower.Parser (pShower)+import Shower.Printer (showerRender)++shower :: Show a => a -> String+shower a =+  case showerString s of+    Left _ -> s+    Right s' -> s'+  where+    s = show a++showerString :: String -> Either String String+showerString s =+  bimap errorBundlePretty showerRender (parse (pShower <* eof) "" s)
+ lib/Shower/Class.hs view
@@ -0,0 +1,21 @@+module Shower.Class where++-- 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").+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)"+  showerStringLit :: String -> a+  -- '('+  showerCharLit :: String -> a+  -- variable names, numeric literals, etc+  showerAtom :: String -> a+  -- whitespace-separated+  showerSpace :: [a] -> a
+ lib/Shower/Parser.hs view
@@ -0,0 +1,83 @@+module Shower.Parser (pShower) where++import Data.Void+import Data.Char+import Text.Megaparsec+import Text.Megaparsec.Char++import Shower.Class++type Parser = Parsec Void String++pLexeme :: Parser a -> Parser a+pLexeme p = p <* space++pShower :: Shower a => Parser a+pShower = space *> pExpr++pExpr :: Shower a => Parser a+pExpr = showerSpace <$> some pPart++pPart :: Shower a => Parser a+pPart =+  pRecord <|>+  pList <|>+  pTuple <|>+  pStringLit <|>+  pCharLit <|>+  pAtom++pRecord :: Shower a => Parser a+pRecord = do+  _ <- pLexeme (char '{')+  fields <- pField `sepBy` pLexeme (char ',')+  _ <- pLexeme (char '}')+  return (showerRecord fields)++pField :: Shower a => Parser (a, a)+pField = do+  name <- pExpr+  _ <- pLexeme (char '=')+  value <- pExpr+  return (name, value)++pList :: Shower a => Parser a+pList = do+  _ <- pLexeme (char '[')+  elements <- pExpr `sepBy` pLexeme (char ',')+  _ <- pLexeme (char ']')+  return (showerList elements)++pTuple :: Shower a => Parser a+pTuple = do+  _ <- pLexeme (char '(')+  elements <- pExpr `sepBy` pLexeme (char ',')+  _ <- pLexeme (char ')')+  return (showerTuple elements)++pStringLit :: Shower a => Parser a+pStringLit =+  pLexeme $ do+    _ <- char '"'+    s <- manyTill pStringPart (char '"')+    return (showerStringLit (concat s))+  where+    pStringPart = string "\\\"" <|> ((:[]) <$> anySingle)++pCharLit :: Shower a => Parser a+pCharLit =+  pLexeme $ try $ do+    _ <- char '\''+    c <- string "\\'" <|> ((:[]) <$> anySingle)+    _ <- char '\''+    return (showerCharLit c)++pAtom :: Shower a => Parser a+pAtom =+  pLexeme $ do+    s <- some (satisfy atomChar)+    return (showerAtom s)+  where+    atomChar c =+      not (c `elem` "()[]{},=") &&+      not (isSpace c)
+ lib/Shower/Printer.hs view
@@ -0,0 +1,53 @@+module Shower.Printer where++import Data.Coerce+import qualified Text.PrettyPrint as PP++import Shower.Class++newtype ShowerDoc = SD PP.Doc++instance Shower ShowerDoc where+  showerRecord = coerce showerRecord'+  showerList = coerce showerList'+  showerTuple = coerce showerTuple'+  showerStringLit = coerce showerStringLit'+  showerCharLit = coerce showerCharLit'+  showerSpace = coerce showerSpace'+  showerAtom = coerce showerAtom'++showerRecord' :: [(PP.Doc, 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++showerList' :: [PP.Doc] -> PP.Doc+showerList' elements =+  PP.brackets (PP.nest 2 (showerElements elements))+  where+    showerElements = PP.sep . PP.punctuate PP.comma++showerTuple' :: [PP.Doc] -> PP.Doc+showerTuple' elements =+  PP.parens (PP.nest 2 (showerElements elements))+  where+    showerElements = PP.sep . PP.punctuate PP.comma++showerSpace' :: [PP.Doc] -> PP.Doc+showerSpace' (x:xs) = PP.hang x 2 (PP.sep xs)+showerSpace' xs = PP.sep xs++showerAtom' :: String -> PP.Doc+showerAtom' = PP.text++showerStringLit' :: String -> PP.Doc+showerStringLit' = PP.doubleQuotes . PP.text++showerCharLit' :: String -> PP.Doc+showerCharLit' = PP.quotes . PP.text++showerRender :: ShowerDoc -> String+showerRender (SD showerDoc) =+  PP.renderStyle PP.style{ PP.lineLength = 80 } showerDoc ++ "\n"
+ shower.cabal view
@@ -0,0 +1,58 @@+name: shower+version: 0.1+synopsis: Clean up the formatting of 'show' output+-- description:+license: BSD3+license-file: LICENSE+author: Vladislav Zavialov+maintainer: Monadfix <hi@monadfix.io>+category: Development+build-type: Simple+cabal-version: >=1.10++homepage: https://monadfix.io/shower+bug-reports: http://github.com/monadfix/shower/issues++source-repository head+  type: git+  location: git://github.com/monadfix/shower.git++library+  exposed-modules:+    Shower+    Shower.Printer+    Shower.Parser+    Shower.Class+  build-depends:+    base >=4.10 && <4.13,+    megaparsec,+    pretty+  hs-source-dirs: lib+  default-language: Haskell2010+  ghc-options: -Wall -O2++executable shower+  main-is: Main.hs+  build-depends:+    base >=4.10 && <4.13,+    shower+  hs-source-dirs: exe+  default-language: Haskell2010+  ghc-options: -Wall -O2++test-suite shower-tests+  main-is: Main.hs+  type: exitcode-stdio-1.0+  build-depends:+    base >=4.10 && <4.13,+    tasty,+    tasty-golden,+    containers,+    filepath,+    directory,+    process,+    temporary,+    shower+  hs-source-dirs: tests+  default-language: Haskell2010+  ghc-options: -Wall -Wno-missing-signatures
+ tests/Main.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE RecordWildCards #-}++module Main where++import Data.Set (Set)+import Data.Map (Map)+import qualified Data.Set as Set+import qualified Data.Map as Map+import Data.Foldable+import Data.Traversable+import Control.Monad++import Control.Exception++import System.Directory+import System.FilePath+import System.Process+import System.IO+import System.IO.Temp+import System.Exit++import Test.Tasty+import Test.Tasty.Golden.Advanced++import Shower++main :: IO ()+main = do+  inOutTests <- mkInOutTests+  defaultMain $+    testGroup "Shower" [inOutTests]++mkInOutTests :: IO TestTree+mkInOutTests = do+  currentDir <- getCurrentDirectory+  let inOutDir = currentDir </> "tests/in-out/"+  inOutFilePaths <- listDirectory inOutDir+  case zipInOutFilePaths (map (inOutDir </>) inOutFilePaths) of+    Left ZipInOutFail{..} -> do+      let+        reportPathSet xs msg =+          unless (Set.null xs) $ do+            putStrLn msg+            traverse_ (putStrLn . ("  "++)) xs+      reportPathSet ziofBadExtension "Bad extension, expected .in or .out:"+      reportPathSet ziofInWithoutOut "In-file has no accompanying out-file:"+      reportPathSet ziofOutWithoutIn "Out-file has no accompanying in-file:"+      exitFailure+    Right zippedPaths -> do+      testCases <- for (Map.toList zippedPaths) $+        \(testName, InOut inFilePath outFilePath) -> do+          let got = do+                inFile <- readFile inFilePath+                case showerString inFile of+                  Left parseError -> throwIO (ErrorCall parseError)+                  Right s -> pure s+          pure $ diffTest testName outFilePath got+      return (testGroup "in/out" testCases)++data ZipInOutFail =+  ZipInOutFail+    { ziofBadExtension :: Set FilePath,+      ziofInWithoutOut :: Set FilePath,+      ziofOutWithoutIn :: Set FilePath }++data InOut a = InOut a a++zipInOutFilePaths :: [FilePath] -> Either ZipInOutFail (Map TestName (InOut FilePath))+zipInOutFilePaths filePaths =+  let+    (badExt, inExt, outExt) = go ([], [], []) filePaths+    inWithoutOut = (Set.fromList . Map.elems) (inExt Map.\\ outExt)+    outWithoutIn = (Set.fromList . Map.elems) (outExt Map.\\ inExt)+    zippedPaths = Map.intersectionWith InOut inExt outExt+  in+    if+      Set.null badExt &&+      Set.null inWithoutOut &&+      Set.null outWithoutIn+    then+      Right zippedPaths+    else+      Left ZipInOutFail+        { ziofBadExtension = badExt,+          ziofInWithoutOut = inWithoutOut,+          ziofOutWithoutIn = outWithoutIn }+  where+    go (accBadExt, accInExt, accOutExt) [] =+      ( Set.fromList accBadExt,+        Map.fromList accInExt,+        Map.fromList accOutExt )+    go (accBadExt, accInExt, accOutExt) (p:ps) =+      let+        fileName = takeFileName p+        (name, ext) = splitExtensions fileName+      in+        case ext of+          ".in"  -> go (accBadExt, (name, p) : accInExt, accOutExt) ps+          ".out" -> go (accBadExt, accInExt, (name, p) : accOutExt) ps+          _ -> go (p:accBadExt, accInExt, accOutExt) ps++-- | Output differences between a file and a string using @git diff@.+diffTest+  :: TestName+  -> FilePath   -- ^ Expected ".out" file+  -> IO String  -- ^ Actual output+  -> TestTree+diffTest name ref got =+  goldenTest name (readFile ref) got cmp (writeFile ref)+  where+    template = takeFileName ref <.> "actual"+    diffParams = ["--no-index", "--color", "--word-diff-regex=."]+    cmp _ actual = withSystemTempFile template $ \tmpFile tmpHandle -> do+      hPutStr tmpHandle actual >> hFlush tmpHandle+      let diffProc = proc "git" (["diff"] ++ diffParams ++ [ref, tmpFile])+      (exitCode, out, _) <- readCreateProcessWithExitCode diffProc ""+      return $ case exitCode of+        ExitSuccess -> Nothing+        _ -> Just (unlines . drop 4 . lines $ out)  -- drop diff header