├── .gitignore
├── .travis.yml
├── .vim.custom
├── CHANGELOG.markdown
├── HLint.hs
├── LICENSE
├── README.markdown
├── Setup.lhs
├── benchmarks
    ├── inserts.hs
    ├── lookups.hs
    └── maps.hs
├── src
    └── Data
    │   └── Vector
    │       ├── Array.hs
    │       ├── Heap.hs
    │       ├── Map.hs
    │       ├── Map
    │           ├── Deamortized.hs
    │           ├── Ephemeral.hs
    │           └── Fusion.hs
    │       ├── Set.hs
    │       ├── Set
    │           └── Fusion.hs
    │       └── Slow.hs
├── structures.cabal
├── tests
    ├── doctests.hsc
    ├── hlint.hs
    ├── hunit.hs
    └── properties.hs
└── travis
    ├── cabal-apt-install
    └── config


/.gitignore:
--------------------------------------------------------------------------------
 1 | dist
 2 | docs
 3 | wiki
 4 | TAGS
 5 | tags
 6 | wip
 7 | stats
 8 | .DS_Store
 9 | .*.swp
10 | .*.swo
11 | *.o
12 | *.hi
13 | *~
14 | *#
15 | .cabal-sandbox
16 | cabal.sandbox.config
17 | 


--------------------------------------------------------------------------------
/.travis.yml:
--------------------------------------------------------------------------------
 1 | language: haskell
 2 | before_install:
 3 |   # Uncomment whenever hackage is down.
 4 |   # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && cabal update
 5 |   - cabal update
 6 | 
 7 |   # Try installing some of the build-deps with apt-get for speed.
 8 |   - travis/cabal-apt-install $mode --force-reinstalls
 9 | 
10 | install:
11 |   - cabal configure -flib-Werror $mode
12 |   - cabal build
13 |   - cabal install --enable-documentation
14 | 
15 | script:
16 |   - $script
17 | 
18 | # disable travis for now, atomic-primops doesn't work on GHC 7.4
19 | branches:
20 |   except: /.*/
21 | 
22 | notifications:
23 |   irc:
24 |     channels:
25 |       - "irc.freenode.org#haskell-lens"
26 |     skip_join: true
27 |     template:
28 |       - "\x0313structures\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"
29 | 
30 | env:
31 |   - mode="--enable-tests" script="cabal test --show-details=always"
32 | 


--------------------------------------------------------------------------------
/.vim.custom:
--------------------------------------------------------------------------------
 1 | " Add the following to your .vimrc to automatically load this on startup
 2 | 
 3 | " if filereadable(".vim.custom")
 4 | "     so .vim.custom
 5 | " endif
 6 | 
 7 | function StripTrailingWhitespace()
 8 |   let myline=line(".")
 9 |   let mycolumn = col(".")
10 |   silent %s/  *$//
11 |   call cursor(myline, mycolumn)
12 | endfunction
13 | 
14 | " enable syntax highlighting
15 | syntax on
16 | 
17 | " search for the tags file anywhere between here and /
18 | set tags=TAGS;/
19 | 
20 | " highlight tabs and trailing spaces
21 | set listchars=tab:‗‗,trail:‗
22 | set list
23 | 
24 | " f2 runs hasktags
25 | map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR>
26 | 
27 | " strip trailing whitespace before saving
28 | " au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace()
29 | 
30 | " rebuild hasktags after saving
31 | au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"
32 | 


--------------------------------------------------------------------------------
/CHANGELOG.markdown:
--------------------------------------------------------------------------------
 1 | 0.2
 2 | ---
 3 | * `Data.Vector.Map` now has asymptotics that are fully deamortized.
 4 | * `Data.Vector.Map.Ephemeral` provides a cache-oblivious lookahead array that doesn't deamortize.
 5 |   On the plus side it can be 2-4x faster than `Data.Vector.Map`.
 6 |   On the downside, using anything but the most recent version can dramaticlly affect the asymptotics of your program.
 7 | 
 8 | 0.1
 9 | ---
10 | * Repository initialized
11 | 
12 | 


--------------------------------------------------------------------------------
/HLint.hs:
--------------------------------------------------------------------------------
1 | import "hint" HLint.Default
2 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright 2013 Edward Kmett
 2 | 
 3 | All rights reserved.
 4 | 
 5 | Redistribution and use in source and binary forms, with or without
 6 | modification, are permitted provided that the following conditions
 7 | are met:
 8 | 
 9 | 1. Redistributions of source code must retain the above copyright
10 |    notice, this list of conditions and the following disclaimer.
11 | 
12 | 2. Redistributions in binary form must reproduce the above copyright
13 |    notice, this list of conditions and the following disclaimer in the
14 |    documentation and/or other materials provided with the distribution.
15 | 
16 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
17 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
18 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
19 | DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
20 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
21 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
22 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
23 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
24 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
25 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
26 | POSSIBILITY OF SUCH DAMAGE.
27 | 


--------------------------------------------------------------------------------
/README.markdown:
--------------------------------------------------------------------------------
 1 | structures
 2 | ==========
 3 | 
 4 | [![Hackage](https://img.shields.io/hackage/v/structures.svg)](https://hackage.haskell.org/package/structures) [![Build Status](https://secure.travis-ci.org/ekmett/structures.png?branch=master)](http://travis-ci.org/ekmett/structures)
 5 | 
 6 | A playground for working with cache oblivious, succinct and compact data structures
 7 | 
 8 | Contact Information
 9 | -------------------
10 | 
11 | Contributions and bug reports are welcome!
12 | 
13 | Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net.
14 | 
15 | -Edward Kmett
16 | 


--------------------------------------------------------------------------------
/Setup.lhs:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/runhaskell
 2 | \begin{code}
 3 | {-# OPTIONS_GHC -Wall #-}
 4 | module Main (main) where
 5 | 
 6 | import Data.List ( nub )
 7 | import Data.Version ( showVersion )
 8 | import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName )
 9 | import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )
10 | import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )
11 | import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles )
12 | import Distribution.Simple.BuildPaths ( autogenModulesDir )
13 | import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref))
14 | import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )
15 | import Distribution.Text ( display )
16 | import Distribution.Verbosity ( Verbosity, normal )
17 | import System.FilePath ( (</>) )
18 | 
19 | main :: IO ()
20 | main = defaultMainWithHooks simpleUserHooks
21 |   { buildHook = \pkg lbi hooks flags -> do
22 |      generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi
23 |      buildHook simpleUserHooks pkg lbi hooks flags
24 |   , postHaddock = \args flags pkg lbi -> do
25 |      copyFiles normal (haddockOutputDir flags pkg) []
26 |      postHaddock simpleUserHooks args flags pkg lbi
27 |   }
28 | 
29 | haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath
30 | haddockOutputDir flags pkg = destDir where
31 |   baseDir = case haddockDistPref flags of
32 |     NoFlag -> "."
33 |     Flag x -> x
34 |   destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)
35 | 
36 | generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()
37 | generateBuildModule verbosity pkg lbi = do
38 |   let dir = autogenModulesDir lbi
39 |   createDirectoryIfMissingVerbose verbosity True dir
40 |   withLibLBI pkg lbi $ \_ libcfg -> do
41 |     withTestLBI pkg lbi $ \suite suitecfg -> do
42 |       rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines
43 |         [ "module Build_" ++ testName suite ++ " where"
44 |         , "deps :: [String]"
45 |         , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))
46 |         ]
47 |   where
48 |     formatdeps = map (formatone . snd)
49 |     formatone p = case packageName p of
50 |       PackageName n -> n ++ "-" ++ showVersion (packageVersion p)
51 | 
52 | testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]
53 | testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys
54 | 
55 | \end{code}
56 | 


--------------------------------------------------------------------------------
/benchmarks/inserts.hs:
--------------------------------------------------------------------------------
 1 | {-# OPTIONS_GHC -fno-warn-orphans #-}
 2 | module Main where
 3 | 
 4 | import Data.Foldable as F
 5 | import Data.Map as M
 6 | import Data.HashMap.Strict as H
 7 | import Data.Vector.Map.Ephemeral as V
 8 | import Data.Vector.Map.Persistent as P
 9 | import Data.Vector.Map.Tuned as T
10 | import Data.Vector.Map as O
11 | import Control.DeepSeq
12 | import Control.Monad.Random
13 | import Control.Monad
14 | import Criterion.Config
15 | import Criterion.Main
16 | 
17 | instance NFData (V.Map k v)
18 | instance NFData (O.Map k v)
19 | instance NFData (P.Map k v)
20 | instance NFData (T.Map k v)
21 | 
22 | buildP :: Int -> P.Map Int Int
23 | buildP n = F.foldl' (flip (join P.insert)) P.empty $ take n $ randoms (mkStdGen 1)
24 | 
25 | buildT :: Int -> T.Map Int Int
26 | buildT n = F.foldl' (flip (join T.insert)) T.empty $ take n $ randoms (mkStdGen 1)
27 | 
28 | buildV :: Int -> V.Map Int Int
29 | buildV n = F.foldl' (flip (join V.insert)) V.empty $ take n $ randoms (mkStdGen 1)
30 | 
31 | fromListV :: Int -> V.Map Int Int
32 | fromListV n = V.fromList $ Prelude.map (\x -> (x,x)) $ take n $ randoms (mkStdGen 1)
33 | 
34 | buildO :: Int -> O.Map Int Int
35 | buildO n = F.foldl' (flip (join O.insert)) O.empty $ take n $ randoms (mkStdGen 1)
36 | 
37 | fromListO :: Int -> O.Map Int Int
38 | fromListO n = O.fromList $ Prelude.map (\x -> (x,x)) $ take n $ randoms (mkStdGen 1)
39 | 
40 | buildM :: Int -> M.Map Int Int
41 | buildM n = F.foldl' (flip (join M.insert)) M.empty $ take n $ randoms (mkStdGen 1)
42 | 
43 | buildH :: Int -> H.HashMap Int Int
44 | buildH n = F.foldl' (flip (join H.insert)) H.empty $ take n $ randoms (mkStdGen 1)
45 | 
46 | main :: IO ()
47 | main = defaultMainWith defaultConfig { cfgSamples = ljust 10 } (return ())
48 |   [ bench "Ephemeral insert 10k"     $ nf buildV 10000
49 |   , bench "Persistent insert 10k"    $ nf buildP 10000
50 |   , bench "Tuned insert 10k"         $ nf buildT 10000
51 |   , bench "Data.Map insert 10k"      $ nf buildM 10000
52 |   , bench "Data.HashMap insert 10k"  $ nf buildH 10000
53 |   , bench "WC insert 10k"            $ nf buildO 10000
54 |   , bench "Ephemeral insert 100k"    $ nf buildV 100000
55 |   , bench "Persistent insert 100k"   $ nf buildP 100000
56 |   , bench "Tuned insert 100k"        $ nf buildT 100000
57 |   , bench "Data.Map insert 100k"     $ nf buildM 100000
58 |   , bench "Data.HashMap insert 100k" $ nf buildH 100000
59 |   , bench "Worstcase insert 100k"    $ nf buildO 100000
60 |   , bench "Ephemeral insert 1m"      $ nf buildV 1000000
61 |   , bench "Persistent insert 1m"     $ nf buildP 1000000
62 |   , bench "Tuned insert 1m"          $ nf buildT 1000000
63 |   , bench "Data.Map insert 1m"       $ nf buildM 1000000
64 |   , bench "Data.HashMap insert 1m"   $ nf buildH 1000000
65 |   , bench "Overmars insert 1m"       $ nf buildO 1000000
66 |   ]
67 | 


--------------------------------------------------------------------------------
/benchmarks/lookups.hs:
--------------------------------------------------------------------------------
 1 | {-# OPTIONS_GHC -fno-warn-orphans #-}
 2 | module Main where
 3 | 
 4 | import Data.Foldable as F
 5 | import Data.Map as M
 6 | import Data.Maybe
 7 | import Data.Vector.Map as V
 8 | import Control.DeepSeq
 9 | import Control.Monad.Random
10 | import Control.Monad
11 | import Criterion.Config
12 | import Criterion.Main
13 | 
14 | instance NFData (V.Map k v)
15 | 
16 | buildV :: Int -> V.Map Int Int
17 | buildV n = F.foldl' (flip (join V.insert)) V.empty $ take n $ randoms (mkStdGen 1)
18 | 
19 | buildM :: Int -> M.Map Int Int
20 | buildM n = F.foldl' (flip (join M.insert)) M.empty $ take n $ randoms (mkStdGen 1)
21 | 
22 | lookupV :: V.Map Int Int -> Int -> Int
23 | lookupV m n = F.foldl' (+) 0 $ catMaybes $ fmap (`V.lookup` m) $ take n $ randoms (mkStdGen 1)
24 | 
25 | lookupM :: M.Map Int Int -> Int -> Int
26 | lookupM m n = F.foldl' (+) 0 $ catMaybes $ fmap (`M.lookup` m) $ take n $ randoms (mkStdGen 1)
27 | 
28 | main :: IO ()
29 | main = do
30 |     nfIO (return v10)
31 |     nfIO (return m10)
32 |     nfIO (return v100)
33 |     nfIO (return m100)
34 |     nfIO (return v1000)
35 |     nfIO (return m1000)
36 |     defaultMainWith defaultConfig { cfgSamples = ljust 10 } (return ())
37 |       [ bench "COLA lookup 10k from 10k"      $ nf (lookupV v10)   10000
38 |       , bench "Data.Map lookup 10k from 10k"  $ nf (lookupM m10)   10000
39 |       , bench "COLA lookup 10k from 100k"     $ nf (lookupV v100)  10000
40 |       , bench "Data.Map lookup 10k from 100k" $ nf (lookupM m100)  10000
41 |       , bench "COLA lookup 10k from 1m"       $ nf (lookupV v1000) 10000
42 |       , bench "Data.Map lookup 10k from 1m"   $ nf (lookupM m1000) 10000
43 |       ]
44 |   where
45 |     v10   = buildV 10000
46 |     m10   = buildM 10000
47 |     v100  = buildV 100000
48 |     m100  = buildM 100000
49 |     v1000 = buildV 1000000
50 |     m1000 = buildM 1000000
51 | 


--------------------------------------------------------------------------------
/benchmarks/maps.hs:
--------------------------------------------------------------------------------
 1 | {-# OPTIONS_GHC -fno-warn-orphans #-}
 2 | module Main where
 3 | 
 4 | import Control.Monad (join)
 5 | import Criterion.Config
 6 | import Criterion.Main
 7 | import qualified Data.Map as M
 8 | import qualified Data.Vector.Map as V
 9 | import qualified Data.Vector.Unboxed as U
10 | import qualified Data.Vector.Generic as G
11 | import qualified Data.Vector.Generic.Mutable as GM
12 | import System.Random.MWC (withSystemRandom, GenIO, Variate(..))
13 | 
14 | randVec :: (U.Unbox a, Variate a) => Int -> GenIO -> IO (U.Vector a)
15 | randVec n g = GM.replicateM n (uniform g) >>= G.unsafeFreeze
16 | 
17 | randVecStd :: (U.Unbox a, Variate a) => Int -> IO (U.Vector a)
18 | randVecStd = withSystemRandom . randVec
19 | 
20 | insertAll :: U.Unbox a => (a -> a -> t -> t) -> t -> U.Vector a -> t
21 | insertAll f e = U.foldl' (flip $ join f) e
22 | 
23 | sumAll :: (U.Unbox a, U.Unbox b, Num b) => (a -> b) -> U.Vector a -> b
24 | sumAll f = U.sum . U.map f
25 | 
26 | main :: IO ()
27 | main = do
28 |   ns <- randVecStd 1000 :: IO (U.Vector Int)
29 |   -- print (vinsert ns)
30 |   -- print (V.shape (vinsert ns))
31 |   putStrLn $ if sumAll (vget (vinsert ns)) ns == sumAll (minsert ns M.!) ns
32 |              then "We are sane"
33 |              else "We are insane, man!"
34 |   defaultMainWith defaultConfig { cfgSamples = ljust 10 } (return ())
35 |     [ bench "Map insertion"  $ whnf minsert ns
36 |     , bench "VMap insertion" $ whnf vinsert ns
37 |     , bench "map sum"        $ whnf (sumAll (minsert ns M.!)) ns
38 |     , bench "vmap sum"       $ whnf (sumAll (vget (vinsert ns))) ns
39 |     ]
40 |  where
41 |   minsert = insertAll M.insert M.empty
42 |   vinsert = insertAll V.insert V.empty
43 |   vget m k = case V.lookup k m of
44 |     Nothing -> error $ "Missing "++show k
45 |     Just x -> x
46 | 


--------------------------------------------------------------------------------
/src/Data/Vector/Array.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP #-}
  2 | {-# LANGUAGE GADTs #-}
  3 | {-# LANGUAGE MagicHash #-}
  4 | {-# LANGUAGE TypeFamilies #-}
  5 | {-# LANGUAGE ViewPatterns #-}
  6 | {-# LANGUAGE KindSignatures #-}
  7 | {-# LANGUAGE FlexibleContexts #-}
  8 | {-# LANGUAGE DefaultSignatures #-}
  9 | {-# LANGUAGE ScopedTypeVariables #-}
 10 | {-# LANGUAGE UndecidableInstances #-}
 11 | {-# LANGUAGE MultiParamTypeClasses #-}
 12 | -----------------------------------------------------------------------------
 13 | -- |
 14 | -- Copyright   :  (C) 2013-2015 Edward Kmett
 15 | -- License     :  BSD-style (see the file LICENSE)
 16 | -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
 17 | -- Stability   :  experimental
 18 | -- Portability :  non-portable
 19 | --
 20 | -- This module provides a choice of a "best" vector type for a given type
 21 | -- that is as unboxed as possible.
 22 | -----------------------------------------------------------------------------
 23 | module Data.Vector.Array
 24 | 
 25 |   ( Arrayed(..)
 26 |   , Array
 27 |   , MArray
 28 |   -- * Internals
 29 |   , V_Complex(V_Complex)
 30 |   , MV_Complex(MV_Complex)
 31 |   , V_Pair(V_Pair)
 32 |   , MV_Pair(MV_Pair)
 33 |   , prefetchArray0#, prefetchArray1#, prefetchArray2#, prefetchArray3#
 34 |   , prefetchSmallArray0#, prefetchSmallArray1#, prefetchSmallArray2#, prefetchSmallArray3#
 35 |   , prefetchMutableArray0#, prefetchMutableArray1#, prefetchMutableArray2#, prefetchMutableArray3#
 36 |   , prefetchSmallMutableArray0#, prefetchSmallMutableArray1#, prefetchSmallMutableArray2#, prefetchSmallMutableArray3#
 37 |   , prefetchPrim0#, prefetchPrim1#, prefetchPrim2#, prefetchPrim3#
 38 |   , prefetchMutablePrim0#, prefetchMutablePrim1#, prefetchMutablePrim2#, prefetchMutablePrim3#
 39 |   ) where
 40 | 
 41 | import Control.Monad
 42 | import Data.Complex
 43 | import Data.Int
 44 | import Data.Primitive hiding (Array)
 45 | import qualified Data.Primitive as Primitive
 46 | import qualified Data.Vector.Generic as G
 47 | import qualified Data.Vector.Generic.Mutable as GM
 48 | import qualified Data.Vector.Primitive as P
 49 | import qualified Data.Vector.Primitive.Mutable as PM
 50 | import qualified Data.Vector.Unboxed as U
 51 | import qualified Data.Vector.Unboxed.Base as UB
 52 | import qualified Data.Vector.Fusion.Stream as Stream
 53 | import qualified Data.Vector as B
 54 | import qualified Data.Vector.Mutable as BM
 55 | import Data.Word
 56 | import GHC.Prim
 57 | import GHC.Types
 58 | import Text.Read
 59 | 
 60 | #include "ghcautoconf.h"
 61 | #include "DerivedConstants.h"
 62 | 
 63 | #if SIZEOF_VOID_P == 4
 64 | #define W 4#
 65 | #elif SIZEOF_VOID_P == 8
 66 | #define W 8#
 67 | #else
 68 | #error unknown pointer size
 69 | #endif
 70 | 
 71 | #if OFFSET_StgMutArrPtrs_size != SIZEOF_VOID_P
 72 | #error did the card marking machinery change?
 73 | #endif
 74 | 
 75 | 
 76 | -- | A vector of product-like data types that know how to store themselves in a Vector optimally,
 77 | -- maximizing the level of unboxing provided, but not guaranteeing to unbox it all.
 78 | 
 79 | type Array a = Arr a a
 80 | type MArray s a = G.Mutable (Arr a) s a
 81 | 
 82 | prefetchArray0#, prefetchArray1#, prefetchArray2#, prefetchArray3# :: Array# a -> Int# -> State# d -> State# d
 83 | prefetchArray0# a i s = unsafeCoerce# prefetchByteArray0# a ((i *# W) +# W) s
 84 | prefetchArray1# a i s = unsafeCoerce# prefetchByteArray1# a ((i *# W) +# W) s
 85 | prefetchArray2# a i s = unsafeCoerce# prefetchByteArray2# a ((i *# W) +# W) s
 86 | prefetchArray3# a i s = unsafeCoerce# prefetchByteArray3# a ((i *# W) +# W) s
 87 | 
 88 | prefetchMutableArray0#, prefetchMutableArray1#, prefetchMutableArray2#, prefetchMutableArray3# :: MutableArray# d a -> Int# -> State# d -> State# d
 89 | prefetchMutableArray0# a i s = unsafeCoerce# prefetchMutableByteArray0# a ((i *# W) +# W) s
 90 | prefetchMutableArray1# a i s = unsafeCoerce# prefetchMutableByteArray1# a ((i *# W) +# W) s
 91 | prefetchMutableArray2# a i s = unsafeCoerce# prefetchMutableByteArray2# a ((i *# W) +# W) s
 92 | prefetchMutableArray3# a i s = unsafeCoerce# prefetchMutableByteArray3# a ((i *# W) +# W) s
 93 | 
 94 | prefetchSmallArray0#, prefetchSmallArray1#, prefetchSmallArray2#, prefetchSmallArray3# :: SmallArray# a -> Int# -> State# d -> State# d
 95 | prefetchSmallArray0# a i s = unsafeCoerce# prefetchByteArray0# a (i *# W) s
 96 | prefetchSmallArray1# a i s = unsafeCoerce# prefetchByteArray1# a (i *# W) s
 97 | prefetchSmallArray2# a i s = unsafeCoerce# prefetchByteArray2# a (i *# W) s
 98 | prefetchSmallArray3# a i s = unsafeCoerce# prefetchByteArray3# a (i *# W) s
 99 | 
100 | prefetchSmallMutableArray0#, prefetchSmallMutableArray1#, prefetchSmallMutableArray2#, prefetchSmallMutableArray3# :: SmallMutableArray# d a -> Int# -> State# d -> State# d
101 | prefetchSmallMutableArray0# a i s = unsafeCoerce# prefetchMutableByteArray0# a (i *# W) s
102 | prefetchSmallMutableArray1# a i s = unsafeCoerce# prefetchMutableByteArray1# a (i *# W) s
103 | prefetchSmallMutableArray2# a i s = unsafeCoerce# prefetchMutableByteArray2# a (i *# W) s
104 | prefetchSmallMutableArray3# a i s = unsafeCoerce# prefetchMutableByteArray3# a (i *# W) s
105 | 
106 | class (G.Vector (Arr a) a, Monoid (Arr a a)) => Arrayed a where
107 |   type Arr a :: * -> *
108 |   type Arr a = B.Vector
109 | 
110 |   prefetchArr0# :: Arr a a -> Int# -> State# s -> State# s
111 |   default prefetchArr0# :: (Arr a ~ B.Vector) => Arr a a -> Int# -> State# s -> State# s
112 |   prefetchArr0# (coerceVector -> BVector (I# o) _ (Primitive.Array arr)) i s = prefetchArray0# arr (o +# i) s
113 | 
114 |   prefetchArr1# :: Arr a a -> Int# -> State# s -> State# s
115 |   default prefetchArr1# :: (Arr a ~ B.Vector) => Arr a a -> Int# -> State# s -> State# s
116 |   prefetchArr1# (coerceVector -> BVector (I# o) _ (Primitive.Array arr)) i s = prefetchArray1# arr (o +# i) s
117 | 
118 |   prefetchArr2# :: Arr a a -> Int# -> State# s -> State# s
119 |   default prefetchArr2# :: (Arr a ~ B.Vector) => Arr a a -> Int# -> State# s -> State# s
120 |   prefetchArr2# (coerceVector -> BVector (I# o) _ (Primitive.Array arr)) i s = prefetchArray2# arr (o +# i) s
121 | 
122 |   prefetchArr3# :: Arr a a -> Int# -> State# s -> State# s
123 |   default prefetchArr3# :: (Arr a ~ B.Vector) => Arr a a -> Int# -> State# s -> State# s
124 |   prefetchArr3# (coerceVector -> BVector (I# o) _ (Primitive.Array arr)) i s = prefetchArray3# arr (o +# i) s
125 | 
126 |   prefetchMutableArr0# :: G.Mutable (Arr a) s a -> Int# -> State# s -> State# s
127 |   default prefetchMutableArr0# :: (G.Mutable (Arr a) ~ BM.MVector) => G.Mutable (Arr a) s a -> Int# -> State# s -> State# s
128 |   prefetchMutableArr0# (BM.MVector (I# o) _ (MutableArray arr)) i s = prefetchMutableArray0# arr (o +# i) s
129 | 
130 |   prefetchMutableArr1# :: G.Mutable (Arr a) s a -> Int# -> State# s -> State# s
131 |   default prefetchMutableArr1# :: (G.Mutable (Arr a) ~ BM.MVector) => G.Mutable (Arr a) s a -> Int# -> State# s -> State# s
132 |   prefetchMutableArr1# (BM.MVector (I# o) _ (MutableArray arr)) i s = prefetchMutableArray1# arr (o +# i) s
133 | 
134 |   prefetchMutableArr2# :: G.Mutable (Arr a) s a -> Int# -> State# s -> State# s
135 |   default prefetchMutableArr2# :: (G.Mutable (Arr a) ~ BM.MVector) => G.Mutable (Arr a) s a -> Int# -> State# s -> State# s
136 |   prefetchMutableArr2# (BM.MVector (I# o) _ (MutableArray arr)) i s = prefetchMutableArray2# arr (o +# i) s
137 | 
138 |   prefetchMutableArr3# :: G.Mutable (Arr a) s a -> Int# -> State# s -> State# s
139 |   default prefetchMutableArr3# :: (G.Mutable (Arr a) ~ BM.MVector) => G.Mutable (Arr a) s a -> Int# -> State# s -> State# s
140 |   prefetchMutableArr3# (BM.MVector (I# o) _ (MutableArray arr)) i s = prefetchMutableArray3# arr (o +# i) s
141 | 
142 | prefetchPrim0#, prefetchPrim1#, prefetchPrim2#, prefetchPrim3# :: forall s a. Prim a => P.Vector a -> Int# -> State# s -> State# s
143 | prefetchPrim0# (P.Vector (I# o) _ (ByteArray arr)) i s = prefetchByteArray0# arr ((o +# i) *# sizeOf# (undefined :: a)) s
144 | prefetchPrim1# (P.Vector (I# o) _ (ByteArray arr)) i s = prefetchByteArray1# arr ((o +# i) *# sizeOf# (undefined :: a)) s
145 | prefetchPrim2# (P.Vector (I# o) _ (ByteArray arr)) i s = prefetchByteArray2# arr ((o +# i) *# sizeOf# (undefined :: a)) s
146 | prefetchPrim3# (P.Vector (I# o) _ (ByteArray arr)) i s = prefetchByteArray3# arr ((o +# i) *# sizeOf# (undefined :: a)) s
147 | 
148 | prefetchMutablePrim0#, prefetchMutablePrim1#, prefetchMutablePrim2#, prefetchMutablePrim3# :: forall s a. Prim a => PM.MVector s a -> Int# -> State# s -> State# s
149 | prefetchMutablePrim0# (PM.MVector (I# o) _ (MutableByteArray arr)) i s = prefetchMutableByteArray0# arr ((o +# i) *# sizeOf# (undefined :: a)) s
150 | prefetchMutablePrim1# (PM.MVector (I# o) _ (MutableByteArray arr)) i s = prefetchMutableByteArray1# arr ((o +# i) *# sizeOf# (undefined :: a)) s
151 | prefetchMutablePrim2# (PM.MVector (I# o) _ (MutableByteArray arr)) i s = prefetchMutableByteArray2# arr ((o +# i) *# sizeOf# (undefined :: a)) s
152 | prefetchMutablePrim3# (PM.MVector (I# o) _ (MutableByteArray arr)) i s = prefetchMutableByteArray3# arr ((o +# i) *# sizeOf# (undefined :: a)) s
153 | 
154 | -- * Unboxed vectors
155 | 
156 | instance Arrayed () where
157 |   type Arr () = U.Vector
158 |   prefetchArr0# _ _ s = s
159 |   prefetchArr1# _ _ s = s
160 |   prefetchArr2# _ _ s = s
161 |   prefetchArr3# _ _ s = s
162 |   prefetchMutableArr0# _ _ s = s
163 |   prefetchMutableArr1# _ _ s = s
164 |   prefetchMutableArr2# _ _ s = s
165 |   prefetchMutableArr3# _ _ s = s
166 | 
167 | instance Arrayed Double where
168 |   type Arr Double = U.Vector
169 |   prefetchArr0# (UB.V_Double v) i s = prefetchPrim0# v i s
170 |   prefetchArr1# (UB.V_Double v) i s = prefetchPrim1# v i s
171 |   prefetchArr2# (UB.V_Double v) i s = prefetchPrim2# v i s
172 |   prefetchArr3# (UB.V_Double v) i s = prefetchPrim3# v i s
173 |   prefetchMutableArr0# (UB.MV_Double v) i s = prefetchMutablePrim0# v i s
174 |   prefetchMutableArr1# (UB.MV_Double v) i s = prefetchMutablePrim1# v i s
175 |   prefetchMutableArr2# (UB.MV_Double v) i s = prefetchMutablePrim2# v i s
176 |   prefetchMutableArr3# (UB.MV_Double v) i s = prefetchMutablePrim3# v i s
177 | 
178 | instance Arrayed Float where
179 |   type Arr Float = U.Vector
180 |   prefetchArr0# (UB.V_Float v) i s = prefetchPrim0# v i s
181 |   prefetchArr1# (UB.V_Float v) i s = prefetchPrim1# v i s
182 |   prefetchArr2# (UB.V_Float v) i s = prefetchPrim2# v i s
183 |   prefetchArr3# (UB.V_Float v) i s = prefetchPrim3# v i s
184 |   prefetchMutableArr0# (UB.MV_Float v) i s = prefetchMutablePrim0# v i s
185 |   prefetchMutableArr1# (UB.MV_Float v) i s = prefetchMutablePrim1# v i s
186 |   prefetchMutableArr2# (UB.MV_Float v) i s = prefetchMutablePrim2# v i s
187 |   prefetchMutableArr3# (UB.MV_Float v) i s = prefetchMutablePrim3# v i s
188 | 
189 | instance Arrayed Int where
190 |   type Arr Int = U.Vector
191 |   prefetchArr0# (UB.V_Int v) i s = prefetchPrim0# v i s
192 |   prefetchArr1# (UB.V_Int v) i s = prefetchPrim1# v i s
193 |   prefetchArr2# (UB.V_Int v) i s = prefetchPrim2# v i s
194 |   prefetchArr3# (UB.V_Int v) i s = prefetchPrim3# v i s
195 |   prefetchMutableArr0# (UB.MV_Int v) i s = prefetchMutablePrim0# v i s
196 |   prefetchMutableArr1# (UB.MV_Int v) i s = prefetchMutablePrim1# v i s
197 |   prefetchMutableArr2# (UB.MV_Int v) i s = prefetchMutablePrim2# v i s
198 |   prefetchMutableArr3# (UB.MV_Int v) i s = prefetchMutablePrim3# v i s
199 | 
200 | instance Arrayed Int8 where
201 |   type Arr Int8 = U.Vector
202 |   prefetchArr0# (UB.V_Int8 v) i s = prefetchPrim0# v i s
203 |   prefetchArr1# (UB.V_Int8 v) i s = prefetchPrim1# v i s
204 |   prefetchArr2# (UB.V_Int8 v) i s = prefetchPrim2# v i s
205 |   prefetchArr3# (UB.V_Int8 v) i s = prefetchPrim3# v i s
206 |   prefetchMutableArr0# (UB.MV_Int8 v) i s = prefetchMutablePrim0# v i s
207 |   prefetchMutableArr1# (UB.MV_Int8 v) i s = prefetchMutablePrim1# v i s
208 |   prefetchMutableArr2# (UB.MV_Int8 v) i s = prefetchMutablePrim2# v i s
209 |   prefetchMutableArr3# (UB.MV_Int8 v) i s = prefetchMutablePrim3# v i s
210 | 
211 | instance Arrayed Int16 where
212 |   type Arr Int16 = U.Vector
213 |   prefetchArr0# (UB.V_Int16 v) i s = prefetchPrim0# v i s
214 |   prefetchArr1# (UB.V_Int16 v) i s = prefetchPrim1# v i s
215 |   prefetchArr2# (UB.V_Int16 v) i s = prefetchPrim2# v i s
216 |   prefetchArr3# (UB.V_Int16 v) i s = prefetchPrim3# v i s
217 |   prefetchMutableArr0# (UB.MV_Int16 v) i s = prefetchMutablePrim0# v i s
218 |   prefetchMutableArr1# (UB.MV_Int16 v) i s = prefetchMutablePrim1# v i s
219 |   prefetchMutableArr2# (UB.MV_Int16 v) i s = prefetchMutablePrim2# v i s
220 |   prefetchMutableArr3# (UB.MV_Int16 v) i s = prefetchMutablePrim3# v i s
221 | 
222 | instance Arrayed Int32 where
223 |   type Arr Int32 = U.Vector
224 |   prefetchArr0# (UB.V_Int32 v) i s = prefetchPrim0# v i s
225 |   prefetchArr1# (UB.V_Int32 v) i s = prefetchPrim1# v i s
226 |   prefetchArr2# (UB.V_Int32 v) i s = prefetchPrim2# v i s
227 |   prefetchArr3# (UB.V_Int32 v) i s = prefetchPrim3# v i s
228 |   prefetchMutableArr0# (UB.MV_Int32 v) i s = prefetchMutablePrim0# v i s
229 |   prefetchMutableArr1# (UB.MV_Int32 v) i s = prefetchMutablePrim1# v i s
230 |   prefetchMutableArr2# (UB.MV_Int32 v) i s = prefetchMutablePrim2# v i s
231 |   prefetchMutableArr3# (UB.MV_Int32 v) i s = prefetchMutablePrim3# v i s
232 | 
233 | instance Arrayed Int64 where
234 |   type Arr Int64 = U.Vector
235 |   prefetchArr0# (UB.V_Int64 v) i s = prefetchPrim0# v i s
236 |   prefetchArr1# (UB.V_Int64 v) i s = prefetchPrim1# v i s
237 |   prefetchArr2# (UB.V_Int64 v) i s = prefetchPrim2# v i s
238 |   prefetchArr3# (UB.V_Int64 v) i s = prefetchPrim3# v i s
239 |   prefetchMutableArr0# (UB.MV_Int64 v) i s = prefetchMutablePrim0# v i s
240 |   prefetchMutableArr1# (UB.MV_Int64 v) i s = prefetchMutablePrim1# v i s
241 |   prefetchMutableArr2# (UB.MV_Int64 v) i s = prefetchMutablePrim2# v i s
242 |   prefetchMutableArr3# (UB.MV_Int64 v) i s = prefetchMutablePrim3# v i s
243 | 
244 | instance Arrayed Word where
245 |   type Arr Word = U.Vector
246 |   prefetchArr0# (UB.V_Word v) i s = prefetchPrim0# v i s
247 |   prefetchArr1# (UB.V_Word v) i s = prefetchPrim1# v i s
248 |   prefetchArr2# (UB.V_Word v) i s = prefetchPrim2# v i s
249 |   prefetchArr3# (UB.V_Word v) i s = prefetchPrim3# v i s
250 |   prefetchMutableArr0# (UB.MV_Word v) i s = prefetchMutablePrim0# v i s
251 |   prefetchMutableArr1# (UB.MV_Word v) i s = prefetchMutablePrim1# v i s
252 |   prefetchMutableArr2# (UB.MV_Word v) i s = prefetchMutablePrim2# v i s
253 |   prefetchMutableArr3# (UB.MV_Word v) i s = prefetchMutablePrim3# v i s
254 | 
255 | instance Arrayed Word8 where
256 |   type Arr Word8 = U.Vector
257 |   prefetchArr0# (UB.V_Word8 v) i s = prefetchPrim0# v i s
258 |   prefetchArr1# (UB.V_Word8 v) i s = prefetchPrim1# v i s
259 |   prefetchArr2# (UB.V_Word8 v) i s = prefetchPrim2# v i s
260 |   prefetchArr3# (UB.V_Word8 v) i s = prefetchPrim3# v i s
261 |   prefetchMutableArr0# (UB.MV_Word8 v) i s = prefetchMutablePrim0# v i s
262 |   prefetchMutableArr1# (UB.MV_Word8 v) i s = prefetchMutablePrim1# v i s
263 |   prefetchMutableArr2# (UB.MV_Word8 v) i s = prefetchMutablePrim2# v i s
264 |   prefetchMutableArr3# (UB.MV_Word8 v) i s = prefetchMutablePrim3# v i s
265 | 
266 | instance Arrayed Word16 where
267 |   type Arr Word16 = U.Vector
268 |   prefetchArr0# (UB.V_Word16 v) i s = prefetchPrim0# v i s
269 |   prefetchArr1# (UB.V_Word16 v) i s = prefetchPrim1# v i s
270 |   prefetchArr2# (UB.V_Word16 v) i s = prefetchPrim2# v i s
271 |   prefetchArr3# (UB.V_Word16 v) i s = prefetchPrim3# v i s
272 |   prefetchMutableArr0# (UB.MV_Word16 v) i s = prefetchMutablePrim0# v i s
273 |   prefetchMutableArr1# (UB.MV_Word16 v) i s = prefetchMutablePrim1# v i s
274 |   prefetchMutableArr2# (UB.MV_Word16 v) i s = prefetchMutablePrim2# v i s
275 |   prefetchMutableArr3# (UB.MV_Word16 v) i s = prefetchMutablePrim3# v i s
276 | 
277 | instance Arrayed Word32 where
278 |   type Arr Word32 = U.Vector
279 |   prefetchArr0# (UB.V_Word32 v) i s = prefetchPrim0# v i s
280 |   prefetchArr1# (UB.V_Word32 v) i s = prefetchPrim1# v i s
281 |   prefetchArr2# (UB.V_Word32 v) i s = prefetchPrim2# v i s
282 |   prefetchArr3# (UB.V_Word32 v) i s = prefetchPrim3# v i s
283 |   prefetchMutableArr0# (UB.MV_Word32 v) i s = prefetchMutablePrim0# v i s
284 |   prefetchMutableArr1# (UB.MV_Word32 v) i s = prefetchMutablePrim1# v i s
285 |   prefetchMutableArr2# (UB.MV_Word32 v) i s = prefetchMutablePrim2# v i s
286 |   prefetchMutableArr3# (UB.MV_Word32 v) i s = prefetchMutablePrim3# v i s
287 | 
288 | instance Arrayed Word64 where
289 |   type Arr Word64 = U.Vector
290 |   prefetchArr0# (UB.V_Word64 v) i s = prefetchPrim0# v i s
291 |   prefetchArr1# (UB.V_Word64 v) i s = prefetchPrim1# v i s
292 |   prefetchArr2# (UB.V_Word64 v) i s = prefetchPrim2# v i s
293 |   prefetchArr3# (UB.V_Word64 v) i s = prefetchPrim3# v i s
294 |   prefetchMutableArr0# (UB.MV_Word64 v) i s = prefetchMutablePrim0# v i s
295 |   prefetchMutableArr1# (UB.MV_Word64 v) i s = prefetchMutablePrim1# v i s
296 |   prefetchMutableArr2# (UB.MV_Word64 v) i s = prefetchMutablePrim2# v i s
297 |   prefetchMutableArr3# (UB.MV_Word64 v) i s = prefetchMutablePrim3# v i s
298 | 
299 | -- * Boxed vectors
300 | 
301 | instance Arrayed Integer
302 | instance Arrayed [a]
303 | instance Arrayed (Maybe a)
304 | instance Arrayed (Either a b)
305 | instance Arrayed (IO a)
306 | 
307 | -- * Pairs are boxed or unboxed based on their components
308 | 
309 | #ifndef HLINT
310 | data MV_Pair :: * -> * -> * where
311 |   MV_Pair:: {-# UNPACK #-} !Int -> !(G.Mutable (Arr a) s a) -> !(G.Mutable (Arr b) s b) -> MV_Pair s (a, b)
312 | 
313 | data V_Pair :: * -> * where
314 |   V_Pair :: {-# UNPACK #-} !Int -> !(Array a) -> !(Array b) -> V_Pair (a, b)
315 | #endif
316 | 
317 | type instance G.Mutable V_Pair = MV_Pair
318 | 
319 | instance (Arrayed a, Arrayed b) => GM.MVector MV_Pair (a, b) where
320 |   {-# INLINE basicLength #-}
321 |   {-# INLINE basicUnsafeSlice #-}
322 |   {-# INLINE basicOverlaps #-}
323 |   {-# INLINE basicUnsafeNew #-}
324 |   {-# INLINE basicUnsafeReplicate #-}
325 |   {-# INLINE basicUnsafeRead #-}
326 |   {-# INLINE basicUnsafeWrite #-}
327 |   {-# INLINE basicClear #-}
328 |   {-# INLINE basicSet #-}
329 |   {-# INLINE basicUnsafeCopy #-}
330 |   {-# INLINE basicUnsafeGrow #-}
331 |   basicLength (MV_Pair l _ _) = l
332 |   basicUnsafeSlice i n (MV_Pair _ u v)                   = MV_Pair n (GM.basicUnsafeSlice i n u) (GM.basicUnsafeSlice i n v)
333 |   basicOverlaps (MV_Pair _ u1 v1) (MV_Pair _ u2 v2)      = GM.basicOverlaps u1 u2 || GM.basicOverlaps v1 v2
334 |   basicUnsafeNew n                                       = liftM2 (MV_Pair n) (GM.basicUnsafeNew n) (GM.basicUnsafeNew n)
335 |   basicUnsafeReplicate n (x, y)                          = liftM2 (MV_Pair n) (GM.basicUnsafeReplicate n x) (GM.basicUnsafeReplicate n y)
336 |   basicUnsafeRead (MV_Pair _ u v) i                      = liftM2 (,) (GM.basicUnsafeRead u i) (GM.basicUnsafeRead v i)
337 |   basicUnsafeWrite (MV_Pair _ u v) i (x, y)              = GM.basicUnsafeWrite u i x >> GM.basicUnsafeWrite v i y
338 |   basicClear (MV_Pair _ u v)                             = GM.basicClear u >> GM.basicClear v
339 |   basicSet (MV_Pair _ u v) (x, y)                        = GM.basicSet u x >> GM.basicSet v y
340 |   basicUnsafeCopy (MV_Pair _ u1 v1) (MV_Pair _ u2 v2)    = GM.basicUnsafeCopy u1 u2 >> GM.basicUnsafeCopy v1 v2
341 |   basicUnsafeMove (MV_Pair _ u1 v1) (MV_Pair _ u2 v2)    = GM.basicUnsafeMove u1 u2 >> GM.basicUnsafeMove v1 v2
342 |   basicUnsafeGrow (MV_Pair _ u v) n                      = liftM2 (MV_Pair n) (GM.basicUnsafeGrow u n) (GM.basicUnsafeGrow v n)
343 | 
344 | instance (Arrayed a, Arrayed b) => G.Vector V_Pair (a, b) where
345 |   {-# INLINE basicLength #-}
346 |   {-# INLINE basicUnsafeFreeze #-}
347 |   {-# INLINE basicUnsafeThaw #-}
348 |   {-# INLINE basicUnsafeSlice #-}
349 |   {-# INLINE basicUnsafeIndexM #-}
350 |   {-# INLINE elemseq #-}
351 |   basicLength (V_Pair v _ _) = v
352 |   basicUnsafeFreeze (MV_Pair n u v)                = liftM2 (V_Pair n) (G.basicUnsafeFreeze u) (G.basicUnsafeFreeze v)
353 |   basicUnsafeThaw (V_Pair n u v)                   = liftM2 (MV_Pair n) (G.basicUnsafeThaw u) (G.basicUnsafeThaw v)
354 |   basicUnsafeSlice i n (V_Pair _ u v)              = V_Pair n (G.basicUnsafeSlice i n u) (G.basicUnsafeSlice i n v)
355 |   basicUnsafeIndexM (V_Pair _ u v) i               = liftM2 (,) (G.basicUnsafeIndexM u i) (G.basicUnsafeIndexM v i)
356 |   basicUnsafeCopy (MV_Pair _ mu mv) (V_Pair _ u v) = G.basicUnsafeCopy mu u >> G.basicUnsafeCopy mv v
357 |   elemseq _ (x, y) z  = G.elemseq (undefined :: Array a) x
358 |                        $ G.elemseq (undefined :: Array b) y z
359 | 
360 | instance (Arrayed a, Arrayed b, Show a, Show b, c ~ (a, b)) => Show (V_Pair c) where
361 |   showsPrec = G.showsPrec
362 | 
363 | instance (Arrayed a, Arrayed b, Read a, Read b, c ~ (a, b)) => Read (V_Pair c) where
364 |   readPrec = G.readPrec
365 |   readListPrec = readListPrecDefault
366 | 
367 | instance (Arrayed a, Arrayed b, Eq a, Eq b, c ~ (a, b)) => Eq (V_Pair c) where
368 |   xs == ys = Stream.eq (G.stream xs) (G.stream ys)
369 |   {-# INLINE (==) #-}
370 | 
371 | instance (Arrayed a, Arrayed b, c ~ (a, b)) => Monoid (V_Pair c) where
372 |   mappend = (G.++)
373 |   {-# INLINE mappend #-}
374 |   mempty = G.empty
375 |   {-# INLINE mempty #-}
376 |   mconcat = G.concat
377 |   {-# INLINE mconcat #-}
378 | 
379 | instance (Arrayed a, Arrayed b) => Arrayed (a, b) where
380 |   type Arr (a, b) = V_Pair
381 |   prefetchArr0# (V_Pair _ u v) i s = prefetchArr0# v i (prefetchArr0# u i s)
382 |   prefetchArr1# (V_Pair _ u v) i s = prefetchArr1# v i (prefetchArr1# u i s)
383 |   prefetchArr2# (V_Pair _ u v) i s = prefetchArr2# v i (prefetchArr2# u i s)
384 |   prefetchArr3# (V_Pair _ u v) i s = prefetchArr3# v i (prefetchArr3# u i s)
385 |   prefetchMutableArr0# (MV_Pair _ u v) i s = prefetchMutableArr0# v i (prefetchMutableArr0# u i s)
386 |   prefetchMutableArr1# (MV_Pair _ u v) i s = prefetchMutableArr1# v i (prefetchMutableArr1# u i s)
387 |   prefetchMutableArr2# (MV_Pair _ u v) i s = prefetchMutableArr2# v i (prefetchMutableArr2# u i s)
388 |   prefetchMutableArr3# (MV_Pair _ u v) i s = prefetchMutableArr3# v i (prefetchMutableArr3# u i s)
389 | 
390 | -- * Complex numbers are boxed or unboxed based on their components
391 | 
392 | #ifndef HLINT
393 | data MV_Complex :: * -> * -> * where
394 |   MV_Complex :: {-# UNPACK #-} !Int -> !(G.Mutable (Arr a) s a) -> !(G.Mutable (Arr a) s a) -> MV_Complex s (Complex a)
395 | 
396 | data V_Complex :: * -> * where
397 |   V_Complex :: {-# UNPACK #-} !Int -> !(Array a) -> !(Array a) -> V_Complex (Complex a)
398 | #endif
399 | 
400 | type instance G.Mutable V_Complex = MV_Complex
401 | 
402 | instance (Arrayed a, RealFloat a) => GM.MVector MV_Complex (Complex a) where
403 |   {-# INLINE basicLength #-}
404 |   {-# INLINE basicUnsafeSlice #-}
405 |   {-# INLINE basicOverlaps #-}
406 |   {-# INLINE basicUnsafeNew #-}
407 |   {-# INLINE basicUnsafeReplicate #-}
408 |   {-# INLINE basicUnsafeRead #-}
409 |   {-# INLINE basicUnsafeWrite #-}
410 |   {-# INLINE basicClear #-}
411 |   {-# INLINE basicSet #-}
412 |   {-# INLINE basicUnsafeCopy #-}
413 |   {-# INLINE basicUnsafeGrow #-}
414 |   basicLength (MV_Complex l _ _) = l
415 |   basicUnsafeSlice i n (MV_Complex _ u v)                   = MV_Complex n (GM.basicUnsafeSlice i n u) (GM.basicUnsafeSlice i n v)
416 |   basicOverlaps (MV_Complex _ u1 v1) (MV_Complex _ u2 v2)   = GM.basicOverlaps u1 u2 || GM.basicOverlaps v1 v2
417 |   basicUnsafeNew n                                          = liftM2 (MV_Complex n) (GM.basicUnsafeNew n) (GM.basicUnsafeNew n)
418 |   basicUnsafeReplicate n (x :+ y)                           = liftM2 (MV_Complex n) (GM.basicUnsafeReplicate n x) (GM.basicUnsafeReplicate n y)
419 |   basicUnsafeRead (MV_Complex _ u v) i                      = liftM2 (:+) (GM.basicUnsafeRead u i) (GM.basicUnsafeRead v i)
420 |   basicUnsafeWrite (MV_Complex _ u v) i (x :+ y)            = GM.basicUnsafeWrite u i x >> GM.basicUnsafeWrite v i y
421 |   basicClear (MV_Complex _ u v)                             = GM.basicClear u >> GM.basicClear v
422 |   basicSet (MV_Complex _ u v) (x :+ y)                      = GM.basicSet u x >> GM.basicSet v y
423 |   basicUnsafeCopy (MV_Complex _ u1 v1) (MV_Complex _ u2 v2) = GM.basicUnsafeCopy u1 u2 >> GM.basicUnsafeCopy v1 v2
424 |   basicUnsafeMove (MV_Complex _ u1 v1) (MV_Complex _ u2 v2) = GM.basicUnsafeMove u1 u2 >> GM.basicUnsafeMove v1 v2
425 |   basicUnsafeGrow (MV_Complex _ u v) n                      = liftM2 (MV_Complex n) (GM.basicUnsafeGrow u n) (GM.basicUnsafeGrow v n)
426 | 
427 | instance (Arrayed a, RealFloat a) => G.Vector V_Complex (Complex a) where
428 |   {-# INLINE basicLength #-}
429 |   {-# INLINE basicUnsafeFreeze #-}
430 |   {-# INLINE basicUnsafeThaw #-}
431 |   {-# INLINE basicUnsafeSlice #-}
432 |   {-# INLINE basicUnsafeIndexM #-}
433 |   {-# INLINE elemseq #-}
434 |   basicLength (V_Complex v _ _) = v
435 |   basicUnsafeFreeze (MV_Complex n u v)                   = liftM2 (V_Complex n) (G.basicUnsafeFreeze u) (G.basicUnsafeFreeze v)
436 |   basicUnsafeThaw (V_Complex n u v)                      = liftM2 (MV_Complex n) (G.basicUnsafeThaw u) (G.basicUnsafeThaw v)
437 |   basicUnsafeSlice i n (V_Complex _ u v)                 = V_Complex n (G.basicUnsafeSlice i n u) (G.basicUnsafeSlice i n v)
438 |   basicUnsafeIndexM (V_Complex _ u v) i                  = liftM2 (:+) (G.basicUnsafeIndexM u i) (G.basicUnsafeIndexM v i)
439 |   basicUnsafeCopy (MV_Complex _ mu mv) (V_Complex _ u v) = G.basicUnsafeCopy mu u >> G.basicUnsafeCopy mv v
440 |   elemseq _ (x :+ y) z = G.elemseq (undefined :: Arr a a) x
441 |                        $ G.elemseq (undefined :: Arr a a) y z
442 | 
443 | instance (Arrayed a, RealFloat a, Show a, b ~ Complex a) => Show (V_Complex b) where
444 |   showsPrec = G.showsPrec
445 | 
446 | instance (Arrayed a, RealFloat a, Read a, b ~ Complex a) => Read (V_Complex b) where
447 |   readPrec = G.readPrec
448 |   readListPrec = readListPrecDefault
449 | 
450 | instance (Arrayed a, RealFloat a, Eq a, b ~ Complex a) => Eq (V_Complex b) where
451 |   xs == ys = Stream.eq (G.stream xs) (G.stream ys)
452 |   {-# INLINE (==) #-}
453 | 
454 | instance (Arrayed a, RealFloat a, b ~ Complex a) => Monoid (V_Complex b) where
455 |   mappend = (G.++)
456 |   {-# INLINE mappend #-}
457 |   mempty = G.empty
458 |   {-# INLINE mempty #-}
459 |   mconcat = G.concat
460 |   {-# INLINE mconcat #-}
461 | 
462 | instance (Arrayed a, RealFloat a) => Arrayed (Complex a) where
463 |   type Arr (Complex a) = V_Complex
464 |   prefetchArr0# (V_Complex _ u v) i s = prefetchArr0# v i (prefetchArr0# u i s)
465 |   prefetchArr1# (V_Complex _ u v) i s = prefetchArr1# v i (prefetchArr1# u i s)
466 |   prefetchArr2# (V_Complex _ u v) i s = prefetchArr2# v i (prefetchArr2# u i s)
467 |   prefetchArr3# (V_Complex _ u v) i s = prefetchArr3# v i (prefetchArr3# u i s)
468 |   prefetchMutableArr0# (MV_Complex _ u v) i s = prefetchMutableArr0# v i (prefetchMutableArr0# u i s)
469 |   prefetchMutableArr1# (MV_Complex _ u v) i s = prefetchMutableArr1# v i (prefetchMutableArr1# u i s)
470 |   prefetchMutableArr2# (MV_Complex _ u v) i s = prefetchMutableArr2# v i (prefetchMutableArr2# u i s)
471 |   prefetchMutableArr3# (MV_Complex _ u v) i s = prefetchMutableArr3# v i (prefetchMutableArr3# u i s)
472 | 
473 | -- LAME!
474 | data BVector a
475 |   = BVector {-# UNPACK #-}!Int
476 |             {-# UNPACK #-}!Int
477 |             {-# UNPACK #-}!(Primitive.Array a)
478 | 
479 | coerceVector :: B.Vector a -> BVector a
480 | coerceVector = unsafeCoerce#
481 | 


--------------------------------------------------------------------------------
/src/Data/Vector/Heap.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE BangPatterns #-}
 2 | {-# LANGUAGE PatternGuards #-}
 3 | module Data.Vector.Heap
 4 |   ( Heap
 5 |   , heapify
 6 |   , sift
 7 |   , findMin
 8 |   , deleteMin
 9 |   , updateMin
10 |   , null
11 |   , length
12 |   ) where
13 | 
14 | -- TODO: switch to vector-algorithm's quaternary heaps?
15 | 
16 | import Control.Monad (when)
17 | import Control.Monad.ST
18 | import Data.Bits
19 | import Data.Vector.Array
20 | import Data.Vector.Generic.Mutable as G
21 | import Prelude hiding (length, null)
22 | 
23 | type Heap s a = MArray s a
24 | 
25 | -- /O(n)/ min heapify for an implicit binary heap
26 | heapify :: (G.MVector v a, Ord a) => v s a -> ST s ()
27 | heapify v = go (unsafeShiftR (n-2) 1) where
28 |   !n = G.length v
29 |   go k = when (k >= 0) $ do
30 |     sift v k
31 |     go (k-1)
32 | 
33 | -- /O(log n)/ push own a given element
34 | sift :: (G.MVector v a, Ord a) => v s a -> Int -> ST s ()
35 | sift v root0 = go root0 where
36 |   !n = G.length v
37 |   go root | child1 <- unsafeShiftL root 1 + 1 = do
38 |     when (child1 < n) $ do -- in bounds
39 |       r  <- G.unsafeRead v root
40 |       c1 <- G.unsafeRead v child1
41 |       let swap0 = if r > c1 then child1 else root
42 |       let child2 = child1 + 1
43 |       swap1 <- if child2 < n -- in bounds
44 |         then do
45 |           s0 <- G.unsafeRead v swap0
46 |           c2 <- G.unsafeRead v child2
47 |           return $ if s0 > c2 then child2 else swap0
48 |         else return swap0
49 |       when (swap1 /= root) $ do
50 |         s1 <- G.unsafeRead v swap1
51 |         G.unsafeWrite v swap1 r
52 |         G.unsafeWrite v root s1
53 |         go swap1
54 | 
55 | -- /O(1)/
56 | findMin :: G.MVector v a => v s a -> ST s a
57 | findMin v = G.unsafeRead v 0
58 | 
59 | -- /O(log n)/
60 | deleteMin :: (G.MVector v a, Ord a) => v s a -> ST s (v s a)
61 | deleteMin v = do
62 |   let !n = G.length v
63 |   a <- G.unsafeRead v (n-1)
64 |   let !v' = G.unsafeSlice 0 (n-1) v
65 |   updateMin a v'
66 |   return v'
67 | 
68 | -- /O(log n)/
69 | updateMin :: (G.MVector v a, Ord a) => a -> v s a -> ST s ()
70 | updateMin a v = do
71 |   G.unsafeWrite v 0 a
72 |   sift v 0
73 | 


--------------------------------------------------------------------------------
/src/Data/Vector/Map.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP #-}
  2 | {-# LANGUAGE RankNTypes #-}
  3 | {-# LANGUAGE TypeFamilies #-}
  4 | {-# LANGUAGE MultiParamTypeClasses #-}
  5 | {-# LANGUAGE ScopedTypeVariables #-}
  6 | {-# LANGUAGE FlexibleInstances #-}
  7 | {-# LANGUAGE GADTs #-}
  8 | {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  9 | {-# LANGUAGE StandaloneDeriving #-}
 10 | {-# LANGUAGE ScopedTypeVariables #-}
 11 | {-# LANGUAGE FlexibleContexts #-}
 12 | {-# LANGUAGE UndecidableInstances #-}
 13 | {-# LANGUAGE BangPatterns #-}
 14 | {-# LANGUAGE PatternGuards #-}
 15 | #if __GLASGOW_HASKELL__ >= 708
 16 | {-# LANGUAGE RoleAnnotations #-}
 17 | #endif
 18 | -----------------------------------------------------------------------------
 19 | -- |
 20 | -- Copyright   :  (C) 2013-2014 Edward Kmett
 21 | -- License     :  BSD-style (see the file LICENSE)
 22 | -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
 23 | -- Stability   :  experimental
 24 | -- Portability :  non-portable
 25 | --
 26 | -- This module provides a 'Vector'-based 'Map' that is loosely based on the
 27 | -- Cache Oblivious Lookahead Array (COLA) by Bender et al. from
 28 | -- <http://supertech.csail.mit.edu/papers/sbtree.pdf "Cache-Oblivious Streaming B-Trees">,
 29 | -- but with inserts converted from ephemerally amortized to persisently amortized using a technique from Overmars and van Leeuwen.
 30 | --
 31 | -- Currently this 'Map' is implemented in an insert-only fashion. Deletions are left to future work
 32 | -- or to another derived structure in case they prove expensive.
 33 | --
 34 | -- Currently, we also do not use fractional cascading, as it affects the constant factors badly enough
 35 | -- to not pay for itself at the scales we are interested in. The naive /O(log^2 n)/ lookup
 36 | -- consistently outperforms the alternative.
 37 | --
 38 | -- Compared to the venerable @Data.Map@, this data structure currently consumes more memory, but it
 39 | -- provides a more limited palette of operations with different asymptotics (~10x faster inserts at a million entries)
 40 | -- and enables us to utilize contiguous storage.
 41 | --
 42 | -- /NB:/ when used with boxed data this structure may hold onto references to old versions
 43 | -- of things for many updates to come until sufficient operations have happened to merge them out
 44 | -- of the COLA.
 45 | -----------------------------------------------------------------------------
 46 | module Data.Vector.Map
 47 |   ( Map
 48 |   , empty
 49 |   , null
 50 |   , singleton
 51 |   , lookup
 52 |   , insert
 53 |   , fromList
 54 |   ) where
 55 | 
 56 | import Data.Bits
 57 | import qualified Data.Foldable as Foldable
 58 | import qualified Data.List as List
 59 | import Data.Vector.Array
 60 | import Data.Vector.Fusion.Stream.Monadic (Stream(..))
 61 | import qualified Data.Vector.Fusion.Stream.Monadic as Stream
 62 | import Data.Vector.Fusion.Util
 63 | import qualified Data.Map as Map
 64 | import qualified Data.Vector.Map.Fusion as Fusion
 65 | import qualified Data.Vector.Generic as G
 66 | import Prelude hiding (null, lookup)
 67 | 
 68 | -- | This Map is implemented as an insert-only Cache Oblivious Lookahead Array (COLA) with amortized complexity bounds
 69 | -- that are equal to those of a B-Tree, except for an extra log factor slowdown on lookups due to the lack of fractional
 70 | -- cascading. It uses a traditional Data.Map as a nursery.
 71 | 
 72 | data Map k a = Map !(Map.Map k a) !(LA k a)
 73 | 
 74 | _THRESHOLD :: Int
 75 | _THRESHOLD = 10
 76 | 
 77 | data LA k a
 78 |   = M0
 79 |   | M1 !(Chunk k a)
 80 |   | M2 !(Chunk k a) !(Chunk k a) (Chunk k a) !(LA k a) -- merged chunk is deliberately lazy
 81 |   | M3 !(Chunk k a) !(Chunk k a) !(Chunk k a) (Chunk k a) !(LA k a)
 82 | 
 83 | data Chunk k a = Chunk !(Array k) !(Array a)
 84 | 
 85 | deriving instance (Show (Arr k k), Show (Arr a a)) => Show (Chunk k a)
 86 | deriving instance (Show (Arr k k), Show (Arr a a)) => Show (LA k a)
 87 | 
 88 | #if __GLASGOW_HASKELL__ >= 708
 89 | type role LA nominal nominal
 90 | #endif
 91 | 
 92 | -- | /O(1)/. Identify if a 'LA' is the 'empty' 'LA'.
 93 | null :: Map k v -> Bool
 94 | null (Map m M0) = Map.null m
 95 | null _          = False
 96 | {-# INLINE null #-}
 97 | 
 98 | -- | /O(1)/ The 'empty' 'LA'.
 99 | empty :: Map k v
100 | empty = Map Map.empty M0
101 | {-# INLINE empty #-}
102 | 
103 | -- | /O(1)/ Construct a 'LA' from a single key/value pair.
104 | singleton :: (Arrayed k, Arrayed v) => k -> v -> Map k v
105 | singleton k v = Map (Map.singleton k v) M0
106 | {-# INLINE singleton #-}
107 | 
108 | -- | /O(log^2 N)/ worst-case. Lookup an element.
109 | lookup :: (Ord k, Arrayed k, Arrayed v) => k -> Map k v -> Maybe v
110 | lookup !k (Map m0 la) = case Map.lookup k m0 of
111 |   Nothing -> go la
112 |   mv      -> mv
113 |  where
114 |   go M0                = Nothing
115 |   go (M1 as)           = lookup1 k as Nothing
116 |   go (M2 as bs _ m)    = lookup1 k as $ lookup1 k bs $ go m
117 |   go (M3 as bs cs _ m) = lookup1 k as $ lookup1 k bs $ lookup1 k cs $ go m
118 | {-# INLINE lookup #-}
119 | 
120 | lookup1 :: (Ord k, Arrayed k, Arrayed v) => k -> Chunk k v -> Maybe v -> Maybe v
121 | lookup1 k (Chunk ks vs) r
122 |   | j <- search (\i -> ks G.! i >= k) 0 (G.length ks - 1)
123 |   , ks G.! j == k = Just $ vs G.! j
124 |   | otherwise = r
125 | {-# INLINE lookup1 #-}
126 | 
127 | zips :: (Arrayed k, Arrayed v) => Chunk k v -> Stream Id (k, v)
128 | zips (Chunk ks vs) = Stream.zip (G.stream ks) (G.stream vs)
129 | {-# INLINE zips #-}
130 | 
131 | merge :: (Ord k, Arrayed k, Arrayed v) => Chunk k v -> Chunk k v -> Chunk k v
132 | merge as bs = case G.unstream $ zips as `Fusion.merge` zips bs of
133 |   V_Pair _ ks vs -> Chunk ks vs
134 | {-# INLINE merge #-}
135 | 
136 | -- | O((log N)\/B) amortized loads for each cache. Insert an element.
137 | insert :: (Ord k, Arrayed k, Arrayed v) => k -> v -> Map k v -> Map k v
138 | insert k0 v0 (Map m0 xs0)
139 |   | n0 <= _THRESHOLD = Map (Map.insert k0 v0 m0) xs0
140 |   | otherwise = Map Map.empty $ inserts (Chunk (G.fromListN n0 (Map.keys m0)) (G.fromListN n0 (Foldable.toList m0))) xs0
141 |  where
142 |   n0 = Map.size m0
143 |   inserts as M0                 = M1 as
144 |   inserts as (M1 bs)            = M2 as bs (merge as bs) M0
145 |   inserts as (M2 bs cs bcs xs)  = M3 as bs cs bcs xs
146 |   inserts as (M3 bs _ _ cds xs) = cds `seq` M2 as bs (merge as bs) (inserts cds xs)
147 | {-# INLINE insert #-}
148 | 
149 | fromList :: (Ord k, Arrayed k, Arrayed v) => [(k,v)] -> Map k v
150 | fromList xs = List.foldl' (\m (k,v) -> insert k v m) empty xs
151 | {-# INLINE fromList #-}
152 | 
153 | -- | Offset binary search
154 | --
155 | -- Assuming @l <= h@. Returns @h@ if the predicate is never @True@ over @[l..h)@
156 | search :: (Int -> Bool) -> Int -> Int -> Int
157 | search p = go where
158 |   go l h
159 |     | l == h    = l
160 |     | p m       = go l m
161 |     | otherwise = go (m+1) h
162 |     where hml = h - l
163 |           m = l + unsafeShiftR hml 1 + unsafeShiftR hml 6
164 | {-# INLINE search #-}
165 | 
166 | 


--------------------------------------------------------------------------------
/src/Data/Vector/Map/Deamortized.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP #-}
  2 | {-# LANGUAGE RankNTypes #-}
  3 | {-# LANGUAGE TypeFamilies #-}
  4 | {-# LANGUAGE MultiParamTypeClasses #-}
  5 | {-# LANGUAGE ScopedTypeVariables #-}
  6 | {-# LANGUAGE FlexibleInstances #-}
  7 | {-# LANGUAGE GADTs #-}
  8 | {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  9 | {-# LANGUAGE StandaloneDeriving #-}
 10 | {-# LANGUAGE ScopedTypeVariables #-}
 11 | {-# LANGUAGE FlexibleContexts #-}
 12 | {-# LANGUAGE UndecidableInstances #-}
 13 | {-# LANGUAGE BangPatterns #-}
 14 | {-# LANGUAGE PatternGuards #-}
 15 | #if __GLASGOW_HASKELL__ >= 708
 16 | {-# LANGUAGE RoleAnnotations #-}
 17 | #endif
 18 | -----------------------------------------------------------------------------
 19 | -- |
 20 | -- Copyright   :  (C) 2013-2014 Edward Kmett
 21 | -- License     :  BSD-style (see the file LICENSE)
 22 | -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
 23 | -- Stability   :  experimental
 24 | -- Portability :  non-portable
 25 | --
 26 | -- This module provides a 'Vector'-based 'Map' that is loosely based on the
 27 | -- Cache Oblivious Lookahead Array (COLA) by Bender et al. from
 28 | -- <http://supertech.csail.mit.edu/papers/sbtree.pdf "Cache-Oblivious Streaming B-Trees">,
 29 | -- but with inserts deamortized by using a varant of a technique from Overmars and van Leeuwen.
 30 | --
 31 | -- Currently this 'Map' is implemented in an insert-only fashion. Deletions are left to future work
 32 | -- or to another derived structure in case they prove expensive.
 33 | --
 34 | -- Currently, we also do not use fractional cascading, as it affects the constant factors badly enough
 35 | -- to not pay for itself at the scales we are interested in. The naive /O(log^2 n)/ lookup
 36 | -- consistently outperforms the alternative.
 37 | --
 38 | -- Compared to the venerable @Data.Map@, this data structure currently consumes more memory, but it
 39 | -- provides a more limited palette of operations with different asymptotics (~10x faster inserts at a million entries)
 40 | -- and enables us to utilize contiguous storage.
 41 | --
 42 | -- /NB:/ when used with boxed data this structure may hold onto references to old versions
 43 | -- of things for many updates to come until sufficient operations have happened to merge them out
 44 | -- of the COLA.
 45 | -----------------------------------------------------------------------------
 46 | module Data.Vector.Map.Deamortized
 47 |   ( Map
 48 |   , empty
 49 |   , null
 50 |   , singleton
 51 |   , lookup
 52 |   , insert
 53 |   , fromList
 54 |   ) where
 55 | 
 56 | import Control.Applicative hiding (empty)
 57 | import Data.Bits
 58 | import Data.Foldable as Foldable hiding (null) 
 59 | import qualified Data.List as List
 60 | import Data.Vector.Array
 61 | import qualified Data.Map.Strict as Map
 62 | import qualified Data.Vector.Generic as G
 63 | import qualified Data.Vector.Generic.Mutable as GM
 64 | import GHC.Prim (RealWorld)
 65 | import Prelude hiding (null, lookup)
 66 | import System.IO.Unsafe as Unsafe
 67 | 
 68 | -- | How many items is it worth batching up in the Nursery?
 69 | _THRESHOLD :: Int
 70 | _THRESHOLD = 1000
 71 | 
 72 | -- | This Map is implemented as an insert-only Cache Oblivious Lookahead Array (COLA) with amortized complexity bounds
 73 | -- that are equal to those of a B-Tree, except for an extra log factor slowdown on lookups due to the lack of fractional
 74 | -- cascading. It uses a traditional Data.Map as a nursery.
 75 | 
 76 | data Map k a = Map !(Map.Map k a) !(LA k a)
 77 | 
 78 | -- | Cache-Oblivious Lookahead Array internals
 79 | data LA k a
 80 |   = M0
 81 |   | M1 !(Array k) !(Array a)
 82 |   | M2 !(Array k) !(Array a)
 83 |        !(Array k) !(Array a)
 84 |        {-# UNPACK #-} !Int {-# UNPACK #-} !Int
 85 |        !(MArray RealWorld k) !(MArray RealWorld a)
 86 |        !(LA k a)
 87 |   | M3 !(Array k) !(Array a)
 88 |        !(Array k) !(Array a)
 89 |        !(Array k) !(Array a)
 90 |        {-# UNPACK #-} !Int {-# UNPACK #-} !Int
 91 |        !(MArray RealWorld k) !(MArray RealWorld a)
 92 |        !(LA k a)
 93 | 
 94 | #if __GLASGOW_HASKELL__ >= 708
 95 | type role Map nominal nominal
 96 | #endif
 97 | 
 98 | instance (Show (Arr v v), Show (Arr k k)) => Show (LA k v) where
 99 |   showsPrec _ M0 = showString "M0"
100 |   showsPrec d (M1 ka a) = showParen (d > 10) $
101 |     showString "M1 " . showsPrec 11 ka . showChar ' ' . showsPrec 11 a
102 |   showsPrec d (M2 ka a kb b ra rb _ _ xs) = showParen (d > 10) $
103 |     showString "M2 " .
104 |     showsPrec 11 ka . showChar ' ' . showsPrec 11 a . showChar ' ' .
105 |     showsPrec 11 kb . showChar ' ' . showsPrec 11 b . showChar ' ' .
106 |     showsPrec 11 ra . showChar ' ' . showsPrec 11 rb . showString " _ _ " .
107 |     showsPrec 11 xs
108 |   showsPrec d (M3 ka a kb b kc c rb rc _ _ xs) = showParen (d > 10) $
109 |     showString "M3 " .
110 |     showsPrec 11 ka . showChar ' ' . showsPrec 11 a . showChar ' ' .
111 |     showsPrec 11 kb . showChar ' ' . showsPrec 11 b . showChar ' ' .
112 |     showsPrec 11 kc . showChar ' ' . showsPrec 11 c . showChar ' ' .
113 |     showsPrec 11 rb . showChar ' ' . showsPrec 11 rc . showString " _ _ " .
114 |     showsPrec 11 xs
115 | 
116 | instance (Show (Arr v v), Show (Arr k k), Show k, Show v) => Show (Map k v) where
117 |   showsPrec d (Map n l) = showParen (d > 10) $
118 |     showString "Map " . showsPrec 11 n . showChar ' ' . showsPrec 11 l
119 | 
120 | -- | /O(1)/. Identify if a 'Map' is the 'empty' 'Map'.
121 | null :: Map k v -> Bool
122 | null (Map n M0) = Map.null n
123 | null _          = False
124 | {-# INLINE null #-}
125 | 
126 | -- | /O(1)/ The 'empty' 'Map'.
127 | empty :: Map k v
128 | empty = Map Map.empty M0
129 | {-# INLINE empty #-}
130 | 
131 | -- | /O(1)/ Construct a 'Map' from a single key/value pair.
132 | singleton :: (Arrayed k, Arrayed v) => k -> v -> Map k v
133 | singleton k v = Map (Map.singleton k v) M0
134 | {-# INLINE singleton #-}
135 | 
136 | -- | /O(log^2 N)/ worst-case. Lookup an element.
137 | lookup :: (Ord k, Arrayed k, Arrayed v) => k -> Map k v -> Maybe v
138 | lookup !k (Map m0 la) = case Map.lookup k m0 of
139 |   Nothing -> go la
140 |   mv      -> mv
141 |  where
142 |   {-# INLINE go #-}
143 |   go M0 = Nothing
144 |   go (M1 ka va)                       = lookup1 k ka va Nothing
145 |   go (M2 ka va kb vb _ _ _ _ m)       = lookup1 k ka va $ lookup1 k kb vb $ go m
146 |   go (M3 ka va kb vb kc vc _ _ _ _ m) = lookup1 k ka va $ lookup1 k kb vb $ lookup1 k kc vc $ go m
147 | {-# INLINE lookup #-}
148 | 
149 | lookup1 :: (Ord k, Arrayed k, Arrayed v) => k -> Array k -> Array v -> Maybe v -> Maybe v
150 | lookup1 k ks vs r
151 |   | j <- search (\i -> ks G.! i >= k) 0 (G.length ks - 1)
152 |   , ks G.! j == k = Just $ vs G.! j
153 |   | otherwise = r
154 | {-# INLINE lookup1 #-}
155 | 
156 | -- | O((log N)\/B) worst-case loads for each cache. Insert an element.
157 | insert :: (Ord k, Arrayed k, Arrayed v) => k -> v -> Map k v -> Map k v
158 | insert k0 v0 (Map m0 xs0)
159 |   | n0 <= _THRESHOLD = Map (Map.insert k0 v0 m0) xs0
160 |   | otherwise = Map Map.empty $ unsafeDupablePerformIO $ inserts (G.fromListN n0 (Map.keys m0)) (G.fromListN n0 (Foldable.toList m0)) xs0
161 |  where
162 |   n0 = Map.size m0
163 |   inserts ka a M0 = return $ M1 ka a
164 |   inserts ka a (M1 kb b) = do
165 |     let n = G.length ka + G.length kb
166 |     kab <- GM.basicUnsafeNew n
167 |     ab  <- GM.basicUnsafeNew n
168 |     (ra,rb) <- steps ka a kb b 0 0 kab ab
169 |     return $ M2 ka a kb b ra rb kab ab M0
170 |   inserts ka a (M2 kb b kc c rb rc kbc bc xs) = do
171 |     (rb',rc') <- steps kb b kc c rb rc kbc bc
172 |     M3 ka a kb b kc c rb' rc' kbc bc <$> stepTail xs
173 |   inserts ka a (M3 kb b _ _ _ _ _ _ kcd cd xs) = do
174 |     let n = G.length ka + G.length kb
175 |     kab <- GM.basicUnsafeNew n
176 |     ab  <- GM.basicUnsafeNew n
177 |     (ra,rb) <- steps ka a kb b 0 0 kab ab
178 |     kcd' <- G.unsafeFreeze kcd
179 |     cd' <- G.unsafeFreeze cd
180 |     M2 ka a kb b ra rb kab ab <$> inserts kcd' cd' xs
181 | 
182 |   stepTail (M2 kx x ky y rx ry kxy xy xs) = do
183 |     (rx',ry') <- steps kx x ky y rx ry kxy xy
184 |     M2 kx x ky y rx' ry' kxy xy <$> stepTail xs
185 |   stepTail (M3 kx x ky y kz z ry rz kyz yz xs) = do
186 |     (ry',rz') <- steps ky y kz z ry rz kyz yz
187 |     M3 kx x ky y kz z ry' rz' kyz yz <$> stepTail xs
188 |   stepTail m = return m
189 | {-# INLINE insert #-}
190 | 
191 | steps :: (Ord k, Arrayed k, Arrayed v) => Array k -> Array v -> Array k -> Array v -> Int -> Int -> MArray RealWorld k -> MArray RealWorld v -> IO (Int, Int)
192 | steps ka a kb b ra0 rb0 kab ab = go ra0 rb0 where
193 |   n = min (ra0 + rb0 + _THRESHOLD) (GM.length kab)
194 |   na = G.length ka
195 |   nb = G.length kb
196 |   go !ra !rb
197 |     | r >= n = return (ra, rb)
198 |     | ra == na = do
199 |       k <- G.basicUnsafeIndexM kb rb
200 |       v <- G.basicUnsafeIndexM b rb
201 |       GM.basicUnsafeWrite kab r k
202 |       GM.basicUnsafeWrite ab r v
203 |       go ra (rb + 1)
204 |     | rb == nb = do
205 |       k <- G.basicUnsafeIndexM ka ra
206 |       v <- G.basicUnsafeIndexM a ra
207 |       GM.basicUnsafeWrite kab r k
208 |       GM.basicUnsafeWrite ab r v
209 |       go (ra + 1) rb
210 |     | otherwise = do
211 |       k1 <- G.basicUnsafeIndexM ka ra
212 |       k2 <- G.basicUnsafeIndexM kb rb
213 |       case compare k1 k2 of
214 |         LT -> do
215 |           v <- G.basicUnsafeIndexM a ra
216 |           GM.basicUnsafeWrite kab r k1
217 |           GM.basicUnsafeWrite ab r v
218 |           go (ra + 1) rb
219 |         EQ -> do -- collision, overwrite with newer value
220 |           v <- G.basicUnsafeIndexM a ra
221 |           GM.basicUnsafeWrite kab r k1
222 |           GM.basicUnsafeWrite ab r v
223 |           go (ra + 1) (rb + 1)
224 |         GT -> do
225 |           v <- G.basicUnsafeIndexM b rb
226 |           GM.basicUnsafeWrite kab r k2
227 |           GM.basicUnsafeWrite ab r v
228 |           go ra (rb + 1)
229 |     where r = ra + rb
230 | 
231 | fromList :: (Ord k, Arrayed k, Arrayed v) => [(k,v)] -> Map k v
232 | fromList xs = List.foldl' (\m (k,v) -> insert k v m) empty xs
233 | {-# INLINE fromList #-}
234 | 
235 | -- | Offset binary search
236 | --
237 | -- Assuming @l <= h@. Returns @h@ if the predicate is never @True@ over @[l..h)@
238 | search :: (Int -> Bool) -> Int -> Int -> Int
239 | search p = go where
240 |   go l h
241 |     | l == h    = l
242 |     | p m       = go l m
243 |     | otherwise = go (m+1) h
244 |     where hml = h - l
245 |           m = l + unsafeShiftR hml 1 + unsafeShiftR hml 6
246 | {-# INLINE search #-}
247 | 


--------------------------------------------------------------------------------
/src/Data/Vector/Map/Ephemeral.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP #-}
  2 | {-# LANGUAGE RankNTypes #-}
  3 | {-# LANGUAGE TypeFamilies #-}
  4 | {-# LANGUAGE MultiParamTypeClasses #-}
  5 | {-# LANGUAGE ScopedTypeVariables #-}
  6 | {-# LANGUAGE FlexibleInstances #-}
  7 | {-# LANGUAGE GADTs #-}
  8 | {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  9 | {-# LANGUAGE StandaloneDeriving #-}
 10 | {-# LANGUAGE ScopedTypeVariables #-}
 11 | {-# LANGUAGE FlexibleContexts #-}
 12 | {-# LANGUAGE UndecidableInstances #-}
 13 | {-# LANGUAGE BangPatterns #-}
 14 | {-# LANGUAGE PatternGuards #-}
 15 | -----------------------------------------------------------------------------
 16 | -- |
 17 | -- Copyright   :  (C) 2013-2014 Edward Kmett
 18 | -- License     :  BSD-style (see the file LICENSE)
 19 | -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
 20 | -- Stability   :  experimental
 21 | -- Portability :  non-portable
 22 | --
 23 | -- This module provides a 'Vector'-based 'Map' that is loosely based on the
 24 | -- Cache Oblivious Lookahead Array (COLA) by Bender et al. from
 25 | -- <http://supertech.csail.mit.edu/papers/sbtree.pdf "Cache-Oblivious Streaming B-Trees">.
 26 | --
 27 | -- Currently this 'Map' is implemented in an insert-only fashion. Deletions are left to future work
 28 | -- or to another derived structure in case they prove expensive.
 29 | --
 30 | -- Unlike the COLA, this version merely provides amortized complexity bounds as this permits us to
 31 | -- provide a fully functional API. However, even those asymptotics are only guaranteed if you do not
 32 | -- modify the \"old\" versions of the 'Map'. If you do, then while correctness is preserved, the
 33 | -- asymptotic analysis becomes inaccurate.
 34 | --
 35 | -- Reading from \"old\" versions of the 'Map' does not affect the asymptotic analysis and is fine.
 36 | --
 37 | -- Fractional cascading was originally replaced with the use of a hierarchical bloom filter per level containing
 38 | -- the elements for that level, with the false positive rate tuned to balance the lookup cost against
 39 | -- the costs of the cache misses for a false positive at that depth. This avoids the need to collect
 40 | -- forwarding pointers from the next level, reducing pressure on the cache dramatically, while providing
 41 | -- the same asymptotic complexity.
 42 | --
 43 | -- With either of these two techniques when used ephemerally, this 'Map' had asymptotic performance equal to that
 44 | -- of a B-Tree tuned to the parameters of your caches with requiring such parameter tuning.
 45 | --
 46 | -- However, the constants were still bad enough that the naive /O(log^2 n)/ version of the COLA actually wins
 47 | -- at lookups in benchmarks at the scale this data structure is interesting, say around a few million entries,
 48 | -- by a factor of 10x! Consequently, we're currently not even Bloom filtering.
 49 | --
 50 | -- Compared to the venerable @Data.Map@, this data structure currently consumes more memory, but it
 51 | -- provides a more limited palette of operations with different asymptotics (~10x faster inserts at a million entries)
 52 | -- and enables us to utilize contiguous storage.
 53 | --
 54 | -- /NB:/ when used with boxed data this structure may hold onto references to old versions
 55 | -- of things for many updates to come until sufficient operations have happened to merge them out
 56 | -- of the COLA.
 57 | --
 58 | -- TODO: track actual percentage of occupancy for each vector compared to the source vector it was based on.
 59 | -- This would permit 'split' and other operations that trim a 'Map' to properly reason about space usage by
 60 | -- borrowing the 1/3rd occupancy rule from a Stratified Doubling Array.
 61 | -----------------------------------------------------------------------------
 62 | module Data.Vector.Map.Ephemeral
 63 |   ( Map(..)
 64 |   , empty
 65 |   , null
 66 |   , singleton
 67 |   , lookup
 68 |   , insert
 69 |   , fromList
 70 |   , shape
 71 |   ) where
 72 | 
 73 | import Data.Bits
 74 | import qualified Data.List as List
 75 | import Data.Vector.Array
 76 | import Data.Vector.Fusion.Stream.Monadic (Stream(..))
 77 | import qualified Data.Vector.Fusion.Stream.Monadic as Stream
 78 | import Data.Vector.Fusion.Util
 79 | import qualified Data.Vector.Generic as G
 80 | import qualified Data.Vector.Map.Fusion as Fusion
 81 | import Prelude hiding (null, lookup)
 82 | 
 83 | #define BOUNDS_CHECK(f) (Ck.f __FILE__ __LINE__ Ck.Bounds)
 84 | 
 85 | -- | This Map is implemented as an insert-only Cache Oblivious Lookahead Array (COLA) with amortized complexity bounds
 86 | -- that are equal to those of a B-Tree when it is used ephemerally, using Bloom filters to replace the fractional
 87 | -- cascade.
 88 | data Map k v
 89 |   = Nil
 90 |   | One !k v !(Map k v)
 91 |   | Map !Int !(Array k) !(Array v) !(Map k v)
 92 | 
 93 | deriving instance (Show (Arr v v), Show (Arr k k), Show k, Show v) => Show (Map k v)
 94 | deriving instance (Read (Arr v v), Read (Arr k k), Read k, Read v) => Read (Map k v)
 95 | 
 96 | -- | /O(1)/. Identify if a 'Map' is the 'empty' 'Map'.
 97 | null :: Map k v -> Bool
 98 | null Nil = True
 99 | null _   = False
100 | {-# INLINE null #-}
101 | 
102 | -- | /O(1)/ The 'empty' 'Map'.
103 | empty :: Map k v
104 | empty = Nil
105 | {-# INLINE empty #-}
106 | 
107 | -- | /O(1)/ Construct a 'Map' from a single key/value pair.
108 | singleton :: Arrayed v => k -> v -> Map k v
109 | singleton k v = v `vseq` One k v Nil
110 | {-# INLINE singleton #-}
111 | 
112 | -- | /O(log^2 N)/ persistently amortized, /O(N)/ worst case. Lookup an element.
113 | lookup :: (Ord k, Arrayed k, Arrayed v) => k -> Map k v -> Maybe v
114 | lookup !k m0 = go m0 where
115 |   {-# INLINE go #-}
116 |   go Nil = Nothing
117 |   go (One i a m)
118 |     | k == i    = Just a
119 |     | otherwise = go m
120 |   go (Map n ks vs m)
121 |     | j <- search (\i -> ks G.! i >= k) 0 (n-1)
122 |     , ks G.! j == k = Just $ vs G.! j
123 |     | otherwise = go m
124 | {-# INLINE lookup #-}
125 | 
126 | threshold :: Int -> Int -> Bool
127 | threshold n1 n2 = n1 > unsafeShiftR n2 1
128 | {-# INLINE threshold #-}
129 | 
130 | -- force a value as much as it would be forced by inserting it into an Array
131 | vseq :: forall a b. Arrayed a => a -> b -> b
132 | vseq a b = G.elemseq (undefined :: Array a) a b
133 | {-# INLINE vseq #-}
134 | 
135 | -- | O((log N)\/B) ephemerally amortized loads for each cache, O(N\/B) worst case. Insert an element.
136 | insert :: (Ord k, Arrayed k, Arrayed v) => k -> v -> Map k v -> Map k v
137 | insert !k v (Map n1 ks1 vs1 (Map n2 ks2 vs2 m))
138 |   | threshold n1 n2 = insert2 k v ks1 vs1 ks2 vs2 m
139 | insert !ka va (One kb vb (One kc vc m)) = case G.unstream $ Fusion.insert ka va rest of
140 |     V_Pair n ks vs -> Map n ks vs m
141 |   where
142 |     rest = case compare kb kc of
143 |       LT -> Stream.fromListN 2 [(kb,vb),(kc,vc)]
144 |       EQ -> Stream.fromListN 1 [(kb,vb)]
145 |       GT -> Stream.fromListN 2 [(kc,vc),(kb,vb)]
146 | insert k v m = v `vseq` One k v m
147 | {-# INLINABLE insert #-}
148 | 
149 | insert2 :: (Ord k, Arrayed k, Arrayed v) => k -> v -> Array k -> Array v -> Array k -> Array v -> Map k v -> Map k v
150 | insert2 k v ks1 vs1 ks2 vs2 m = case G.unstream $ Fusion.insert k v (zips ks1 vs1) `Fusion.merge` zips ks2 vs2 of
151 |   V_Pair n ks3 vs3 -> Map n ks3 vs3 m
152 | {-# INLINE insert2 #-}
153 | 
154 | fromList :: (Ord k, Arrayed k, Arrayed v) => [(k,v)] -> Map k v
155 | fromList xs = List.foldl' (\m (k,v) -> insert k v m) empty xs
156 | {-# INLINE fromList #-}
157 | 
158 | -- | Offset binary search
159 | --
160 | -- Assuming @l <= h@. Returns @h@ if the predicate is never @True@ over @[l..h)@
161 | search :: (Int -> Bool) -> Int -> Int -> Int
162 | search p = go where
163 |   go l h
164 |     | l == h    = l
165 |     | p m       = go l m
166 |     | otherwise = go (m+1) h
167 |     where hml = h - l
168 |           m = l + unsafeShiftR hml 1 + unsafeShiftR hml 6
169 | {-# INLINE search #-}
170 | 
171 | zips :: (G.Vector v a, G.Vector u b) => v a -> u b -> Stream Id (a, b)
172 | zips va ub = Stream.zip (G.stream va) (G.stream ub)
173 | {-# INLINE zips #-}
174 | 
175 | -- * Debugging
176 | 
177 | shape :: Map k v -> [Int]
178 | shape Nil           = []
179 | shape (One _ _ m)   = 1 : shape m
180 | shape (Map n _ _ m) = n : shape m
181 | 


--------------------------------------------------------------------------------
/src/Data/Vector/Map/Fusion.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP #-}
  2 | {-# LANGUAGE BangPatterns #-}
  3 | -----------------------------------------------------------------------------
  4 | -- |
  5 | -- Copyright   :  (C) 2013 Edward Kmett
  6 | -- License     :  BSD-style (see the file LICENSE)
  7 | -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
  8 | -- Stability   :  experimental
  9 | -- Portability :  non-portable
 10 | --
 11 | -- COLA fusion internals
 12 | --
 13 | -----------------------------------------------------------------------------
 14 | module Data.Vector.Map.Fusion
 15 |   ( merge
 16 |   , insert
 17 |   ) where
 18 | 
 19 | import Data.Vector.Fusion.Stream.Monadic as Stream
 20 | import Data.Vector.Fusion.Stream.Size as Stream
 21 | 
 22 | -- | The state for 'Stream' fusion that is used by 'mergeStreamsWith'.
 23 | --
 24 | -- This form permits cancellative addition.
 25 | data MergeState sa sb i a
 26 |   = MergeL sa sb i a
 27 |   | MergeR sa sb i a
 28 |   | MergeLeftEnded sb
 29 |   | MergeRightEnded sa
 30 |   | MergeStart sa sb
 31 | 
 32 | -- | This is the internal stream fusion combinator used to merge streams for addition.
 33 | merge :: (Monad m, Ord k) => Stream m (k, a) -> Stream m (k, a) -> Stream m (k, a)
 34 | merge (Stream stepa sa0 na) (Stream stepb sb0 nb) = Stream step (MergeStart sa0 sb0) (toMax na + toMax nb) where
 35 |   step (MergeStart sa sb) = do
 36 |     r <- stepa sa
 37 |     return $ case r of
 38 |       Yield (i, a) sa' -> Skip (MergeL sa' sb i a)
 39 |       Skip sa'         -> Skip (MergeStart sa' sb)
 40 |       Done             -> Skip (MergeLeftEnded sb)
 41 |   step (MergeL sa sb i a) = do
 42 |     r <- stepb sb
 43 |     return $ case r of
 44 |       Yield (j, b) sb' -> case compare i j of
 45 |         LT -> Yield (i, a) (MergeR sa sb' j b)
 46 |         EQ -> Yield (i, a) (MergeStart sa sb')
 47 |         GT -> Yield (j, b) (MergeL sa sb' i a)
 48 |       Skip sb' -> Skip (MergeL sa sb' i a)
 49 |       Done     -> Yield (i, a) (MergeRightEnded sa)
 50 |   step (MergeR sa sb j b) = do
 51 |     r <- stepa sa
 52 |     return $ case r of
 53 |       Yield (i, a) sa' -> case compare i j of
 54 |         LT -> Yield (i, a) (MergeR sa' sb j b)
 55 |         EQ -> Yield (i, a) (MergeStart sa' sb)
 56 |         GT -> Yield (j, b) (MergeL sa' sb i a)
 57 |       Skip sa' -> Skip (MergeR sa' sb j b)
 58 |       Done     -> Yield (j, b) (MergeLeftEnded sb)
 59 |   step (MergeLeftEnded sb) = do
 60 |     r <- stepb sb
 61 |     return $ case r of
 62 |       Yield (j, b) sb' -> Yield (j, b) (MergeLeftEnded sb')
 63 |       Skip sb'         -> Skip (MergeLeftEnded sb')
 64 |       Done             -> Done
 65 |   step (MergeRightEnded sa) = do
 66 |     r <- stepa sa
 67 |     return $ case r of
 68 |       Yield (i, a) sa' -> Yield (i, a) (MergeRightEnded sa')
 69 |       Skip sa'         -> Skip (MergeRightEnded sa')
 70 |       Done             -> Done
 71 |   {-# INLINE [0] step #-}
 72 | {-# INLINE [1] merge #-}
 73 | 
 74 | -- | The state for 'Stream' fusion that is used by 'mergeStreamsAnd'.
 75 | --
 76 | -- This form permits cancellative addition.
 77 | data InsertState sa ia
 78 |   = Searching sa
 79 |   | Holding sa ia
 80 |   | Found sa
 81 |   | Over
 82 | 
 83 | insert :: (Monad m, Ord k) => k -> a -> Stream m (k, a) -> Stream m (k, a)
 84 | insert k c (Stream stepa sa0 na) = Stream step (Searching sa0) (toMax na + 1) where
 85 |   step (Searching sa) = do
 86 |     r <- stepa sa
 87 |     return $ case r of
 88 |       Yield ia sa' -> case compare (fst ia) k of
 89 |         LT -> Yield ia (Searching sa')
 90 |         EQ -> Yield (k, c) (Found sa')
 91 |         GT -> Yield (k, c) (Holding sa' ia)
 92 |       Skip sa' -> Skip (Searching sa')
 93 |       Done     -> Yield (k, c) Over
 94 |   step (Holding sa ia) = return $ Yield ia (Found sa)
 95 |   step (Found sa) = do
 96 |     r <- stepa sa
 97 |     return $ case r of
 98 |       Yield p sa' -> Yield p (Found sa')
 99 |       Skip sa'    -> Skip (Found sa')
100 |       Done        -> Done
101 |   step Over = return Done
102 |   {-# INLINE [0] step #-}
103 | {-# INLINE [1] insert #-}
104 | 


--------------------------------------------------------------------------------
/src/Data/Vector/Set.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE PatternGuards #-}
 2 | {-# LANGUAGE StandaloneDeriving #-}
 3 | {-# LANGUAGE UndecidableInstances #-}
 4 | {-# LANGUAGE FlexibleContexts #-}
 5 | 
 6 | -- | A non-standard zeroless-binary deamortized cache-oblivious Set
 7 | module Data.Vector.Set where
 8 | 
 9 | import Data.Bits
10 | import qualified Data.Vector.Set.Fusion as Fusion
11 | import Data.Vector.Array
12 | import Data.Vector.Slow as Slow
13 | import qualified Data.Vector.Generic as G
14 | 
15 | data Set a
16 |   = S0
17 |   | S1 !(Array a)
18 |   | S2 !(Array a) !(Array a)            !(Partial (Array a)) !(Set a)
19 |   | S3 !(Array a) !(Array a) !(Array a) !(Partial (Array a)) !(Set a)
20 | 
21 | deriving instance Show (Array a) => Show (Set a)
22 | 
23 | empty :: Set a
24 | empty = S0
25 | {-# INLINE empty #-}
26 | 
27 | null :: Set a -> Bool
28 | null S0 = True
29 | null _ = False
30 | {-# INLINE null #-}
31 | 
32 | -- | /O(log n)/ gives a conservative upper bound on size, assuming no collisions
33 | size :: Set a -> Int
34 | size S0                             = 0
35 | size (S1 _)                         = 1
36 | size (S2 _ _ _ xs)   | n <- size xs = n + n + 2
37 | size (S3 _ _ _ _ xs) | n <- size xs = n + n + 3
38 | 
39 | -- | /O(log n)/ worst case
40 | insert :: (Arrayed a, Ord a) => a -> Set a -> Set a
41 | insert z0 s0 = go (G.singleton z0) s0 where
42 |   go a S0     = S1 a
43 |   go a (S1 b) = S2 a b (merge a b) S0
44 |   go a (S2 b c   mbc xs) = S3 a b c (step mbc) (steps xs)
45 |   go a (S3 b _ _ mcd xs) = case mcd of
46 |     Stop cd -> S2 a b (merge a b) (go cd xs)
47 |     _       -> error "insert: stop Step"
48 | 
49 |   steps (S2 x y mxy xs)   = S2 x y (step mxy) (steps xs)
50 |   steps (S3 x y z myz xs) = S3 x y z (step myz) (steps xs)
51 |   steps m = m
52 | {-# INLINE insert #-}
53 | 
54 | -- | /O(log^n)/ worst and amortized
55 | member :: (Arrayed a, Ord a) => a -> Set a -> Bool
56 | member _ S0 = False
57 | member x (S1 a) = member1 x a
58 | member x (S2 a b _ xs) = member1 x a || member1 x b || member x xs
59 | member x (S3 a b c _ xs) = member1 x a || member1 x b || member1 x c || member x xs
60 | {-# INLINE member #-}
61 | 
62 | member1 :: (Arrayed a, Ord a) => a -> Array a -> Bool
63 | member1 x xs = xs G.! search (\i -> xs G.! i >= x) 0 (G.length xs - 1) == x
64 | {-# INLINE member1 #-}
65 | 
66 | merge :: (Arrayed a, Ord a) => Array a -> Array a -> Partial (Array a)
67 | merge m n = step $ walkST $ Slow.unstreamM $ Slow.streamST $ Fusion.merge (G.stream m) (G.stream n)
68 | {-# INLINE merge #-}
69 | 
70 | step :: Partial a -> Partial a
71 | step (Stop _)  = error "insert: step Stop"
72 | step (Step m) = m
73 | {-# INLINE step #-}
74 | 
75 | -- | Offset binary search
76 | --
77 | -- Assuming @l <= h@. Returns @h@ if the predicate is never @True@ over @[l..h)@
78 | search :: (Int -> Bool) -> Int -> Int -> Int
79 | search p = go where
80 |   go l h
81 |     | l == h    = l
82 |     | p m       = go l m
83 |     | otherwise = go (m+1) h
84 |     where hml = h - l
85 |           m = l + unsafeShiftR hml 1 + unsafeShiftR hml 6
86 | {-# INLINE search #-}
87 | 


--------------------------------------------------------------------------------
/src/Data/Vector/Set/Fusion.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE CPP #-}
 2 | {-# LANGUAGE BangPatterns #-}
 3 | -----------------------------------------------------------------------------
 4 | -- |
 5 | -- Copyright   :  (C) 2013 Edward Kmett
 6 | -- License     :  BSD-style (see the file LICENSE)
 7 | -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
 8 | -- Stability   :  experimental
 9 | -- Portability :  non-portable
10 | --
11 | -----------------------------------------------------------------------------
12 | module Data.Vector.Set.Fusion
13 |   ( merge
14 |   ) where
15 | 
16 | import Data.Vector.Fusion.Stream.Monadic as Stream
17 | import Data.Vector.Fusion.Stream.Size as Stream
18 | 
19 | -- |
20 | -- This form permits cancellative addition.
21 | data MergeState sa sb a
22 |   = MergeL sa sb a
23 |   | MergeR sa sb a
24 |   | MergeLeftEnded sb
25 |   | MergeRightEnded sa
26 |   | MergeStart sa sb
27 | 
28 | -- | This is the internal stream fusion combinator used to merge streams for addition.
29 | merge :: (Monad m, Ord k) => Stream m k -> Stream m k -> Stream m k
30 | merge (Stream stepa sa0 na) (Stream stepb sb0 nb) = Stream step (MergeStart sa0 sb0) (toMax na + toMax nb) where
31 |   step (MergeStart sa sb) = do
32 |     r <- stepa sa
33 |     return $ case r of
34 |       Yield i sa' -> Skip (MergeL sa' sb i)
35 |       Skip sa'         -> Skip (MergeStart sa' sb)
36 |       Done             -> Skip (MergeLeftEnded sb)
37 |   step (MergeL sa sb i) = do
38 |     r <- stepb sb
39 |     return $ case r of
40 |       Yield j sb' -> case compare i j of
41 |         LT -> Yield i (MergeR sa sb' j)
42 |         EQ -> Yield i (MergeStart sa sb')
43 |         GT -> Yield j (MergeL sa sb' i)
44 |       Skip sb' -> Skip (MergeL sa sb' i)
45 |       Done     -> Yield i (MergeRightEnded sa)
46 |   step (MergeR sa sb j) = do
47 |     r <- stepa sa
48 |     return $ case r of
49 |       Yield i sa' -> case compare i j of
50 |         LT -> Yield i (MergeR sa' sb j)
51 |         EQ -> Yield i (MergeStart sa' sb)
52 |         GT -> Yield j (MergeL sa' sb i)
53 |       Skip sa' -> Skip (MergeR sa' sb j)
54 |       Done     -> Yield j (MergeLeftEnded sb)
55 |   step (MergeLeftEnded sb) = do
56 |     r <- stepb sb
57 |     return $ case r of
58 |       Yield j sb' -> Yield j (MergeLeftEnded sb')
59 |       Skip sb'    -> Skip (MergeLeftEnded sb')
60 |       Done        -> Done
61 |   step (MergeRightEnded sa) = do
62 |     r <- stepa sa
63 |     return $ case r of
64 |       Yield i sa' -> Yield i (MergeRightEnded sa')
65 |       Skip sa'    -> Skip (MergeRightEnded sa')
66 |       Done        -> Done
67 |   {-# INLINE [0] step #-}
68 | {-# INLINE [1] merge #-}
69 | 


--------------------------------------------------------------------------------
/src/Data/Vector/Slow.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP #-}
  2 | {-# LANGUAGE RankNTypes  #-}
  3 | {-# LANGUAGE Trustworthy #-}
  4 | {-# LANGUAGE BangPatterns #-}
  5 | {-# LANGUAGE StandaloneDeriving #-}
  6 | {-# OPTIONS_GHC -fno-warn-unused-matches -fno-warn-unused-binds #-}
  7 | 
  8 | module Data.Vector.Slow
  9 |   ( IterST
 10 |   , Partial(..)
 11 |   , delay
 12 |   , walkST
 13 |   , streamST
 14 |   , munstream
 15 |   , unstreamM
 16 |   , foldM'
 17 |   , foldM
 18 |   ) where
 19 | 
 20 | import Control.Monad.ST
 21 | import Control.Monad.ST.Class
 22 | import Control.Monad.ST.Unsafe as Unsafe
 23 | import Control.Monad.Trans.Iter hiding (foldM)
 24 | import qualified Data.Vector.Fusion.Stream.Monadic as M
 25 | import qualified Data.Vector.Fusion.Stream.Size as SS
 26 | import Data.Vector.Internal.Check as Ck
 27 | import qualified Data.Vector.Generic as G
 28 | import qualified Data.Vector.Generic.Mutable as GM
 29 | import System.IO.Unsafe as Unsafe
 30 | import Data.Vector.Fusion.Util
 31 | 
 32 | import SpecConstr ( SpecConstrAnnotation(..) )
 33 | data SPEC = SPEC | SPEC2
 34 | {-# ANN type SPEC ForceSpecConstr #-}
 35 | 
 36 | data Partial a
 37 |   = Stop a
 38 |   | Step (Partial a)
 39 |   deriving (Show, Read, Eq, Ord)
 40 | 
 41 | #define BOUNDS_CHECK(f)   (Ck.f __FILE__ __LINE__ Ck.Bounds)
 42 | #define INTERNAL_CHECK(f) (Ck.f __FILE__ __LINE__ Ck.Internal)
 43 | 
 44 | type IterST s = IterT (ST s)
 45 | 
 46 | walkST :: (forall s. IterST s a) -> Partial a
 47 | walkST m0 = go m0 where
 48 |   go (IterT m) =
 49 |     case Unsafe.unsafePerformIO $
 50 |          Unsafe.unsafeSTToIO m of
 51 |       Left  a -> Stop a
 52 |       Right n -> Step (go n)
 53 | 
 54 | streamST :: M.Stream Id a -> M.Stream (ST s) a
 55 | streamST (M.Stream step s n) = M.Stream (return . unId . step) s n
 56 | 
 57 | unstreamM :: G.Vector v a => M.Stream (ST s) a -> IterST s (v a)
 58 | unstreamM s = munstream s >>= liftST . G.unsafeFreeze
 59 | 
 60 | munstream :: GM.MVector v a => M.Stream (ST s) a -> IterST s (v s a)
 61 | munstream s = case SS.upperBound (M.size s) of
 62 |   Just n  -> munstreamMax     s n
 63 |   Nothing -> munstreamUnknown s
 64 | {-# INLINE [1] munstream #-}
 65 | 
 66 | -- pay once per entry
 67 | foldM' :: (a -> b -> ST s a) -> a -> M.Stream (ST s) b -> IterST s a
 68 | foldM' m z0 (M.Stream step s0 _) = foldM'_loop SPEC z0 s0
 69 |   where
 70 |     foldM'_loop !_SPEC z s
 71 |       = z `seq`
 72 |         do
 73 |           r <- liftST (step s)
 74 |           case r of
 75 |             M.Yield x s' -> do
 76 |               z' <- liftST (m z x)
 77 |               delay $ foldM'_loop SPEC z' s'
 78 |             M.Skip s' -> foldM'_loop SPEC z s'
 79 |             M.Done -> return z
 80 | {-# INLINE [1] foldM' #-}
 81 | 
 82 | -- | Left fold with a monadic operator
 83 | foldM :: (a -> b -> ST s a) -> a -> M.Stream (ST s) b -> IterST s a
 84 | foldM m z0 (M.Stream step s0 _) = foldM_loop SPEC z0 s0
 85 |   where
 86 |     foldM_loop !_SPEC z s
 87 |       = do
 88 |           r <- liftST (step s)
 89 |           case r of
 90 |             M.Yield x s' -> do
 91 |               z' <- liftST (m z x)
 92 |               delay $ foldM_loop SPEC z' s'
 93 |             M.Skip s' -> foldM_loop SPEC z s'
 94 |             M.Done -> return z
 95 | {-# INLINE [1] foldM #-}
 96 | 
 97 | 
 98 | munstreamMax :: GM.MVector v a => M.Stream (ST s) a -> Int -> IterST s (v s a)
 99 | munstreamMax s n = do
100 |   v <- INTERNAL_CHECK(checkLength) "munstreamMax" n
101 |        $ liftST (GM.unsafeNew n)
102 |   let put i x = do
103 |                    INTERNAL_CHECK(checkIndex) "munstreamMax" i n
104 |                      $ GM.unsafeWrite v i x
105 |                    return (i+1)
106 |   n' <- foldM' put 0 s
107 |   return $ INTERNAL_CHECK(checkSlice) "munstreamMax" 0 n' n
108 |          $ GM.unsafeSlice 0 n' v
109 | {-# INLINE munstreamMax #-}
110 | 
111 | munstreamUnknown :: GM.MVector v a => M.Stream (ST s) a -> IterST s (v s a)
112 | munstreamUnknown s = do
113 |   v <- liftST (GM.unsafeNew 0)
114 |   (v', n) <- foldM put (v, 0) s
115 |   return $ INTERNAL_CHECK(checkSlice) "munstreamUnknown" 0 n (GM.length v')
116 |          $ GM.unsafeSlice 0 n v'
117 |   where
118 |     {-# INLINE [0] put #-}
119 |     put (v,i) x = do
120 |       v' <- unsafeAppend1 v i x
121 |       return (v',i+1)
122 | {-# INLINE munstreamUnknown #-}
123 | 
124 | unsafeAppend1 :: GM.MVector v a => v s a -> Int -> a -> ST s (v s a)
125 | {-# INLINE [0] unsafeAppend1 #-}
126 | unsafeAppend1 v i x
127 |   | i < GM.length v = do
128 |     GM.unsafeWrite v i x
129 |     return v
130 |   | otherwise    = do
131 |     v' <- enlarge v
132 |     INTERNAL_CHECK(checkIndex) "unsafeAppend1" i (GM.length v')
133 |       $ GM.unsafeWrite v' i x
134 |     return v'
135 | 
136 | enlarge_delta :: GM.MVector v a => v s a -> Int
137 | enlarge_delta v = max (GM.length v) 1
138 | 
139 | -- | Grow a vector logarithmically
140 | enlarge :: GM.MVector v a => v s a -> ST s (v s a)
141 | enlarge v = GM.unsafeGrow v (enlarge_delta v)
142 | {-# INLINE enlarge #-}
143 | 


--------------------------------------------------------------------------------
/structures.cabal:
--------------------------------------------------------------------------------
  1 | name:          structures
  2 | category:      Data, Structures
  3 | version:       0.2
  4 | license:       BSD3
  5 | cabal-version: >= 1.8
  6 | license-file:  LICENSE
  7 | author:        Edward A. Kmett
  8 | maintainer:    Edward A. Kmett <ekmett@gmail.com>
  9 | stability:     experimental
 10 | homepage:      http://github.com/ekmett/structures
 11 | bug-reports:   http://github.com/ekmett/structures/issues
 12 | copyright:     Copyright (C) 2013 Edward A. Kmett
 13 | build-type:    Custom
 14 | synopsis:      "Advanced" Data Structures
 15 | 
 16 | extra-source-files:
 17 |   .travis.yml
 18 |   .gitignore
 19 |   .vim.custom
 20 |   CHANGELOG.markdown
 21 |   README.markdown
 22 | 
 23 | description:
 24 |   This package is a playground for working with several types of advanced data structures including
 25 |   wavelet trees and cache oblivious lookahead arrays.
 26 | 
 27 | source-repository head
 28 |   type: git
 29 |   location: git://github.com/ekmett/structures.git
 30 | 
 31 | -- You can disable the QuickCheck tests with -f-test-properties
 32 | flag test-properties
 33 |   default: True
 34 |   manual: True
 35 | 
 36 | -- You can disable the HUnit tests with -f-test-hunit
 37 | -- NB: We have no hunit tests, so this is disabled.
 38 | flag test-hunit
 39 |   default: False
 40 |   manual: True
 41 | 
 42 | -- You can disable the doctests test suite with -f-test-doctests
 43 | flag test-doctests
 44 |   default: True
 45 |   manual: True
 46 | 
 47 | -- You can disable the hlint test suite with -f-test-hlint
 48 | flag test-hlint
 49 |   default: True
 50 |   manual: True
 51 | 
 52 | flag threaded
 53 |   default: True
 54 |   manual: True
 55 | 
 56 | flag llvm
 57 |   default: False
 58 |   manual: True
 59 | 
 60 | library
 61 |   build-depends:
 62 |     base              >= 4.8   && < 5,
 63 |     containers        >= 0.5   && < 0.6,
 64 |     contravariant     >= 0.4.2 && < 2,
 65 |     deepseq           >= 1.1   && < 1.5,
 66 |     free              >= 4.6.1 && < 5,
 67 |     ghc,
 68 |     ghc-prim,
 69 |     hashable          >= 1.2.1 && < 1.3,
 70 |     hybrid-vectors    >= 0.1   && < 1,
 71 |     lens              >= 4     && < 5,
 72 |     monad-st          >= 0.2.2 && < 1,
 73 |     parallel          >= 3.2   && < 3.3,
 74 |     primitive         >= 0.5   && < 0.7,
 75 |     semigroups        >= 0.9   && < 1,
 76 |     transformers      >= 0.3   && < 0.5,
 77 |     vector            >= 0.10  && < 0.11,
 78 |     vector-algorithms >= 0.5   && < 0.8
 79 | 
 80 |   hs-source-dirs: src
 81 | 
 82 |   exposed-modules:
 83 |     Data.Vector.Array
 84 |     Data.Vector.Heap
 85 |     Data.Vector.Map
 86 |     Data.Vector.Map.Deamortized
 87 |     Data.Vector.Map.Ephemeral
 88 |     Data.Vector.Map.Fusion
 89 |     Data.Vector.Set
 90 |     Data.Vector.Set.Fusion
 91 |     Data.Vector.Slow
 92 | 
 93 |   ghc-options: -Wall
 94 | 
 95 |   if flag(llvm)
 96 |     ghc-options: -fllvm
 97 | 
 98 | test-suite properties
 99 |   type: exitcode-stdio-1.0
100 |   main-is: properties.hs
101 |   ghc-options: -w
102 |   hs-source-dirs: tests
103 | 
104 |   if flag(threaded)
105 |     ghc-options: -threaded -rtsopts -with-rtsopts=-N
106 | 
107 |   if flag(llvm)
108 |     ghc-options: -fllvm
109 | 
110 |   if !flag(test-properties)
111 |     buildable: False
112 |   else
113 |     build-depends:
114 |       base,
115 |       structures,
116 |       deepseq,
117 |       QuickCheck       >= 2.4,
118 |       tasty            >= 0.3,
119 |       tasty-quickcheck >= 0.3,
120 |       tasty-th         >= 0.1.1
121 | 
122 | test-suite hunit
123 |   type: exitcode-stdio-1.0
124 |   main-is: hunit.hs
125 |   ghc-options: -w
126 |   hs-source-dirs: tests
127 | 
128 |   if flag(threaded)
129 |     ghc-options: -threaded -rtsopts -with-rtsopts=-N
130 | 
131 |   if flag(llvm)
132 |     ghc-options: -fllvm
133 | 
134 |   if !flag(test-hunit)
135 |     buildable: False
136 |   else
137 |     build-depends:
138 |       base,
139 |       structures,
140 |       QuickCheck       >= 2.4,
141 |       tasty            >= 0.3,
142 |       tasty-hunit      >= 0.2,
143 |       tasty-th         >= 0.1.1
144 | 
145 | test-suite hlint
146 |   type: exitcode-stdio-1.0
147 |   main-is: hlint.hs
148 |   ghc-options: -w
149 |   hs-source-dirs: tests
150 | 
151 |   if flag(threaded)
152 |     ghc-options: -threaded -rtsopts -with-rtsopts=-N
153 | 
154 |   if flag(llvm)
155 |     ghc-options: -fllvm
156 | 
157 |   if !flag(test-hlint)
158 |     buildable: False
159 |   else
160 |     build-depends:
161 |       base,
162 |       hlint >= 1.7
163 | 
164 | -- Verify the results of the examples
165 | test-suite doctests
166 |   type:           exitcode-stdio-1.0
167 |   main-is:        doctests.hs
168 |   ghc-options:    -Wall
169 |   hs-source-dirs: tests
170 | 
171 |   if flag(threaded)
172 |     ghc-options: -threaded -rtsopts -with-rtsopts=-N
173 | 
174 |   if flag(llvm)
175 |     ghc-options: -fllvm
176 | 
177 |   if !flag(test-doctests)
178 |     buildable: False
179 |   else
180 |     build-depends:
181 |       base,
182 |       bytestring,
183 |       containers,
184 |       directory      >= 1.0,
185 |       deepseq,
186 |       doctest        >= 0.9.1,
187 |       filepath,
188 |       semigroups     >= 0.9,
189 |       unordered-containers
190 | 
191 |   if impl(ghc<7.6.1)
192 |     ghc-options: -Werror
193 | 
194 | benchmark maps
195 |   type:           exitcode-stdio-1.0
196 |   main-is:        maps.hs
197 |   ghc-options:    -Wall
198 |   hs-source-dirs: benchmarks
199 |   buildable: False
200 | 
201 |   if flag(threaded)
202 |     ghc-options: -threaded -rtsopts -with-rtsopts=-N
203 | 
204 |   if flag(llvm)
205 |     ghc-options: -fllvm
206 | 
207 |   build-depends:
208 |     array,
209 |     base,
210 |     containers,
211 |     criterion,
212 |     mwc-random,
213 |     structures,
214 |     unordered-containers,
215 |     vector
216 | 
217 | benchmark lookups
218 |   type:           exitcode-stdio-1.0
219 |   main-is:        lookups.hs
220 |   ghc-options:    -Wall
221 |   hs-source-dirs: benchmarks
222 |   buildable: False
223 | 
224 |   if flag(threaded)
225 |     ghc-options: -threaded -rtsopts -with-rtsopts=-N
226 | 
227 |   if flag(llvm)
228 |     ghc-options: -fllvm
229 | 
230 |   build-depends:
231 |     array,
232 |     base,
233 |     containers,
234 |     criterion,
235 |     deepseq,
236 |     MonadRandom,
237 |     structures,
238 |     unordered-containers,
239 |     vector
240 | 
241 | benchmark inserts
242 |   type:           exitcode-stdio-1.0
243 |   main-is:        inserts.hs
244 |   ghc-options:    -Wall
245 |   hs-source-dirs: benchmarks
246 | 
247 |   if flag(threaded)
248 |     ghc-options: -threaded -rtsopts -with-rtsopts=-N
249 | 
250 |   if flag(llvm)
251 |     ghc-options: -fllvm
252 | 
253 |   build-depends:
254 |     array,
255 |     base,
256 |     containers,
257 |     criterion,
258 |     deepseq,
259 |     MonadRandom,
260 |     structures,
261 |     unordered-containers,
262 |     vector
263 | 


--------------------------------------------------------------------------------
/tests/doctests.hsc:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE CPP #-}
 2 | {-# LANGUAGE ForeignFunctionInterface #-}
 3 | -----------------------------------------------------------------------------
 4 | -- |
 5 | -- Module      :  Main (doctests)
 6 | -- Copyright   :  (C) 2012-13 Edward Kmett
 7 | -- License     :  BSD-style (see the file LICENSE)
 8 | -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
 9 | -- Stability   :  provisional
10 | -- Portability :  portable
11 | --
12 | -- This module provides doctests for a project based on the actual versions
13 | -- of the packages it was built with. It requires a corresponding Setup.lhs
14 | -- to be added to the project
15 | -----------------------------------------------------------------------------
16 | module Main where
17 | 
18 | import Build_doctests (deps)
19 | import Control.Applicative
20 | import Control.Monad
21 | import Data.List
22 | import System.Directory
23 | import System.FilePath
24 | import Test.DocTest
25 | 
26 | ##if defined(mingw32_HOST_OS)
27 | ##if defined(i386_HOST_ARCH)
28 | ##define USE_CP
29 | import Control.Applicative
30 | import Control.Exception
31 | import Foreign.C.Types
32 | foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool
33 | foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt
34 | ##elif defined(x86_64_HOST_ARCH)
35 | ##define USE_CP
36 | import Control.Applicative
37 | import Control.Exception
38 | import Foreign.C.Types
39 | foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool
40 | foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt
41 | ##endif
42 | ##endif
43 | 
44 | -- | Run in a modified codepage where we can print UTF-8 values on Windows.
45 | withUnicode :: IO a -> IO a
46 | ##ifdef USE_CP
47 | withUnicode m = do
48 |   cp <- c_GetConsoleCP
49 |   (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp
50 | ##else
51 | withUnicode m = m
52 | ##endif
53 | 
54 | main :: IO ()
55 | main = withUnicode $ getSources >>= \sources -> doctest $
56 |     "-isrc"
57 |   : "-idist/build/autogen"
58 |   : "-optP-include"
59 |   : "-optPdist/build/autogen/cabal_macros.h"
60 |   : "-hide-all-packages"
61 |   : map ("-package="++) deps ++ sources
62 | 
63 | getSources :: IO [FilePath]
64 | getSources = filter (isSuffixOf ".hs") <$> go "src"
65 |   where
66 |     go dir = do
67 |       (dirs, files) <- getFilesAndDirectories dir
68 |       (files ++) . concat <$> mapM go dirs
69 | 
70 | getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])
71 | getFilesAndDirectories dir = do
72 |   c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir
73 |   (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c
74 | 


--------------------------------------------------------------------------------
/tests/hlint.hs:
--------------------------------------------------------------------------------
 1 | -----------------------------------------------------------------------------
 2 | -- |
 3 | -- Module      :  Main (hlint)
 4 | -- Copyright   :  (C) 2013 Edward Kmett
 5 | -- License     :  BSD-style (see the file LICENSE)
 6 | -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
 7 | -- Stability   :  provisional
 8 | -- Portability :  portable
 9 | --
10 | -- This module runs HLint on the lens source tree.
11 | -----------------------------------------------------------------------------
12 | module Main where
13 | 
14 | import Control.Monad
15 | import Language.Haskell.HLint
16 | import System.Environment
17 | import System.Exit
18 | 
19 | main :: IO ()
20 | main = do
21 |     args <- getArgs
22 |     hints <- hlint $ ["src", "--cpp-define=HLINT"] ++ args
23 |     unless (null hints) exitFailure
24 | 


--------------------------------------------------------------------------------
/tests/hunit.hs:
--------------------------------------------------------------------------------
1 | module Main
2 |        ( main  -- :: IO ()
3 |        ) where
4 | 
5 | main :: IO ()
6 | main = return ()
7 | 


--------------------------------------------------------------------------------
/tests/properties.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE TemplateHaskell #-}
 2 | module Main
 3 |        ( main  -- :: IO ()
 4 |        ) where
 5 | import Prelude as Prelude
 6 | import Data.List as List
 7 | import Data.Maybe
 8 | import Data.Function
 9 | import Control.Monad
10 | import Control.DeepSeq
11 | import Debug.Trace
12 | 
13 | import Test.Tasty
14 | import Test.Tasty.TH
15 | import Test.Tasty.QuickCheck as QC
16 | 
17 | import Data.Vector.Map as V
18 | 
19 | --------------------------------------------------------------------------------
20 | 
21 | type UMap = V.Map Int ()
22 | 
23 | --------------------------------------------------------------------------------
24 | 
25 | prop_null :: Int -> Bool
26 | prop_null x =
27 |   V.null V.empty == True &&
28 |   V.null (V.insert x () V.empty) == False
29 | 
30 | prop_emptyLookup :: Int -> Bool
31 | prop_emptyLookup k = (V.lookup k (V.empty :: UMap)) == Nothing
32 | 
33 | prop_insertLookup :: Int -> Bool
34 | prop_insertLookup k = V.lookup k (V.insert k () V.empty) /= Nothing
35 | 
36 | -- We need a working Eq instance
37 | --prop_fromList :: [(Int, Int)] -> Bool
38 | --prop_fromList xs = V.fromList xs == foldr (\(k,v) -> V.insert k v) V.empty xs
39 | 
40 | prop_lookupMany :: [(Int,Int)] -> Property
41 | prop_lookupMany xs = List.length xs > 0 ==> prop
42 |   where
43 |     prop = all (\(x,_) -> isJust $ V.lookup x ls) xs'
44 | 
45 |     ls  = V.fromList xs'
46 |     xs' = List.nubBy ((==) `on` fst) xs
47 | 
48 | --------------------------------------------------------------------------------
49 | 
50 | main :: IO ()
51 | main = $(defaultMainGenerator)
52 | 


--------------------------------------------------------------------------------
/travis/cabal-apt-install:
--------------------------------------------------------------------------------
 1 | #! /bin/bash
 2 | set -eu
 3 | 
 4 | APT="sudo apt-get -q -y"
 5 | CABAL_INSTALL_DEPS="cabal install --only-dependencies --force-reinstall"
 6 | 
 7 | $APT update
 8 | $APT install dctrl-tools
 9 | 
10 | # Find potential system packages to satisfy cabal dependencies
11 | deps()
12 | {
13 | 	local M='^\([^ ]\+\)-[0-9.]\+ (.*$'
14 | 	local G=' -o ( -FPackage -X libghc-\L\1\E-dev )'
15 | 	local E="$($CABAL_INSTALL_DEPS "$@" --dry-run -v 2> /dev/null \
16 | 		| sed -ne "s/$M/$G/p" | sort -u)"
17 | 	grep-aptavail -n -sPackage \( -FNone -X None \) $E | sort -u
18 | }
19 | 
20 | $APT install $(deps "$@") libghc-quickcheck2-dev # QuickCheck is special
21 | $CABAL_INSTALL_DEPS "$@" # Install the rest via Hackage
22 | 
23 | if ! $APT install hlint ; then
24 | 	$APT install $(deps hlint)
25 | 	cabal install hlint
26 | fi
27 | 
28 | 


--------------------------------------------------------------------------------
/travis/config:
--------------------------------------------------------------------------------
 1 | -- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix
 2 | --
 3 | -- This is particularly useful for travis-ci to get it to stop complaining
 4 | -- about a broken build when everything is still correct on our end.
 5 | --
 6 | -- This uses Luite Stegeman's mirror of hackage provided by his 'hdiff' site instead
 7 | --
 8 | -- To enable this, uncomment the before_script in .travis.yml
 9 | 
10 | remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive
11 | remote-repo-cache: ~/.cabal/packages
12 | world-file: ~/.cabal/world
13 | build-summary: ~/.cabal/logs/build.log
14 | remote-build-reporting: anonymous
15 | install-dirs user
16 | install-dirs global
17 | 


--------------------------------------------------------------------------------