packages feed

structures (empty) → 0.1

raw patch · 27 files changed

+2100/−0 lines, 27 filesdep +MonadRandomdep +QuickCheckdep +arraybuild-type:Customsetup-changed

Dependencies added: MonadRandom, QuickCheck, array, base, bytestring, containers, contravariant, criterion, deepseq, directory, doctest, filepath, free, ghc, ghc-prim, hashable, hlint, hybrid-vectors, lens, monad-st, mwc-random, parallel, primitive, semigroups, structures, tasty, tasty-hunit, tasty-quickcheck, tasty-th, transformers, unordered-containers, vector, vector-algorithms

Files

+ .ghci view
@@ -0,0 +1,1 @@+:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h
+ .gitignore view
@@ -0,0 +1,16 @@+dist+docs+wiki+TAGS+tags+wip+stats+.DS_Store+.*.swp+.*.swo+*.o+*.hi+*~+*#+.cabal-sandbox+cabal.sandbox.config
+ .travis.yml view
@@ -0,0 +1,31 @@+language: haskell+before_install:+  # Uncomment whenever hackage is down.+  # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && cabal update+  - cabal update++  # Try installing some of the build-deps with apt-get for speed.+  - travis/cabal-apt-install $mode --force-reinstalls++install:+  - cabal configure -flib-Werror $mode+  - cabal build+  - cabal install --enable-documentation++script:+  - $script++# disable travis for now, atomic-primops doesn't work on GHC 7.4+branches:+  except: /.*/++notifications:+  irc:+    channels:+      - "irc.freenode.org#haskell-lens"+    skip_join: true+    template:+      - "\x0313structures\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"++env:+  - mode="--enable-tests" script="cabal test --show-details=always"
+ .vim.custom view
@@ -0,0 +1,31 @@+" Add the following to your .vimrc to automatically load this on startup++" if filereadable(".vim.custom")+"     so .vim.custom+" endif++function StripTrailingWhitespace()+  let myline=line(".")+  let mycolumn = col(".")+  silent %s/  *$//+  call cursor(myline, mycolumn)+endfunction++" enable syntax highlighting+syntax on++" search for the tags file anywhere between here and /+set tags=TAGS;/++" highlight tabs and trailing spaces+set listchars=tab:‗‗,trail:‗+set list++" f2 runs hasktags+map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR>++" strip trailing whitespace before saving+" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace()++" rebuild hasktags after saving+au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"
+ CHANGELOG.markdown view
@@ -0,0 +1,4 @@+0.1+---+* Repository initialized+
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2013 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README.markdown view
@@ -0,0 +1,15 @@+structures+==========++[![Build Status](https://secure.travis-ci.org/ekmett/structures.png?branch=master)](http://travis-ci.org/ekmett/structures)++A playground for working with cache oblivious, succinct and compact data structures++Contact Information+-------------------++Contributions and bug reports are welcome!++Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net.++-Edward Kmett
+ Setup.lhs view
@@ -0,0 +1,55 @@+#!/usr/bin/runhaskell+\begin{code}+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++import Data.List ( nub )+import Data.Version ( showVersion )+import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref))+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )+import Distribution.Text ( display )+import Distribution.Verbosity ( Verbosity, normal )+import System.FilePath ( (</>) )++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+  { buildHook = \pkg lbi hooks flags -> do+     generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi+     buildHook simpleUserHooks pkg lbi hooks flags+  , postHaddock = \args flags pkg lbi -> do+     copyFiles normal (haddockOutputDir flags pkg) []+     postHaddock simpleUserHooks args flags pkg lbi+  }++haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath+haddockOutputDir flags pkg = destDir where+  baseDir = case haddockDistPref flags of+    NoFlag -> "."+    Flag x -> x+  destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)++generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule verbosity pkg lbi = do+  let dir = autogenModulesDir lbi+  createDirectoryIfMissingVerbose verbosity True dir+  withLibLBI pkg lbi $ \_ libcfg -> do+    withTestLBI pkg lbi $ \suite suitecfg -> do+      rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines+        [ "module Build_" ++ testName suite ++ " where"+        , "deps :: [String]"+        , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))+        ]+  where+    formatdeps = map (formatone . snd)+    formatone p = case packageName p of+      PackageName n -> n ++ "-" ++ showVersion (packageVersion p)++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys++\end{code}
+ benchmarks/inserts.hs view
@@ -0,0 +1,42 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Main where++import Data.Foldable as F+import Data.Map as M+import Data.HashMap.Strict as H+import Data.Vector.Map as V+import Control.DeepSeq+import Control.Monad.Random+import Control.Monad+import Criterion.Config+import Criterion.Main++instance NFData (V.Map k v)++buildV :: Int -> V.Map Int Int+buildV n = F.foldl' (flip (join V.insert)) V.empty $ take n $ randoms (mkStdGen 1)++fromListV :: Int -> V.Map Int Int+fromListV n = V.fromList $ Prelude.map (\x -> (x,x)) $ take n $ randoms (mkStdGen 1)++buildM :: Int -> M.Map Int Int+buildM n = F.foldl' (flip (join M.insert)) M.empty $ take n $ randoms (mkStdGen 1)++buildH :: Int -> H.HashMap Int Int+buildH n = F.foldl' (flip (join H.insert)) H.empty $ take n $ randoms (mkStdGen 1)++main :: IO ()+main = defaultMainWith defaultConfig { cfgSamples = ljust 10 } (return ())+  [ bench "COLA insert 10k"               $ nf buildV    10000+  , bench "COLA fromList 10k"             $ nf fromListV 10000+  , bench "Data.Map insert 10k"           $ nf buildM 10000+  , bench "Data.HashMap insert 10k"       $ nf buildH 10000+  , bench "COLA insert 100k"              $ nf buildV 100000+  , bench "COLA fromList 100k"            $ nf fromListV 100000+  , bench "Data.Map insert 100k"          $ nf buildM 100000+  , bench "Data.HashMap insert 100k"      $ nf buildH 100000+  , bench "COLA insert 1m"                $ nf buildV 1000000+  , bench "COLA fromList 1m"              $ nf fromListV 1000000+  , bench "Data.Map insert 1m"            $ nf buildM 1000000+  , bench "Data.HashMap insert 1m"        $ nf buildH 1000000+  ]
+ benchmarks/lookups.hs view
@@ -0,0 +1,50 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Main where++import Data.Foldable as F+import Data.Map as M+import Data.Maybe+import Data.Vector.Map as V+import Control.DeepSeq+import Control.Monad.Random+import Control.Monad+import Criterion.Config+import Criterion.Main++instance NFData (V.Map k v)++buildV :: Int -> V.Map Int Int+buildV n = F.foldl' (flip (join V.insert)) V.empty $ take n $ randoms (mkStdGen 1)++buildM :: Int -> M.Map Int Int+buildM n = F.foldl' (flip (join M.insert)) M.empty $ take n $ randoms (mkStdGen 1)++lookupV :: V.Map Int Int -> Int -> Int+lookupV m n = F.foldl' (+) 0 $ catMaybes $ fmap (`V.lookup` m) $ take n $ randoms (mkStdGen 1)++lookupM :: M.Map Int Int -> Int -> Int+lookupM m n = F.foldl' (+) 0 $ catMaybes $ fmap (`M.lookup` m) $ take n $ randoms (mkStdGen 1)++main :: IO ()+main = do+    nfIO (return v10)+    nfIO (return m10)+    nfIO (return v100)+    nfIO (return m100)+    nfIO (return v1000)+    nfIO (return m1000)+    defaultMainWith defaultConfig { cfgSamples = ljust 10 } (return ())+      [ bench "COLA lookup 10k from 10k"      $ nf (lookupV v10)   10000+      , bench "Data.Map lookup 10k from 10k"  $ nf (lookupM m10)   10000+      , bench "COLA lookup 10k from 100k"     $ nf (lookupV v100)  10000+      , bench "Data.Map lookup 10k from 100k" $ nf (lookupM m100)  10000+      , bench "COLA lookup 10k from 1m"       $ nf (lookupV v1000) 10000+      , bench "Data.Map lookup 10k from 1m"   $ nf (lookupM m1000) 10000+      ]+  where+    v10   = buildV 10000+    m10   = buildM 10000+    v100  = buildV 100000+    m100  = buildM 100000+    v1000 = buildV 1000000+    m1000 = buildM 1000000
+ benchmarks/maps.hs view
@@ -0,0 +1,45 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Main where++import Control.Monad (join)+import Criterion.Config+import Criterion.Main+import qualified Data.Map as M+import qualified Data.Vector.Map as V+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Generic.Mutable as GM+import System.Random.MWC (withSystemRandom, GenIO, Variate(..))++randVec :: (U.Unbox a, Variate a) => Int -> GenIO -> IO (U.Vector a)+randVec n g = GM.replicateM n (uniform g) >>= G.unsafeFreeze++randVecStd :: (U.Unbox a, Variate a) => Int -> IO (U.Vector a)+randVecStd = withSystemRandom . randVec++insertAll :: U.Unbox a => (a -> a -> t -> t) -> t -> U.Vector a -> t+insertAll f e = U.foldl' (flip $ join f) e++sumAll :: (U.Unbox a, U.Unbox b, Num b) => (a -> b) -> U.Vector a -> b+sumAll f = U.sum . U.map f++main :: IO ()+main = do+  ns <- randVecStd 1000 :: IO (U.Vector Int)+  -- print (vinsert ns)+  -- print (V.shape (vinsert ns))+  putStrLn $ if sumAll (vget (vinsert ns)) ns == sumAll (minsert ns M.!) ns+             then "We are sane"+             else "We are insane, man!"+  defaultMainWith defaultConfig { cfgSamples = ljust 10 } (return ())+    [ bench "Map insertion"  $ whnf minsert ns+    , bench "VMap insertion" $ whnf vinsert ns+    , bench "map sum"        $ whnf (sumAll (minsert ns M.!)) ns+    , bench "vmap sum"       $ whnf (sumAll (vget (vinsert ns))) ns+    ]+ where+  minsert = insertAll M.insert M.empty+  vinsert = insertAll V.insert V.empty+  vget m k = case V.lookup k m of+    Nothing -> error $ "Missing "++show k+    Just x -> x
+ src/Data/Vector/Array.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2013 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- This module provides a choice of a "best" vector type for a given type+-- that is as unboxed as possible.+-----------------------------------------------------------------------------+module Data.Vector.Array++  ( Arrayed(..)+  , Array+  , MArray+  -- * Internals+  , V_Complex(V_Complex)+  , MV_Complex(MV_Complex)+  , V_Pair(V_Pair)+  , MV_Pair(MV_Pair)+  ) where++import Control.Monad+import Data.Complex+import Data.Int+import Data.Monoid+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Generic.Mutable as GM+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Fusion.Stream as Stream+import qualified Data.Vector as B+import Data.Word+import Text.Read++-- | A vector of product-like data types that know how to store themselves in a Vector optimally,+-- maximizing the level of unboxing provided, but not guaranteeing to unbox it all.++type Array a = Arr a a+type MArray s a = G.Mutable (Arr a) s a++class (G.Vector (Arr a) a, Monoid (Arr a a)) => Arrayed a where+  type Arr a :: * -> *+  type Arr a = U.Vector++-- * Unboxed vectors++instance Arrayed ()+instance Arrayed Double+instance Arrayed Float+instance Arrayed Int+instance Arrayed Int8+instance Arrayed Int16+instance Arrayed Int32+instance Arrayed Int64+instance Arrayed Word+instance Arrayed Word8+instance Arrayed Word16+instance Arrayed Word32+instance Arrayed Word64++-- * Boxed vectors++instance Arrayed Integer where+  type Arr Integer = B.Vector++instance Arrayed [a] where+  type Arr [a] = B.Vector++instance Arrayed (Maybe a) where+  type Arr (Maybe a) = B.Vector++instance Arrayed (Either a b) where+  type Arr (Either a b) = B.Vector++instance Arrayed (IO a) where+  type Arr (IO a) = B.Vector++-- * Pairs are boxed or unboxed based on their components++#ifndef HLINT+data MV_Pair :: * -> * -> * where+  MV_Pair:: {-# UNPACK #-} !Int -> !(G.Mutable (Arr a) s a) -> !(G.Mutable (Arr b) s b) -> MV_Pair s (a, b)++data V_Pair :: * -> * where+  V_Pair :: {-# UNPACK #-} !Int -> !(Array a) -> !(Array b) -> V_Pair (a, b)+#endif++type instance G.Mutable V_Pair = MV_Pair++instance (Arrayed a, Arrayed b) => GM.MVector MV_Pair (a, b) where+  {-# INLINE basicLength #-}+  {-# INLINE basicUnsafeSlice #-}+  {-# INLINE basicOverlaps #-}+  {-# INLINE basicUnsafeNew #-}+  {-# INLINE basicUnsafeReplicate #-}+  {-# INLINE basicUnsafeRead #-}+  {-# INLINE basicUnsafeWrite #-}+  {-# INLINE basicClear #-}+  {-# INLINE basicSet #-}+  {-# INLINE basicUnsafeCopy #-}+  {-# INLINE basicUnsafeGrow #-}+  basicLength (MV_Pair l _ _) = l+  basicUnsafeSlice i n (MV_Pair _ u v)                   = MV_Pair n (GM.basicUnsafeSlice i n u) (GM.basicUnsafeSlice i n v)+  basicOverlaps (MV_Pair _ u1 v1) (MV_Pair _ u2 v2)      = GM.basicOverlaps u1 u2 || GM.basicOverlaps v1 v2+  basicUnsafeNew n                                       = liftM2 (MV_Pair n) (GM.basicUnsafeNew n) (GM.basicUnsafeNew n)+  basicUnsafeReplicate n (x, y)                          = liftM2 (MV_Pair n) (GM.basicUnsafeReplicate n x) (GM.basicUnsafeReplicate n y)+  basicUnsafeRead (MV_Pair _ u v) i                      = liftM2 (,) (GM.basicUnsafeRead u i) (GM.basicUnsafeRead v i)+  basicUnsafeWrite (MV_Pair _ u v) i (x, y)              = GM.basicUnsafeWrite u i x >> GM.basicUnsafeWrite v i y+  basicClear (MV_Pair _ u v)                             = GM.basicClear u >> GM.basicClear v+  basicSet (MV_Pair _ u v) (x, y)                        = GM.basicSet u x >> GM.basicSet v y+  basicUnsafeCopy (MV_Pair _ u1 v1) (MV_Pair _ u2 v2)    = GM.basicUnsafeCopy u1 u2 >> GM.basicUnsafeCopy v1 v2+  basicUnsafeMove (MV_Pair _ u1 v1) (MV_Pair _ u2 v2)    = GM.basicUnsafeMove u1 u2 >> GM.basicUnsafeMove v1 v2+  basicUnsafeGrow (MV_Pair _ u v) n                      = liftM2 (MV_Pair n) (GM.basicUnsafeGrow u n) (GM.basicUnsafeGrow v n)++instance (Arrayed a, Arrayed b) => G.Vector V_Pair (a, b) where+  {-# INLINE basicLength #-}+  {-# INLINE basicUnsafeFreeze #-}+  {-# INLINE basicUnsafeThaw #-}+  {-# INLINE basicUnsafeSlice #-}+  {-# INLINE basicUnsafeIndexM #-}+  {-# INLINE elemseq #-}+  basicLength (V_Pair v _ _) = v+  basicUnsafeFreeze (MV_Pair n u v)                = liftM2 (V_Pair n) (G.basicUnsafeFreeze u) (G.basicUnsafeFreeze v)+  basicUnsafeThaw (V_Pair n u v)                   = liftM2 (MV_Pair n) (G.basicUnsafeThaw u) (G.basicUnsafeThaw v)+  basicUnsafeSlice i n (V_Pair _ u v)              = V_Pair n (G.basicUnsafeSlice i n u) (G.basicUnsafeSlice i n v)+  basicUnsafeIndexM (V_Pair _ u v) i               = liftM2 (,) (G.basicUnsafeIndexM u i) (G.basicUnsafeIndexM v i)+  basicUnsafeCopy (MV_Pair _ mu mv) (V_Pair _ u v) = G.basicUnsafeCopy mu u >> G.basicUnsafeCopy mv v+  elemseq _ (x, y) z  = G.elemseq (undefined :: Array a) x+                       $ G.elemseq (undefined :: Array b) y z++instance (Arrayed a, Arrayed b, Show a, Show b, c ~ (a, b)) => Show (V_Pair c) where+  showsPrec = G.showsPrec++instance (Arrayed a, Arrayed b, Read a, Read b, c ~ (a, b)) => Read (V_Pair c) where+  readPrec = G.readPrec+  readListPrec = readListPrecDefault++instance (Arrayed a, Arrayed b, Eq a, Eq b, c ~ (a, b)) => Eq (V_Pair c) where+  xs == ys = Stream.eq (G.stream xs) (G.stream ys)+  {-# INLINE (==) #-}++instance (Arrayed a, Arrayed b, c ~ (a, b)) => Monoid (V_Pair c) where+  mappend = (G.++)+  {-# INLINE mappend #-}+  mempty = G.empty+  {-# INLINE mempty #-}+  mconcat = G.concat+  {-# INLINE mconcat #-}++instance (Arrayed a, Arrayed b) => Arrayed (a, b) where+  type Arr (a, b) = V_Pair++-- * Complex numbers are boxed or unboxed based on their components++#ifndef HLINT+data MV_Complex :: * -> * -> * where+  MV_Complex :: {-# UNPACK #-} !Int -> !(G.Mutable (Arr a) s a) -> !(G.Mutable (Arr a) s a) -> MV_Complex s (Complex a)++data V_Complex :: * -> * where+  V_Complex :: {-# UNPACK #-} !Int -> !(Array a) -> !(Array a) -> V_Complex (Complex a)+#endif++type instance G.Mutable V_Complex = MV_Complex++instance (Arrayed a, RealFloat a) => GM.MVector MV_Complex (Complex a) where+  {-# INLINE basicLength #-}+  {-# INLINE basicUnsafeSlice #-}+  {-# INLINE basicOverlaps #-}+  {-# INLINE basicUnsafeNew #-}+  {-# INLINE basicUnsafeReplicate #-}+  {-# INLINE basicUnsafeRead #-}+  {-# INLINE basicUnsafeWrite #-}+  {-# INLINE basicClear #-}+  {-# INLINE basicSet #-}+  {-# INLINE basicUnsafeCopy #-}+  {-# INLINE basicUnsafeGrow #-}+  basicLength (MV_Complex l _ _) = l+  basicUnsafeSlice i n (MV_Complex _ u v)                   = MV_Complex n (GM.basicUnsafeSlice i n u) (GM.basicUnsafeSlice i n v)+  basicOverlaps (MV_Complex _ u1 v1) (MV_Complex _ u2 v2)   = GM.basicOverlaps u1 u2 || GM.basicOverlaps v1 v2+  basicUnsafeNew n                                          = liftM2 (MV_Complex n) (GM.basicUnsafeNew n) (GM.basicUnsafeNew n)+  basicUnsafeReplicate n (x :+ y)                           = liftM2 (MV_Complex n) (GM.basicUnsafeReplicate n x) (GM.basicUnsafeReplicate n y)+  basicUnsafeRead (MV_Complex _ u v) i                      = liftM2 (:+) (GM.basicUnsafeRead u i) (GM.basicUnsafeRead v i)+  basicUnsafeWrite (MV_Complex _ u v) i (x :+ y)            = GM.basicUnsafeWrite u i x >> GM.basicUnsafeWrite v i y+  basicClear (MV_Complex _ u v)                             = GM.basicClear u >> GM.basicClear v+  basicSet (MV_Complex _ u v) (x :+ y)                      = GM.basicSet u x >> GM.basicSet v y+  basicUnsafeCopy (MV_Complex _ u1 v1) (MV_Complex _ u2 v2) = GM.basicUnsafeCopy u1 u2 >> GM.basicUnsafeCopy v1 v2+  basicUnsafeMove (MV_Complex _ u1 v1) (MV_Complex _ u2 v2) = GM.basicUnsafeMove u1 u2 >> GM.basicUnsafeMove v1 v2+  basicUnsafeGrow (MV_Complex _ u v) n                      = liftM2 (MV_Complex n) (GM.basicUnsafeGrow u n) (GM.basicUnsafeGrow v n)++instance (Arrayed a, RealFloat a) => G.Vector V_Complex (Complex a) where+  {-# INLINE basicLength #-}+  {-# INLINE basicUnsafeFreeze #-}+  {-# INLINE basicUnsafeThaw #-}+  {-# INLINE basicUnsafeSlice #-}+  {-# INLINE basicUnsafeIndexM #-}+  {-# INLINE elemseq #-}+  basicLength (V_Complex v _ _) = v+  basicUnsafeFreeze (MV_Complex n u v)                   = liftM2 (V_Complex n) (G.basicUnsafeFreeze u) (G.basicUnsafeFreeze v)+  basicUnsafeThaw (V_Complex n u v)                      = liftM2 (MV_Complex n) (G.basicUnsafeThaw u) (G.basicUnsafeThaw v)+  basicUnsafeSlice i n (V_Complex _ u v)                 = V_Complex n (G.basicUnsafeSlice i n u) (G.basicUnsafeSlice i n v)+  basicUnsafeIndexM (V_Complex _ u v) i                  = liftM2 (:+) (G.basicUnsafeIndexM u i) (G.basicUnsafeIndexM v i)+  basicUnsafeCopy (MV_Complex _ mu mv) (V_Complex _ u v) = G.basicUnsafeCopy mu u >> G.basicUnsafeCopy mv v+  elemseq _ (x :+ y) z = G.elemseq (undefined :: Arr a a) x+                       $ G.elemseq (undefined :: Arr a a) y z++instance (Arrayed a, RealFloat a, Show a, b ~ Complex a) => Show (V_Complex b) where+  showsPrec = G.showsPrec++instance (Arrayed a, RealFloat a, Read a, b ~ Complex a) => Read (V_Complex b) where+  readPrec = G.readPrec+  readListPrec = readListPrecDefault++instance (Arrayed a, RealFloat a, Eq a, b ~ Complex a) => Eq (V_Complex b) where+  xs == ys = Stream.eq (G.stream xs) (G.stream ys)+  {-# INLINE (==) #-}++instance (Arrayed a, RealFloat a, b ~ Complex a) => Monoid (V_Complex b) where+  mappend = (G.++)+  {-# INLINE mappend #-}+  mempty = G.empty+  {-# INLINE mempty #-}+  mconcat = G.concat+  {-# INLINE mconcat #-}++instance (Arrayed a, RealFloat a) => Arrayed (Complex a) where+  type Arr (Complex a) = V_Complex
+ src/Data/Vector/Bit.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Data.Vector.Bit+  (+  -- * Bits+    Bit(..)+  , _Bit+  -- * Bit Vectors with rank+  , BitVector(..)+  , _BitVector+  , rank+  , null+  , size+  , singleton+  , empty+  , access+  -- * Vectors of Bits+  , UM.MVector(MV_Bit)+  , U.Vector(V_Bit)+  ) where++import Control.Lens as L+import Control.Monad+import Data.Bits+import Data.Data+import Data.Vector.Array+import Data.Vector.Internal.Check as Ck+import Data.Word+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Generic.Mutable as GM+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as UM+import Prelude hiding (null)++#define BOUNDS_CHECK(f) (Ck.f __FILE__ __LINE__ Ck.Bounds)++-- | A simple newtype around a 'Bool'+--+-- The principal use of this is that a 'U.Vector' 'Bit' is densely+-- packed into individual bits rather than stored as one entry per 'Word8'.+newtype Bit = Bit { getBit :: Bool }+  deriving (Show,Read,Eq,Ord,Enum,Bounded,Data,Typeable)++-- | 'Bit' and 'Bool' are isomorphic.+_Bit :: Iso' Bit Bool+_Bit = iso getBit Bit+{-# INLINE _Bit #-}++instance Arrayed Bit+instance UM.Unbox Bit++data instance UM.MVector s Bit = MV_Bit {-# UNPACK #-} !Int !(UM.MVector s Word64)++instance GM.MVector U.MVector Bit where+  {-# INLINE basicLength #-}+  {-# INLINE basicUnsafeSlice #-}+  {-# INLINE basicOverlaps #-}+  {-# INLINE basicUnsafeNew #-}+  {-# INLINE basicUnsafeReplicate #-}+  {-# INLINE basicUnsafeRead #-}+  {-# INLINE basicUnsafeWrite #-}+  {-# INLINE basicClear #-}+  {-# INLINE basicSet #-}+  {-# INLINE basicUnsafeCopy #-}+  {-# INLINE basicUnsafeGrow #-}+  basicLength (MV_Bit n _) = n+  basicUnsafeSlice i n (MV_Bit _ u) = MV_Bit n $ GM.basicUnsafeSlice i (wds n) u+  basicOverlaps (MV_Bit _ v1) (MV_Bit _ v2) = GM.basicOverlaps v1 v2+  basicUnsafeNew n = do+    v <- GM.basicUnsafeNew (wds n)+    return $ MV_Bit n v+  basicUnsafeReplicate n (Bit b) = do+    v <- GM.basicUnsafeReplicate (wds n) (if b then -1 else 0)+    return $ MV_Bit n v+  basicUnsafeRead (MV_Bit _ u) i = do+    w <- GM.basicUnsafeRead u (wd i)+    return $ Bit $ testBit w (bt i)+  basicUnsafeWrite (MV_Bit _ u) i (Bit b) = do+    let wn = wd i+    w <- GM.basicUnsafeRead u wn+    GM.basicUnsafeWrite u wn $ if b then setBit w (bt i) else clearBit w (bt i)+  basicClear (MV_Bit _ u) = GM.basicClear u+  basicSet (MV_Bit _ u) (Bit b) = GM.basicSet u $ if b then -1 else 0+  basicUnsafeCopy (MV_Bit _ u1) (MV_Bit _ u2) = GM.basicUnsafeCopy u1 u2+  basicUnsafeMove (MV_Bit _ u1) (MV_Bit _ u2) = GM.basicUnsafeMove u1 u2+  basicUnsafeGrow (MV_Bit _ u) n = liftM (MV_Bit n) (GM.basicUnsafeGrow u (wds n))++data instance U.Vector Bit = V_Bit {-# UNPACK #-} !Int !(U.Vector Word64)+instance G.Vector U.Vector Bit where+  {-# INLINE basicLength #-}+  {-# INLINE basicUnsafeFreeze #-}+  {-# INLINE basicUnsafeThaw #-}+  {-# INLINE basicUnsafeSlice #-}+  {-# INLINE basicUnsafeIndexM #-}+  {-# INLINE elemseq #-}+  basicLength (V_Bit n _)          = n+  basicUnsafeFreeze (MV_Bit n u)   = liftM (V_Bit n) (G.basicUnsafeFreeze u)+  basicUnsafeThaw (V_Bit n u)      = liftM (MV_Bit n) (G.basicUnsafeThaw u)+  basicUnsafeSlice i n (V_Bit _ u) = V_Bit n (G.basicUnsafeSlice i (wds n) u)+  basicUnsafeIndexM (V_Bit _ u) i  = do+    w <- G.basicUnsafeIndexM u (wd i)+    return $ Bit $ testBit w (bt i)+  basicUnsafeCopy (MV_Bit _ mu) (V_Bit _ u) = G.basicUnsafeCopy mu u+  elemseq _ b z = b `seq` z++#define BOUNDS_CHECK(f) (Ck.f __FILE__ __LINE__ Ck.Bounds)++-- | A BitVector support for naïve /O(1)/ 'rank'.+data BitVector = BitVector {-# UNPACK #-} !Int !(Array Bit) !(U.Vector Int)+  deriving (Eq,Ord,Show,Read)++-- | /O(n) embedding/ A 'BitVector' is isomorphic to a vector of bits. It just carries extra information.+_BitVector :: Iso' BitVector (Array Bit)+_BitVector = iso (\(BitVector _ v _) -> v) $ \v@(V_Bit n ws) -> BitVector n v $ G.scanl (\a b -> a + popCount b) 0 ws+{-# INLINE _BitVector #-}++-- | /O(1)/. @'rank' i v@ counts the number of 'True' bits up through and including the position @i@+rank :: BitVector -> Int -> Int+rank (BitVector n (V_Bit _ ws) ps) i+  = BOUNDS_CHECK(checkIndex) "rank" i n+  $ (ps U.! w) + popCount ((ws U.! w) .&. (bit (bt i + 1) - 1))+  where w = wd i+{-# INLINE rank #-}++-- | The 'empty' 'BitVector'+empty :: BitVector+empty = _BitVector # G.empty+{-# INLINE empty #-}++-- | /O(1)/. Is the 'BitVector' 'empty'?+null :: BitVector -> Bool+null (BitVector n _ _) = n == 0+{-# INLINE null #-}++-- | /O(1)/. Return the size of the 'BitVector'.+size :: BitVector -> Int+size (BitVector n _ _) = n+{-# INLINE size #-}++access :: Int -> BitVector -> Bool+access i (BitVector n as _) = 0 <= i && i < n && getBit (as U.! i)+{-# INLINE access #-}++-- | Construct a 'BitVector' with a single element.+singleton :: Bool -> BitVector+singleton True = true1+singleton False = false1+{-# INLINE singleton #-}++-- * Implementation Details++true1 :: BitVector+true1 = _BitVector # U.singleton (Bit True)++false1 :: BitVector+false1 = _BitVector # U.singleton (Bit False)++wds :: Int -> Int+wds x = unsafeShiftR (x + 63) 6+{-# INLINE wds #-}++wd :: Int -> Int+wd x = unsafeShiftR x 6+{-# INLINE wd #-}++bt :: Int -> Int+bt x = x .&. 63+{-# INLINE bt #-}+
+ src/Data/Vector/Bloom.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+-- | Hierarchical Bloom filters+module Data.Vector.Bloom+  ( Bloom(Bloom)+  -- * Information+  , entries+  , hashes+  , width+  -- * Construction+  , bloom+  -- * Modification+  , modify+  , insert+  -- * Testing+  , elem+  -- * Combining Blooms+  , union+  , intersection+  -- * Freezing/Thawing+  , freeze, thaw+  , unsafeFreeze, unsafeThaw+  ) where++import Control.Monad hiding (forM_)+import Control.Monad.Primitive+import Control.Monad.ST+import Data.Bits+import Data.Data+import qualified Data.Foldable as F+import Data.Hashable+import Data.Semigroup+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Bloom.Mutable as MB+import Data.Vector.Bloom.Mutable (MBloom(MBloom))+import Data.Vector.Bloom.Util+import Data.Word+import Prelude hiding (elem)++-- TODO: switch to a hash that we can persist to disk cross-platform!++data Bloom+  = Bloom+    { hashes :: {-# UNPACK #-} !Int -- number of hash functions to use+    , _mask  :: {-# UNPACK #-} !Int -- 2^p-1+    , _bits  :: !(U.Vector Word64)  -- when length > 512, then it is an integral multiple of 512, and data is binned into pages+    }+  deriving (Eq,Ord,Show,Read,Typeable,Data)++-- | @'bloom' k m@ builds an @m@-bit wide 'Bloom' filter that uses @k@ hashes.+bloom :: (F.Foldable f, Hashable a) => Int -> Int -> f a -> Bloom+bloom k m fa = runST $ do+  mb <- MB.mbloom k m+  F.forM_ fa $ \a -> MB.insert a mb+  freeze mb+{-# INLINE bloom #-}++-- | Number of bits set+entries :: Bloom -> Int+entries (Bloom _ _ v) = U.foldl' (\r a -> r + popCount a) 0 v+{-# INLINE entries #-}++-- | Compute the union of two 'Bloom' filters.+union :: Bloom -> Bloom -> Bloom+union (Bloom k1 m v1) (Bloom k2 n v2) = Bloom (min k1 k2) (max m n) v3 where+  v3 = U.generate (U.length v1 `max` U.length v2) $ \i -> U.unsafeIndex v1 (i .&. m) .|. U.unsafeIndex v2 (i .&. n)+{-# INLINE union #-}++-- | Compute the intersection of two 'Bloom' filters.+intersection :: Bloom -> Bloom -> Bloom+intersection (Bloom k1 m v1) (Bloom k2 n v2) = Bloom (min k1 k2) (max m n) v3 where+  v3 = U.generate (U.length v1 `max` U.length v2) $ \i -> U.unsafeIndex v1 (i .&. m) .&. U.unsafeIndex v2 (i .&. n)+{-# INLINE intersection #-}++-- | Check if an element is a member of a 'Bloom' filter.+--+-- This may return false positives, but never a false negative.+elem :: Hashable a => a -> Bloom -> Bool+elem a (Bloom k m v)+  | m > 32767, h:hs <- rehash k a, p <- unsafeShiftL h 15 =+    all (\i -> let im = (p+(i.&.32767)).&.m in testBit (U.unsafeIndex v (unsafeShiftR im 6)) (i .&. 63)) hs+  | otherwise =+    all (\i -> let im = i.&.m in testBit (U.unsafeIndex v (unsafeShiftR im 6)) (im .&. 63)) (rehash k a)+{-# INLINE elem #-}++-- | Insert an element into a 'Bloom' filter.+insert :: Hashable a => a -> Bloom -> Bloom+insert a b = modify (MB.insert a) b+{-# INLINE insert #-}++-- | Given an action on a mutable 'Bloom' filter, modify this one.+modify :: (forall s. MBloom s -> ST s ()) -> Bloom -> Bloom+modify f (Bloom a m v) = Bloom a m (U.modify (f . MBloom a m) v)+{-# INLINE modify #-}++-- | The number of bits in our 'Bloom' filter. Always an integral multiple of 64.+width :: Bloom -> Int+width (Bloom _ m _) = m + 1+{-# INLINE width #-}++instance Semigroup Bloom where+  (<>) = union+  {-# INLINE (<>) #-}++-- | /O(m)/+freeze :: PrimMonad m => MBloom (PrimState m) -> m Bloom+freeze (MBloom k m bs) = Bloom k m `liftM` U.freeze bs+{-# INLINE freeze #-}++-- | /O(m)/+thaw :: PrimMonad m => Bloom -> m (MBloom (PrimState m))+thaw (Bloom k m bs) = MBloom k m `liftM` U.thaw bs+{-# INLINE thaw #-}++-- | /O(1)/+unsafeFreeze :: PrimMonad m => MBloom (PrimState m) -> m Bloom+unsafeFreeze (MBloom k m bs) = Bloom k m `liftM` U.unsafeFreeze bs+{-# INLINE unsafeFreeze #-}++-- | /O(1)/+unsafeThaw :: PrimMonad m => Bloom -> m (MBloom (PrimState m))+unsafeThaw (Bloom k m bs) = MBloom k m `liftM` U.unsafeThaw bs+{-# INLINE unsafeThaw #-}
+ src/Data/Vector/Bloom/Mutable.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE BangPatterns #-}+module Data.Vector.Bloom.Mutable+  (+  -- * Mutable Bloom filters+    MBloom(MBloom)+  , mbloom+  , hashes+  , width+  , insert+  ) where++import Control.Monad.Primitive+import Control.Monad.ST+import Data.Bits+import Data.Typeable+import Data.Foldable (forM_)+import Data.Hashable+import Data.Vector.Bloom.Util+import qualified Data.Vector.Unboxed.Mutable as UM+import Data.Word++data MBloom s = MBloom+  { hashes :: {-# UNPACK #-} !Int+  , _mask  :: {-# UNPACK #-} !Int+  , _bits  :: !(UM.MVector s Word64)+  } deriving Typeable+++mbloom :: Int -> Int -> ST s (MBloom s)+mbloom k m0 = do+  let m1 = m0 .|. unsafeShiftR m0 1+  let m2 = m1 .|. unsafeShiftR m1 2+  let m3 = m2 .|. unsafeShiftR m2 4+  let m4 = m3 .|. unsafeShiftR m3 8+  let m5 = m4 .|. unsafeShiftR m4 16+  let m6 = m5 .|. shiftR m5 32+  v <- UM.replicate (unsafeShiftR m6 6 + 1) 0+  return $ MBloom k m6 v+{-# INLINE mbloom #-}++width :: MBloom s -> Int+width (MBloom _ m _) = m + 1+{-# INLINE width #-}++insert :: (PrimMonad m, Hashable a) => a -> MBloom (PrimState m) -> m ()+insert a (MBloom k m bs)+  | m > 32767, h:hs <- rehash k a, p <- unsafeShiftL h 15 = forM_ hs $ \i -> do+    let !im = (p + (i.&.32767)) .&. m+    let !iw = unsafeShiftR im 6+    w <- UM.unsafeRead bs iw+    UM.unsafeWrite bs iw $ setBit w (im .&. 63)+  | otherwise = forM_ (rehash k a) $ \ i -> do+    let !im = i .&. m+    let !iw = unsafeShiftR im 6+    w <- UM.unsafeRead bs iw+    UM.unsafeWrite bs iw $ setBit w (im .&. 63)+{-# INLINE insert #-}
+ src/Data/Vector/Bloom/Util.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE BangPatterns #-}+module Data.Vector.Bloom.Util+  ( rehash+  , optimalHashes+  , optimalWidth+  ) where++import Data.Bits+import Data.Hashable++pepper :: Int+pepper = 0x53dffa872f4d7341++-- | Compute several hashes using a variant of+-- <http://www.eecs.harvard.edu/~kirsch/pubs/bbbf/esa06.pdf Kirsch and Mitzenmacher>'s+-- double hashing.+rehash :: Hashable a => Int -> a -> [Int]+rehash k a = go k where+  go 0 = []+  go i = h : go (i - 1) where !h = h1 + shiftR h2 i+  !h1 = hash a+  !h2 = hashWithSalt pepper a++-- * Utility Functions++-- |+-- @optimalHashes n m@ calculates the optimal number of hash functions for a given number of entries @n@ in a+-- Bloom filter that is @m@ bits wide.+--+-- @k = m/n log 2@+optimalHashes :: Int -> Int -> Int+optimalHashes n m = ceiling (fromIntegral m / fromIntegral n * log 2 :: Double)++-- |+-- @optimalWidth n p@ calculate the optimal width @m@ of a bloom filter given the expected number of entries @n@+-- and target failure rate @p@ at capacity.+--+-- @m = -n log p / (log 2)^2@+optimalWidth :: Int -> Double -> Int+optimalWidth n p = ceiling (-1 * fromIntegral n * log p / log 2 / log 2 :: Double)
+ src/Data/Vector/Heap.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}+module Data.Vector.Heap+  ( Heap+  , heapify+  , sift+  , findMin+  , deleteMin+  , updateMin+  , null+  , length+  ) where++-- TODO: switch to vector-algorithm's quaternary heaps?++import Control.Monad (when)+import Control.Monad.ST+import Data.Bits+import Data.Vector.Array+import Data.Vector.Generic.Mutable as G+import Prelude hiding (length, null)++type Heap s a = MArray s a++-- /O(n)/ min heapify for an implicit binary heap+heapify :: (G.MVector v a, Ord a) => v s a -> ST s ()+heapify v = go (unsafeShiftR (n-2) 1) where+  !n = G.length v+  go k = when (k >= 0) $ do+    sift v k+    go (k-1)++-- /O(log n)/ push own a given element+sift :: (G.MVector v a, Ord a) => v s a -> Int -> ST s ()+sift v root0 = go root0 where+  !n = G.length v+  go root | child1 <- unsafeShiftL root 1 + 1 = do+    when (child1 < n) $ do -- in bounds+      r  <- G.unsafeRead v root+      c1 <- G.unsafeRead v child1+      let swap0 = if r > c1 then child1 else root+      let child2 = child1 + 1+      swap1 <- if child2 < n -- in bounds+        then do+          s0 <- G.unsafeRead v swap0+          c2 <- G.unsafeRead v child2+          return $ if s0 > c2 then child2 else swap0+        else return swap0+      when (swap1 /= root) $ do+        s1 <- G.unsafeRead v swap1+        G.unsafeWrite v swap1 r+        G.unsafeWrite v root s1+        go swap1++-- /O(1)/+findMin :: G.MVector v a => v s a -> ST s a+findMin v = G.unsafeRead v 0++-- /O(log n)/+deleteMin :: (G.MVector v a, Ord a) => v s a -> ST s (v s a)+deleteMin v = do+  let !n = G.length v+  a <- G.unsafeRead v (n-1)+  let !v' = G.unsafeSlice 0 (n-1) v+  updateMin a v'+  return v'++-- /O(log n)/+updateMin :: (G.MVector v a, Ord a) => a -> v s a -> ST s ()+updateMin a v = do+  G.unsafeWrite v 0 a+  sift v 0
+ src/Data/Vector/Map.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2013 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- This module provides a 'Vector'-based 'Map' that is loosely based on the+-- Cache Oblivious Lookahead Array (COLA) by Bender et al. from+-- <http://supertech.csail.mit.edu/papers/sbtree.pdf "Cache-Oblivious Streaming B-Trees">,+-- but with inserts deamortized using a technique from Overmars and van Leeuwen.+--+-- Currently this 'Map' is implemented in an insert-only fashion. Deletions are left to future work+-- or to another derived structure in case they prove expensive.+--+-- Currently, we also do not use fractional cascading, as it affects the constant factors badly enough+-- to not pay for itself at the scales we are interested in. The naive /O(log^2 n)/ lookup+-- consistently outperforms the alternative.+--+-- Compared to the venerable @Data.Map@, this data structure currently consumes more memory, but it+-- provides a more limited palette of operations with different asymptotics (~10x faster inserts at a million entries)+-- and enables us to utilize contiguous storage.+--+-- /NB:/ when used with boxed data this structure may hold onto references to old versions+-- of things for many updates to come until sufficient operations have happened to merge them out+-- of the COLA.+-----------------------------------------------------------------------------+module Data.Vector.Map+  ( Map(..)+  , empty+  , null+  , singleton+  , lookup+  , insert+  , fromList+  ) where++import Control.Monad.ST.Unsafe as Unsafe+import Control.Monad.ST.Class+import Control.Monad.Trans.Iter+import Data.Bits+import qualified Data.List as List+import Data.Vector.Array+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Generic.Mutable as GM+import Data.Vector.Slow as Slow+import Prelude hiding (null, lookup)+import System.IO.Unsafe as Unsafe++#define BOUNDS_CHECK(f) (Ck.f __FILE__ __LINE__ Ck.Bounds)++-- | This Map is implemented as an insert-only Cache Oblivious Lookahead Array (COLA) with amortized complexity bounds+-- that are equal to those of a B-Tree, except for an extra log factor slowdown on lookups due to the lack of fractional+-- cascading.++data Chunk k a = Chunk !(Array k) !(Array a)++data Map k a+  = M0+  | M1 !(Array k) !(Array a)+  | M2 !(Array k) !(Array a)+       !(Array k) !(Array a) !(Partial (Chunk k a)) !(Map k a)+  | M3 !(Array k) !(Array a)+       !(Array k) !(Array a)+       !(Array k) !(Array a) !(Partial (Chunk k a)) !(Map k a)++deriving instance (Show (Arr v v), Show (Arr k k)) => Show (Map k v)+deriving instance (Show (Arr v v), Show (Arr k k)) => Show (Chunk k v)++-- | /O(1)/. Identify if a 'Map' is the 'empty' 'Map'.+null :: Map k v -> Bool+null M0 = True+null _  = False+{-# INLINE null #-}++-- | /O(1)/ The 'empty' 'Map'.+empty :: Map k v+empty = M0+{-# INLINE empty #-}++-- | /O(1)/ Construct a 'Map' from a single key/value pair.+singleton :: (Arrayed k, Arrayed v) => k -> v -> Map k v+singleton k v = M1 (G.singleton k) (G.singleton v)+{-# INLINE singleton #-}++-- | /O(log^2 N)/ worst-case. Lookup an element.+lookup :: (Ord k, Arrayed k, Arrayed v) => k -> Map k v -> Maybe v+lookup !k m0 = go m0 where+  {-# INLINE go #-}+  go M0 = Nothing+  go (M1 ka va)                 = lookup1 k ka va Nothing+  go (M2 ka va kb vb _ m)       = lookup1 k ka va $ lookup1 k kb vb $ go m+  go (M3 ka va kb vb kc vc _ m) = lookup1 k ka va $ lookup1 k kb vb $ lookup1 k kc vc $ go m+{-# INLINE lookup #-}++lookup1 :: (Ord k, Arrayed k, Arrayed v) => k -> Array k -> Array v -> Maybe v -> Maybe v+lookup1 k ks vs r+  | j <- search (\i -> ks G.! i >= k) 0 (G.length ks - 1)+  , ks G.! j == k = Just $ vs G.! j+  | otherwise = r+{-# INLINE lookup1 #-}++-- | O((log N)\/B) worst-case loads for each cache. Insert an element.+insert :: (Ord k, Arrayed k, Arrayed v) => k -> v -> Map k v -> Map k v+insert k0 v0 s0 = go (G.singleton k0) (G.singleton v0) s0 where+  go ka a M0                    = M1 ka a+  go ka a (M1 kb b)             = M2 ka a kb b (merge ka a kb b) M0+  go ka a (M2 kb b kc c mbc xs) = M3 ka a kb b kc c (step mbc) (steps xs)+  go ka a (M3 kb b _ _ _ _ mcd xs) = case mcd of+    Stop (Chunk kcd cd) -> M2 ka a kb b (merge ka a kb b) (go kcd cd xs)+    _       -> error "insert: stop Step"++  steps (M2 kx x ky y mxy xs)   = M2 kx x ky y (step mxy) (steps xs)+  steps (M3 kx x ky y kz z myz xs) = M3 kx x ky y kz z (step myz) (steps xs)+  steps m = m+{-# INLINE insert #-}++step :: Partial a -> Partial a+step (Stop _)  = error "insert: step Stop"+step (Step m) = m+{-# INLINE step #-}++merge :: forall k a. (Ord k, Arrayed k, Arrayed a) => Array k -> Array a -> Array k -> Array a -> Partial (Chunk k a)+merge ka va kb vb = step (walkDupableST mergeST) where+ mergeST :: forall s. IterST s (Chunk k a)+ mergeST = do+  let+    !la = G.length ka+    !lb = G.length kb+  kc <- liftST $ GM.unsafeNew (la + lb)+  vc <- liftST $ GM.unsafeNew (la + lb)+  let+    goL :: Int -> Int -> IterST s ()+    goL !i !j -- left exhausted+      | j >= lb = return ()+      | !k <- i + j = do+        liftST $ do+          kj <- G.unsafeIndexM kb j+          GM.unsafeWrite kc k kj+          vj <- G.unsafeIndexM vb j+          GM.unsafeWrite vc k vj+        delay $ goL i (j+1)++    goR :: Int -> Int -> IterST s ()+    goR !i !j -- right exhausted+      | i >= la = return ()+      | !k <- i + j = do+        liftST $ do+          ki <- G.unsafeIndexM ka i+          GM.unsafeWrite kc k ki+          vi <- G.unsafeIndexM va i+          GM.unsafeWrite vc k vi+        delay $ goR (i+1) j++    go :: Int -> Int -> IterST s ()+    go !i !j+      | i >= la = goL i j+      | j >= lb = goR i j+      | !k <- i + j = do+        ki <- liftST $ G.unsafeIndexM ka i+        kj <- liftST $ G.unsafeIndexM kb j+        case compare ki kj of+          LT -> do+            liftST $ do+              vi <- G.unsafeIndexM va i+              GM.unsafeWrite kc k ki+              GM.unsafeWrite vc k vi+            delay $ go (i+1) j+          EQ -> do+            liftST $ do+              vi <- G.unsafeIndexM va i+              GM.unsafeWrite kc k ki+              GM.unsafeWrite vc k vi+            delay $ go (i+1) (i+j)+          GT -> do+            liftST $ do+              vj <- G.unsafeIndexM vb j+              GM.unsafeWrite kc k kj+              GM.unsafeWrite vc k vj+            delay $ go i (j+1)+  go 0 0+  liftST $ do+    fkc <- G.unsafeFreeze kc+    fvc <- G.unsafeFreeze vc+    return $ Chunk fkc fvc+{-# INLINE merge #-}++walkDupableST :: (forall s. IterST s a) -> Partial a+walkDupableST m0 = go m0 where+  go (IterT m) =+    case Unsafe.unsafeDupablePerformIO $+         Unsafe.unsafeSTToIO m of+      Left  a -> Stop a+      Right n -> Step (go n)++{-+merge :: (Ord k, Arrayed k, Arrayed a) => Array k -> Array a -> Array k -> Array a -> Partial (Chunk k a)+merge km m kn n = step $ walkDupableST $ do+  V_Pair _ ks vs <- Slow.unstreamM $ Slow.streamST $ Fusion.merge (zips km m) (zips kn n)+  return $ Chunk ks vs+{-# INLINE merge #-}+-}++fromList :: (Ord k, Arrayed k, Arrayed v) => [(k,v)] -> Map k v+fromList xs = List.foldl' (\m (k,v) -> insert k v m) empty xs+{-# INLINE fromList #-}++-- | Offset binary search+--+-- Assuming @l <= h@. Returns @h@ if the predicate is never @True@ over @[l..h)@+search :: (Int -> Bool) -> Int -> Int -> Int+search p = go where+  go l h+    | l == h    = l+    | p m       = go l m+    | otherwise = go (m+1) h+    where hml = h - l+          m = l + unsafeShiftR hml 1 + unsafeShiftR hml 6+{-# INLINE search #-}++{-+zips :: (G.Vector v a, G.Vector u b) => v a -> u b -> Stream Id (a, b)+zips va ub = Stream.zip (G.stream va) (G.stream ub)+{-# INLINE zips #-}+-}
+ src/Data/Vector/Map/Fusion.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2013 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- COLA fusion internals+--+-----------------------------------------------------------------------------+module Data.Vector.Map.Fusion+  ( merge+  , insert+  ) where++import Data.Vector.Fusion.Stream.Monadic as Stream+import Data.Vector.Fusion.Stream.Size as Stream++-- | The state for 'Stream' fusion that is used by 'mergeStreamsWith'.+--+-- This form permits cancellative addition.+data MergeState sa sb i a+  = MergeL sa sb i a+  | MergeR sa sb i a+  | MergeLeftEnded sb+  | MergeRightEnded sa+  | MergeStart sa sb++-- | This is the internal stream fusion combinator used to merge streams for addition.+merge :: (Monad m, Ord k) => Stream m (k, a) -> Stream m (k, a) -> Stream m (k, a)+merge (Stream stepa sa0 na) (Stream stepb sb0 nb) = Stream step (MergeStart sa0 sb0) (toMax na + toMax nb) where+  step (MergeStart sa sb) = do+    r <- stepa sa+    return $ case r of+      Yield (i, a) sa' -> Skip (MergeL sa' sb i a)+      Skip sa'         -> Skip (MergeStart sa' sb)+      Done             -> Skip (MergeLeftEnded sb)+  step (MergeL sa sb i a) = do+    r <- stepb sb+    return $ case r of+      Yield (j, b) sb' -> case compare i j of+        LT -> Yield (i, a) (MergeR sa sb' j b)+        EQ -> Yield (i, a) (MergeStart sa sb')+        GT -> Yield (j, b) (MergeL sa sb' i a)+      Skip sb' -> Skip (MergeL sa sb' i a)+      Done     -> Yield (i, a) (MergeRightEnded sa)+  step (MergeR sa sb j b) = do+    r <- stepa sa+    return $ case r of+      Yield (i, a) sa' -> case compare i j of+        LT -> Yield (i, a) (MergeR sa' sb j b)+        EQ -> Yield (i, a) (MergeStart sa' sb)+        GT -> Yield (j, b) (MergeL sa' sb i a)+      Skip sa' -> Skip (MergeR sa' sb j b)+      Done     -> Yield (j, b) (MergeLeftEnded sb)+  step (MergeLeftEnded sb) = do+    r <- stepb sb+    return $ case r of+      Yield (j, b) sb' -> Yield (j, b) (MergeLeftEnded sb')+      Skip sb'         -> Skip (MergeLeftEnded sb')+      Done             -> Done+  step (MergeRightEnded sa) = do+    r <- stepa sa+    return $ case r of+      Yield (i, a) sa' -> Yield (i, a) (MergeRightEnded sa')+      Skip sa'         -> Skip (MergeRightEnded sa')+      Done             -> Done+  {-# INLINE [0] step #-}+{-# INLINE [1] merge #-}++-- | The state for 'Stream' fusion that is used by 'mergeStreamsAnd'.+--+-- This form permits cancellative addition.+data InsertState sa ia+  = Searching sa+  | Holding sa ia+  | Found sa+  | Over++insert :: (Monad m, Ord k) => k -> a -> Stream m (k, a) -> Stream m (k, a)+insert k c (Stream stepa sa0 na) = Stream step (Searching sa0) (toMax na + 1) where+  step (Searching sa) = do+    r <- stepa sa+    return $ case r of+      Yield ia sa' -> case compare (fst ia) k of+        LT -> Yield ia (Searching sa')+        EQ -> Yield (k, c) (Found sa')+        GT -> Yield (k, c) (Holding sa' ia)+      Skip sa' -> Skip (Searching sa')+      Done     -> Yield (k, c) Over+  step (Holding sa ia) = return $ Yield ia (Found sa)+  step (Found sa) = do+    r <- stepa sa+    return $ case r of+      Yield p sa' -> Yield p (Found sa')+      Skip sa'    -> Skip (Found sa')+      Done        -> Done+  step Over = return Done+  {-# INLINE [0] step #-}+{-# INLINE [1] insert #-}
+ src/Data/Vector/Set.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}++-- | A non-standard zeroless-binary deamortized cache-oblivious Set+module Data.Vector.Set where++import Data.Bits+import qualified Data.Vector.Set.Fusion as Fusion+import Data.Vector.Array+import Data.Vector.Slow as Slow+import qualified Data.Vector.Generic as G++data Set a+  = S0+  | S1                       !(Array a)+  | S2            !(Array a) !(Array a) !(Partial (Array a)) !(Set a)+  | S3 !(Array a) !(Array a) !(Array a) !(Partial (Array a)) !(Set a)++deriving instance Show (Array a) => Show (Set a)++empty :: Set a+empty = S0+{-# INLINE empty #-}++null :: Set a -> Bool+null S0 = True+null _ = False+{-# INLINE null #-}++-- | /O(log n)/ gives a conservative upper bound on size, assuming no collisions+size :: Set a -> Int+size S0                             = 0+size (S1 _)                         = 1+size (S2 _ _ _ xs)   | n <- size xs = n + n + 2+size (S3 _ _ _ _ xs) | n <- size xs = n + n + 3++-- | /O(log n)/ worst case+insert :: (Arrayed a, Ord a) => a -> Set a -> Set a+insert z0 s0 = go (G.singleton z0) s0 where+  go a S0     = S1 a+  go a (S1 b) = S2 a b (merge a b) S0+  go a (S2 b c   mbc xs) = S3 a b c (step mbc) (steps xs)+  go a (S3 b _ _ mcd xs) = case mcd of+    Stop cd -> S2 a b (merge a b) (go cd xs)+    _       -> error "insert: stop Step"++  steps (S2 x y mxy xs)   = S2 x y (step mxy) (steps xs)+  steps (S3 x y z myz xs) = S3 x y z (step myz) (steps xs)+  steps m = m+{-# INLINE insert #-}++-- | /O(log^n)/ worst and amortized+member :: (Arrayed a, Ord a) => a -> Set a -> Bool+member _ S0 = False+member x (S1 a) = member1 x a+member x (S2 a b _ xs) = member1 x a || member1 x b || member x xs+member x (S3 a b c _ xs) = member1 x a || member1 x b || member1 x c || member x xs+{-# INLINE member #-}++member1 :: (Arrayed a, Ord a) => a -> Array a -> Bool+member1 x xs = xs G.! search (\i -> xs G.! i >= x) 0 (G.length xs - 1) == x+{-# INLINE member1 #-}++merge :: (Arrayed a, Ord a) => Array a -> Array a -> Partial (Array a)+merge m n = step $ walkST $ Slow.unstreamM $ Slow.streamST $ Fusion.merge (G.stream m) (G.stream n)+{-# INLINE merge #-}++step :: Partial a -> Partial a+step (Stop _)  = error "insert: step Stop"+step (Step m) = m+{-# INLINE step #-}++-- | Offset binary search+--+-- Assuming @l <= h@. Returns @h@ if the predicate is never @True@ over @[l..h)@+search :: (Int -> Bool) -> Int -> Int -> Int+search p = go where+  go l h+    | l == h    = l+    | p m       = go l m+    | otherwise = go (m+1) h+    where hml = h - l+          m = l + unsafeShiftR hml 1 + unsafeShiftR hml 6+{-# INLINE search #-}
+ src/Data/Vector/Set/Fusion.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2013 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-----------------------------------------------------------------------------+module Data.Vector.Set.Fusion+  ( merge+  ) where++import Data.Vector.Fusion.Stream.Monadic as Stream+import Data.Vector.Fusion.Stream.Size as Stream++-- |+-- This form permits cancellative addition.+data MergeState sa sb a+  = MergeL sa sb a+  | MergeR sa sb a+  | MergeLeftEnded sb+  | MergeRightEnded sa+  | MergeStart sa sb++-- | This is the internal stream fusion combinator used to merge streams for addition.+merge :: (Monad m, Ord k) => Stream m k -> Stream m k -> Stream m k+merge (Stream stepa sa0 na) (Stream stepb sb0 nb) = Stream step (MergeStart sa0 sb0) (toMax na + toMax nb) where+  step (MergeStart sa sb) = do+    r <- stepa sa+    return $ case r of+      Yield i sa' -> Skip (MergeL sa' sb i)+      Skip sa'         -> Skip (MergeStart sa' sb)+      Done             -> Skip (MergeLeftEnded sb)+  step (MergeL sa sb i) = do+    r <- stepb sb+    return $ case r of+      Yield j sb' -> case compare i j of+        LT -> Yield i (MergeR sa sb' j)+        EQ -> Yield i (MergeStart sa sb')+        GT -> Yield j (MergeL sa sb' i)+      Skip sb' -> Skip (MergeL sa sb' i)+      Done     -> Yield i (MergeRightEnded sa)+  step (MergeR sa sb j) = do+    r <- stepa sa+    return $ case r of+      Yield i sa' -> case compare i j of+        LT -> Yield i (MergeR sa' sb j)+        EQ -> Yield i (MergeStart sa' sb)+        GT -> Yield j (MergeL sa' sb i)+      Skip sa' -> Skip (MergeR sa' sb j)+      Done     -> Yield j (MergeLeftEnded sb)+  step (MergeLeftEnded sb) = do+    r <- stepb sb+    return $ case r of+      Yield j sb' -> Yield j (MergeLeftEnded sb')+      Skip sb'    -> Skip (MergeLeftEnded sb')+      Done        -> Done+  step (MergeRightEnded sa) = do+    r <- stepa sa+    return $ case r of+      Yield i sa' -> Yield i (MergeRightEnded sa')+      Skip sa'    -> Skip (MergeRightEnded sa')+      Done        -> Done+  {-# INLINE [0] step #-}+{-# INLINE [1] merge #-}
+ src/Data/Vector/Slow.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes  #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-unused-matches -fno-warn-unused-binds #-}++module Data.Vector.Slow+  ( IterST+  , Partial(..)+  , delay+  , walkST+  , streamST+  , munstream+  , unstreamM+  , foldM'+  , foldM+  ) where++import Control.Monad.ST+import Control.Monad.ST.Class+import Control.Monad.ST.Unsafe as Unsafe+import Control.Monad.Trans.Iter+import qualified Data.Vector.Fusion.Stream.Monadic as M+import qualified Data.Vector.Fusion.Stream.Size as SS+import Data.Vector.Internal.Check as Ck+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Generic.Mutable as GM+import System.IO.Unsafe as Unsafe+import Data.Vector.Fusion.Util++import SpecConstr ( SpecConstrAnnotation(..) )+data SPEC = SPEC | SPEC2+{-# ANN type SPEC ForceSpecConstr #-}++data Partial a+  = Stop a+  | Step (Partial a)+  deriving (Show, Read, Eq, Ord)++#define BOUNDS_CHECK(f)   (Ck.f __FILE__ __LINE__ Ck.Bounds)+#define INTERNAL_CHECK(f) (Ck.f __FILE__ __LINE__ Ck.Internal)++type IterST s = IterT (ST s)++walkST :: (forall s. IterST s a) -> Partial a+walkST m0 = go m0 where+  go (IterT m) =+    case Unsafe.unsafePerformIO $+         Unsafe.unsafeSTToIO m of+      Left  a -> Stop a+      Right n -> Step (go n)++streamST :: M.Stream Id a -> M.Stream (ST s) a+streamST (M.Stream step s n) = M.Stream (return . unId . step) s n++unstreamM :: G.Vector v a => M.Stream (ST s) a -> IterST s (v a)+unstreamM s = munstream s >>= liftST . G.unsafeFreeze++munstream :: GM.MVector v a => M.Stream (ST s) a -> IterST s (v s a)+munstream s = case SS.upperBound (M.size s) of+  Just n  -> munstreamMax     s n+  Nothing -> munstreamUnknown s+{-# INLINE [1] munstream #-}++-- pay once per entry+foldM' :: (a -> b -> ST s a) -> a -> M.Stream (ST s) b -> IterST s a+foldM' m z0 (M.Stream step s0 _) = foldM'_loop SPEC z0 s0+  where+    foldM'_loop !_SPEC z s+      = z `seq`+        do+          r <- liftST (step s)+          case r of+            M.Yield x s' -> do+              z' <- liftST (m z x)+              delay $ foldM'_loop SPEC z' s'+            M.Skip s' -> foldM'_loop SPEC z s'+            M.Done -> return z+{-# INLINE [1] foldM' #-}++-- | Left fold with a monadic operator+foldM :: (a -> b -> ST s a) -> a -> M.Stream (ST s) b -> IterST s a+foldM m z0 (M.Stream step s0 _) = foldM_loop SPEC z0 s0+  where+    foldM_loop !_SPEC z s+      = do+          r <- liftST (step s)+          case r of+            M.Yield x s' -> do+              z' <- liftST (m z x)+              delay $ foldM_loop SPEC z' s'+            M.Skip s' -> foldM_loop SPEC z s'+            M.Done -> return z+{-# INLINE [1] foldM #-}+++munstreamMax :: GM.MVector v a => M.Stream (ST s) a -> Int -> IterST s (v s a)+munstreamMax s n = do+  v <- INTERNAL_CHECK(checkLength) "munstreamMax" n+       $ liftST (GM.unsafeNew n)+  let put i x = do+                   INTERNAL_CHECK(checkIndex) "munstreamMax" i n+                     $ GM.unsafeWrite v i x+                   return (i+1)+  n' <- foldM' put 0 s+  return $ INTERNAL_CHECK(checkSlice) "munstreamMax" 0 n' n+         $ GM.unsafeSlice 0 n' v+{-# INLINE munstreamMax #-}++munstreamUnknown :: GM.MVector v a => M.Stream (ST s) a -> IterST s (v s a)+munstreamUnknown s = do+  v <- liftST (GM.unsafeNew 0)+  (v', n) <- foldM put (v, 0) s+  return $ INTERNAL_CHECK(checkSlice) "munstreamUnknown" 0 n (GM.length v')+         $ GM.unsafeSlice 0 n v'+  where+    {-# INLINE [0] put #-}+    put (v,i) x = do+      v' <- unsafeAppend1 v i x+      return (v',i+1)+{-# INLINE munstreamUnknown #-}++unsafeAppend1 :: GM.MVector v a => v s a -> Int -> a -> ST s (v s a)+{-# INLINE [0] unsafeAppend1 #-}+unsafeAppend1 v i x+  | i < GM.length v = do+    GM.unsafeWrite v i x+    return v+  | otherwise    = do+    v' <- enlarge v+    INTERNAL_CHECK(checkIndex) "unsafeAppend1" i (GM.length v')+      $ GM.unsafeWrite v' i x+    return v'++enlarge_delta :: GM.MVector v a => v s a -> Int+enlarge_delta v = max (GM.length v) 1++-- | Grow a vector logarithmically+enlarge :: GM.MVector v a => v s a -> ST s (v s a)+enlarge v = GM.unsafeGrow v (enlarge_delta v)+{-# INLINE enlarge #-}
+ structures.cabal view
@@ -0,0 +1,284 @@+name:          structures+category:      Data, Structures+version:       0.1+license:       BSD3+cabal-version: >= 1.8+license-file:  LICENSE+author:        Edward A. Kmett+maintainer:    Edward A. Kmett <ekmett@gmail.com>+stability:     experimental+homepage:      http://github.com/ekmett/structures+bug-reports:   http://github.com/ekmett/structures/issues+copyright:     Copyright (C) 2013 Edward A. Kmett+build-type:    Custom+synopsis:      "Advanced" Data Structures++extra-source-files:+  .ghci+  .travis.yml+  .gitignore+  .vim.custom+  CHANGELOG.markdown+  README.markdown++description:+  This package is a playground for working with several types of advanced data structures including+  wavelet trees and cache oblivious lookahead arrays.++source-repository head+  type: git+  location: git://github.com/ekmett/structures.git++-- You can disable the QuickCheck tests with -f-test-properties+flag test-properties+  default: True+  manual: True++-- You can disable the HUnit tests with -f-test-hunit+-- NB: We have no hunit tests, so this is disabled.+flag test-hunit+  default: False+  manual: True++-- You can disable the doctests test suite with -f-test-doctests+flag test-doctests+  default: True+  manual: True++-- You can disable the hlint test suite with -f-test-hlint+flag test-hlint+  default: True+  manual: True++flag threaded+  default: True+  manual: True++flag llvm+  default: False+  manual: True++flag optimized+  default: True+  manual: True++library+  build-depends:+    base              >= 4     && < 5,+    contravariant     >= 0.4.2 && < 1,+    deepseq           >= 1.1   && < 1.4,+    free              >= 4.3   && < 5,+    ghc,+    ghc-prim,+    hashable          >= 1.2.1 && < 1.3,+    hybrid-vectors    >= 0.1   && < 1,+    lens              >= 4     && < 5,+    monad-st          >= 0.2.2 && < 1,+    parallel          >= 3.2   && < 3.3,+    primitive         >= 0.5   && < 0.6,+    semigroups        >= 0.9   && < 1,+    transformers      >= 0.3   && < 0.4,+    vector            >= 0.10  && < 0.11,+    vector-algorithms >= 0.5   && < 0.6++  hs-source-dirs: src++  exposed-modules:+    Data.Vector.Array+    Data.Vector.Bit+    Data.Vector.Bloom+    Data.Vector.Bloom.Mutable+    Data.Vector.Bloom.Util+    Data.Vector.Heap+    Data.Vector.Map+    Data.Vector.Map.Fusion+    Data.Vector.Set+    Data.Vector.Set.Fusion+    Data.Vector.Slow++  ghc-options: -Wall++  if flag(optimized)+    ghc-options: -O2++  if flag(threaded)+    ghc-options: -threaded -rtsopts -with-rtsopts=-N++  if flag(llvm)+    ghc-options: -fllvm++  if impl(ghc<6.13)+    Ghc-Options: -finline-if-enough-args -fno-method-sharing++test-suite properties+  type: exitcode-stdio-1.0+  main-is: properties.hs+  ghc-options: -w+  hs-source-dirs: tests++  if flag(threaded)+    ghc-options: -threaded -rtsopts -with-rtsopts=-N++  if flag(llvm)+    ghc-options: -fllvm++  if !flag(test-properties)+    buildable: False+  else+    build-depends:+      base,+      structures,+      deepseq,+      QuickCheck       >= 2.4,+      tasty            >= 0.3,+      tasty-quickcheck >= 0.3,+      tasty-th         >= 0.1.1++test-suite hunit+  type: exitcode-stdio-1.0+  main-is: hunit.hs+  ghc-options: -w+  hs-source-dirs: tests++  if flag(threaded)+    ghc-options: -threaded -rtsopts -with-rtsopts=-N++  if flag(llvm)+    ghc-options: -fllvm++  if !flag(test-hunit)+    buildable: False+  else+    build-depends:+      base,+      structures,+      QuickCheck       >= 2.4,+      tasty            >= 0.3,+      tasty-hunit      >= 0.2,+      tasty-th         >= 0.1.1++test-suite hlint+  type: exitcode-stdio-1.0+  main-is: hlint.hs+  ghc-options: -w+  hs-source-dirs: tests++  if flag(threaded)+    ghc-options: -threaded -rtsopts -with-rtsopts=-N++  if flag(llvm)+    ghc-options: -fllvm++  if !flag(test-hlint)+    buildable: False+  else+    build-depends:+      base,+      hlint >= 1.7++-- Verify the results of the examples+test-suite doctests+  type:           exitcode-stdio-1.0+  main-is:        doctests.hs+  ghc-options:    -Wall+  hs-source-dirs: tests++  if flag(threaded)+    ghc-options: -threaded -rtsopts -with-rtsopts=-N++  if flag(llvm)+    ghc-options: -fllvm++  if !flag(test-doctests)+    buildable: False+  else+    build-depends:+      base,+      bytestring,+      containers,+      directory      >= 1.0,+      deepseq,+      doctest        >= 0.9.1,+      filepath,+      semigroups     >= 0.9,+      unordered-containers++  if impl(ghc<7.6.1)+    ghc-options: -Werror++benchmark maps+  type:           exitcode-stdio-1.0+  main-is:        maps.hs+  ghc-options:    -Wall+  hs-source-dirs: benchmarks++  if flag(optimized)+    ghc-options: -O2++  if flag(threaded)+    ghc-options: -threaded -rtsopts -with-rtsopts=-N++  if flag(llvm)+    ghc-options: -fllvm++  build-depends:+    array,+    base,+    containers,+    criterion,+    mwc-random,+    structures,+    unordered-containers,+    vector++benchmark lookups+  type:           exitcode-stdio-1.0+  main-is:        lookups.hs+  ghc-options:    -Wall+  hs-source-dirs: benchmarks++  if flag(optimized)+    ghc-options: -O2++  if flag(threaded)+    ghc-options: -threaded -rtsopts -with-rtsopts=-N++  if flag(llvm)+    ghc-options: -fllvm++  build-depends:+    array,+    base,+    containers,+    criterion,+    deepseq,+    MonadRandom,+    structures,+    unordered-containers,+    vector++benchmark inserts+  type:           exitcode-stdio-1.0+  main-is:        inserts.hs+  ghc-options:    -Wall+  hs-source-dirs: benchmarks++  if flag(optimized)+    ghc-options: -O2++  if flag(threaded)+    ghc-options: -threaded -rtsopts -with-rtsopts=-N++  if flag(llvm)+    ghc-options: -fllvm++  build-depends:+    array,+    base,+    containers,+    criterion,+    deepseq,+    MonadRandom,+    structures,+    unordered-containers,+    vector
+ tests/doctests.hsc view
@@ -0,0 +1,73 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Main (doctests)+-- Copyright   :  (C) 2012-13 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- This module provides doctests for a project based on the actual versions+-- of the packages it was built with. It requires a corresponding Setup.lhs+-- to be added to the project+-----------------------------------------------------------------------------+module Main where++import Build_doctests (deps)+import Control.Applicative+import Control.Monad+import Data.List+import System.Directory+import System.FilePath+import Test.DocTest++##if defined(mingw32_HOST_OS)+##if defined(i386_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##elif defined(x86_64_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##endif+##endif++-- | Run in a modified codepage where we can print UTF-8 values on Windows.+withUnicode :: IO a -> IO a+##ifdef USE_CP+withUnicode m = do+  cp <- c_GetConsoleCP+  (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp+##else+withUnicode m = m+##endif++main :: IO ()+main = withUnicode $ getSources >>= \sources -> doctest $+    "-isrc"+  : "-idist/build/autogen"+  : "-optP-include"+  : "-optPdist/build/autogen/cabal_macros.h"+  : "-hide-all-packages"+  : map ("-package="++) deps ++ sources++getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "src"+  where+    go dir = do+      (dirs, files) <- getFilesAndDirectories dir+      (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+  c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+  (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c
+ tests/hlint.hs view
@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Main (hlint)+-- Copyright   :  (C) 2013 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- This module runs HLint on the lens source tree.+-----------------------------------------------------------------------------+module Main where++import Control.Monad+import Language.Haskell.HLint+import System.Environment+import System.Exit++main :: IO ()+main = do+    args <- getArgs+    hints <- hlint $ ["src", "--cpp-define=HLINT"] ++ args+    unless (null hints) exitFailure
+ tests/hunit.hs view
@@ -0,0 +1,6 @@+module Main+       ( main  -- :: IO ()+       ) where++main :: IO ()+main = return ()
+ tests/properties.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE TemplateHaskell #-}+module Main+       ( main  -- :: IO ()+       ) where+import Prelude as Prelude+import Data.List as List+import Data.Maybe+import Data.Function+import Control.Monad+import Control.DeepSeq+import Debug.Trace++import Test.Tasty+import Test.Tasty.TH+import Test.Tasty.QuickCheck as QC++import Data.Vector.Map as V++--------------------------------------------------------------------------------++type UMap = V.Map Int ()++--------------------------------------------------------------------------------++prop_null :: Int -> Bool+prop_null x =+  V.null V.empty == True &&+  V.null (V.insert x () V.empty) == False++prop_emptyLookup :: Int -> Bool+prop_emptyLookup k = (V.lookup k (V.empty :: UMap)) == Nothing++prop_insertLookup :: Int -> Bool+prop_insertLookup k = V.lookup k (V.insert k () V.empty) /= Nothing++-- We need a working Eq instance+--prop_fromList :: [(Int, Int)] -> Bool+--prop_fromList xs = V.fromList xs == foldr (\(k,v) -> V.insert k v) V.empty xs++prop_lookupMany :: [(Int,Int)] -> Property+prop_lookupMany xs = List.length xs > 0 ==> prop+  where+    prop = all (\(x,_) -> isJust $ V.lookup x ls) xs'++    ls  = V.fromList xs'+    xs' = List.nubBy ((==) `on` fst) xs++--------------------------------------------------------------------------------++main :: IO ()+main = $(defaultMainGenerator)