diff --git a/Context.hs b/Context.hs new file mode 100644 --- /dev/null +++ b/Context.hs @@ -0,0 +1,35 @@ +module Context + ( Context(..) + , standardContext + , smallContext + , prepareContext + , inOutput + ) where + +import Data.Int +import System.FilePath (()) +import System.Directory (createDirectoryIfMissing) + +data Context = Context + { cBaseDir :: FilePath + , cOutputDir :: FilePath + , cFilesPerMerge :: Int + , cBytesPerFileSplit :: Int64 + } deriving (Show, Eq) + +smallContext :: Context +smallContext = standardContext { cBytesPerFileSplit = 1000 } + +standardContext :: Context +standardContext = Context + { cBaseDir = "./" + , cOutputDir = "output" + , cFilesPerMerge = 10 + , cBytesPerFileSplit = 100 * 1024 * 1024 + } + +prepareContext :: Context -> IO () +prepareContext ctx = createDirectoryIfMissing True (cOutputDir ctx) + +inOutput :: Context -> FilePath -> FilePath +inOutput ctx fp = cOutputDir ctx fp diff --git a/DefinitionHelpers.hs b/DefinitionHelpers.hs new file mode 100644 --- /dev/null +++ b/DefinitionHelpers.hs @@ -0,0 +1,27 @@ +module DefinitionHelpers + ( extractIdsFromDefinitions + , extractFilenamesFromDefinitions + , extractDefinedIds + ) where + +import SetData +import qualified Data.Set as S + +extractIdsFromExpression :: Expression -> S.Set Identifier +extractIdsFromExpression (BinaryExpression _ a b) = extractIdsFromExpression a `S.union` extractIdsFromExpression b +extractIdsFromExpression (FileExpression _) = S.empty +extractIdsFromExpression (IdentifierExpression i) = S.singleton i + +extractIdsFromDefinitions :: Definitions -> S.Set Identifier +extractIdsFromDefinitions = foldr S.union S.empty . fmap (extractIdsFromExpression . definitionExpression) + +extractFilenamesFromExpression :: Expression -> S.Set FilePath +extractFilenamesFromExpression (BinaryExpression _ a b) = extractFilenamesFromExpression a `S.union` extractFilenamesFromExpression b +extractFilenamesFromExpression (FileExpression fn) = S.singleton fn +extractFilenamesFromExpression (IdentifierExpression _) = S.empty + +extractFilenamesFromDefinitions :: Definitions -> S.Set FilePath +extractFilenamesFromDefinitions = foldr S.union S.empty . fmap (extractFilenamesFromExpression . definitionExpression) + +extractDefinedIds :: Definitions -> S.Set Identifier +extractDefinedIds = S.fromList . fmap definitionId diff --git a/DuplicateElimination.hs b/DuplicateElimination.hs new file mode 100644 --- /dev/null +++ b/DuplicateElimination.hs @@ -0,0 +1,72 @@ +module DuplicateElimination + ( eliminateDuplicates + , orderDefinitions + ) where + +import SetData +import Data.Ord (comparing) +import Data.List (sort, sortBy, groupBy, partition) +import Data.Function (on) +import qualified Data.Set as S + +eliminateDuplicates :: SimpleDefinitions -> SimpleDefinitions +eliminateDuplicates sds = sort . flip updateWithDuplicates sds $ findDuplicates sds + +updateWithDuplicates :: [Duplicates] -> SimpleDefinitions -> SimpleDefinitions +updateWithDuplicates ds sds = S.toList $ foldr updateWithDuplicate (S.fromList sds) ds + +-- TODO we now want to find all of the duplicates +-- There are three scenarios that we need to consider: +-- 0 Retain dupes: we can randomly select a node to be the remainder and replace references to the +-- rest +-- 1 Retain dupes: we select the retain dupe and point all of the other dupes to it +-- 2+ Retain dupes: we select a retain dupe and point the other retain dupes to it and replace all +-- of the other dupes with it +updateWithDuplicate :: Duplicates -> S.Set SimpleDefinition -> S.Set SimpleDefinition +updateWithDuplicate (Duplicates [] []) sds = sds +updateWithDuplicate dupes sds = S.insert retainDupe cleanedDefs + where + cleanedDefs = S.map (replaceIds newId oldIds) remainingDefs + remainingDefs = sds S.\\ S.fromList discardDupes + newId = sdId retainDupe + oldIds = S.fromList . fmap sdId $ discardDupes + (retainDupe : discardDupes) = dupRetain dupes ++ dupDiscontinue dupes + +replaceIds :: Identifier -> S.Set Identifier -> SimpleDefinition -> SimpleDefinition +replaceIds newId oldIds (SimpleDefinition ident expr retain) = SimpleDefinition ident (replaceIdsInExpression newId oldIds expr) retain + +replaceIdsInExpression :: Identifier -> S.Set Identifier -> SimpleExpression -> SimpleExpression +replaceIdsInExpression newId oldIds (SimpleUnaryExpression be) = SimpleUnaryExpression (replaceIdsInBaseExpression newId oldIds be) +replaceIdsInExpression newId oldIds (SimpleBinaryExpression op left right) = SimpleBinaryExpression op (replace left) (replace right) + where + replace = replaceIdsInBaseExpression newId oldIds + +replaceIdsInBaseExpression :: Identifier -> S.Set Identifier -> BaseExpression -> BaseExpression +replaceIdsInBaseExpression _ _ be@(BaseFileExpression {}) = be +replaceIdsInBaseExpression newId oldIds be@(BaseIdentifierExpression ident) = if ident `S.member` oldIds then BaseIdentifierExpression newId else be + +findDuplicates :: SimpleDefinitions -> [Duplicates] +findDuplicates = fmap toDuplicates . filter (\x -> length x > 1) . groupBy ((==) `on` sdExpression) + +toDuplicates :: SimpleDefinitions -> Duplicates +toDuplicates = uncurry Duplicates . partition sdRetain + +data Duplicates = Duplicates + { dupRetain :: SimpleDefinitions + , dupDiscontinue :: SimpleDefinitions + } deriving (Show) + +orderDefinitions :: SimpleDefinitions -> SimpleDefinitions +orderDefinitions = sortBy (comparing sdExpression) . fmap orderDefinition + +orderDefinition :: SimpleDefinition -> SimpleDefinition +orderDefinition sd = sd { sdExpression = orderExpression . sdExpression $ sd } + +orderExpression :: SimpleExpression -> SimpleExpression +orderExpression se@(SimpleUnaryExpression {}) = se +orderExpression se@(SimpleBinaryExpression op left right) = if operatorIsCommutative op && right < left then SimpleBinaryExpression op right left else se + +operatorIsCommutative :: Operator -> Bool +operatorIsCommutative And = True +operatorIsCommutative Or = True +operatorIsCommutative Difference = False diff --git a/ExpressionConversion.hs b/ExpressionConversion.hs new file mode 100644 --- /dev/null +++ b/ExpressionConversion.hs @@ -0,0 +1,68 @@ +module ExpressionConversion + ( complexToSimpleDefinitions + ) where + +import SetData +import DefinitionHelpers +import Control.Monad.State +import qualified Data.Text.Lazy as T +import Data.Maybe (catMaybes) +import qualified Data.Set as S + +data TransitionState = TS + { tsCount :: Integer + , tsUsedIds :: S.Set Identifier + } deriving (Show) + +type ConvState = State TransitionState + +complexToSimpleDefinitions :: Definitions -> SimpleDefinitions +complexToSimpleDefinitions defs = evalState (fromDefinitions defs) initialState + where + initialState = TS + { tsCount = 0 + , tsUsedIds = extractDefinedIds defs + } + +fromDefinitions :: Definitions -> ConvState SimpleDefinitions +fromDefinitions defs = do + definitions <- mapM fromDefinition defs + return . concat $ definitions + +fromDefinition :: Definition -> ConvState SimpleDefinitions +fromDefinition (Definition ident expression) = do + (expr, conv) <- convertExpression expression + return $ SimpleDefinition ident expr True : conv + +convertExpression :: Expression -> ConvState (SimpleExpression, SimpleDefinitions) +convertExpression (IdentifierExpression ident) = return (SimpleUnaryExpression (BaseIdentifierExpression ident), []) +convertExpression (FileExpression filePath) = return (SimpleUnaryExpression (BaseFileExpression filePath), []) +convertExpression (BinaryExpression op left right) = do + (leftExp, leftConv) <- convertExpression left + (rightExp, rightConv) <- convertExpression right + (leftBase, leftDef) <- defFromExpression leftExp + (rightBase, rightDef) <- defFromExpression rightExp + return (SimpleBinaryExpression op leftBase rightBase, catMaybes [leftDef, rightDef] ++ leftConv ++ rightConv) + +defFromExpression :: SimpleExpression -> ConvState (BaseExpression, Maybe SimpleDefinition) +defFromExpression (SimpleUnaryExpression be) = return (be, Nothing) +defFromExpression se@(SimpleBinaryExpression {}) = do + defId <- getIdThenIncrement + let newDef = SimpleDefinition defId se False + return (BaseIdentifierExpression defId, Just newDef) + +getIdThenIncrement :: ConvState Identifier +getIdThenIncrement = do + original <- get + let (intId, ident) = head . filter (\x -> snd x `S.notMember` tsUsedIds original) . fmap withId . thisAndFurther . tsCount $ original + put $ original { tsCount = intId + 1 } + return ident + +withId :: Integer -> (Integer, Identifier) +withId x = (x, integerToId x) + +thisAndFurther :: Integer -> [Integer] +thisAndFurther = iterate (+1) + +integerToId :: Integer -> Identifier +integerToId = T.pack . show diff --git a/ExternalSort.hs b/ExternalSort.hs new file mode 100644 --- /dev/null +++ b/ExternalSort.hs @@ -0,0 +1,105 @@ +module ExternalSort + ( extractAndSortFiles + , extractAndSortFile + , splitSortAndMerge + ) where + +import Data.List (sort, groupBy) +import Data.Int +import Data.Maybe (catMaybes) +import qualified Data.UUID.V4 as UUID +import Data.List.Split (chunksOf) +import Control.Monad (forM) +import System.FilePath (()) +import Control.Arrow (second) +import Control.Applicative +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.IO as T + +import Context + +extractAndSortFiles :: Context -> [FilePath] -> IO [(FilePath, FilePath)] +extractAndSortFiles ctx = mapM (extractAndSortFile ctx) + +extractAndSortFile :: Context -> FilePath -> IO (FilePath, FilePath) +extractAndSortFile ctx fp = do + resultFile <- splitSortAndMerge ctx fp + return (fp, resultFile) + +splitSortAndMerge :: Context -> FilePath -> IO FilePath +splitSortAndMerge ctx fp = mergeFiles ctx =<< splitAndSort ctx fp + +splitAndSort :: Context -> FilePath -> IO [FilePath] +splitAndSort ctx fp = do + splits <- splitFile ctx fp + mapM simpleFileSort splits + +simpleFileSort :: FilePath -> IO FilePath +simpleFileSort fp = do + T.writeFile sfp . T.unlines . sort . T.lines =<< T.readFile fp + return sfp + where + sfp = fp ++ ".sorted" + +accLines :: [T.Text] -> [(T.Text, Int64)] +accLines = go 0 + where + go :: Int64 -> [T.Text] -> [(T.Text, Int64)] + go _ [] = [] + go start (x:xs) = (x, start) : go (start + T.length x) xs + +chunkGroup :: Integral a => a -> (b, a) -> (b, a) +chunkGroup size = second (`div` size) + +sameChunk :: Eq b => (a, b) -> (a, b) -> Bool +sameChunk (_, a) (_, b) = a == b + +splitFile :: Context -> FilePath -> IO [FilePath] +splitFile ctx inputFile = do + contents <- T.readFile (withBaseDir ctx inputFile) + -- TODO replace constants with the context + let splitContents = fmap (T.unlines . fmap fst) . groupBy sameChunk . fmap (chunkGroup . cBytesPerFileSplit $ ctx) . accLines . T.lines $ contents + let namesAndContents = zip names splitContents + sequence_ . fmap (uncurry T.writeFile) $ namesAndContents + return . fmap fst $ namesAndContents + where + names = map (\num -> cOutputDir ctx inputFile ++ "." ++ show num ++ ".split") [(1 :: Integer)..] + +mergeFiles :: Context -> [FilePath] -> IO FilePath +mergeFiles _ [] = error "Tried to merge no files..." +mergeFiles _ [f] = return f -- TODO rename to something sensible +mergeFiles ctx fps = do + let mergeFilepaths = chunksOf (cFilesPerMerge ctx) fps -- [[FilePath]] + mergedFiles <- forM mergeFilepaths (directMergeFiles ctx) + mergeFiles ctx mergedFiles + +directMergeFiles :: Context -> [FilePath] -> IO FilePath +directMergeFiles ctx fps = do + fileContents <- fmap T.lines <$> mapM T.readFile fps + randomFilename <- fmap show UUID.nextRandom + let newFile = cOutputDir ctx randomFilename + writeFileLines newFile . merge $ fileContents + return newFile + +writeFileLines :: FilePath -> [T.Text] -> IO () +writeFileLines f = T.writeFile f . T.unlines + +merge :: [[T.Text]] -> [T.Text] +merge xs = case minHead xs of + Nothing -> [] + Just x -> x : merge (remainders x xs) + +remainders :: T.Text -> [[T.Text]] -> [[T.Text]] +remainders x = fmap (dropWhile (== x)) + +minHead :: [[T.Text]] -> Maybe T.Text +minHead fs = case catMaybes $ fmap safeHead fs of + [] -> Nothing + xs -> Just . minimum $ xs + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x:_) = Just x + +withBaseDir :: Context -> FilePath -> FilePath +withBaseDir ctx fp = cBaseDir ctx fp diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Robert Massaioli + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Robert Massaioli nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Main where + +import System.Console.CmdArgs +import qualified Data.ByteString.Lazy as B +import qualified Data.Text.Lazy.IO as T +import qualified Data.Set as S +import System.Exit + +import Control.Monad (unless, forM_, filterM) +import Data.List (intersperse, partition) +import Data.Maybe (fromMaybe) +import Control.Applicative + +import SetData +import SetInput +import SetInputVerification +import Context +import ExternalSort +import PrintDefinition +import ExpressionConversion +import DefinitionHelpers + +import DuplicateElimination +import PerformOperations +import SimpleDefinitionCycles + +import System.Directory (doesFileExist) +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 :: 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 + &= typ "definitions.setdown" + &= argPos 0 + } + &= program "setdown" + &= summary "setdown allows you to perform set operations on multiple files efficiently using an intuitive language." + +-- TODO the setdownFile should be optional, at which point we should search the current directory +-- for one +main :: IO () +main = do + opts <- cmdArgs options + + let inputFilePath = setdownFile opts + inputFileExists <- doesFileExist inputFilePath + unless inputFileExists $ do + putStrLn $ "Error: The given setdown file did not exist: " ++ inputFilePath + exitWith (ExitFailure 1) + + -- 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 . setdownFile $ opts) + 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 "" diff --git a/PerformOperations.hs b/PerformOperations.hs new file mode 100644 --- /dev/null +++ b/PerformOperations.hs @@ -0,0 +1,118 @@ +module PerformOperations (runSimpleDefinitions) where + +import Control.Arrow (first) +import Control.Applicative +import Control.Monad.State.Lazy +import Context +import SetData +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.IO as T +import qualified Data.Map as M +import qualified Data.UUID.V4 as UUID + +data ComputeState = CS + { expressionToFile :: M.Map BaseExpression FilePath + , definitionMap :: M.Map Identifier SimpleDefinition + , csContext :: Context + } + +runSimpleDefinitions :: Context -> SimpleDefinitions -> [(FilePath, FilePath)] -> IO [(SimpleDefinition, FilePath)] +runSimpleDefinitions context defs sortedFileMapping = fst <$> runStateT (computeSimpleDefinitions defs) cs + where + cs = CS + { expressionToFile = setupExpressionsToFile sortedFileMapping + , definitionMap = toDefinitionMap defs + , csContext = context + } + +toDefinitionMap :: SimpleDefinitions -> M.Map Identifier SimpleDefinition +toDefinitionMap = M.fromList . fmap (\x -> (sdId x, x)) + +setupExpressionsToFile :: [(FilePath, FilePath)] -> M.Map BaseExpression FilePath +setupExpressionsToFile = M.fromList . fmap (first BaseFileExpression) + +computeSimpleDefinitions :: SimpleDefinitions -> StateT ComputeState IO [(SimpleDefinition, FilePath)] +computeSimpleDefinitions = mapM csd + where + csd :: SimpleDefinition -> StateT ComputeState IO (SimpleDefinition, FilePath) + csd sd = do + resultFile <- computeSimpleDefinition sd + return (sd, resultFile) + +-- Always return the file that should be used for the next computation +computeSimpleDefinition :: SimpleDefinition -> StateT ComputeState IO FilePath +computeSimpleDefinition (SimpleDefinition ident (SimpleUnaryExpression be) _) = do + newFile <- computeBaseExpression be + mapIdToFile ident newFile + return newFile +computeSimpleDefinition (SimpleDefinition ident (SimpleBinaryExpression op left right) _) = do + leftFile <- computeBaseExpression left + rightFile <- computeBaseExpression right + ctx <- csContext <$> get + resultFile <- lift $ fileSetOperation ctx op leftFile rightFile + mapIdToFile ident resultFile + return resultFile + +computeBaseExpression :: BaseExpression -> StateT ComputeState IO FilePath +computeBaseExpression be@(BaseFileExpression fp) = do + expressionMap <- expressionToFile <$> get + case M.lookup be expressionMap of + Just sortedFile -> return sortedFile + Nothing -> fail $ "Could not find a sorted file for: " ++ fp +computeBaseExpression be@(BaseIdentifierExpression ident) = do + cs <- get + case M.lookup be (expressionToFile cs) of + Just preComputedFile -> return preComputedFile + Nothing -> case M.lookup ident (definitionMap cs) of + Nothing -> fail $ "Could not find a definition for the identifier: " ++ T.unpack ident + Just def -> computeSimpleDefinition def + +mapIdToFile :: Monad a => Identifier -> FilePath -> StateT ComputeState a () +mapIdToFile ident fp = modify (\currentState -> currentState + { expressionToFile = M.insert (BaseIdentifierExpression ident) fp (expressionToFile currentState) + }) + +fileSetOperation :: Context -> Operator -> FilePath -> FilePath -> IO FilePath +fileSetOperation ctx ot leftFp rightFp = do + leftContents <- T.lines <$> T.readFile leftFp + rightContents <- T.lines <$> T.readFile rightFp + let mergedContents = linesSetOperation (operatorTools ot) leftContents rightContents + randomFilename <- randomFilenameInOutput ctx + T.writeFile randomFilename . T.unlines $ mergedContents + return randomFilename + +randomFilenameInOutput :: Context -> IO FilePath +randomFilenameInOutput ctx = inOutput ctx . show <$> UUID.nextRandom + +linesSetOperation :: OperatorTools T.Text -> [T.Text] -> [T.Text] -> [T.Text] +linesSetOperation ot = go + where + go :: [T.Text] -> [T.Text] -> [T.Text] + go [] [] = [] + go xs [] = if otKeepRemainderLeft ot then xs else [] + go [] xs = if otKeepRemainderRight ot then xs else [] + go left@(l:ls) right@(r:rs) = + if (otCompare ot) l r + then chosen : go (dropWhileChosen left) (dropWhileChosen right) + else case compare l r of + LT -> go ls right + EQ -> go ls rs + GT -> go left rs + where + chosen = (otChoose ot) l r + dropWhileChosen = dropWhile (== chosen) + +data (Eq a, Ord a) => OperatorTools a = OT + { otCompare :: a -> a -> Bool + , otChoose :: a -> a -> a + , otKeepRemainderLeft :: Bool + , otKeepRemainderRight :: Bool + } + +operatorTools :: Ord a => Operator -> OperatorTools a +operatorTools And = OT (==) const False False -- fst or snd, it does not matter they are equal +operatorTools Or = OT (const2 True) min True True +operatorTools Difference = OT (<) const True False + +const2 :: a -> b -> c -> a +const2 = const . const diff --git a/PrintDefinition.hs b/PrintDefinition.hs new file mode 100644 --- /dev/null +++ b/PrintDefinition.hs @@ -0,0 +1,85 @@ +module PrintDefinition + ( printDefinitions + , printDefinition + , printSimpleDefinitions + , printSimpleDefinition + ) where + +import SetData +import Data.List (intersperse) +import qualified Data.Text.Lazy.IO as T + +-- Complex Definition Printing +printDefinitions :: Definitions -> IO () +printDefinitions = sequence_ . intersperse printNewline . fmap printDefinition + +printDefinition :: Definition -> IO () +printDefinition (Definition ident expression) = do + printId ident + putStr ": " + printExpression expression + printNewline + +printExpression :: Expression -> IO () +printExpression (FileExpression fp) = putStr $ "\"" ++ fp ++ "\"" +printExpression (IdentifierExpression ident) = printId ident +printExpression (BinaryExpression op left right) = do + printSubExpression left + putStr " " + printOperator op + putStr " " + printSubExpression right + where + printSubExpression expr = maybeWrapInBrackets (isBinaryExpression expr) (printExpression expr) + + +-- Simple Definition Printing +printSimpleDefinitions :: SimpleDefinitions -> IO () +printSimpleDefinitions = sequence_ . intersperse printNewline . fmap printSimpleDefinition + +printSimpleDefinition :: SimpleDefinition -> IO () +printSimpleDefinition (SimpleDefinition ident se _) = do + printId ident + putStr ": " + printSimpleExpression se + printNewline + +printSimpleExpression :: SimpleExpression -> IO () +printSimpleExpression (SimpleUnaryExpression be) = printBaseExpression be +printSimpleExpression (SimpleBinaryExpression op left right) = do + printBaseExpression left + putStr " " + printOperator op + putStr " " + printBaseExpression right + +printBaseExpression :: BaseExpression -> IO () +printBaseExpression (BaseIdentifierExpression ident) = printId ident +printBaseExpression (BaseFileExpression fp) = putStr $ "\"" ++ fp ++ "\"" + +-- Common Printing Code +maybeWrapInBrackets :: Bool -> IO () -> IO () +maybeWrapInBrackets True = wrapInBrackets +maybeWrapInBrackets False = id + +wrapInBrackets :: IO () -> IO () +wrapInBrackets printAction = do + putStr "(" + printAction + putStr ")" + +printOperator :: Operator -> IO () +printOperator And = putStr "/\\" +printOperator Or = putStr "\\/" +printOperator Difference = putStr "-" + +printId :: Identifier -> IO () +printId = T.putStr + +printNewline :: IO () +printNewline = putStrLn "" + +-- TODO Move this out to a utility class +isBinaryExpression :: Expression -> Bool +isBinaryExpression (BinaryExpression {}) = True +isBinaryExpression _ = False diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,153 @@ +# Setdown - Line based set manipulation + +Author: [Robert Massaioli][6] +Created in: 2015 + +## What is setdown and how does it work? + +Setdown is a command line tool for line based set operations. To use setdown you write a "setdown +definitions file" often suffixed with **.setdown**. If you are familiar with [Make][3] then you can think +of this **.setdown** file much like a Makefile. Inside that file you write a number of +definitions of the form: + + definitionName: "file-1.txt" /\ "file-2.txt" + +This line says that "definitionName" is a new set definition that is a label for the intersection of +"file-1.txt" and "file-2.txt". You can write more complicated expressions that this. + +### Example Setdown Projects + +You should read how setdown works in the sections below, however, if you wish to follow along by +using a few descriptions then you should [checkout the setdown-examples project][2] on BitBucket. + +### Input Files + +In setdown *each file is treated as a list of elements where each line +is an element*. You may have thought that each file would be treated as a Set of elements (no +duplicate lines). But I decided not to make this a requirement, this is because I don't assume that +you will give us sorted input with no duplicates or that it will be easy for you to do so. Instead +you can give us any file that you like and the first thing that setdown will do to those files is +sort them and remove duplicates; essentially turning them into sets. + +Another important point is that of relativity: specifically, if have a **.setdown** file that +references the input file "some-elements.txt" and I run the setdown executable from a directory that +is not the same directory as the **.setdown** file then where will setdown look for the +some-elements.txt file? The answer is that we always look for files relative to the **.setdown** +file. That is where you wrote your definitions so the paths are relative to that. It was designed in +this way so that you could run setdown from anywhere in the directory tree and still get the same +result. It was an important design of setdown that you always get the same result every time that you run it. +Setdown has been designed to be current working directory invariant, as opposed to many +other command line programs. Please keep this in mind. + +### Set Operations and Precidence + +In the setdown language there are a number of supported operators: + + - Intersection: /\ + - Union: \/ + - Difference: - + +For example, they might be used in the following way: + + definition: (A - B) \/ (C /\ D) + +You may be wondering what [operator precidence][1] the setdown language uses and the answer is: +there is no operator precidence at all, instead *you must clearly specify the precidence of nested +expressions with brackets*. This is very important because it will result in parsing errors +otherwise. To show you why I made this decision lets show you an example: + + -- Here is a simple expression + def: A /\ B \/ C + -- Now, should this be parsed as: + defV1: (A /\ B) \/ C + -- or as: + defV2: A /\ (B \/ C) + -- If you pretend that B is the empty set (E) then you can see that these expression evaluate + -- completely differently. If we simplify them with that assumption then they become: + defV1-bempty: E + defV2-bempty: A /\ C + +So as you can see, order of operations really matters for set operations. Because it is so critical +I decided to make the use of brackets mandatory. Sorry for the extra brackets but you will thank me +when you expressions come out exactly the way that you expect them to. + +### Comments + +In the setdown language you can add comments by writing a double-dash (--) and then writing the +comment till the end of the line. The following comments are valid: + + -- This is a definition for A, created because we wanted to do X + A: "y.txt" - "z.txt" + + -- This is an example of a comment halfway through an expression + B: (A \/ C) -- \/ D This is still a comment and \/ D never happens + +You can use comments to leave messages for any people that might read your setdown definitions in +the future. It may help explain to them what you were trying to do. + +### Writing your own definitions + +In the setdown language you can write a definition in the following format: + + : + +Where the definition name is the identifier that you give to that expression. An expression is the +application of set operations on identifiers or files. A practical example of what this looks like +should help cement what this means. Here is a valid setdown file: + + -- A is the intersection of the file b-1.out and the set B + A: "b-1.out" /\ B + + -- B is the union of the file a-1.out and a-2.out + B: "a-1.out" \/ "a-2.out" + + -- C is the difference of the file b-1.out and the set B + C: "b-1.out" - B + +Usually, when you write these definitions you put them in a file that has a suffix of **.setdown**. +You can then feed this file into the setdown executable like so: + + setdown path/to/mydefinitions.setdown + +For more information on the options that you can pass to the setdown executable try running + + setdown --help + +And good luck! + +## Building the code + +To build the code for this project just have [Haskell installed][4] and [cabal][5] and then: + + cabal sandbox init + cabal install + +And that should have the code built on your machine. Then, if you modify the code, just use cabal run to run setdown: + + cabal run -- --help + cabal run mydefinitions.setdown + +That is all that there is to it! + +## Contributing to the setdown project + +If you wish to contribute to the setdown project then please just: + + 1. Raise an issue with what you intend to fix / improve. + 1. Wait for Robert Massioli to get back to you and give you the thumbs up. If you get Robert + Massaioli's "merge approval" then that means that, if you write the code to Roberts satisfaction + then it will be merged in. + 1. Write the code. + 1. Raise a PR and ask Robert Massaioli to review it. (Maybe iterate a bit to get it cleaned up) + 1. Get it merged in. + 1. Celebrate! + +I would love to have contributions to the project and, even though it may look like a complicated +process just follow it because it is designed to make your life, and my life, easier. Cheers! + + [1]: http://en.wikipedia.org/wiki/Order_of_operations + [2]: https://bitbucket.org/robertmassaioli/setdown-examples + [3]: http://www.gnu.org/software/make/ + [4]: https://www.haskell.org/platform/ + [5]: https://www.haskell.org/cabal/ + [6]: https://robertmassaioli.wordpress.com/ diff --git a/SetData.hs b/SetData.hs new file mode 100644 --- /dev/null +++ b/SetData.hs @@ -0,0 +1,53 @@ +module SetData + ( Definitions + , Definition(..) + , Expression(..) + , Operator(..) + , Identifier + , SimpleDefinitions + , SimpleDefinition(..) + , SimpleExpression(..) + , BaseExpression(..) + ) where + +import qualified Data.Text.Lazy as TL + +type Definitions = [Definition] + +data Definition = Definition + { definitionId :: Identifier + , definitionExpression :: Expression + } deriving (Eq, Show) + +data Operator + = And + | Or + | Difference + deriving (Eq, Ord, Show) + +data Expression + = BinaryExpression Operator Expression Expression + | FileExpression FilePath + | IdentifierExpression Identifier + deriving (Eq, Show) + +type Identifier = TL.Text + +type SimpleDefinitions = [SimpleDefinition] + +data SimpleDefinition = SimpleDefinition + { sdId :: Identifier + , sdExpression :: SimpleExpression + , sdRetain :: Bool -- This is true if this is a definition that must be maintained + } deriving (Eq, Ord, Show) + +data SimpleExpression + = SimpleBinaryExpression Operator BaseExpression BaseExpression + | SimpleUnaryExpression BaseExpression + deriving (Eq, Ord, Show) + +data BaseExpression + = BaseFileExpression FilePath + | BaseIdentifierExpression Identifier + deriving (Eq, Ord, Show) + diff --git a/SetInput.hs b/SetInput.hs new file mode 100644 --- /dev/null +++ b/SetInput.hs @@ -0,0 +1,26 @@ +module SetInput + ( parse + ) where + +import SetData + +import qualified Data.ByteString.Lazy as BL +import qualified SetLanguage as SL +import qualified SetParser as SP + +parse :: BL.ByteString -> Definitions +parse = fmap fromParserDefinition . SP.parseSetLanguage . SL.alexScanTokens + +fromParserDefinition :: SP.Definition -> Definition +fromParserDefinition (SP.Definition (SP.Identifier name) expression) = Definition name (fromParserExpression expression) + +fromParserExpression :: SP.Expression -> Expression +fromParserExpression (SP.BinaryExp op a b) = BinaryExpression (fromParserOperator op) (fromParserExpression a) (fromParserExpression b) +fromParserExpression (SP.BrackExp a) = fromParserExpression a +fromParserExpression (SP.FilenameExp filename) = FileExpression filename +fromParserExpression (SP.IdentifierExp (SP.Identifier name)) = IdentifierExpression name + +fromParserOperator :: SP.SetOperator -> Operator +fromParserOperator SP.IntersectionOp = And +fromParserOperator SP.UnionOp = Or +fromParserOperator SP.DifferenceOp = Difference diff --git a/SetInputVerification.hs b/SetInputVerification.hs new file mode 100644 --- /dev/null +++ b/SetInputVerification.hs @@ -0,0 +1,30 @@ +module SetInputVerification where + +import qualified Data.Text.Lazy as TL +import Data.List +import qualified Data.Set as S +import SetData +import DefinitionHelpers + +-- TODO these functions should generate potential lists of error messages + +duplicateDefinitionName :: Definitions -> [TL.Text] +duplicateDefinitionName defs = fmap message problems + where + message :: [Identifier] -> TL.Text + message problem = TL.pack "Created multiple definitions for: " `TL.append` (TL.pack . show $ problem) + + problems = filter ((>1) . length) . group . sort . fmap definitionId $ defs + +unknownIdentifier :: Definitions -> [TL.Text] +unknownIdentifier defs = fmap message (S.toList nonDefinedIds) + where + message :: Identifier -> TL.Text + message problem = TL.pack "Attempted to use an identifier that has not been defined: " `TL.append` problem + + nonDefinedIds = usedIds S.\\ definitionIds + usedIds = extractIdsFromDefinitions defs + definitionIds = extractDefinedIds defs + +-- TODO add a function that searches through the list of files in the definition and returns an +-- error for all of the files that do not exist diff --git a/SetLanguage.x b/SetLanguage.x new file mode 100644 --- /dev/null +++ b/SetLanguage.x @@ -0,0 +1,43 @@ +{ +{-# OPTIONS_GHC -w #-} +module SetLanguage where + +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE +} + +%wrapper "basic-bytestring" + +$digit = [0-9] +$nonFilename = [^\\\/\?\%\*\:\|\<\>\ ] +$ident = [a-zA-Z0-9\-\_] + +tokens :- + + $white+ ; + "--".* ; + "(" { const LParenTok } + ")" { const RParenTok } + "/\" { const IntersectionTok } + "\/" { const UnionTok } + "∪" { const IntersectionTok } + "∩" { const UnionTok } + "-" { const DifferenceTok } + \"[^\"]+\" { FilenameTok . TL.unpack . TL.init . TL.tail . TLE.decodeUtf8 } + $ident+$white*":" { IdentifierDefinitionTok . TL.strip . TL.init . TLE.decodeUtf8 } + $ident+ { IdentifierTok . TLE.decodeUtf8 } + +{ +-- TODO include the location in which the token ocurred so that we can give better error messages +-- later in the parsing +data SetToken + = FilenameTok FilePath + | IdentifierDefinitionTok TL.Text + | IdentifierTok TL.Text + | IntersectionTok + | UnionTok + | DifferenceTok + | LParenTok + | RParenTok + deriving(Show, Eq) +} diff --git a/SetParser.y b/SetParser.y new file mode 100644 --- /dev/null +++ b/SetParser.y @@ -0,0 +1,70 @@ +{ +module SetParser where + +import SetLanguage +import qualified Data.Text.Lazy as TL +-- TODO add precidence of operators +-- TODO add comments to the language +-- TODO The tokens should come with line number information so that we can better pinpoint errors. +} + +%name parseSetLanguage +%tokentype { SetToken } +%error { parseError } + +%token + '(' { LParenTok } + ')' { RParenTok } + and { IntersectionTok } + or { UnionTok } + diff { DifferenceTok } + identifierDef { IdentifierDefinitionTok $$ } + identifier { IdentifierTok $$ } + filename { FilenameTok $$ } + +%% + +definitions : definition { [$1] } + | definitions definition { $2 : $1 } + +definition : identifierDef exp { Definition (Identifier $1) $2 } + +exp : baseexp { $1 } + | brackexp { $1 } + | baseorbrack operator baseorbrack { BinaryExp $2 $1 $3 } + +baseorbrack : baseexp { $1 } + | brackexp { $1 } + +brackexp : '(' exp ')' { BrackExp $2 } + +baseexp : filename { FilenameExp $1 } + | identifier { IdentifierExp (Identifier $1) } + +operator : and { IntersectionOp } + | or { UnionOp } + | diff { DifferenceOp } + +{ +parseError :: [SetToken] -> a +parseError tokens = error $ "Parse error: " ++ show tokens + +data SetOperator + = IntersectionOp + | UnionOp + | DifferenceOp + deriving(Show, Eq) + +data Identifier = Identifier + { idName :: TL.Text + } deriving(Show, Eq) + +data Expression + = BinaryExp SetOperator Expression Expression + | BrackExp Expression + | FilenameExp FilePath + | IdentifierExp Identifier + deriving(Show, Eq) + +data Definition = Definition Identifier Expression deriving (Show, Eq) +} diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/SimpleDefinitionCycles.hs b/SimpleDefinitionCycles.hs new file mode 100644 --- /dev/null +++ b/SimpleDefinitionCycles.hs @@ -0,0 +1,30 @@ +module SimpleDefinitionCycles + ( getCyclesInSimpleDefinitions + ) where + +import SetData +import qualified Data.Graph as G + +getCyclesInSimpleDefinitions :: SimpleDefinitions -> [SimpleDefinitions] +getCyclesInSimpleDefinitions = filter (not . null) . fmap getCycles . simpleDefinitionsToSCC + +getCycles :: G.SCC SimpleDefinition -> SimpleDefinitions +getCycles (G.CyclicSCC verticies) = verticies +getCycles _ = [] + +simpleDefinitionsToSCC :: SimpleDefinitions -> [G.SCC SimpleDefinition] +simpleDefinitionsToSCC = G.stronglyConnComp . fmap toNode + +toNode :: SimpleDefinition -> (SimpleDefinition, Identifier, [Identifier]) +toNode sd = (sd, sdId sd, getIdsFromSimpleDefinition sd) + +getIdsFromSimpleDefinition :: SimpleDefinition -> [Identifier] +getIdsFromSimpleDefinition (SimpleDefinition _ expr _) = getIdsFromSimpleExpression expr + +getIdsFromSimpleExpression :: SimpleExpression -> [Identifier] +getIdsFromSimpleExpression (SimpleBinaryExpression _ left right) = getIdsFromBaseExpression left ++ getIdsFromBaseExpression right +getIdsFromSimpleExpression (SimpleUnaryExpression expr) = getIdsFromBaseExpression expr + +getIdsFromBaseExpression :: BaseExpression -> [Identifier] +getIdsFromBaseExpression (BaseIdentifierExpression ident) = [ident] +getIdsFromBaseExpression _ = [] diff --git a/setdown.cabal b/setdown.cabal new file mode 100644 --- /dev/null +++ b/setdown.cabal @@ -0,0 +1,105 @@ +-- Initial setdown.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: setdown + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: Treating files as sets to perform rapid set manipulation. + +-- A longer description of the package. +description: There will be times when you have lots of set data and you want to perform many + set operations quickly and reliably, you will also want to be able to add new + data to your set operations and be able to run the same set operations with + little effort. This is the problem that setdown aims to solve. Setdown was + built with the intention that you would use it in conjunction with version + control tools to manage your set data and set description file. + +homepage: http://bitbucket.org/robertmassaioli/setdown +bug-reports: https://bitbucket.org/robertmassaioli/setdown/issues + +-- The license under which the package is released. +license: BSD3 + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Robert Massaioli + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: robertmassaioli@gmail.com + +-- A copyright notice. +copyright: (c) 2015 Robert Massaioli + +-- category: + +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a +-- README. +extra-source-files: README.markdown + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.10 + +source-repository head + 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 + , SetParser + , Context + , DefinitionHelpers + , DuplicateElimination + , ExpressionConversion + , ExternalSort + , Main + , PerformOperations + , PrintDefinition + , SetData + , SetInput + , 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 && <4.8 + -- Lexing dependencies + , array == 0.5.* + , bytestring == 0.10.4.* + , text == 1.2.* + -- , pretty-show == 1.6.* + -- Module Dependencies + , filepath >= 1.2 && < 2 + , directory >= 1.1 && < 2 + , containers == 0.5.* + , uuid == 1.3.* + , split == 0.2.* + , mtl == 2.2.* + , cmdargs == 0.10.* + + -- Directories containing source files. + -- hs-source-dirs: + + -- Base language which the package is written in. + default-language: Haskell2010 + + ghc-options: -Wall