setdown-0.1.0.4: Main.hs
{-# LANGUAGE DeriveDataTypeable #-}
module Main where
import qualified Data.ByteString.Lazy as B
import qualified Data.Set as S
import qualified Data.Text.Lazy.IO as T
import System.Console.CmdArgs
import System.Exit
import Control.Monad (filterM, forM_, unless)
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)
import System.FilePath (dropFileName, (</>))
-- 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
} deriving (Show, Data, Typeable)
options :: Options
options = Options
{ outputDirectory = def
&= explicit
&= name "output"
&= typDir
&= help "The directory in which to place the output contents. Relative to your .setdown file."
&= opt "output"
, setdownFile = def
&= explicit
&= name "input"
&= help "The setdown definition file that contains all of the set operations that should be performed."
&= typ "definitions.setdown"
}
&= program "setdown"
&= summary "setdown allows you to perform set operations on multiple files efficiently using an intuitive language."
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
-- 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
-- Step 0: Verify that the definitions are well defined and that the referenced files exist
-- relative to the file that we pass in.
printNewline
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 . 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
putStrLn "DONE:"
printSimpleDefinitions simpleSetData
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 "==> Copying and Sorting all 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
printSortResults sortedFiles
printNewline
putStrLn "==> Computing set operations between the files..."
-- 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: Print out the final statistics with the defitions pointing to how many elements that
-- each contained and where to find their output files.
printComputedResults computedFiles
filesNotFound :: [FilePath] -> IO [FilePath]
filesNotFound = filterM (\x -> not <$> doesFileExist 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 ++ "\""
printComputedResults :: [(SimpleDefinition, FilePath)] -> IO ()
printComputedResults results = do
unless (null tempResults) $ do
putStrLn "Transient results:"
printResults tempResults
printNewline
unless (null retainResults) $ do
putStrLn "Required results:"
printResults retainResults
where
(retainResults, tempResults) = partition (sdRetain . fst) results
printResults = sequence_ . intersperse printNewline . fmap printComputedResult
printComputedResult :: (SimpleDefinition, FilePath) -> IO ()
printComputedResult (SimpleDefinition ident _ _, fp) = do
printIdentifier ident
putStr ": "
putStrLn fp
printIdentifier :: Identifier -> IO ()
printIdentifier = T.putStr
printNewline :: IO ()
printNewline = putStrLn ""