diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,12 @@ Version history. +# 0.1 Rainy Summer edition released 2023-08-07 + +- Flag `--verbose` now also displays locations of whitespace violations + ([#7](https://github.com/agda/fix-whitespace/issues/7), contributed by Artem Pelenitsyn). +- Tested with GHC 8.0.2 - 9.8.1-alpha1. + ## 0.0.11 Santa Clause edition released 2022-12-06 - Delete trailing tabs even when `--tab=0` diff --git a/FixWhitespace.hs b/FixWhitespace.hs --- a/FixWhitespace.hs +++ b/FixWhitespace.hs @@ -1,50 +1,42 @@ -- | Program to enforce a whitespace policy. +{-# LANGUAGE OverloadedStrings #-} + module Main where -import Control.Monad -import Control.Exception (IOException, handle) +import Control.Monad ( unless, when ) -import Data.Char as Char -import Data.List.Extra (nubOrd) -import Data.Text (Text) -import Data.Version (showVersion) -import qualified Data.Text as Text -import qualified Data.Text.IO as Text -- Strict IO. +import Data.List.Extra ( nubOrd ) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text {- Strict IO -} +import Data.Version ( showVersion ) -import System.Directory (getCurrentDirectory, doesFileExist) -import System.Environment -import System.Exit --- import System.FilePath --- import System.FilePattern -import System.FilePattern.Directory (getDirectoryFiles, getDirectoryFilesIgnore) -import System.IO -import System.Console.GetOpt +import System.Console.GetOpt ( OptDescr(Option), ArgDescr(NoArg, ReqArg), ArgOrder(Permute), getOpt, usageInfo ) +import System.Directory ( getCurrentDirectory, doesFileExist ) +import System.Environment ( getArgs, getProgName ) +import System.Exit ( die, exitFailure, exitSuccess ) +import System.FilePattern.Directory ( getDirectoryFiles, getDirectoryFilesIgnore ) +import System.IO ( IOMode(WriteMode), hPutStr, hPutStrLn, hSetEncoding, stderr, utf8, withFile ) -import Text.Read (readMaybe) +import Text.Read ( readMaybe ) -import ParseConfig -import qualified Paths_fix_whitespace as PFW (version) +import Data.Text.FixWhitespace ( CheckResult(CheckOK, CheckViolation, CheckIOError), checkFile, displayLineError + , TabSize, Verbose, defaultTabSize ) +import ParseConfig ( Config(Config), parseConfig ) +import qualified Paths_fix_whitespace as PFW ( version ) + -- | Default configuration file. defaultConfigFile :: String defaultConfigFile = "fix-whitespace.yaml" --- | Default tab size. - -defaultTabSize :: String -defaultTabSize = "8" - -- Modes. data Mode = Fix -- ^ Fix whitespace issues. | Check -- ^ Check if there are any whitespace issues. deriving (Show, Eq) -type Verbose = Bool -type TabSize = Int - data Options = Options { optVerbose :: Verbose -- ^ Display the location of a file being checked or not. @@ -66,7 +58,7 @@ , optVersion = False , optMode = Fix , optConfig = defaultConfigFile - , optTabSize = defaultTabSize + , optTabSize = show defaultTabSize } options :: [OptDescr (Options -> Options)] @@ -74,16 +66,19 @@ [ Option ['h'] ["help"] (NoArg (\opts -> opts { optHelp = True })) "Show this help information." - , Option [] ["version"] + , Option ['V'] ["version"] (NoArg (\opts -> opts { optVersion = True })) "Show the program's version." , Option ['v'] ["verbose"] (NoArg (\opts -> opts { optVerbose = True })) - "Show files as they are being checked." + (unlines + [ "Show files as they are being checked." + , "Display location of detected whitespace violations." + ]) , Option ['t'] ["tab"] (ReqArg (\ts opts -> opts { optTabSize = ts }) "TABSIZE") (unlines - [ "Expand tab characters to TABSIZE (default: " ++ defaultTabSize ++ ") many spaces." + [ "Expand tab characters to TABSIZE (default: " ++ show defaultTabSize ++ ") many spaces." , "Keep tabs if 0 is given as TABSIZE." ]) , Option [] ["config"] @@ -122,7 +117,7 @@ , " * Removes trailing whitespace." , " * Removes trailing lines containing nothing but whitespace." , " * Ensures that the file ends in a newline character." - , " * Convert tabs to TABSIZE (default: " ++ defaultTabSize ++ ") spaces, unless TABSIZE is set to 0." + , " * Convert tabs to TABSIZE (default: " ++ show defaultTabSize ++ ") spaces, unless TABSIZE is set to 0." , "" , "for files specified in [FILES] or" , "" @@ -209,18 +204,15 @@ fix :: Mode -> Verbose -> TabSize -> FilePath -> IO Bool fix mode verbose tabSize f = - checkFile tabSize f >>= \case + checkFile tabSize verbose f >>= \case CheckOK -> do when verbose $ putStrLn $ "[ Checked ] " ++ f return False - CheckViolation s -> do - hPutStrLn stderr $ - "[ Violation " ++ - (if mode == Fix then "fixed" else "detected") ++ - " ] " ++ f + CheckViolation s vs -> do + hPutStrLn stderr (msg vs) when (mode == Fix) $ withFile f WriteMode $ \h -> do hSetEncoding h utf8 @@ -232,61 +224,12 @@ "[ Read error ] " ++ f return False --- | Result of checking a file against the whitespace policy. - -data CheckResult - = CheckOK - -- ^ The file satifies the policy. - | CheckViolation Text - -- ^ The file violates the policy, a fix is returned. - | CheckIOError IOException - -- ^ An I/O error occurred while accessing the file. - -- (E.g., the file is not UTF8 encoded.) - --- | Check a file against the whitespace policy, --- returning a fix if violations occurred. - -checkFile :: TabSize -> FilePath -> IO CheckResult -checkFile tabSize f = - handle (\ (e :: IOException) -> return $ CheckIOError e) $ - withFile f ReadMode $ \ h -> do - hSetEncoding h utf8 - s <- Text.hGetContents h - let s' = transform tabSize s - return $ if s' == s then CheckOK else CheckViolation s' - --- | Transforms the contents of a file. - -transform - :: TabSize -- ^ Expand tab characters to so many spaces. Keep tabs if @<= 0@. - -> Text -- ^ Text before transformation. - -> Text -- ^ Text after transformation. -transform tabSize = - Text.unlines . - removeFinalEmptyLinesExceptOne . - map (removeTrailingWhitespace . convertTabs) . - Text.lines where - removeFinalEmptyLinesExceptOne = - reverse . dropWhile1 Text.null . reverse - - removeTrailingWhitespace = - Text.dropWhileEnd $ \ c -> generalCategory c `elem` [Space,Format] || c == '\t' - - convertTabs = if tabSize <= 0 then id else - Text.pack . reverse . fst . foldl convertOne ([], 0) . Text.unpack - - convertOne (a, p) '\t' = (addSpaces n a, p + n) - where - n = tabSize - p `mod` tabSize -- Here, tabSize > 0 is guaranteed - convertOne (a, p) c = (c:a, p+1) - - addSpaces :: Int -> String -> String - addSpaces n = (replicate n ' ' ++) + msg vs + | mode == Fix = + "[ Violation fixed ] " ++ f --- | 'dropWhile' except keep the first of the dropped elements -dropWhile1 :: (a -> Bool) -> [a] -> [a] -dropWhile1 _ [] = [] -dropWhile1 p (x:xs) - | p x = x : dropWhile p xs - | otherwise = x : xs + | otherwise = + "[ Violation detected ] " ++ f ++ + (if not verbose then "" else + ":\n" ++ unlines (map (Text.unpack . displayLineError f) vs)) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,9 +1,9 @@ -Copyright (c) 2005-2021 remains with the authors. +Copyright (c) 2005-2023 remains with the authors. fix-whitespace was originally written by Nils Anders Danielsson as part of Agda 2 with contributions from Ulf Norell, Andrés Sicard-Ramírez, Andreas Abel, Philipp Hausmann, Jesper Cockx, -Vlad Semenov, and Liang-Ting Chen. +Vlad Semenov, Liang-Ting Chen, and Artem Pelenitsyn. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the diff --git a/ParseConfig.hs b/ParseConfig.hs --- a/ParseConfig.hs +++ b/ParseConfig.hs @@ -7,7 +7,7 @@ import Data.Maybe (fromMaybe) import qualified Data.Yaml as Y -import Data.Yaml (FromJSON(..), (.:?)) +import Data.Yaml (FromJSON(parseJSON), (.:?)) data RawConfig = RawConfig { __included_dirs :: Maybe [FilePath] diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -10,7 +10,7 @@ This tool can keep your project and repository clean of trailing whitespace and missing terminal newline. -Usage: `fix-whitespace [-h|--help] [-v|--verbose] [--version] [--check] [--config CONFIG] [FILES]` +Usage: `fix-whitespace [-h|--help] [-v|--verbose] [-V|--version] [--check] [--config CONFIG] [FILES]` The program does the following to files specified in `FILES` or in the configuration file `fix-whitespace.yaml` under the current directory @@ -30,8 +30,9 @@ * `-v --verbose` Show files as they are being checked. + _Since 0.1:_ Display location of detected whitespace violations. -* `--version` +* `-V --version` Show program's version. @@ -51,3 +52,8 @@ In the latter case, it returns with a non-zero exit code. For an example configuration file see [the one of Agda](https://github.com/agda/agda/blob/f9a181685397517b5d14943ca88a1c0acacc2075/fix-whitespace.yaml). + +Continuous integration +---------------------- + +`fix-whitespace` comfortably integrates into your GitHub CI via the [`fix-whitespace-action`](https://github.com/andreasabel/fix-whitespace-action). diff --git a/fix-whitespace.cabal b/fix-whitespace.cabal --- a/fix-whitespace.cabal +++ b/fix-whitespace.cabal @@ -1,20 +1,24 @@ +cabal-version: 2.2 name: fix-whitespace -version: 0.0.11 -cabal-version: 1.24 +version: 0.1 build-type: Simple + +category: Text +synopsis: Fixes whitespace issues. description: Removes trailing whitespace, lines containing only whitespace, expands tabs, and ensures that every file ends in a newline character. -license: OtherLicense +license: MIT license-file: LICENSE -author: fix-whitespace was originally written by Nils Anders Danielsson as part of Agda 2 with contributions from Ulf Norell, Andrés Sicard-Ramírez, Andreas Abel, Philipp Hausmann, Jesper Cockx, Vlad Semenov, and Liang-Ting Chen. +author: fix-whitespace was originally written by Nils Anders Danielsson as part of Agda 2 with contributions from Ulf Norell, Andrés Sicard-Ramírez, Andreas Abel, Philipp Hausmann, Jesper Cockx, Vlad Semenov, Liang-Ting Chen, and Artem Pelenitsyn. +maintainer: Andreas Abel, Liang-Ting Chen homepage: https://github.com/agda/fix-whitespace bug-reports: https://github.com/agda/fix-whitespace/issues -maintainer: Liang-Ting Chen , Andreas Abel -Category: Text -Synopsis: Fixes whitespace issues. + tested-with: - GHC == 9.4.3 - GHC == 9.2.5 + -- cabal-supported GHCs + GHC == 9.6.2 + GHC == 9.4.5 + GHC == 9.2.8 GHC == 9.0.2 GHC == 8.10.7 GHC == 8.8.4 @@ -23,51 +27,97 @@ GHC == 8.2.2 GHC == 8.0.2 -extra-source-files: +extra-doc-files: CHANGELOG.md README.md fix-whitespace.yaml - stack-8.0.2.yaml - stack-8.2.2.yaml - stack-8.4.4.yaml - stack-8.6.5.yaml - stack-8.8.4.yaml - stack-8.10.7.yaml + -- stack-supported GHCs + stack-9.6.2.yaml + stack-9.4.5.yaml + stack-9.2.8.yaml stack-9.0.2.yaml - stack-9.2.4.yaml - stack-9.2.5.yaml - stack-9.4.3.yaml + stack-8.10.7.yaml + stack-8.8.4.yaml + stack-8.6.5.yaml + stack-8.4.4.yaml source-repository head type: git location: https://github.com/agda/fix-whitespace.git -executable fix-whitespace - hs-source-dirs: . - main-is: FixWhitespace.hs - other-modules: ParseConfig - Paths_fix_whitespace + +common common-build-parameters default-language: Haskell2010 default-extensions: LambdaCase ScopedTypeVariables - build-depends: base >= 4.9.0.0 && < 5 - , directory >= 1.2.6.2 && < 1.4 - , extra >= 1.1 && < 2.0 - , filepath >= 1.4.1.0 && < 1.5 - , filepattern >= 0.1.3 && < 0.2 - -- filepattern 0.1.3 fixes issue fix-whitespace#9 - , text >= 1.2.3.0 && < 1.3 || == 2.0.* - , yaml >= 0.8.4 && < 0.12 - - -- ASR (2018-10-16). - -- text-1.2.3.0 required for supporting GHC 8.4.1, 8.4.2 and 8.4.3. - -- See Agda issue #3277. - -- The other GHC versions can restrict to >= 1.2.3.1. - if impl(ghc < 8.4.1) || impl(ghc > 8.4.3) - build-depends: text >= 1.2.3.1 - ghc-options: -Wall -Wcompat + -Wmissing-import-lists + +library + import: common-build-parameters + + hs-source-dirs: src + exposed-modules: Data.List.Extra.Drop + Data.Text.FixWhitespace + + build-depends: + base >= 4.9.0.0 && < 5 + , text >= 1.2.3.0 && < 1.3 || == 2.0.* + , transformers >= 0.5.2.0 && < 0.7 + +executable fix-whitespace + import: common-build-parameters + + hs-source-dirs: . + main-is: FixWhitespace.hs + other-modules: ParseConfig + Paths_fix_whitespace + autogen-modules: Paths_fix_whitespace + + build-depends: + fix-whitespace + , base + , text + -- non-inherited dependencies: + , directory >= 1.2.6.2 && < 1.4 + , extra >= 1.1 && < 2.0 + , filepath >= 1.4.1.0 && < 1.5 + , filepattern >= 0.1.3 && < 0.2 + -- filepattern 0.1.3 fixes issue fix-whitespace#9 + , yaml >= 0.8.4 && < 0.12 + +test-suite QuickCheck + import: common-build-parameters + + hs-source-dirs: test + main-is: QuickCheck.hs + type: exitcode-stdio-1.0 + + build-depends: + fix-whitespace + , base + -- non-inherited dependencies + , QuickCheck + , tasty + , tasty-quickcheck + +test-suite Golden + import: common-build-parameters + + hs-source-dirs: test + main-is: Golden.hs + type: exitcode-stdio-1.0 + + build-depends: + fix-whitespace + , base + , filepath + , text + -- non-inherited dependencies + , bytestring + , tasty + , tasty-golden diff --git a/src/Data/List/Extra/Drop.hs b/src/Data/List/Extra/Drop.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/Extra/Drop.hs @@ -0,0 +1,24 @@ +module Data.List.Extra.Drop where + +-- | 'dropWhile' except keep the first of the dropped elements. +-- +dropWhile1 :: (a -> Bool) -> [a] -> [a] +dropWhile1 _ [] = [] +dropWhile1 p (x:xs) + | p x = x : dropWhile p xs + | otherwise = x : xs + +-- | 'dropWhileEnd' except keep the first of the dropped elements. +-- +dropWhileEnd1 :: (a -> Bool) -> [a] -> [a] +dropWhileEnd1 p = go + where + -- State where @p@ isn't holding atm. + go = \case + [] -> [] + x:xs -> x : if p x then go' [] xs else go xs + -- State where @p@ is holding atm. + -- The accumulator holds the elements where @p@ holds (but the first of these). + go' acc = \case + [] -> [] + x:xs -> if p x then go' (x:acc) xs else reverse acc ++ x : go xs diff --git a/src/Data/Text/FixWhitespace.hs b/src/Data/Text/FixWhitespace.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/FixWhitespace.hs @@ -0,0 +1,163 @@ + +{-# LANGUAGE OverloadedStrings #-} + +module Data.Text.FixWhitespace + ( CheckResult(..) + , checkFile + , LineError(..) + , displayLineError + , transform + , transformWithLog + , TabSize + , Verbose + , defaultTabSize + ) + where + +import Control.Monad ( (<=<) ) +import Control.Monad.Trans.Writer.Strict ( Writer, runWriter, tell ) +import Control.Exception ( IOException, handle ) + +import Data.Char ( GeneralCategory(Space, Format), generalCategory ) +import Data.Text ( Text ) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text {- Strict IO -} + +import System.IO ( IOMode(ReadMode), hSetEncoding, utf8, withFile ) + +import Data.List.Extra.Drop ( dropWhileEnd1, dropWhile1 ) + +type Verbose = Bool +type TabSize = Int + +-- | Default tab size. +-- +defaultTabSize :: TabSize +defaultTabSize = 8 + +-- | Result of checking a file against the whitespace policy. +-- +data CheckResult + = CheckOK + -- ^ The file satifies the policy. + | CheckViolation Text [LineError] + -- ^ The file violates the policy, a fix and a list of + -- violating lines are returned. + | CheckIOError IOException + -- ^ An I/O error occurred while accessing the file. + -- (E.g., the file is not UTF8 encoded.) + +-- | Represents a line of input violating whitespace rules. +-- Stores the index of the line and the line itself. +data LineError = LineError Int Text + +-- | Check a file against the whitespace policy, +-- returning a fix if violations occurred. +-- +checkFile :: TabSize -> Verbose -> FilePath -> IO CheckResult +checkFile tabSize verbose f = + handle (\ (e :: IOException) -> return $ CheckIOError e) $ + withFile f ReadMode $ \ h -> do + hSetEncoding h utf8 + s <- Text.hGetContents h + let (s', lvs) + | verbose = transformWithLog tabSize s + | otherwise = (transform tabSize s, []) + return $ if s' == s then CheckOK else CheckViolation s' lvs + +transform + :: TabSize -- ^ Expand tab characters to so many spaces. Keep tabs if @<= 0@. + -> Text -- ^ Text before transformation. + -> Text -- ^ Text after transformation. +transform tabSize = + Text.unlines . + removeFinalEmptyLinesExceptOne . + map (removeTrailingWhitespace . convertTabs tabSize) . + Text.lines + where + removeFinalEmptyLinesExceptOne = + reverse . dropWhile1 Text.null . reverse + +-- | The transformation monad: maintains info about lines that +-- violate the rules. Used in the verbose mode to build a log. +-- +type TransformM = Writer [LineError] + +-- | Transforms the contents of a file. +-- +transformWithLog + :: TabSize -- ^ Expand tab characters to so many spaces. Keep tabs if @<= 0@. + -> Text -- ^ Text before transformation. + -> (Text, [LineError]) -- ^ Text after transformation and violating lines if any. +transformWithLog tabSize = + runWriter . + fmap Text.unlines . + fixAllViolations . + zip [1..] . + Text.lines + where + fixAllViolations :: [(Int,Text)] -> TransformM [Text] + fixAllViolations = + removeFinalEmptyLinesExceptOne + <=< + mapM (fixLineWith $ removeTrailingWhitespace . convertTabs tabSize) + + removeFinalEmptyLinesExceptOne :: [Text] -> TransformM [Text] + removeFinalEmptyLinesExceptOne ls + | lenLs == lenLs' = pure ls + | otherwise = do + tell $ zipWith LineError [1+lenLs' ..] els + pure ls' + where + ls' = dropWhileEnd1 Text.null ls + lenLs = length ls + lenLs' = length ls' + els = replicate (lenLs - lenLs') "" + + fixLineWith :: (Text -> Text) -> (Int, Text) -> TransformM Text + fixLineWith fixer (i, l) + | l == l' = pure l + | otherwise = do + tell [LineError i l] + pure l' + where + l' = fixer l + +removeTrailingWhitespace :: Text -> Text +removeTrailingWhitespace = + Text.dropWhileEnd $ \ c -> generalCategory c `elem` [Space,Format] || c == '\t' + +convertTabs :: TabSize -> Text -> Text +convertTabs tabSize = if tabSize <= 0 then id else + Text.pack . reverse . fst . foldl (convertOne tabSize) ([], 0) . Text.unpack + +convertOne :: TabSize -> (String, Int) -> Char -> (String, Int) +convertOne tabSize (a, p) '\t' = (addSpaces n a, p + n) + where + n = tabSize - p `mod` tabSize -- Here, tabSize > 0 is guaranteed +convertOne _tabSize (a, p) c = (c:a, p+1) + +addSpaces :: Int -> String -> String +addSpaces n = (replicate n ' ' ++) + +-- | Print a erroneous line with 'visibleSpaces'. +-- +displayLineError :: FilePath -> LineError -> Text +displayLineError fname (LineError i l) = Text.concat + [ Text.pack fname + , ":" + , Text.pack $ show i + , ": " + , visibleSpaces l + ] + +-- | Replace spaces and tabs with visible characters for presentation purposes. +-- Space turns into '·' and tab into ''. +-- +visibleSpaces :: Text -> Text +visibleSpaces s + | Text.null s = "" + | otherwise = flip Text.concatMap s $ \case + '\t' -> "" + ' ' -> "·" + c -> Text.pack [c] diff --git a/stack-8.0.2.yaml b/stack-8.0.2.yaml deleted file mode 100644 --- a/stack-8.0.2.yaml +++ /dev/null @@ -1,8 +0,0 @@ -resolver: lts-9.21 -compiler: ghc-8.0.2 -compiler-check: match-exact - -extra-deps: - - text-1.2.3.1 - - extra-1.7.1 - - filepattern-0.1.3 diff --git a/stack-8.2.2.yaml b/stack-8.2.2.yaml deleted file mode 100644 --- a/stack-8.2.2.yaml +++ /dev/null @@ -1,7 +0,0 @@ -resolver: lts-11.22 -compiler: ghc-8.2.2 -compiler-check: match-exact - -extra-deps: - - text-1.2.3.1 - - filepattern-0.1.3 diff --git a/stack-9.2.4.yaml b/stack-9.2.4.yaml deleted file mode 100644 --- a/stack-9.2.4.yaml +++ /dev/null @@ -1,3 +0,0 @@ -resolver: nightly-2022-11-12 -compiler: ghc-9.2.4 -compiler-check: match-exact diff --git a/stack-9.2.5.yaml b/stack-9.2.5.yaml deleted file mode 100644 --- a/stack-9.2.5.yaml +++ /dev/null @@ -1,3 +0,0 @@ -resolver: lts-20.3 -compiler: ghc-9.2.5 -compiler-check: match-exact diff --git a/stack-9.2.8.yaml b/stack-9.2.8.yaml new file mode 100644 --- /dev/null +++ b/stack-9.2.8.yaml @@ -0,0 +1,3 @@ +resolver: lts-20.26 +compiler: ghc-9.2.8 +compiler-check: match-exact diff --git a/stack-9.4.3.yaml b/stack-9.4.3.yaml deleted file mode 100644 --- a/stack-9.4.3.yaml +++ /dev/null @@ -1,3 +0,0 @@ -resolver: nightly-2022-12-05 -compiler: ghc-9.4.3 -compiler-check: match-exact diff --git a/stack-9.4.5.yaml b/stack-9.4.5.yaml new file mode 100644 --- /dev/null +++ b/stack-9.4.5.yaml @@ -0,0 +1,3 @@ +resolver: lts-21.0 +compiler: ghc-9.4.5 +compiler-check: match-exact diff --git a/stack-9.6.2.yaml b/stack-9.6.2.yaml new file mode 100644 --- /dev/null +++ b/stack-9.6.2.yaml @@ -0,0 +1,3 @@ +resolver: nightly-2023-06-22 +compiler: ghc-9.6.2 +compiler-check: match-exact diff --git a/test/Golden.hs b/test/Golden.hs new file mode 100644 --- /dev/null +++ b/test/Golden.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | A golden value testsuite for fix-whitespace. +-- + +module Main where + +import Data.ByteString.Lazy ( ByteString ) +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LazyText +import qualified Data.Text.Lazy.Encoding as LazyText + +import System.FilePath ( takeBaseName, replaceExtension ) + +import Test.Tasty ( defaultMain, TestTree, testGroup ) +import Test.Tasty.Golden ( goldenVsString, findByExtension ) + +import Data.Text.FixWhitespace ( CheckResult(CheckOK, CheckViolation, CheckIOError) + , checkFile, displayLineError, defaultTabSize ) + +main :: IO () +main = defaultMain =<< goldenTests + +goldenTests :: IO TestTree +goldenTests = do + files <- findByExtension [".txt"] "test" + return $ testGroup "Golden tests" + [ goldenVsString + (takeBaseName file) -- test name + (replaceExtension file ".golden") -- golden file path + (goldenValue file) -- action whose result is tested + | file <- files + ] + +goldenValue :: FilePath -> IO ByteString +goldenValue file = do + checkFile defaultTabSize {-verbose: -}True file >>= \case + + CheckIOError e -> + ioError e + + CheckOK -> + return "OK\n" + + CheckViolation _ errs -> + return $ LazyText.encodeUtf8 $ LazyText.fromStrict $ + Text.unlines $ "Violations:" : map (displayLineError file) errs diff --git a/test/QuickCheck.hs b/test/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/test/QuickCheck.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Test 'dropWhileEnd1'. + +module Main where + +import Data.Maybe ( isJust ) + +import Test.QuickCheck.All ( allProperties ) +import Test.Tasty ( defaultMain ) +import Test.Tasty.QuickCheck ( testProperties ) + +import Data.List.Extra.Drop ( dropWhile1, dropWhileEnd1 ) + +-- | If the predicate is true for exactly one value, we can express 'dropWhileEnd1' in terms of 'dropWhile1'. +-- +-- Example: predicate 'not' holds only for 'False'. +-- +prop_dropWhileEnd1_Bool :: [Bool] -> Bool +prop_dropWhileEnd1_Bool xs = dropWhileEnd1 not xs == (reverse . dropWhile1 not . reverse) xs + +-- | If the predicate is *not* a singleton, this relation does not hold. +-- +prop_dropWhileEnd1_Maybe_Bool :: Bool +prop_dropWhileEnd1_Maybe_Bool = l /= r + where + xs = [Just True, Just False] + l = dropWhileEnd1 isJust xs -- Just True + r = (reverse . dropWhile1 isJust . reverse) xs -- Just False + +-- Pseudo Template Haskell instruction to make $allProperties work +return [] + +main :: IO () +main = defaultMain $ testProperties "Tests" $allProperties