module Combinatorics.Battleship.Count.CountMap (
   T,
   KeyCount,

   Path(Path),
   readFile,
   writeFile,

   fromList,
   fromListStorable,
   fromListExternal,
   writeSorted,
   fromMap,
   singleton,
   size,
   toAscList,
   toMap,

   mergeMany,

   propMerge,
   ) where

import qualified Combinatorics.Battleship.Count.Frontier as Frontier
import qualified Combinatorics.Battleship.Count.Counter as Counter
import qualified Combinatorics.Battleship.Fleet as Fleet
import Combinatorics.Battleship.Count.Counter (add)
import Combinatorics.Battleship.Size (Nat, N10, )

import qualified System.IO.Temp as Temp
import System.Directory (removeFile, )
import System.FilePath ((</>), )

import qualified Data.StorableVector.Lazy.Pointer as SVP
import qualified Data.StorableVector.Lazy as SVL

import Data.Map (Map, )
import qualified Data.Map as Map

import qualified Control.Concurrent.PooledIO.Independent as Pool
import Control.DeepSeq (NFData, rnf, )
import Control.Monad (liftM2, zipWithM_, foldM, forM_, )
import Control.Applicative ((<$>), )
import Control.Functor.HT (void, )

import qualified Data.NonEmpty as NonEmpty
import qualified Data.List.Match as Match
import Data.Monoid (Monoid, mempty, mappend, mconcat, )
import Data.Semigroup (Semigroup, (<>))
import Data.List.HT (sliceVertical, )
import Text.Printf (printf, )

import Data.Word (Word64, )

import Foreign.Storable
          (Storable, sizeOf, alignment,
           poke, peek, pokeByteOff, peekByteOff, )

import Prelude hiding (readFile, writeFile, )


type Count64 = Word64
type Count128 = Counter.Composed Word64 Word64

{- |
Represents a @Map Key Count@
by a lazy ByteString containing the (key,count) pairs in ascending order.
-}
newtype T w a = Cons (SVL.Vector (Element w a))
   deriving (T w a -> T w a -> Bool
(T w a -> T w a -> Bool) -> (T w a -> T w a -> Bool) -> Eq (T w a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall w a. (Storable a, Eq a) => T w a -> T w a -> Bool
/= :: T w a -> T w a -> Bool
$c/= :: forall w a. (Storable a, Eq a) => T w a -> T w a -> Bool
== :: T w a -> T w a -> Bool
$c== :: forall w a. (Storable a, Eq a) => T w a -> T w a -> Bool
Eq)

instance (Nat w, Show a, Storable a) => Show (T w a) where
   showsPrec :: Int -> T w a -> ShowS
showsPrec Int
prec (Cons Vector (Element w a)
x) =
      Bool -> ShowS -> ShowS
showParen (Int
precInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
         String -> ShowS
showString String
"CountMap.fromAscList " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
         [Element w a] -> ShowS
forall a. Show a => a -> ShowS
shows (Vector (Element w a) -> [Element w a]
forall a. Storable a => Vector a -> [a]
SVL.unpack Vector (Element w a)
x)

instance (Storable a) => NFData (T w a) where
   rnf :: T w a -> ()
rnf (Cons Vector (Element w a)
x) = Vector (Element w a) -> ()
forall a. NFData a => a -> ()
rnf Vector (Element w a)
x


data Element w a =
   Element {
      Element w a -> Key w
_elementKey :: Key w,
      Element w a -> a
_elementCount :: a
   } deriving (Element w a -> Element w a -> Bool
(Element w a -> Element w a -> Bool)
-> (Element w a -> Element w a -> Bool) -> Eq (Element w a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall w a. Eq a => Element w a -> Element w a -> Bool
/= :: Element w a -> Element w a -> Bool
$c/= :: forall w a. Eq a => Element w a -> Element w a -> Bool
== :: Element w a -> Element w a -> Bool
$c== :: forall w a. Eq a => Element w a -> Element w a -> Bool
Eq, Int -> Element w a -> ShowS
[Element w a] -> ShowS
Element w a -> String
(Int -> Element w a -> ShowS)
-> (Element w a -> String)
-> ([Element w a] -> ShowS)
-> Show (Element w a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall w a. (Nat w, Show a) => Int -> Element w a -> ShowS
forall w a. (Nat w, Show a) => [Element w a] -> ShowS
forall w a. (Nat w, Show a) => Element w a -> String
showList :: [Element w a] -> ShowS
$cshowList :: forall w a. (Nat w, Show a) => [Element w a] -> ShowS
show :: Element w a -> String
$cshow :: forall w a. (Nat w, Show a) => Element w a -> String
showsPrec :: Int -> Element w a -> ShowS
$cshowsPrec :: forall w a. (Nat w, Show a) => Int -> Element w a -> ShowS
Show)

type Key w = (Frontier.T w, Fleet.T)
type KeyCount w a = (Key w, a)

instance (Storable a) => Storable (Element w a) where
   sizeOf :: Element w a -> Int
sizeOf ~(Element ~(T w
front, T
fleet) a
cnt) =
      T w -> Int
forall a. Storable a => a -> Int
sizeOf T w
front Int -> Int -> Int
forall a. Num a => a -> a -> a
+ T -> Int
forall a. Storable a => a -> Int
sizeOf T
fleet Int -> Int -> Int
forall a. Num a => a -> a -> a
+ a -> Int
forall a. Storable a => a -> Int
sizeOf a
cnt
   alignment :: Element w a -> Int
alignment ~(Element ~(T w
front, T
fleet) a
cnt) =
      T w -> Int
forall a. Storable a => a -> Int
alignment T w
front Int -> Int -> Int
forall a. Integral a => a -> a -> a
`lcm` T -> Int
forall a. Storable a => a -> Int
alignment T
fleet Int -> Int -> Int
forall a. Integral a => a -> a -> a
`lcm` a -> Int
forall a. Storable a => a -> Int
alignment a
cnt
   poke :: Ptr (Element w a) -> Element w a -> IO ()
poke Ptr (Element w a)
ptr (Element (T w
front, T
fleet) a
cnt) = do
      Ptr (Element w a) -> Int -> T w -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr (Element w a)
ptr Int
0 T w
front
      Ptr (Element w a) -> Int -> T -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr (Element w a)
ptr (T w -> Int
forall a. Storable a => a -> Int
sizeOf T w
front) T
fleet
      Ptr (Element w a) -> Int -> a -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr (Element w a)
ptr (T w -> Int
forall a. Storable a => a -> Int
sizeOf T w
front Int -> Int -> Int
forall a. Num a => a -> a -> a
+ T -> Int
forall a. Storable a => a -> Int
sizeOf T
fleet) a
cnt
   peek :: Ptr (Element w a) -> IO (Element w a)
peek Ptr (Element w a)
ptr = do
      T w
front <- Ptr (Element w a) -> Int -> IO (T w)
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr (Element w a)
ptr Int
0
      T
fleet <- Ptr (Element w a) -> Int -> IO T
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr (Element w a)
ptr (T w -> Int
forall a. Storable a => a -> Int
sizeOf T w
front)
      a
cnt   <- Ptr (Element w a) -> Int -> IO a
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr (Element w a)
ptr (T w -> Int
forall a. Storable a => a -> Int
sizeOf T w
front Int -> Int -> Int
forall a. Num a => a -> a -> a
+ T -> Int
forall a. Storable a => a -> Int
sizeOf T
fleet)
      Element w a -> IO (Element w a)
forall (m :: * -> *) a. Monad m => a -> m a
return ((T w, T) -> a -> Element w a
forall w a. Key w -> a -> Element w a
Element (T w
front, T
fleet) a
cnt)


defaultChunkSize :: SVL.ChunkSize
defaultChunkSize :: ChunkSize
defaultChunkSize = Int -> ChunkSize
SVL.chunkSize Int
512

fromAscList :: (Storable a) => [KeyCount w a] -> T w a
fromAscList :: [KeyCount w a] -> T w a
fromAscList =
   Vector (Element w a) -> T w a
forall w a. Vector (Element w a) -> T w a
Cons (Vector (Element w a) -> T w a)
-> ([KeyCount w a] -> Vector (Element w a))
-> [KeyCount w a]
-> T w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChunkSize -> [Element w a] -> Vector (Element w a)
forall a. Storable a => ChunkSize -> [a] -> Vector a
SVL.pack ChunkSize
defaultChunkSize ([Element w a] -> Vector (Element w a))
-> ([KeyCount w a] -> [Element w a])
-> [KeyCount w a]
-> Vector (Element w a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyCount w a -> Element w a) -> [KeyCount w a] -> [Element w a]
forall a b. (a -> b) -> [a] -> [b]
map ((Key w -> a -> Element w a) -> KeyCount w a -> Element w a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Key w -> a -> Element w a
forall w a. Key w -> a -> Element w a
Element)

fromMap :: (Storable a) => Map (Key w) a -> T w a
fromMap :: Map (Key w) a -> T w a
fromMap = [KeyCount w a] -> T w a
forall a w. Storable a => [KeyCount w a] -> T w a
fromAscList ([KeyCount w a] -> T w a)
-> (Map (Key w) a -> [KeyCount w a]) -> Map (Key w) a -> T w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (Key w) a -> [KeyCount w a]
forall k a. Map k a -> [(k, a)]
Map.toAscList

fromList :: (Counter.C a, Storable a) => [KeyCount w a] -> T w a
fromList :: [KeyCount w a] -> T w a
fromList = Map (Key w) a -> T w a
forall a w. Storable a => Map (Key w) a -> T w a
fromMap (Map (Key w) a -> T w a)
-> ([KeyCount w a] -> Map (Key w) a) -> [KeyCount w a] -> T w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> a) -> [KeyCount w a] -> Map (Key w) a
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith a -> a -> a
forall a. C a => a -> a -> a
add

fromListStorable :: (Counter.C a, Storable a) => [KeyCount w a] -> T w a
fromListStorable :: [KeyCount w a] -> T w a
fromListStorable = [T w a] -> T w a
forall a. Monoid a => [a] -> a
mconcat ([T w a] -> T w a)
-> ([KeyCount w a] -> [T w a]) -> [KeyCount w a] -> T w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyCount w a -> T w a) -> [KeyCount w a] -> [T w a]
forall a b. (a -> b) -> [a] -> [b]
map ((Key w -> a -> T w a) -> KeyCount w a -> T w a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Key w -> a -> T w a
forall a w. Storable a => Key w -> a -> T w a
singleton)


toAscList :: (Storable a) => T w a -> [KeyCount w a]
toAscList :: T w a -> [KeyCount w a]
toAscList (Cons Vector (Element w a)
m) = (Element w a -> KeyCount w a) -> [Element w a] -> [KeyCount w a]
forall a b. (a -> b) -> [a] -> [b]
map Element w a -> KeyCount w a
forall w a. Element w a -> KeyCount w a
pairFromElement ([Element w a] -> [KeyCount w a])
-> [Element w a] -> [KeyCount w a]
forall a b. (a -> b) -> a -> b
$ Vector (Element w a) -> [Element w a]
forall a. Storable a => Vector a -> [a]
SVL.unpack Vector (Element w a)
m

toMap :: (Storable a) => T w a -> Map (Key w) a
toMap :: T w a -> Map (Key w) a
toMap = [(Key w, a)] -> Map (Key w) a
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList ([(Key w, a)] -> Map (Key w) a)
-> (T w a -> [(Key w, a)]) -> T w a -> Map (Key w) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T w a -> [(Key w, a)]
forall a w. Storable a => T w a -> [KeyCount w a]
toAscList


singleton :: (Storable a) => Key w -> a -> T w a
singleton :: Key w -> a -> T w a
singleton Key w
key a
cnt = Vector (Element w a) -> T w a
forall w a. Vector (Element w a) -> T w a
Cons (Vector (Element w a) -> T w a) -> Vector (Element w a) -> T w a
forall a b. (a -> b) -> a -> b
$ Element w a -> Vector (Element w a)
forall a. Storable a => a -> Vector a
SVL.singleton (Element w a -> Vector (Element w a))
-> Element w a -> Vector (Element w a)
forall a b. (a -> b) -> a -> b
$ Key w -> a -> Element w a
forall w a. Key w -> a -> Element w a
Element Key w
key a
cnt

pairFromElement :: Element w a -> KeyCount w a
pairFromElement :: Element w a -> KeyCount w a
pairFromElement (Element Key w
key a
cnt) = (Key w
key, a
cnt)


size :: T w a -> Int
size :: T w a -> Int
size (Cons Vector (Element w a)
x) = Vector (Element w a) -> Int
forall a. Vector a -> Int
SVL.length Vector (Element w a)
x


newtype Path w a = Path {Path w a -> String
getPath :: FilePath}

writeFile :: (Storable a) => Path w a -> T w a -> IO ()
writeFile :: Path w a -> T w a -> IO ()
writeFile (Path String
path) (Cons Vector (Element w a)
xs) = String -> Vector (Element w a) -> IO ()
forall a. Storable a => String -> Vector a -> IO ()
SVL.writeFile String
path Vector (Element w a)
xs

{- |
It silently drops IO exceptions
and does not check whether the loaded data is valid.
-}
readFile :: (Storable a) => Path w a -> IO (T w a)
readFile :: Path w a -> IO (T w a)
readFile (Path String
path) =
   Vector (Element w a) -> T w a
forall w a. Vector (Element w a) -> T w a
Cons (Vector (Element w a) -> T w a)
-> ((IOError, Vector (Element w a)) -> Vector (Element w a))
-> (IOError, Vector (Element w a))
-> T w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IOError, Vector (Element w a)) -> Vector (Element w a)
forall a b. (a, b) -> b
snd ((IOError, Vector (Element w a)) -> T w a)
-> IO (IOError, Vector (Element w a)) -> IO (T w a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChunkSize -> String -> IO (IOError, Vector (Element w a))
forall a.
Storable a =>
ChunkSize -> String -> IO (IOError, Vector a)
SVL.readFileAsync ChunkSize
defaultChunkSize String
path

formatPath :: FilePath -> Int -> Path w a
formatPath :: String -> Int -> Path w a
formatPath String
dir = String -> Path w a
forall w a. String -> Path w a
Path (String -> Path w a) -> (Int -> String) -> Int -> Path w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
dir String -> ShowS
</>) ShowS -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"extsort%04d"

{- |
It deletes the input files after the merge.
This saves a lot of disk space when running 'fromListExternal'.
-}
mergeFiles ::
   (Counter.C a, Storable a) => Path w a -> Path w a -> Path w a -> IO ()
mergeFiles :: Path w a -> Path w a -> Path w a -> IO ()
mergeFiles Path w a
input0 Path w a
input1 Path w a
output = do
   Path w a -> T w a -> IO ()
forall a w. Storable a => Path w a -> T w a -> IO ()
writeFile Path w a
output (T w a -> IO ()) -> IO (T w a) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (T w a -> T w a -> T w a) -> IO (T w a) -> IO (T w a) -> IO (T w a)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 T w a -> T w a -> T w a
forall a w. (C a, Storable a) => T w a -> T w a -> T w a
merge (Path w a -> IO (T w a)
forall a w. Storable a => Path w a -> IO (T w a)
readFile Path w a
input0) (Path w a -> IO (T w a)
forall a w. Storable a => Path w a -> IO (T w a)
readFile Path w a
input1)
   String -> IO ()
removeFile (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Path w a -> String
forall w a. Path w a -> String
getPath Path w a
input0
   String -> IO ()
removeFile (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Path w a -> String
forall w a. Path w a -> String
getPath Path w a
input1

sequenceLast :: (Monad m) => a -> [m a] -> m a
sequenceLast :: a -> [m a] -> m a
sequenceLast a
deflt = (a -> m a -> m a) -> a -> [m a] -> m a
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\a
_ m a
act -> m a
act) a
deflt

{- |
Create a @CountMap@ from a large list of elements.
Neither the argument nor the result needs to fit in memory.
You only have to provide enough space on disk.
The result is lazily read from a temporary file.
That is, this file should neither be modified
nor deleted while processing the result.
Even more, 'fromListExternal' must not be called again
while processing the result.
You may better choose 'writeSorted'.
-}
fromListExternal ::
   (Counter.C a, Storable a) => Int -> [KeyCount w a] -> IO (T w a)
fromListExternal :: Int -> [KeyCount w a] -> IO (T w a)
fromListExternal Int
bucketSize [KeyCount w a]
xs = do
   let dir :: String
dir = String
"/tmp"
   Int
lastN <-
      Int -> [IO Int] -> IO Int
forall (m :: * -> *) a. Monad m => a -> [m a] -> m a
sequenceLast (-Int
1) ([IO Int] -> IO Int) -> [IO Int] -> IO Int
forall a b. (a -> b) -> a -> b
$
      (Int -> T w a -> IO Int) -> [Int] -> [T w a] -> [IO Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
         (\Int
n T w a
bucket -> Path w a -> T w a -> IO ()
forall a w. Storable a => Path w a -> T w a -> IO ()
writeFile (String -> Int -> Path w a
forall w a. String -> Int -> Path w a
formatPath String
dir Int
n) T w a
bucket IO () -> IO Int -> IO Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n)
         [Int
0 ..] ([T w a] -> [IO Int]) -> [T w a] -> [IO Int]
forall a b. (a -> b) -> a -> b
$
      ([KeyCount w a] -> T w a) -> [[KeyCount w a]] -> [T w a]
forall a b. (a -> b) -> [a] -> [b]
map [KeyCount w a] -> T w a
forall a w. (C a, Storable a) => [KeyCount w a] -> T w a
fromList ([[KeyCount w a]] -> [T w a]) -> [[KeyCount w a]] -> [T w a]
forall a b. (a -> b) -> a -> b
$
      Int -> [KeyCount w a] -> [[KeyCount w a]]
forall a. Int -> [a] -> [[a]]
sliceVertical Int
bucketSize [KeyCount w a]
xs
   case String -> Int -> Path w a
forall w a. String -> Int -> Path w a
formatPath String
dir (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
lastN) of
      Path w a
finalPath -> do
         [(Int, Int)] -> ((Int, Int) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Int -> [(Int, Int)] -> [(Int, Int)]
forall a. Int -> [a] -> [a]
take Int
lastN ([(Int, Int)] -> [(Int, Int)]) -> [(Int, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Int -> Int) -> Int -> [Int]
forall a. (a -> a) -> a -> [a]
iterate (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
+) Int
0) [Int
lastNInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 ..]) (((Int, Int) -> IO ()) -> IO ()) -> ((Int, Int) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
            \(Int
srcN, Int
dstN) ->
               Path w a -> Path w a -> Path w a -> IO ()
forall a w.
(C a, Storable a) =>
Path w a -> Path w a -> Path w a -> IO ()
mergeFiles
                  (String -> Int -> Path w a
forall w a. String -> Int -> Path w a
formatPath String
dir Int
srcN)
                  (String -> Int -> Path w a
forall w a. String -> Int -> Path w a
formatPath String
dir (Int
srcNInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))
                  (String -> Int -> Path w a
forall w a. String -> Int -> Path w a
formatPath String
dir Int
dstN Path w a -> Path w a -> Path w a
forall a. a -> a -> a
`asTypeOf` Path w a
finalPath)
         Path w a -> IO (T w a)
forall a w. Storable a => Path w a -> IO (T w a)
readFile Path w a
finalPath

pairs :: [a] -> [(a,a)]
pairs :: [a] -> [(a, a)]
pairs (a
x0:a
x1:[a]
xs) = (a
x0,a
x1) (a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
: [a] -> [(a, a)]
forall a. [a] -> [(a, a)]
pairs [a]
xs
pairs (a
_:[a]
_) = []
pairs [] = String -> [(a, a)]
forall a. HasCallStack => String -> a
error String
"pairs: even number of elements"

{-
The final external sort is bound by disk access time,
thus we only sort the buckets individually in parallel.
-}
writeSorted ::
   (Counter.C a, Storable a) => Path w a -> [[KeyCount w a]] -> IO ()
writeSorted :: Path w a -> [[KeyCount w a]] -> IO ()
writeSorted Path w a
dst [[KeyCount w a]]
xs =
   String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
Temp.withSystemTempDirectory String
"battleship" ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
      let chunks :: [T w a]
chunks = ([KeyCount w a] -> T w a) -> [[KeyCount w a]] -> [T w a]
forall a b. (a -> b) -> [a] -> [b]
map [KeyCount w a] -> T w a
forall a w. (C a, Storable a) => [KeyCount w a] -> T w a
fromList [[KeyCount w a]]
xs
      let unary :: [()]
unary = [T w a] -> [()]
forall (f :: * -> *) a. Functor f => f a -> f ()
void [T w a]
chunks
      let paths :: [Path w a]
paths =
            {-
            Matching with () makes sure
            that references from 'unary' to 'chunks' are removed
            as chunks are written to disk.
            They can then be reclaimed by the garbage collector.
            -}
            (() -> Int -> Path w a) -> [()] -> [Int] -> [Path w a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\() -> String -> Int -> Path w a
forall w a. String -> Int -> Path w a
formatPath String
dir) ([()] -> [()]
forall a. [a] -> [a]
init ([()] -> [()]) -> [()] -> [()]
forall a b. (a -> b) -> a -> b
$ [()] -> [()]
forall a. [a] -> [a]
init ([()] -> [()]) -> [()] -> [()]
forall a b. (a -> b) -> a -> b
$ [()]
unary [()] -> [()] -> [()]
forall a. [a] -> [a] -> [a]
++ [()]
unary) [Int
0..]
            [Path w a] -> [Path w a] -> [Path w a]
forall a. [a] -> [a] -> [a]
++
            [Path w a
dst]
      [IO ()] -> IO ()
Pool.run ([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ (Path w a -> T w a -> IO ()) -> [Path w a] -> [T w a] -> [IO ()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Path w a -> T w a -> IO ()
forall a w. Storable a => Path w a -> T w a -> IO ()
writeFile [Path w a]
paths [T w a]
chunks
      ((Path w a, Path w a) -> Path w a -> IO ())
-> [(Path w a, Path w a)] -> [Path w a] -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ ((Path w a -> Path w a -> Path w a -> IO ())
-> (Path w a, Path w a) -> Path w a -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Path w a -> Path w a -> Path w a -> IO ()
forall a w.
(C a, Storable a) =>
Path w a -> Path w a -> Path w a -> IO ()
mergeFiles) ([Path w a] -> [(Path w a, Path w a)]
forall a. [a] -> [(a, a)]
pairs [Path w a]
paths) ([()] -> [Path w a] -> [Path w a]
forall b a. [b] -> [a] -> [a]
Match.drop [()]
unary [Path w a]
paths)


empty :: (Storable a) => T w a
empty :: T w a
empty = Vector (Element w a) -> T w a
forall w a. Vector (Element w a) -> T w a
Cons Vector (Element w a)
forall a. Storable a => Vector a
SVL.empty

merge :: (Counter.C a, Storable a) => T w a -> T w a -> T w a
merge :: T w a -> T w a -> T w a
merge (Cons Vector (Element w a)
xs0) (Cons Vector (Element w a)
ys0) =
   Vector (Element w a) -> T w a
forall w a. Vector (Element w a) -> T w a
Cons (Vector (Element w a) -> T w a) -> Vector (Element w a) -> T w a
forall a b. (a -> b) -> a -> b
$
   ChunkSize
-> ((Pointer (Element w a), Pointer (Element w a))
    -> Maybe
         (Element w a, (Pointer (Element w a), Pointer (Element w a))))
-> (Pointer (Element w a), Pointer (Element w a))
-> Vector (Element w a)
forall b a.
Storable b =>
ChunkSize -> (a -> Maybe (b, a)) -> a -> Vector b
SVL.unfoldr ChunkSize
defaultChunkSize
      (\(Pointer (Element w a)
xt,Pointer (Element w a)
yt) ->
         case (Pointer (Element w a) -> Maybe (Element w a, Pointer (Element w a))
forall a. Storable a => Pointer a -> Maybe (a, Pointer a)
SVP.viewL Pointer (Element w a)
xt, Pointer (Element w a) -> Maybe (Element w a, Pointer (Element w a))
forall a. Storable a => Pointer a -> Maybe (a, Pointer a)
SVP.viewL Pointer (Element w a)
yt) of
            (Maybe (Element w a, Pointer (Element w a))
Nothing, Maybe (Element w a, Pointer (Element w a))
Nothing) -> Maybe (Element w a, (Pointer (Element w a), Pointer (Element w a)))
forall a. Maybe a
Nothing
            (Just (Element w a
x,Pointer (Element w a)
xs), Maybe (Element w a, Pointer (Element w a))
Nothing) -> (Element w a, (Pointer (Element w a), Pointer (Element w a)))
-> Maybe
     (Element w a, (Pointer (Element w a), Pointer (Element w a)))
forall a. a -> Maybe a
Just (Element w a
x, (Pointer (Element w a)
xs,Pointer (Element w a)
yt))
            (Maybe (Element w a, Pointer (Element w a))
Nothing, Just (Element w a
y,Pointer (Element w a)
ys)) -> (Element w a, (Pointer (Element w a), Pointer (Element w a)))
-> Maybe
     (Element w a, (Pointer (Element w a), Pointer (Element w a)))
forall a. a -> Maybe a
Just (Element w a
y, (Pointer (Element w a)
xt,Pointer (Element w a)
ys))
            (Just (Element Key w
xkey a
xcnt, Pointer (Element w a)
xs),
             Just (Element Key w
ykey a
ycnt, Pointer (Element w a)
ys)) -> (Element w a, (Pointer (Element w a), Pointer (Element w a)))
-> Maybe
     (Element w a, (Pointer (Element w a), Pointer (Element w a)))
forall a. a -> Maybe a
Just ((Element w a, (Pointer (Element w a), Pointer (Element w a)))
 -> Maybe
      (Element w a, (Pointer (Element w a), Pointer (Element w a))))
-> (Element w a, (Pointer (Element w a), Pointer (Element w a)))
-> Maybe
     (Element w a, (Pointer (Element w a), Pointer (Element w a)))
forall a b. (a -> b) -> a -> b
$
               case Key w -> Key w -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Key w
xkey Key w
ykey of
                  Ordering
EQ -> (Key w -> a -> Element w a
forall w a. Key w -> a -> Element w a
Element Key w
xkey (a -> a -> a
forall a. C a => a -> a -> a
add a
xcnt a
ycnt), (Pointer (Element w a)
xs,Pointer (Element w a)
ys))
                  Ordering
LT -> (Key w -> a -> Element w a
forall w a. Key w -> a -> Element w a
Element Key w
xkey a
xcnt, (Pointer (Element w a)
xs,Pointer (Element w a)
yt))
                  Ordering
GT -> (Key w -> a -> Element w a
forall w a. Key w -> a -> Element w a
Element Key w
ykey a
ycnt, (Pointer (Element w a)
xt,Pointer (Element w a)
ys)))
      (Vector (Element w a) -> Pointer (Element w a)
forall a. Storable a => Vector a -> Pointer a
SVP.cons Vector (Element w a)
xs0, Vector (Element w a) -> Pointer (Element w a)
forall a. Storable a => Vector a -> Pointer a
SVP.cons Vector (Element w a)
ys0)

propMerge :: [KeyCount N10 Count64] -> [KeyCount N10 Count64] -> Bool
propMerge :: [KeyCount N10 Count64] -> [KeyCount N10 Count64] -> Bool
propMerge [KeyCount N10 Count64]
xs [KeyCount N10 Count64]
ys =
   let xm :: Map (Key N10) Count64
xm = (Count64 -> Count64 -> Count64)
-> [KeyCount N10 Count64] -> Map (Key N10) Count64
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Count64 -> Count64 -> Count64
forall a. C a => a -> a -> a
add [KeyCount N10 Count64]
xs
       ym :: Map (Key N10) Count64
ym = (Count64 -> Count64 -> Count64)
-> [KeyCount N10 Count64] -> Map (Key N10) Count64
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Count64 -> Count64 -> Count64
forall a. C a => a -> a -> a
add [KeyCount N10 Count64]
ys
   in  T N10 Count64 -> T N10 Count64 -> T N10 Count64
forall a w. (C a, Storable a) => T w a -> T w a -> T w a
merge (Map (Key N10) Count64 -> T N10 Count64
forall a w. Storable a => Map (Key w) a -> T w a
fromMap Map (Key N10) Count64
xm) (Map (Key N10) Count64 -> T N10 Count64
forall a w. Storable a => Map (Key w) a -> T w a
fromMap Map (Key N10) Count64
ym)
       T N10 Count64 -> T N10 Count64 -> Bool
forall a. Eq a => a -> a -> Bool
==
       Map (Key N10) Count64 -> T N10 Count64
forall a w. Storable a => Map (Key w) a -> T w a
fromMap ((Count64 -> Count64 -> Count64)
-> Map (Key N10) Count64
-> Map (Key N10) Count64
-> Map (Key N10) Count64
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Count64 -> Count64 -> Count64
forall a. C a => a -> a -> a
add Map (Key N10) Count64
xm Map (Key N10) Count64
ym)


{-# SPECIALISE mergeMany :: [T w Count64] -> T w Count64 #-}
{-# SPECIALISE mergeMany :: [T w Count128] -> T w Count128 #-}
{-# INLINEABLE mergeMany #-}
mergeMany :: (Counter.C a, Storable a) => [T w a] -> T w a
mergeMany :: [T w a] -> T w a
mergeMany = T w a -> (T [] (T w a) -> T w a) -> Maybe (T [] (T w a)) -> T w a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe T w a
forall a w. Storable a => T w a
empty ((T w a -> T w a -> T w a) -> T [] (T w a) -> T w a
forall a. (a -> a -> a) -> T [] a -> a
NonEmpty.foldBalanced T w a -> T w a -> T w a
forall a w. (C a, Storable a) => T w a -> T w a -> T w a
merge) (Maybe (T [] (T w a)) -> T w a)
-> ([T w a] -> Maybe (T [] (T w a))) -> [T w a] -> T w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [T w a] -> Maybe (T [] (T w a))
forall (f :: * -> *) a. ViewL f => f a -> Maybe (T f a)
NonEmpty.fetch

instance (Counter.C a, Storable a) => Semigroup (T w a) where
   <> :: T w a -> T w a -> T w a
(<>) = T w a -> T w a -> T w a
forall a w. (C a, Storable a) => T w a -> T w a -> T w a
merge

instance (Counter.C a, Storable a) => Monoid (T w a) where
   mempty :: T w a
mempty = T w a
forall a w. Storable a => T w a
empty
   mappend :: T w a -> T w a -> T w a
mappend = T w a -> T w a -> T w a
forall a w. (C a, Storable a) => T w a -> T w a -> T w a
merge
   mconcat :: [T w a] -> T w a
mconcat = [T w a] -> T w a
forall a w. (C a, Storable a) => [T w a] -> T w a
mergeMany