diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 "" diff --git a/setdown.cabal b/setdown.cabal --- a/setdown.cabal +++ b/setdown.cabal @@ -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 diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -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 "" diff --git a/src/PerformOperations.hs b/src/PerformOperations.hs --- a/src/PerformOperations.hs +++ b/src/PerformOperations.hs @@ -1,4 +1,4 @@ -module PerformOperations (runSimpleDefinitions) where +module PerformOperations (runSimpleDefinitions, linesSetOperation, operatorTools, OperatorTools) where import Context import Control.Arrow (first) diff --git a/test/GoldenTests.hs b/test/GoldenTests.hs new file mode 100644 --- /dev/null +++ b/test/GoldenTests.hs @@ -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// 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//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] diff --git a/test/PropertyTests.hs b/test/PropertyTests.hs new file mode 100644 --- /dev/null +++ b/test/PropertyTests.hs @@ -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) diff --git a/test/UnitTests.hs b/test/UnitTests.hs new file mode 100644 --- /dev/null +++ b/test/UnitTests.hs @@ -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 + ]