quiver-sort 0.1.0.0 → 0.2.0.0

raw patch · 4 files changed

+175/−37 lines, 4 filesdep +containersPVP ok

version bump matches the API change (PVP)

Dependencies added: containers

API changes (from Hackage documentation)

Files

• quiver-sort.cabal +3/−1
• src/Control/Quiver/Sort.hs +129/−34
• stack.yaml +41/−0
• test/Spec.hs +2/−2

@@ -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

@@ -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

@@ -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

@@ -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 ()