diff --git a/quiver-sort.cabal b/quiver-sort.cabal --- a/quiver-sort.cabal +++ b/quiver-sort.cabal @@ -1,5 +1,5 @@ name: quiver-sort -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Sort the values in a quiver description: Allows sorting values within a Quiver, including using external @@ -11,6 +11,7 @@ category: Control build-type: Simple extra-source-files: README.md + , stack.yaml cabal-version: >=1.10 tested-with: GHC == 7.10.2, GHC == 7.11.* @@ -23,6 +24,7 @@ exposed-modules: Control.Quiver.Sort -- other-modules: build-depends: base >=4.8 && <4.9 + , containers , directory , exceptions , quiver >= 1.1.3 && < 1.2 diff --git a/src/Control/Quiver/Sort.hs b/src/Control/Quiver/Sort.hs --- a/src/Control/Quiver/Sort.hs +++ b/src/Control/Quiver/Sort.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} +{-# LANGUAGE PatternSynonyms, RankNTypes, ScopedTypeVariables, ViewPatterns #-} + {- | Module : Control.Quiver.Sort Description : Sort values in a Quiver @@ -19,6 +20,12 @@ -- $filesort , spfilesort , spfilesortBy + -- ** Configuration + , SPFileConfig + , defaultConfig + , setChunkSize + , setTempDir + , setMaxFiles ) where import Control.Quiver.Binary @@ -28,21 +35,28 @@ import Control.Quiver.Interleave import Control.Quiver.SP -import Control.Applicative (liftA2) -import Control.Exception (IOException, finally) -import Control.Monad (join) -import Control.Monad.Catch (MonadCatch (..), MonadMask) -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Trans.Resource (MonadResource, allocate) -import Data.Bool (bool) -import Data.Function (on) -import Data.List (sortBy) -import Data.Maybe (fromMaybe) -import System.Directory (doesDirectoryExist, getPermissions, - getTemporaryDirectory, - removeDirectoryRecursive, writable) -import System.IO (hClose, openTempFile) -import System.IO.Temp (createTempDirectory) +import Control.Applicative (liftA2) +import Control.Exception (IOException) +import Control.Monad (join) +import Control.Monad.Catch (MonadCatch (..), MonadMask, + finally) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Resource (MonadResource, allocate) +import Data.Bool (bool) +import Data.Coerce (coerce) +import Data.Foldable (toList) +import Data.Function (on) +import Data.List (sortBy) +import Data.Monoid (First (..), (<>)) +import Data.Sequence (Seq, (|>)) +import qualified Data.Sequence as S +import System.Directory (doesDirectoryExist, + getPermissions, + getTemporaryDirectory, + removeDirectoryRecursive, + removeFile, writable) +import System.IO (hClose, openTempFile) +import System.IO.Temp (createTempDirectory) -------------------------------------------------------------------------------- @@ -59,7 +73,7 @@ -- | Use the specified comparison function to sort the values. spsortBy :: (Monad m) => (a -> a -> Ordering) -> SP a a m () -spsortBy f = (sortBy f <$> spfoldr (:) []) >>= spevery +spsortBy f = (sortBy f <$> spToList) >>= spevery -- | Use the provided function to be able to compare values. spsortOn :: (Ord b, Monad m) => (a -> b) -> SP a a m () @@ -67,6 +81,9 @@ >->> spsortBy (compare `on` snd) >->> sppure fst >&> snd +spToList :: SQ a x f [a] +spToList = spfoldr (:) [] + -------------------------------------------------------------------------------- {- $filesort @@ -77,13 +94,64 @@ -} +-- | Configuration settings for 'spfilesort' and 'spfilesortBy'. Use +-- 'defaultConfig' and the various @set*@ functions to configure it. +data SPFileConfig = FC { _chunkSize :: !Int + -- ^ How large the chunks should be for + -- individual sorting. + , _withTmpDir :: !(Maybe FilePath) + -- ^ Where to store temporary files. Will be + -- cleaned up afterwards. 'Nothing' + -- indicates to use the system temporary + -- directory. + , _maxFiles :: !Int + -- ^ The maximum number of temporary files to + -- be open at any one time. + } + +-- | Default settings for sorting using external files: +-- +-- * Have a chunk size of @1000@. +-- +-- * Use the system temporary directory. +-- +-- * No more than @100@ temporary files to be open at a time. +defaultConfig :: SPFileConfig +defaultConfig = FC { _chunkSize = 1000 + , _withTmpDir = Nothing + , _maxFiles = 100 + } + +-- | Specify the size of chunks to be individually sorted: the larger +-- the value the fewer temporary files need to be created but the more +-- memory needed to accumulate the values and sort them. +setChunkSize :: Int -> SPFileConfig -> SPFileConfig +setChunkSize cs cfg = cfg { _chunkSize = cs } + +-- | Specify where temporary files should be stored. +-- +-- Typically you would only set this if the system temporary +-- directory isn't large or fast enough. +-- +-- NOTE: this directory /must/ exist and be writable! +setTempDir :: FilePath -> SPFileConfig -> SPFileConfig +setTempDir dir cfg = cfg { _withTmpDir = Just dir } + +-- | The maximum number of files that should be open at any one time. +-- +-- Larger values will be faster, but run the risk of exhausting the +-- operating system's supply of file descriptors (and thus being +-- killed). +setMaxFiles :: Int -> SPFileConfig -> SPFileConfig +setMaxFiles c cfg = cfg { _maxFiles = c } + -- | Use external files to temporarily store partially sorted results -- (splitting into chunks of the specified size if one is provided). -- -- These files are stored inside the specified directory if provided; -- if no such directory is provided then the system temporary -- directory is used. -spfilesort :: (Binary a, Ord a, MonadResource m, MonadMask m) => Maybe Int -> Maybe FilePath +spfilesort :: (Binary a, Ord a, MonadResource m, MonadMask m) => SPFileConfig -> P () a a () m (SPResult IOException) spfilesort = spfilesortBy compare @@ -94,10 +162,10 @@ -- These files are stored inside the specified directory if provided; -- if no such directory is provided then the system temporary -- directory is used. -spfilesortBy :: (Binary a, MonadResource m, MonadMask m) => (a -> a -> Ordering) -> Maybe Int -> Maybe FilePath +spfilesortBy :: (Binary a, MonadResource m, MonadMask m) => (a -> a -> Ordering) -> SPFileConfig -> P () a a () m (SPResult IOException) -spfilesortBy cmp mchunks mdir = do mdir' <- join <$> liftIO (traverse checkDir mdir) - getTmpDir mdir' "quiver-sort" pipeline +spfilesortBy cmp cfg = do mdir' <- join <$> liftIO (traverse checkDir (_withTmpDir cfg)) + getTmpDir mdir' "quiver-sort" pipeline where -- Make sure the directory exists and is writable. checkDir dir = do ex <- liftA2 (liftA2 (&&)) doesDirectoryExist (fmap writable . getPermissions) dir @@ -105,32 +173,53 @@ getTmpDir = maybe withSystemTempDirectory withTempDirectory - pipeline tmpDir = toFiles tmpDir >>= either spfailed (sortFromFiles cmp) + pipeline tmpDir = toFiles tmpDir >>= either spfailed (sortFromFiles maxFiles cmp tmpDir) - toFiles tmpDir = sortToFiles chunkSize cmp tmpDir >->> spToList >&> uncurry (flip checkFailed) + toFiles tmpDir = sortToFiles chunkSize cmp tmpDir >->> spToSeq >&> uncurry (flip checkFailed) - chunkSize = fromMaybe 10000 mchunks + chunkSize = _chunkSize cfg -sortToFiles :: (Binary a, MonadIO m) => Int -> (a -> a -> Ordering) -> FilePath + maxFiles = _maxFiles cfg + +sortToFiles :: (Binary a, MonadIO m, MonadMask m) => Int -> (a -> a -> Ordering) -> FilePath -> SP a FilePath m IOException sortToFiles chunkSize cmp tmpDir = spchunks chunkSize >->> spTraverseUntil sortChunk >&> snd where - sortChunk as = liftIO $ do (fl,h) <- openTempFile tmpDir "quiver-sort-chunk" - finally (checkFailed fl <$> sprun (pipeline h)) (hClose h) - where - pipeline h = spevery (sortBy cmp as) >->> spencode >->> qPut h >&> snd + sortChunk as = writeOut tmpDir (spevery (sortBy cmp as)) -sortFromFiles :: (Binary a, MonadIO m) => (a -> a -> Ordering) -> [FilePath] - -> Producer a () m (SPResult IOException) -sortFromFiles cmp fls = spinterleave cmp (map readFl fls) +writeOut :: (Binary a, MonadIO m, MonadMask m) => FilePath -> P () x a () m (SPResult IOException) + -> m (Either IOException FilePath) +writeOut tmpDir p = do (fl,h) <- liftIO (openTempFile tmpDir "quiver-sort-chunk") + finally (checkFailed fl <$> sprun (pipeline h) <* liftIO (hClose h)) + (liftIO (hClose h)) where + pipeline h = p >->> spencode >&> fst >->> qhoist liftIO (qPut h) >&> getFirstError + +sortFromFiles :: (Binary a, MonadIO m, MonadMask m) => Int -> (a -> a -> Ordering) -> FilePath + -> Seq FilePath -> Producer a () m (SPResult IOException) +sortFromFiles mf cmp tmpDir = nextBatch + where + nextBatch Empty = spcomplete + nextBatch fls = case S.splitAt mf fls of + (b,Empty) -> batch b + (b,fls') -> do br <- qlift (writeBatch b) + liftIO $ mapM_ removeFile b + either spfailed (nextBatch . (fls' |>)) br + + writeBatch = writeOut tmpDir . batch + + batch = spinterleave cmp . map readFl . toList + -- Assume decoding is successful for now. readFl fl = qhoist liftIO (qReadFile fl readSize) >->> spdecode >&> fst readSize = 4096 +-- Just to make it nicer to pattern-match +pattern Empty <- (S.viewl -> S.EmptyL) + spTraverseUntil :: (Monad m) => (a -> m (Either e b)) -> SP a b m e spTraverseUntil k = loop where @@ -142,8 +231,8 @@ checkFailed _ (Just (Just e)) = Left e checkFailed r _ = Right r -spToList :: SQ a x f [a] -spToList = spfoldr (:) [] +spToSeq :: SQ a x f (Seq a) +spToSeq = spfoldl' (|>) mempty -------------------------------------------------------------------------------- -- Creating the temporary directory @@ -166,3 +255,9 @@ ignoringIOErrors :: (MonadCatch m) => m () -> m () ignoringIOErrors ioe = ioe `catch` (\(_ :: IOError) -> return ()) + +getFirstError :: (SPResult a, SPResult a) -> SPResult a +getFirstError (r1,r2) = coerce (toFirst r1 <> toFirst r2) + where + toFirst :: SPResult a -> Maybe (First a) + toFirst = coerce diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,41 @@ +# This file was automatically generated by stack init +# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) +resolver: lts-5.11 + +# Local packages, usually specified by relative directory name +packages: +- '.' +# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) +extra-deps: +- quiver-1.1.3 +- quiver-binary-0.1.1.0 +- quiver-bytestring-1.0.0 +- quiver-groups-0.1.0.0 +- quiver-instances-0.2.0.0 +- quiver-interleave-0.2.0.0 + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true + +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: >= 1.0.0 + +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 + +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] + +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -63,7 +63,7 @@ spList p as = spevery as >->> p >->> spToList >&> snd fileSort :: (Binary a, Ord a) => Int -> [a] -> IO [a] -fileSort cs as = runResourceT $ sprun $ spList (spfilesort (Just cs) Nothing) as +fileSort cs as = runResourceT $ sprun $ spList (spfilesort (setChunkSize cs defaultConfig)) as -- The provided producer is assumed to be short. fileSortCleanup :: (Binary a, Ord a) => Producer a () IO e -> Expectation @@ -76,6 +76,6 @@ pipeline tmpDir = qhoist lift prod -- Use a chunk size of 1 to make sure files are -- created, even if an exception is thrown. - >->> spfilesort (Just 1) (Just tmpDir) + >->> spfilesort (setChunkSize 1 . setTempDir tmpDir $ defaultConfig) >->> sptraverse_ (lift . void . evaluate) -- Just to consume them all >&> const ()