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.2.0 +version: 0.1.3.0 -- A short (one-line) description of the package. synopsis: Treating files as sets to perform rapid set manipulation. @@ -42,7 +42,7 @@ -- A copyright notice. copyright: (c) 2015 Robert Massaioli --- category: +category: Data build-type: Simple @@ -82,19 +82,23 @@ -- Other library packages from which modules are imported. build-depends: base >=4.7 && < 5 -- Lexing dependencies - , array >= 0.5 - , bytestring >= 0.10.4 - , text >= 1.2 + , 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 - , containers >= 0.6 - , uuid >= 1.3 + , filepath >= 1.2 && < 3 + , directory >= 1.1 && < 3 + , containers >= 0.6 && < 0.8 + , uuid >= 1.3 && < 1.4 , split == 0.2.* - , mtl >= 2.2 - , cmdargs >= 0.10 - , table-layout >= 0.8 + , mtl >= 2.2 && < 2.4 + , 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 diff --git a/src/DuplicateElimination.hs b/src/DuplicateElimination.hs --- a/src/DuplicateElimination.hs +++ b/src/DuplicateElimination.hs @@ -69,6 +69,7 @@ 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 +operatorIsCommutative And = True +operatorIsCommutative Or = True +operatorIsCommutative Difference = False +operatorIsCommutative SymmetricDifference = True diff --git a/src/ExternalSort.hs b/src/ExternalSort.hs --- a/src/ExternalSort.hs +++ b/src/ExternalSort.hs @@ -9,7 +9,8 @@ import Data.Maybe (catMaybes) import qualified Data.UUID.V4 as UUID import Data.List.Split (chunksOf) -import Control.Monad (forM) +import Control.Monad (forM) +import Control.Concurrent.Async (mapConcurrently) import System.FilePath (()) import Control.Arrow (second) import qualified Data.Text.Lazy as T @@ -18,7 +19,7 @@ import Context extractAndSortFiles :: Context -> [FilePath] -> IO [(FilePath, FilePath)] -extractAndSortFiles ctx = mapM (extractAndSortFile ctx) +extractAndSortFiles ctx = mapConcurrently (extractAndSortFile ctx) extractAndSortFile :: Context -> FilePath -> IO (FilePath, FilePath) extractAndSortFile ctx fp = do diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} module Main where @@ -10,8 +11,9 @@ import System.Console.CmdArgs import System.Exit -import Control.Monad (filterM, forM_, unless) -import Control.Arrow (first) +import Control.Monad (filterM, forM, forM_, unless, when) +import Data.Word (Word8) + import Data.List (intersperse, isSuffixOf, partition) import Data.Maybe (fromMaybe) @@ -29,9 +31,13 @@ import SimpleDefinitionCycles import System.Directory (doesFileExist, getCurrentDirectory, - listDirectory) + 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 () @@ -154,7 +160,7 @@ mapM_ T.putStrLn xs exitWith (ExitFailure 12) - allFiles <- filesNotFound . S.toList . extractFilenamesFromDefinitions $ setData + 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) @@ -201,13 +207,39 @@ -- 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 + -- 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 computedFiles + printComputedResults opts annotatedFiles -filesNotFound :: [FilePath] -> IO [FilePath] -filesNotFound = filterM (\x -> not <$> doesFileExist x) +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 " " @@ -246,19 +278,32 @@ rows = [Tab.rowsG $ fmap (\(from, to) -> [from, to]) fileMapping] -printComputedResults :: Options -> [(SimpleDefinition, FilePath)] -> IO () +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:" - printTabularResults . fmap (first (LT.unpack . getIdentifier)) $ tempResults + printTabularResultsWithCount . fmap toRow $ tempResults printNewline unless (null retainResults) $ do unless (not (showTransient opts)) $ putStrLn "Required results:" - printTabularResults . fmap (first (LT.unpack . getIdentifier)) $ retainResults + printTabularResultsWithCount . fmap toRow $ retainResults where - (retainResults, tempResults) = partition (sdRetain . fst) results - --printResults = sequence_ . intersperse printNewline . fmap printComputedResult + (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 () diff --git a/src/PerformOperations.hs b/src/PerformOperations.hs --- a/src/PerformOperations.hs +++ b/src/PerformOperations.hs @@ -109,9 +109,17 @@ } 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 +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 +-- Symmetric difference: OT (/=) min True True +-- Correctness: when l /= r, chosen = min l r. +-- l < r: emit l; dropWhileChosen advances left past l, leaves right unchanged (r > l). ✓ +-- l > r: emit r; dropWhileChosen leaves left unchanged (l > r), advances right past r. ✓ +-- l == r: otCompare is False → else-EQ branch: skip both, no emit. ✓ +-- Remainders of either side: kept by otKeepRemainderLeft/Right = True. ✓ +-- The else-LT and else-GT branches are unreachable since (/=) fires for both LT and GT. +operatorTools SymmetricDifference = OT (/=) min True True const2 :: a -> b -> c -> a const2 = const . const diff --git a/src/PrintDefinition.hs b/src/PrintDefinition.hs --- a/src/PrintDefinition.hs +++ b/src/PrintDefinition.hs @@ -1,21 +1,28 @@ module PrintDefinition ( printDefinitions , printDefinition - , printSimpleDefinitions + , printSimpleDefinitions , printSimpleDefinition ) where import SetData import Data.List (intersperse) +import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.IO as T +maxAlignWidth :: Int +maxAlignWidth = 24 + -- Complex Definition Printing printDefinitions :: Definitions -> IO () -printDefinitions = sequence_ . intersperse printNewline . fmap printDefinition +printDefinitions defs = sequence_ . intersperse printNewline $ fmap (printDefinition col) defs + where + col = min maxAlignWidth . maximum $ fmap (\(Definition i _) -> fromIntegral (TL.length i)) defs -printDefinition :: Definition -> IO () -printDefinition (Definition ident expression) = do - printId ident +printDefinition :: Int -> Definition -> IO () +printDefinition col (Definition ident expression) = do + T.putStr ident + putStr $ replicate (col - fromIntegral (TL.length ident)) ' ' putStr ": " printExpression expression printNewline @@ -35,11 +42,14 @@ -- Simple Definition Printing printSimpleDefinitions :: SimpleDefinitions -> IO () -printSimpleDefinitions = sequence_ . intersperse printNewline . fmap printSimpleDefinition +printSimpleDefinitions defs = sequence_ . intersperse printNewline $ fmap (printSimpleDefinition col) defs + where + col = min maxAlignWidth . maximum $ fmap (\(SimpleDefinition i _ _) -> fromIntegral (TL.length i)) defs -printSimpleDefinition :: SimpleDefinition -> IO () -printSimpleDefinition (SimpleDefinition ident se _) = do - printId ident +printSimpleDefinition :: Int -> SimpleDefinition -> IO () +printSimpleDefinition col (SimpleDefinition ident se _) = do + T.putStr ident + putStr $ replicate (col - fromIntegral (TL.length ident)) ' ' putStr ": " printSimpleExpression se printNewline @@ -69,9 +79,10 @@ putStr ")" printOperator :: Operator -> IO () -printOperator And = putStr "/\\" -printOperator Or = putStr "\\/" -printOperator Difference = putStr "-" +printOperator And = putStr "∩" +printOperator Or = putStr "∪" +printOperator Difference = putStr "-" +printOperator SymmetricDifference = putStr "△" printId :: Identifier -> IO () printId = T.putStr diff --git a/src/SetData.hs b/src/SetData.hs --- a/src/SetData.hs +++ b/src/SetData.hs @@ -23,6 +23,7 @@ = And | Or | Difference + | SymmetricDifference deriving (Eq, Ord, Show) data Expression diff --git a/src/SetInput.hs b/src/SetInput.hs --- a/src/SetInput.hs +++ b/src/SetInput.hs @@ -21,6 +21,7 @@ fromParserExpression (SP.IdentifierExp (SP.Identifier name)) = IdentifierExpression name fromParserOperator :: SP.SetOperator -> Operator -fromParserOperator SP.IntersectionOp = And -fromParserOperator SP.UnionOp = Or -fromParserOperator SP.DifferenceOp = Difference +fromParserOperator SP.IntersectionOp = And +fromParserOperator SP.UnionOp = Or +fromParserOperator SP.DifferenceOp = Difference +fromParserOperator SP.SymmetricDifferenceOp = SymmetricDifference diff --git a/src/SetLanguage.x b/src/SetLanguage.x --- a/src/SetLanguage.x +++ b/src/SetLanguage.x @@ -2,11 +2,12 @@ {-# OPTIONS_GHC -w #-} module SetLanguage where -import qualified Data.Text.Lazy as TL +import qualified Data.ByteString.Lazy as ByteString +import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLE } -%wrapper "basic-bytestring" +%wrapper "posn-bytestring" $digit = [0-9] $nonFilename = [^\\\/\?\%\*\:\|\<\>\ ] @@ -16,20 +17,20 @@ $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 } + "(" { tok LParenTok } + ")" { tok RParenTok } + "/\" { tok IntersectionTok } + "\/" { tok UnionTok } + "∪" { tok UnionTok } + "∩" { tok IntersectionTok } + "-" { tok DifferenceTok } + "><" { tok SymmetricDifferenceTok } + "△" { tok SymmetricDifferenceTok } + \"[^\"]+\" { \pos bs -> LocatedToken pos (FilenameTok . TL.unpack . TL.init . TL.tail . TLE.decodeUtf8 $ bs) } + $ident+$white*":" { \pos bs -> LocatedToken pos (IdentifierDefinitionTok . TL.strip . TL.init . TLE.decodeUtf8 $ bs) } + $ident+ { \pos bs -> LocatedToken pos (IdentifierTok . TLE.decodeUtf8 $ bs) } { --- 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 @@ -39,5 +40,22 @@ | DifferenceTok | LParenTok | RParenTok + | SymmetricDifferenceTok deriving(Show, Eq) + +prettyToken :: SetToken -> String +prettyToken (FilenameTok fp) = "\"" ++ fp ++ "\"" +prettyToken (IdentifierDefinitionTok name) = TL.unpack name ++ ":" +prettyToken (IdentifierTok name) = TL.unpack name +prettyToken IntersectionTok = "/\\" +prettyToken UnionTok = "\\/" +prettyToken DifferenceTok = "-" +prettyToken SymmetricDifferenceTok = "><" +prettyToken LParenTok = "(" +prettyToken RParenTok = ")" + +data LocatedToken = LocatedToken AlexPosn SetToken deriving (Show, Eq) + +tok :: SetToken -> AlexPosn -> ByteString.ByteString -> LocatedToken +tok t pos _ = LocatedToken pos t } diff --git a/src/SetParser.y b/src/SetParser.y --- a/src/SetParser.y +++ b/src/SetParser.y @@ -4,22 +4,22 @@ import SetLanguage import qualified Data.Text.Lazy as TL -- TODO add precedence of operators --- TODO The tokens should come with line number information so that we can better pinpoint errors. } %name parseSetLanguage -%tokentype { SetToken } +%tokentype { LocatedToken } %error { parseError } %token - '(' { LParenTok } - ')' { RParenTok } - and { IntersectionTok } - or { UnionTok } - diff { DifferenceTok } - identifierDef { IdentifierDefinitionTok $$ } - identifier { IdentifierTok $$ } - filename { FilenameTok $$ } + '(' { LocatedToken _ LParenTok } + ')' { LocatedToken _ RParenTok } + and { LocatedToken _ IntersectionTok } + or { LocatedToken _ UnionTok } + diff { LocatedToken _ DifferenceTok } + symdiff { LocatedToken _ SymmetricDifferenceTok } + identifierDef { LocatedToken _ (IdentifierDefinitionTok $$) } + identifier { LocatedToken _ (IdentifierTok $$) } + filename { LocatedToken _ (FilenameTok $$) } %% @@ -40,18 +40,25 @@ baseexp : filename { FilenameExp $1 } | identifier { IdentifierExp (Identifier $1) } -operator : and { IntersectionOp } - | or { UnionOp } - | diff { DifferenceOp } +operator : and { IntersectionOp } + | or { UnionOp } + | diff { DifferenceOp } + | symdiff { SymmetricDifferenceOp } { -parseError :: [SetToken] -> a -parseError tokens = error $ "Parse error: " ++ show tokens +parseError :: [LocatedToken] -> a +parseError [] + = error "Parse error: unexpected end of input" +parseError (LocatedToken (AlexPn _ line col) t : _) + = error $ "Parse error at line " ++ show line + ++ ", column " ++ show col + ++ ": unexpected \"" ++ prettyToken t ++ "\"" data SetOperator = IntersectionOp | UnionOp | DifferenceOp + | SymmetricDifferenceOp deriving(Show, Eq) data Identifier = Identifier