setdown 0.1.3.1 → 0.1.4.0
raw patch · 7 files changed
+762/−337 lines, 7 filesdep +QuickCheckdep +processdep +setdown
Dependencies added: QuickCheck, process, setdown, tasty, tasty-golden, tasty-hunit, tasty-quickcheck
Files
- app/Main.hs +319/−0
- setdown.cabal +70/−17
- src/Main.hs +0/−319
- src/PerformOperations.hs +1/−1
- test/GoldenTests.hs +44/−0
- test/PropertyTests.hs +102/−0
- test/UnitTests.hs +226/−0
+ app/Main.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Main where++import qualified Data.ByteString.Lazy as B+import qualified Data.Set as S++import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.IO as T+import qualified Text.Layout.Table as Tab+import System.Console.CmdArgs+import System.Exit++import Control.Monad (filterM, forM, forM_, unless, when)+import Data.Word (Word8)++import Data.List (intersperse, isSuffixOf, partition)+import Data.Maybe (fromMaybe)++import Context+import DefinitionHelpers+import ExpressionConversion+import ExternalSort+import PrintDefinition+import SetData+import SetInput+import SetInputVerification++import DuplicateElimination+import PerformOperations+import SimpleDefinitionCycles++import System.Directory (doesFileExist, getCurrentDirectory,+ listDirectory, removeFile)+import System.FilePath (dropFileName, (</>))++#ifndef mingw32_HOST_OS+import System.Posix.Files (createLink)+#endif++-- Useful for Print Debugging+-- import Text.Show.Pretty+-- prettyPrint :: Show a => a -> IO ()+-- prettyPrint = putStrLn . ppShow+++data Options = Options+ { outputDirectory :: Maybe FilePath+ , setdownFile :: Maybe FilePath+ , showTransient :: Bool+ } deriving (Show, Data, Typeable)++options :: Options+options = Options+ { outputDirectory = def+ &= explicit+ &= name "output"+ &= name "o"+ &= typDir+ &= help "Directory in which to place output files, relative to your .setdown file. Defaults to 'output' if omitted."+ &= opt "output"+ , setdownFile = def+ &= name "input"+ &= name "i"+ &= explicit+ &= help "The .setdown definitions file to evaluate. If omitted, setdown looks for a single .setdown file in the current directory and uses it automatically. Exits with an error if zero or more than one are found."+ &= typ "definitions.setdown"+ , showTransient = def+ &= explicit+ &= name "show-transient"+ &= help "Also show intermediate results for sub-expressions generated internally to evaluate your definitions. Useful for debugging complex .setdown files."+ }+ &= program "setdown"+ &= summary "setdown evaluates a .setdown definitions file to perform set operations (intersection, union, difference) on line-based text files, writing one result file per definition to an output directory."++data GuessError+ = NoMatchingFiles+ | TooManyMatchingFiles [FilePath]++-- attempt to use the+guessInputFile :: IO (Either GuessError FilePath)+guessInputFile = do+ currentDirFiles <- listDirectory =<< getCurrentDirectory+ case filter hasSetdownExtension currentDirFiles of+ [] -> return . Left $ NoMatchingFiles+ [x] -> return . Right $ x+ xs -> return . Left $ TooManyMatchingFiles xs+ where+ hasSetdownExtension filePath = ".setdown" `isSuffixOf` filePath++getInputFileOrFail :: Maybe FilePath -> IO FilePath+getInputFileOrFail (Just userSuggested) = do+ inputFileExists <- doesFileExist userSuggested+ if inputFileExists+ then return userSuggested+ else do+ putStrLn $ "Error: The given setdown file did not exist: " ++ userSuggested+ exitWith (ExitFailure 1)+getInputFileOrFail Nothing = do+ guessResult <- guessInputFile+ case guessResult of+ (Right match) -> do+ inputFileExists <- doesFileExist match+ if inputFileExists+ then return match+ else do+ putStrLn $ "Error: The given setdown file did not exist: " ++ match+ exitWith (ExitFailure 1)+ (Left (TooManyMatchingFiles matches)) -> do+ putStrLn $ "Error: There were too many files that look like setdown definition files in the current directory. Could not pick one. Select one with '--input'."+ putStrLn $ "Matching files: " ++ (show matches)+ exitWith (ExitFailure 2)+ (Left NoMatchingFiles) -> do+ putStrLn $ "Error: There were no files that look like setdown definition files in the current directory. Write one or select one with '--input'."+ exitWith (ExitFailure 3)++-- TODO the setdownFile should be optional, at which point we should search the current directory+-- for one+main :: IO ()+main = do+ opts <- cmdArgs options++ inputFilePath <- getInputFileOrFail (setdownFile opts)+ putStrLn $ "==> Using setdown file: " ++ inputFilePath+ printNewline++ -- Todo work out the parent directory of the setdown file+ putStrLn "==> Creating the environment..."+ let baseDir = dropFileName inputFilePath++ let context = standardContext+ { cBaseDir = baseDir+ , cOutputDir = baseDir </> fromMaybe "output" (outputDirectory opts)+ }++ putStrLn $ " Base Directory: " ++ cBaseDir context+ putStrLn $ " Output Directory: " ++ cOutputDir context+ prepareContext context+ printNewline++ setData <- parse <$> (B.readFile inputFilePath)+ putStrLn "==> Parsed original definitions..."+ printDefinitions setData+ printNewline++ -- Step 0: Verify that the definitions are well defined and that the referenced files exist+ -- relative to the file that we pass in.+ putStrLn "==> Verification (Ensuring correctness in the set definitions file)"+ case duplicateDefinitionName setData of+ [] -> putStrLn " OK: No duplicate definitions found."+ xs -> do+ putStrLn "[Error 11] Duplicate definitions found:"+ mapM_ T.putStrLn xs+ exitWith (ExitFailure 11)++ case unknownIdentifier setData of+ [] -> putStrLn " OK: No unknown identifiers found."+ xs -> do+ putStrLn "[Error 12] Unknown identifiers used in the set descriptor file:"+ mapM_ T.putStrLn xs+ exitWith (ExitFailure 12)++ allFiles <- filesNotFound context . S.toList . extractFilenamesFromDefinitions $ setData+ unless (null allFiles) $ do+ putStrLn "[Error 13] the following files could not be found:"+ forM_ allFiles (\fp -> putStrLn $ " - " ++ fp)+ exitWith (ExitFailure 13)+ putStrLn " OK: All files in the definitions could be found."+ printNewline++ putStr "==> Simplifying and eliminating duplicates from set definitions..."+ let simpleSetData = eliminateDuplicates . orderDefinitions . complexToSimpleDefinitions $ setData+ if showTransient opts+ then do+ putStrLn "DONE:"+ printSimpleDefinitions simpleSetData+ printNewline+ else do+ putStrLn "DONE!"+ printNewline++ putStr "==> Checking for cycles in the simplified definitions..."+ let cycles = getCyclesInSimpleDefinitions simpleSetData+ putStrLn "DONE:"+ unless (null cycles) $ do+ putStrLn "[Error 20] found cyclic dependencies in the definitions!"+ printNewline+ putStrLn "We found the following cycles:"+ printCycles cycles+ exitWith (ExitFailure 20)+ putStrLn " OK: No cycles were found in the definitions."+ printNewline++ putStrLn "==> Sorting and de-duplicated input files from the definitions..."+ -- Step 1: For every unique file, sort it (Use external sort for this purpose:+ -- https://hackage.haskell.org/package/external-sort-0.2/docs/Algorithms-ExternalSort.html add+ -- docs to that library if at all possible)+ -- TODO use file timestamps to not sort these big files more than once if possible+ sortedFiles <- extractAndSortFiles context (S.toList . extractFilenamesFromDefinitions $ setData) -- TODO use the simple set data here+ printTabularResults sortedFiles+ printNewline++ putStrLn "==> Setdown results"+ -- Step 2: Calculate the graph of everything that needs to be computed and compute things one at+ -- a time. Even make sure that you store the temporary results along the way. That way we can+ -- refer to them later if the same computation is made twice. We should certainly memoize with+ -- the file system. It would be great if we could print out the results of the computations as we+ -- go.+ computedFiles <- runSimpleDefinitions context simpleSetData sortedFiles+ -- Step 3: Publish retained results under their definition names.+ publishedFiles <- publishResults context computedFiles+ -- Step 4: Count the elements in each result file.+ annotatedFiles <- forM publishedFiles $ \(sd, fp) -> do+ n <- countLines fp+ return (sd, fp, n)+ -- Step 5: Print out the final statistics with the definitions pointing to how many elements that+ -- each contained and where to find their output files.+ printComputedResults opts annotatedFiles++publishResults :: Context -> [(SimpleDefinition, FilePath)] -> IO [(SimpleDefinition, FilePath)]+#ifndef mingw32_HOST_OS+publishResults ctx results = mapM publish results+ where+ publish (sd, src)+ | sdRetain sd = do+ let dest = cOutputDir ctx </> LT.unpack (sdId sd) ++ ".txt"+ destExists <- doesFileExist dest+ when destExists $ removeFile dest+ createLink src dest+ return (sd, dest)+ | otherwise = return (sd, src)+#else+publishResults _ results = return results+#endif++countLines :: FilePath -> IO Int+countLines fp = fromIntegral . B.count newlineByte <$> B.readFile fp+ where newlineByte = 0x0A :: Word8++filesNotFound :: Context -> [FilePath] -> IO [FilePath]+filesNotFound ctx = filterM (\x -> not <$> doesFileExist (cBaseDir ctx </> x))++printCycles :: [SimpleDefinitions] -> IO ()+printCycles sds = forM_ sds $ \sd -> do+ putStr " "+ printCycle sd+ printNewline++printCycle :: SimpleDefinitions -> IO ()+printCycle [] = putStrLn "Not a cycle."+printCycle (x:xs) = sequence_ . intersperse (putStr " -> ") $ printIdentifiers+ where+ printIdentifiers = fmap (printIdentifier . sdId) loopRound+ loopRound = [x] ++ xs ++ [x]++-- TODO use the box library to print these items in a nice tabulated way+printSortResults :: [(FilePath, FilePath)] -> IO ()+printSortResults = sequence_ . fmap printSortResult++printSortResult :: (FilePath, FilePath) -> IO ()+printSortResult (unsortedFile, sortedFile) = do+ putStr . wrapInQuotes $ unsortedFile+ putStr " (unsorted) => "+ putStr . wrapInQuotes $ sortedFile+ putStrLn " (sorted)"+ where+ wrapInQuotes x = "\"" ++ x ++ "\""++printTabularResults :: [(FilePath, FilePath)] -> IO ()+printTabularResults fileMapping = sequence_ . fmap putStrLn $ Tab.tableLines (Tab.columnHeaderTableS columns Tab.unicodeBoldHeaderS headers rows)+ where+ headers = Tab.titlesH ["From", "To"]++ columns =+ [ Tab.column Tab.expand Tab.left Tab.noAlign Tab.noCutMark+ , Tab.column Tab.expand Tab.left Tab.noAlign Tab.noCutMark+ ]++ rows = [Tab.rowsG $ fmap (\(from, to) -> [from, to]) fileMapping]++printTabularResultsWithCount :: [(String, FilePath, Int)] -> IO ()+printTabularResultsWithCount rows = sequence_ . fmap putStrLn $ Tab.tableLines (Tab.columnHeaderTableS columns Tab.unicodeBoldHeaderS headers tableRows)+ where+ headers = Tab.titlesH ["Name", "File", "Count"]++ columns =+ [ Tab.column Tab.expand Tab.left Tab.noAlign Tab.noCutMark+ , Tab.column Tab.expand Tab.left Tab.noAlign Tab.noCutMark+ , Tab.column Tab.expand Tab.right Tab.noAlign Tab.noCutMark+ ]++ tableRows = [Tab.rowsG $ fmap (\(defName, fp, n) -> [defName, fp, show n]) rows]++printComputedResults :: Options -> [(SimpleDefinition, FilePath, Int)] -> IO ()+printComputedResults opts results = do+ unless (null tempResults || not (showTransient opts)) $ do+ putStrLn "Transient results:"+ printTabularResultsWithCount . fmap toRow $ tempResults+ printNewline+ unless (null retainResults) $ do+ unless (not (showTransient opts)) $ putStrLn "Required results:"+ printTabularResultsWithCount . fmap toRow $ retainResults+ where+ (retainResults, tempResults) = partition (\(sd, _, _) -> sdRetain sd) results+ getIdentifier (SimpleDefinition ident _ _) = ident+ toRow (sd, fp, n) = (LT.unpack (getIdentifier sd), fp, n)+++printComputedResult :: (SimpleDefinition, FilePath) -> IO ()+printComputedResult (SimpleDefinition ident _ _, fp) = do+ printIdentifier ident+ putStr ": "+ putStrLn fp++printIdentifier :: Identifier -> IO ()+printIdentifier = T.putStr++printNewline :: IO ()+printNewline = putStrLn ""
setdown.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.1.3.1+version: 0.1.4.0 -- A short (one-line) description of the package. synopsis: Treating files as sets to perform rapid set manipulation.@@ -57,12 +57,8 @@ type: git location: git@bitbucket.org:robertmassaioli/setdown.git -executable setdown- -- .hs or .lhs file containing the Main module.- main-is: Main.hs-- -- Modules included in this executable, other than Main.- other-modules: SetLanguage+library+ exposed-modules: SetLanguage , SetParser , Context , DefinitionHelpers@@ -76,16 +72,11 @@ , SetInputVerification , SimpleDefinitionCycles - -- LANGUAGE extensions used by modules in this package.- -- other-extensions:-- -- Other library packages from which modules are imported. build-depends: base >=4.7 && < 5 -- Lexing dependencies , array >= 0.5 && < 0.6 , bytestring >= 0.10 && < 0.13 , text >= 1.2 && < 2.2- -- , pretty-show == 1.6.* -- Module Dependencies , filepath >= 1.2 && < 3 , directory >= 1.1 && < 3@@ -93,19 +84,81 @@ , uuid >= 1.3 && < 1.4 , split == 0.2.* , mtl >= 2.2 && < 2.4+ , async >= 2.2 && < 2.3++ build-tools: alex, happy++ hs-source-dirs: src++ default-language: Haskell2010++ ghc-options: -Wall++executable setdown+ main-is: Main.hs++ build-depends: base >=4.7 && < 5+ , setdown+ , bytestring >= 0.10 && < 0.13+ , text >= 1.2 && < 2.2+ , containers >= 0.6 && < 0.8+ , directory >= 1.1 && < 3+ , filepath >= 1.2 && < 3 , cmdargs >= 0.10 && < 0.11 , table-layout >= 0.8 && < 1.1- , async >= 2.2 && < 2.3 if !os(windows) build-depends: unix >= 2.7 && < 2.9 - build-tools: alex, happy+ hs-source-dirs: app - -- Directories containing source files.- hs-source-dirs: src+ default-language: Haskell2010 - -- Base language which the package is written in.+ ghc-options: -Wall++test-suite setdown-tests+ type: exitcode-stdio-1.0+ main-is: UnitTests.hs+ hs-source-dirs: test++ build-depends: base >=4.7 && < 5+ , setdown+ , tasty >= 1.4 && < 1.6+ , tasty-hunit >= 0.10 && < 0.11+ , text >= 1.2 && < 2.2+ , bytestring >= 0.10 && < 0.13++ default-language: Haskell2010++ ghc-options: -Wall++test-suite setdown-property-tests+ type: exitcode-stdio-1.0+ main-is: PropertyTests.hs+ hs-source-dirs: test++ build-depends: base >=4.7 && < 5+ , setdown+ , tasty >= 1.4 && < 1.6+ , tasty-quickcheck >= 0.10 && < 0.12+ , QuickCheck >= 2.14 && < 2.16+ , text >= 1.2 && < 2.2++ default-language: Haskell2010++ ghc-options: -Wall++test-suite setdown-golden-tests+ type: exitcode-stdio-1.0+ main-is: GoldenTests.hs+ hs-source-dirs: test++ build-depends: base >=4.7 && < 5+ , tasty >= 1.4 && < 1.6+ , tasty-golden >= 2.3 && < 2.4+ , filepath >= 1.2 && < 3+ , process >= 1.6 && < 1.7+ default-language: Haskell2010 ghc-options: -Wall
− src/Main.hs
@@ -1,319 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-module Main where--import qualified Data.ByteString.Lazy as B-import qualified Data.Set as S--import qualified Data.Text.Lazy as LT-import qualified Data.Text.Lazy.IO as T-import qualified Text.Layout.Table as Tab-import System.Console.CmdArgs-import System.Exit--import Control.Monad (filterM, forM, forM_, unless, when)-import Data.Word (Word8)--import Data.List (intersperse, isSuffixOf, partition)-import Data.Maybe (fromMaybe)--import Context-import DefinitionHelpers-import ExpressionConversion-import ExternalSort-import PrintDefinition-import SetData-import SetInput-import SetInputVerification--import DuplicateElimination-import PerformOperations-import SimpleDefinitionCycles--import System.Directory (doesFileExist, getCurrentDirectory,- listDirectory, removeFile)-import System.FilePath (dropFileName, (</>))--#ifndef mingw32_HOST_OS-import System.Posix.Files (createLink)-#endif---- Useful for Print Debugging--- import Text.Show.Pretty--- prettyPrint :: Show a => a -> IO ()--- prettyPrint = putStrLn . ppShow---data Options = Options- { outputDirectory :: Maybe FilePath- , setdownFile :: Maybe FilePath- , showTransient :: Bool- } deriving (Show, Data, Typeable)--options :: Options-options = Options- { outputDirectory = def- &= explicit- &= name "output"- &= name "o"- &= typDir- &= help "Directory in which to place output files, relative to your .setdown file. Defaults to 'output' if omitted."- &= opt "output"- , setdownFile = def- &= name "input"- &= name "i"- &= explicit- &= help "The .setdown definitions file to evaluate. If omitted, setdown looks for a single .setdown file in the current directory and uses it automatically. Exits with an error if zero or more than one are found."- &= typ "definitions.setdown"- , showTransient = def- &= explicit- &= name "show-transient"- &= help "Also show intermediate results for sub-expressions generated internally to evaluate your definitions. Useful for debugging complex .setdown files."- }- &= program "setdown"- &= summary "setdown evaluates a .setdown definitions file to perform set operations (intersection, union, difference) on line-based text files, writing one result file per definition to an output directory."--data GuessError- = NoMatchingFiles- | TooManyMatchingFiles [FilePath]---- attempt to use the-guessInputFile :: IO (Either GuessError FilePath)-guessInputFile = do- currentDirFiles <- listDirectory =<< getCurrentDirectory- case filter hasSetdownExtension currentDirFiles of- [] -> return . Left $ NoMatchingFiles- [x] -> return . Right $ x- xs -> return . Left $ TooManyMatchingFiles xs- where- hasSetdownExtension filePath = ".setdown" `isSuffixOf` filePath--getInputFileOrFail :: Maybe FilePath -> IO FilePath-getInputFileOrFail (Just userSuggested) = do- inputFileExists <- doesFileExist userSuggested- if inputFileExists- then return userSuggested- else do- putStrLn $ "Error: The given setdown file did not exist: " ++ userSuggested- exitWith (ExitFailure 1)-getInputFileOrFail Nothing = do- guessResult <- guessInputFile- case guessResult of- (Right match) -> do- inputFileExists <- doesFileExist match- if inputFileExists- then return match- else do- putStrLn $ "Error: The given setdown file did not exist: " ++ match- exitWith (ExitFailure 1)- (Left (TooManyMatchingFiles matches)) -> do- putStrLn $ "Error: There were too many files that look like setdown definition files in the current directory. Could not pick one. Select one with '--input'."- putStrLn $ "Matching files: " ++ (show matches)- exitWith (ExitFailure 2)- (Left NoMatchingFiles) -> do- putStrLn $ "Error: There were no files that look like setdown definition files in the current directory. Write one or select one with '--input'."- exitWith (ExitFailure 3)---- TODO the setdownFile should be optional, at which point we should search the current directory--- for one-main :: IO ()-main = do- opts <- cmdArgs options-- inputFilePath <- getInputFileOrFail (setdownFile opts)- putStrLn $ "==> Using setdown file: " ++ inputFilePath- printNewline-- -- Todo work out the parent directory of the setdown file- putStrLn "==> Creating the environment..."- let baseDir = dropFileName inputFilePath-- let context = standardContext- { cBaseDir = baseDir- , cOutputDir = baseDir </> fromMaybe "output" (outputDirectory opts)- }-- putStrLn $ " Base Directory: " ++ cBaseDir context- putStrLn $ " Output Directory: " ++ cOutputDir context- prepareContext context- printNewline-- setData <- parse <$> (B.readFile inputFilePath)- putStrLn "==> Parsed original definitions..."- printDefinitions setData- printNewline-- -- Step 0: Verify that the definitions are well defined and that the referenced files exist- -- relative to the file that we pass in.- putStrLn "==> Verification (Ensuring correctness in the set definitions file)"- case duplicateDefinitionName setData of- [] -> putStrLn " OK: No duplicate definitions found."- xs -> do- putStrLn "[Error 11] Duplicate definitions found:"- mapM_ T.putStrLn xs- exitWith (ExitFailure 11)-- case unknownIdentifier setData of- [] -> putStrLn " OK: No unknown identifiers found."- xs -> do- putStrLn "[Error 12] Unknown identifiers used in the set descriptor file:"- mapM_ T.putStrLn xs- exitWith (ExitFailure 12)-- allFiles <- filesNotFound context . S.toList . extractFilenamesFromDefinitions $ setData- unless (null allFiles) $ do- putStrLn "[Error 13] the following files could not be found:"- forM_ allFiles (\fp -> putStrLn $ " - " ++ fp)- exitWith (ExitFailure 13)- putStrLn " OK: All files in the definitions could be found."- printNewline-- putStr "==> Simplifying and eliminating duplicates from set definitions..."- let simpleSetData = eliminateDuplicates . orderDefinitions . complexToSimpleDefinitions $ setData- if showTransient opts- then do- putStrLn "DONE:"- printSimpleDefinitions simpleSetData- printNewline- else do- putStrLn "DONE!"- printNewline-- putStr "==> Checking for cycles in the simplified definitions..."- let cycles = getCyclesInSimpleDefinitions simpleSetData- putStrLn "DONE:"- unless (null cycles) $ do- putStrLn "[Error 20] found cyclic dependencies in the definitions!"- printNewline- putStrLn "We found the following cycles:"- printCycles cycles- exitWith (ExitFailure 20)- putStrLn " OK: No cycles were found in the definitions."- printNewline-- putStrLn "==> Sorting and de-duplicated input files from the definitions..."- -- Step 1: For every unique file, sort it (Use external sort for this purpose:- -- https://hackage.haskell.org/package/external-sort-0.2/docs/Algorithms-ExternalSort.html add- -- docs to that library if at all possible)- -- TODO use file timestamps to not sort these big files more than once if possible- sortedFiles <- extractAndSortFiles context (S.toList . extractFilenamesFromDefinitions $ setData) -- TODO use the simple set data here- printTabularResults sortedFiles- printNewline-- putStrLn "==> Setdown results"- -- Step 2: Calculate the graph of everything that needs to be computed and compute things one at- -- a time. Even make sure that you store the temporary results along the way. That way we can- -- refer to them later if the same computation is made twice. We should certainly memoize with- -- the file system. It would be great if we could print out the results of the computations as we- -- go.- computedFiles <- runSimpleDefinitions context simpleSetData sortedFiles- -- Step 3: Publish retained results under their definition names.- publishedFiles <- publishResults context computedFiles- -- Step 4: Count the elements in each result file.- annotatedFiles <- forM publishedFiles $ \(sd, fp) -> do- n <- countLines fp- return (sd, fp, n)- -- Step 5: Print out the final statistics with the definitions pointing to how many elements that- -- each contained and where to find their output files.- printComputedResults opts annotatedFiles--publishResults :: Context -> [(SimpleDefinition, FilePath)] -> IO [(SimpleDefinition, FilePath)]-#ifndef mingw32_HOST_OS-publishResults ctx results = mapM publish results- where- publish (sd, src)- | sdRetain sd = do- let dest = cOutputDir ctx </> LT.unpack (sdId sd) ++ ".txt"- destExists <- doesFileExist dest- when destExists $ removeFile dest- createLink src dest- return (sd, dest)- | otherwise = return (sd, src)-#else-publishResults _ results = return results-#endif--countLines :: FilePath -> IO Int-countLines fp = fromIntegral . B.count newlineByte <$> B.readFile fp- where newlineByte = 0x0A :: Word8--filesNotFound :: Context -> [FilePath] -> IO [FilePath]-filesNotFound ctx = filterM (\x -> not <$> doesFileExist (cBaseDir ctx </> x))--printCycles :: [SimpleDefinitions] -> IO ()-printCycles sds = forM_ sds $ \sd -> do- putStr " "- printCycle sd- printNewline--printCycle :: SimpleDefinitions -> IO ()-printCycle [] = putStrLn "Not a cycle."-printCycle (x:xs) = sequence_ . intersperse (putStr " -> ") $ printIdentifiers- where- printIdentifiers = fmap (printIdentifier . sdId) loopRound- loopRound = [x] ++ xs ++ [x]---- TODO use the box library to print these items in a nice tabulated way-printSortResults :: [(FilePath, FilePath)] -> IO ()-printSortResults = sequence_ . fmap printSortResult--printSortResult :: (FilePath, FilePath) -> IO ()-printSortResult (unsortedFile, sortedFile) = do- putStr . wrapInQuotes $ unsortedFile- putStr " (unsorted) => "- putStr . wrapInQuotes $ sortedFile- putStrLn " (sorted)"- where- wrapInQuotes x = "\"" ++ x ++ "\""--printTabularResults :: [(FilePath, FilePath)] -> IO ()-printTabularResults fileMapping = sequence_ . fmap putStrLn $ Tab.tableLines (Tab.columnHeaderTableS columns Tab.unicodeBoldHeaderS headers rows)- where- headers = Tab.titlesH ["From", "To"]-- columns =- [ Tab.column Tab.expand Tab.left Tab.noAlign Tab.noCutMark- , Tab.column Tab.expand Tab.left Tab.noAlign Tab.noCutMark- ]-- rows = [Tab.rowsG $ fmap (\(from, to) -> [from, to]) fileMapping]--printTabularResultsWithCount :: [(String, FilePath, Int)] -> IO ()-printTabularResultsWithCount rows = sequence_ . fmap putStrLn $ Tab.tableLines (Tab.columnHeaderTableS columns Tab.unicodeBoldHeaderS headers tableRows)- where- headers = Tab.titlesH ["Name", "File", "Count"]-- columns =- [ Tab.column Tab.expand Tab.left Tab.noAlign Tab.noCutMark- , Tab.column Tab.expand Tab.left Tab.noAlign Tab.noCutMark- , Tab.column Tab.expand Tab.right Tab.noAlign Tab.noCutMark- ]-- tableRows = [Tab.rowsG $ fmap (\(defName, fp, n) -> [defName, fp, show n]) rows]--printComputedResults :: Options -> [(SimpleDefinition, FilePath, Int)] -> IO ()-printComputedResults opts results = do- unless (null tempResults || not (showTransient opts)) $ do- putStrLn "Transient results:"- printTabularResultsWithCount . fmap toRow $ tempResults- printNewline- unless (null retainResults) $ do- unless (not (showTransient opts)) $ putStrLn "Required results:"- printTabularResultsWithCount . fmap toRow $ retainResults- where- (retainResults, tempResults) = partition (\(sd, _, _) -> sdRetain sd) results- getIdentifier (SimpleDefinition ident _ _) = ident- toRow (sd, fp, n) = (LT.unpack (getIdentifier sd), fp, n)---printComputedResult :: (SimpleDefinition, FilePath) -> IO ()-printComputedResult (SimpleDefinition ident _ _, fp) = do- printIdentifier ident- putStr ": "- putStrLn fp--printIdentifier :: Identifier -> IO ()-printIdentifier = T.putStr--printNewline :: IO ()-printNewline = putStrLn ""
src/PerformOperations.hs view
@@ -1,4 +1,4 @@-module PerformOperations (runSimpleDefinitions) where+module PerformOperations (runSimpleDefinitions, linesSetOperation, operatorTools, OperatorTools) where import Context import Control.Arrow (first)
+ test/GoldenTests.hs view
@@ -0,0 +1,44 @@+module Main where++import Test.Tasty+import Test.Tasty.Golden+import System.FilePath ((</>))+import System.Process (callProcess)++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "setdown golden tests"+ [ goldenTest "intersection"+ , goldenTest "union"+ , goldenTest "difference"+ , goldenTest "symmetric-difference"+ ]++-- | Run setdown on a fixture directory and compare the Result.txt output+-- against the committed golden file.+--+-- Each fixture lives under test/golden/<name>/ and contains:+-- a.txt, b.txt – input files+-- example.setdown – the definitions file (references a.txt and b.txt)+-- golden/Result.txt – the committed expected output+--+-- setdown writes its result to test/golden/<name>/output/Result.txt,+-- which is what tasty-golden compares against the golden file.+--+-- To regenerate golden files after an intentional change:+-- stack test setdown:setdown-golden-tests --test-arguments=--accept+goldenTest :: String -> TestTree+goldenTest name =+ goldenVsFile+ name+ (fixtureDir </> "golden" </> "Result.txt") -- expected (committed)+ (fixtureDir </> "output" </> "Result.txt") -- actual (generated)+ (runSetdown (fixtureDir </> "example.setdown"))+ where+ fixtureDir = "test" </> "golden" </> name++runSetdown :: FilePath -> IO ()+runSetdown inputFile =+ callProcess "stack" ["exec", "--", "setdown", "-i", inputFile]
+ test/PropertyTests.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Test.Tasty+import Test.Tasty.QuickCheck++import qualified Data.Text.Lazy as T+import Data.List (nub, sort)++import PerformOperations (linesSetOperation, operatorTools)+import SetData++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "setdown property tests"+ [ testGroup "commutativity"+ [ testProperty "intersection is commutative" prop_intersectionCommutative+ , testProperty "union is commutative" prop_unionCommutative+ , testProperty "symmetric difference is commutative" prop_symdiffCommutative+ ]+ , testGroup "idempotent and identity laws"+ [ testProperty "intersection with itself is idempotent" prop_intersectionIdempotent+ , testProperty "union with itself is idempotent" prop_unionIdempotent+ , testProperty "difference with itself is empty" prop_differenceEmpty+ , testProperty "intersection with empty is empty" prop_intersectionEmptyRight+ , testProperty "union with empty is identity" prop_unionEmptyRight+ , testProperty "difference with empty is identity" prop_differenceEmptyRight+ ]+ , testGroup "algebraic equivalences"+ [ testProperty "symmetric difference equals (A-B) ∪ (B-A)" prop_symdiffEquivalence+ ]+ ]++-- ---------------------------------------------------------------------------+-- Sorted, deduplicated list of Text — the invariant linesSetOperation requires+-- ---------------------------------------------------------------------------++newtype SortedSet = SortedSet [T.Text] deriving (Show, Eq)++instance Arbitrary SortedSet where+ arbitrary = do+ strs <- listOf (listOf1 (elements (['a'..'z'] ++ ['0'..'9'])))+ return . SortedSet . map T.pack . nub . sort $ strs++ shrink (SortedSet xs) =+ [ SortedSet (nub . sort . map T.pack $ ys)+ | ys <- shrinkList shrink (map T.unpack xs)+ ]++-- ---------------------------------------------------------------------------+-- Helper+-- ---------------------------------------------------------------------------++lso :: Operator -> [T.Text] -> [T.Text] -> [T.Text]+lso op = linesSetOperation (operatorTools op)++-- ---------------------------------------------------------------------------+-- Properties+-- ---------------------------------------------------------------------------++prop_intersectionCommutative :: SortedSet -> SortedSet -> Property+prop_intersectionCommutative (SortedSet a) (SortedSet b) =+ lso And a b === lso And b a++prop_unionCommutative :: SortedSet -> SortedSet -> Property+prop_unionCommutative (SortedSet a) (SortedSet b) =+ lso Or a b === lso Or b a++prop_symdiffCommutative :: SortedSet -> SortedSet -> Property+prop_symdiffCommutative (SortedSet a) (SortedSet b) =+ lso SymmetricDifference a b === lso SymmetricDifference b a++prop_intersectionIdempotent :: SortedSet -> Property+prop_intersectionIdempotent (SortedSet a) =+ lso And a a === a++prop_unionIdempotent :: SortedSet -> Property+prop_unionIdempotent (SortedSet a) =+ lso Or a a === a++prop_differenceEmpty :: SortedSet -> Property+prop_differenceEmpty (SortedSet a) =+ lso Difference a a === []++prop_intersectionEmptyRight :: SortedSet -> Property+prop_intersectionEmptyRight (SortedSet a) =+ lso And a [] === []++prop_unionEmptyRight :: SortedSet -> Property+prop_unionEmptyRight (SortedSet a) =+ lso Or a [] === a++prop_differenceEmptyRight :: SortedSet -> Property+prop_differenceEmptyRight (SortedSet a) =+ lso Difference a [] === a++prop_symdiffEquivalence :: SortedSet -> SortedSet -> Property+prop_symdiffEquivalence (SortedSet a) (SortedSet b) =+ lso SymmetricDifference a b+ === lso Or (lso Difference a b) (lso Difference b a)
+ test/UnitTests.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Test.Tasty+import Test.Tasty.HUnit++import qualified Data.Text.Lazy as T+import qualified Data.ByteString.Lazy.Char8 as BC++import PerformOperations (linesSetOperation, operatorTools)+import SetData+import SimpleDefinitionCycles (getCyclesInSimpleDefinitions)+import DuplicateElimination (eliminateDuplicates, orderDefinitions)+import SetInput (parse)++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "setdown"+ [ testGroup "set operations"+ [ intersectionTests+ , unionTests+ , differenceTests+ , symmetricDifferenceTests+ ]+ , cycleDetectionTests+ , duplicateEliminationTests+ , parseTests+ ]++-- ---------------------------------------------------------------------------+-- Helpers+-- ---------------------------------------------------------------------------++lso :: Operator -> [T.Text] -> [T.Text] -> [T.Text]+lso op = linesSetOperation (operatorTools op)++mkDef :: String -> SimpleExpression -> Bool -> SimpleDefinition+mkDef name expr retain = SimpleDefinition (T.pack name) expr retain++mkFileExpr :: FilePath -> SimpleExpression+mkFileExpr = SimpleUnaryExpression . BaseFileExpression++mkIdentExpr :: String -> SimpleExpression+mkIdentExpr = SimpleUnaryExpression . BaseIdentifierExpression . T.pack++-- ---------------------------------------------------------------------------+-- Intersection+-- ---------------------------------------------------------------------------++intersectionTests :: TestTree+intersectionTests = testGroup "intersection"+ [ testCase "disjoint sets → empty" $+ lso And ["a", "b"] ["c", "d"] @?= []+ , testCase "identical sets → same set" $+ lso And ["a", "b", "c"] ["a", "b", "c"] @?= ["a", "b", "c"]+ , testCase "partial overlap → common elements" $+ lso And ["a", "b", "c"] ["b", "c", "d"] @?= ["b", "c"]+ , testCase "empty left → empty" $+ lso And [] ["a", "b"] @?= []+ , testCase "empty right → empty" $+ lso And ["a", "b"] [] @?= []+ , testCase "both empty → empty" $+ lso And [] [] @?= []+ , testCase "single shared element" $+ lso And ["x"] ["x"] @?= ["x"]+ ]++-- ---------------------------------------------------------------------------+-- Union+-- ---------------------------------------------------------------------------++unionTests :: TestTree+unionTests = testGroup "union"+ [ testCase "disjoint sets → all elements" $+ lso Or ["a", "b"] ["c", "d"] @?= ["a", "b", "c", "d"]+ , testCase "identical sets → same set (no duplicates)" $+ lso Or ["a", "b", "c"] ["a", "b", "c"] @?= ["a", "b", "c"]+ , testCase "partial overlap → all unique elements" $+ lso Or ["a", "b", "c"] ["b", "c", "d"] @?= ["a", "b", "c", "d"]+ , testCase "empty left → right" $+ lso Or [] ["a", "b"] @?= ["a", "b"]+ , testCase "empty right → left" $+ lso Or ["a", "b"] [] @?= ["a", "b"]+ , testCase "both empty → empty" $+ lso Or [] [] @?= []+ ]++-- ---------------------------------------------------------------------------+-- Difference+-- ---------------------------------------------------------------------------++differenceTests :: TestTree+differenceTests = testGroup "difference"+ [ testCase "disjoint sets → left unchanged" $+ lso Difference ["a", "b"] ["c", "d"] @?= ["a", "b"]+ , testCase "identical sets → empty" $+ lso Difference ["a", "b"] ["a", "b"] @?= []+ , testCase "remove one element from middle" $+ lso Difference ["a", "b", "c"] ["b"] @?= ["a", "c"]+ , testCase "empty left → empty" $+ lso Difference [] ["a", "b"] @?= []+ , testCase "empty right → left unchanged" $+ lso Difference ["a", "b"] [] @?= ["a", "b"]+ , testCase "A - B ≠ B - A (not commutative)" $ do+ lso Difference ["a", "b"] ["a"] @?= ["b"]+ lso Difference ["a"] ["a", "b"] @?= []+ ]++-- ---------------------------------------------------------------------------+-- Symmetric difference+-- ---------------------------------------------------------------------------++symmetricDifferenceTests :: TestTree+symmetricDifferenceTests = testGroup "symmetric difference"+ [ testCase "identical sets → empty" $+ lso SymmetricDifference ["a", "b"] ["a", "b"] @?= []+ , testCase "disjoint sets → all elements" $+ lso SymmetricDifference ["a", "b"] ["c", "d"] @?= ["a", "b", "c", "d"]+ , testCase "partial overlap → non-shared elements" $+ lso SymmetricDifference ["a", "b", "c"] ["b", "c", "d"] @?= ["a", "d"]+ , testCase "empty left → right" $+ lso SymmetricDifference [] ["a", "b"] @?= ["a", "b"]+ , testCase "empty right → left" $+ lso SymmetricDifference ["a", "b"] [] @?= ["a", "b"]+ , testCase "commutative: A >< B = B >< A" $+ lso SymmetricDifference ["a", "c"] ["b", "c"]+ @?= lso SymmetricDifference ["b", "c"] ["a", "c"]+ , testCase "equivalent to (A - B) ∪ (B - A)" $+ let a = ["a", "b", "c"]+ b = ["b", "c", "d"]+ in lso SymmetricDifference a b+ @?= lso Or (lso Difference a b) (lso Difference b a)+ ]++-- ---------------------------------------------------------------------------+-- Cycle detection+-- ---------------------------------------------------------------------------++cycleDetectionTests :: TestTree+cycleDetectionTests = testGroup "cycle detection"+ [ testCase "single file definition has no cycle" $+ getCyclesInSimpleDefinitions+ [mkDef "A" (mkFileExpr "a.txt") True]+ @?= []+ , testCase "linear chain has no cycle" $+ getCyclesInSimpleDefinitions+ [ mkDef "A" (mkFileExpr "a.txt") True+ , mkDef "B" (mkIdentExpr "A") True+ ]+ @?= []+ , testCase "independent definitions have no cycle" $+ getCyclesInSimpleDefinitions+ [ mkDef "A" (mkFileExpr "a.txt") True+ , mkDef "B" (mkFileExpr "b.txt") True+ ]+ @?= []+ , testCase "direct two-way cycle is detected" $+ let defs = [ mkDef "A" (SimpleBinaryExpression Or+ (BaseFileExpression "f.txt")+ (BaseIdentifierExpression (T.pack "B"))) True+ , mkDef "B" (mkIdentExpr "A") True+ ]+ in assertBool "expected cycle" (not . null $ getCyclesInSimpleDefinitions defs)+ , testCase "three-way cycle is detected" $+ let defs = [ mkDef "A" (mkIdentExpr "B") True+ , mkDef "B" (mkIdentExpr "C") True+ , mkDef "C" (mkIdentExpr "A") True+ ]+ in assertBool "expected cycle" (not . null $ getCyclesInSimpleDefinitions defs)+ ]++-- ---------------------------------------------------------------------------+-- Duplicate elimination+-- ---------------------------------------------------------------------------++duplicateEliminationTests :: TestTree+duplicateEliminationTests = testGroup "duplicate elimination"+ [ testCase "distinct expressions → count unchanged" $+ let defs = [ mkDef "A" (mkFileExpr "a.txt") True+ , mkDef "B" (mkFileExpr "b.txt") True+ ]+ in length (eliminateDuplicates defs) @?= 2+ , testCase "identical expressions → one definition kept" $+ let expr = mkFileExpr "a.txt"+ defs = [ mkDef "A" expr True+ , mkDef "B" expr True+ ]+ in length (eliminateDuplicates defs) @?= 1+ , testCase "orderDefinitions canonicalises commutative operand order" $+ let before = SimpleBinaryExpression And+ (BaseIdentifierExpression (T.pack "Z"))+ (BaseIdentifierExpression (T.pack "A"))+ expected = SimpleBinaryExpression And+ (BaseIdentifierExpression (T.pack "A"))+ (BaseIdentifierExpression (T.pack "Z"))+ results = orderDefinitions [mkDef "X" before True]+ in case results of+ [r] -> sdExpression r @?= expected+ _ -> assertFailure "expected exactly one definition"+ ]++-- ---------------------------------------------------------------------------+-- Parsing+-- ---------------------------------------------------------------------------++parseTests :: TestTree+parseTests = testGroup "parse"+ [ testCase "single file expression" $+ length (parse (BC.pack "A: \"a.txt\"")) @?= 1+ , testCase "two definitions" $+ length (parse (BC.pack "A: \"a.txt\"\nB: \"b.txt\"")) @?= 2+ , testCase "intersection expression" $+ length (parse (BC.pack "A: \"a.txt\" /\\ \"b.txt\"")) @?= 1+ , testCase "union expression" $+ length (parse (BC.pack "A: \"a.txt\" \\/ \"b.txt\"")) @?= 1+ , testCase "difference expression" $+ length (parse (BC.pack "A: \"a.txt\" - \"b.txt\"")) @?= 1+ , testCase "symmetric difference expression" $+ length (parse (BC.pack "A: \"a.txt\" >< \"b.txt\"")) @?= 1+ , testCase "bracketed expression" $+ length (parse (BC.pack "A: (\"a.txt\" /\\ \"b.txt\")")) @?= 1+ , testCase "comment is ignored" $+ length (parse (BC.pack "-- just a comment\nA: \"a.txt\"")) @?= 1+ ]