packages feed

PrimitiveArray 0.7.0.1 → 0.7.1.0

raw patch · 11 files changed

+197/−146 lines, 11 filesdep +DPutilsdep +smallcheckdep +tastydep −test-frameworkdep −test-framework-quickcheck2dep −test-framework-thdep ~OrderedBitsdep ~aesondep ~base

Dependencies added: DPutils, smallcheck, tasty, tasty-quickcheck, tasty-smallcheck, tasty-th

Dependencies removed: test-framework, test-framework-quickcheck2, test-framework-th

Dependency ranges changed: OrderedBits, aeson, base, binary, bits

Files

Data/PrimitiveArray/Dense.hs view
@@ -74,7 +74,7 @@     forM_ [0 .. size l h -1] $ \k -> unsafeWrite mba k def     return ma   readM  (MUnboxed l h mba) idx     = assert (inBounds l h idx) $ unsafeRead  mba (linearIndex l h idx)-  writeM (MUnboxed l h mba) idx elm = write mba (linearIndex l h idx) elm+  writeM (MUnboxed l h mba) idx elm = unsafeWrite mba (linearIndex l h idx) elm   {-# INLINE boundsM #-}   {-# INLINE fromListM #-}   {-# INLINE newM #-}
Data/PrimitiveArray/Index/Point.hs view
@@ -1,4 +1,6 @@ +{-# Language MagicHash #-}+ -- | @Point@ index structures are used for left- and right-linear grammars. -- Such grammars have at most one syntactic symbol on each r.h.s. of a rule. -- The syntactic symbol needs to be in an outermost position.@@ -15,10 +17,12 @@ import           Data.Serialize import           Data.Vector.Unboxed.Deriving import           Data.Vector.Unboxed (Unbox(..))+import           GHC.Exts import           GHC.Generics (Generic) import qualified Data.Vector.Fusion.Stream.Monadic as SM import qualified Data.Vector.Unboxed as VU-import           Test.QuickCheck+import           Test.QuickCheck as TQ+import           Test.SmallCheck.Series as TS  import           Data.PrimitiveArray.Index.Class import           Data.PrimitiveArray.Index.IOC@@ -30,7 +34,7 @@ -- position.  newtype PointL t = PointL {fromPointL :: Int}-  deriving (Eq,Read,Show,Generic)+  deriving (Eq,Ord,Read,Show,Generic)  pointLI :: Int -> PointL I pointLI = PointL@@ -47,7 +51,7 @@ -- | A point in a right-linear grammars.  newtype PointR t = PointR {fromPointR :: Int}-  deriving (Eq,Read,Show,Generic)+  deriving (Eq,Ord,Read,Show,Generic)   @@ -96,42 +100,24 @@   {-# Inline streamUp #-}   {-# Inline streamDown #-} -streamUpMk lf z = return (z,lf)+data SP z = SP !z !Int#++streamUpMk (I# lf) z = return $ SP z lf {-# Inline [0] streamUpMk #-} -streamUpStep ht (z,k)-  | k > ht    = return $ SM.Done-  | otherwise = return $ SM.Yield (z:.PointL k) (z,k+1)+streamUpStep (I# ht) (SP z k)+  | 1# <- k ># ht = return $ SM.Done+  | otherwise     = return $ SM.Yield (z:.PointL (I# k)) (SP z (k +# 1#)) {-# Inline [0] streamUpStep #-} -streamDownMk ht z = return (z,ht)+streamDownMk (I# ht) z = return $ SP z ht {-# Inline [0] streamDownMk #-} -streamDownStep lf (z,k)-  | k < lf    = return $ SM.Done-  | otherwise = return $ SM.Yield (z:.PointL k) (z,k-1)+streamDownStep (I# lf) (SP z k)+  | 1# <- k <# lf = return $ SM.Done+  | otherwise     = return $ SM.Yield (z:.PointL (I# k)) (SP z (k -# 1#)) {-# Inline [0] streamDownStep #-} -{--instance IndexStream z => IndexStream (z:.PointL) where-  streamUp (ls:.PointL lf) (hs:.PointL ht) = SM.flatten mk step Unknown $ streamUp ls hs-    where mk z = return (z,lf)-          step (z,k)-            | k > ht    = return $ SM.Done-            | otherwise = return $ SM.Yield (z:.PointL k) (z,k+1)-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline streamUp #-}-  streamDown (ls:.PointL lf) (hs:.PointL ht) = SM.flatten mk step Unknown $ streamDown ls hs-    where mk z = return (z,ht)-          step (z,k)-            | k < lf    = return $ SM.Done-            | otherwise = return $ SM.Yield (z:.PointL k) (z,k-1)-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline streamDown #-}--}- instance IndexStream (Z:.PointL t) => IndexStream (PointL t)  instance Arbitrary (PointL t) where@@ -141,6 +127,9 @@   shrink (PointL j)     | 0<j = [PointL $ j-1]     | otherwise = []++instance Monad m => Serial m (PointL t) where+  series = PointL . TS.getNonNegative <$> series
Data/PrimitiveArray/Index/Subword.hs view
@@ -4,7 +4,9 @@  module Data.PrimitiveArray.Index.Subword where +import Control.Applicative ((<$>)) import Control.DeepSeq (NFData(..))+import Control.Monad (filterM, guard) import Data.Aeson (FromJSON,ToJSON) import Data.Binary (Binary) import Data.Hashable (Hashable)@@ -14,7 +16,10 @@ import GHC.Generics (Generic) import Prelude hiding (map) import Test.QuickCheck (Arbitrary(..), choose)+import Test.SmallCheck.Series as TS +import Math.TriangularNumbers+ import Data.PrimitiveArray.Index.Class import Data.PrimitiveArray.Index.IOC import Data.PrimitiveArray.Vector.Compat@@ -65,47 +70,16 @@ subwordC i j = Subword (i:.j) {-# INLINE subwordC #-} --- | triangular numbers------ A000217 -triangularNumber :: Int -> Int-triangularNumber x = (x * (x+1)) `quot` 2-{-# INLINE triangularNumber #-} --- | Size of an upper triangle starting at 'i' and ending at 'j'. "(0,N)" what--- be the normal thing to use.--upperTri :: Subword t -> Int-upperTri (Subword (i:.j)) = triangularNumber $ j-i+1-{-# INLINE upperTri #-}---- | Subword indexing. Given the longest subword and the current subword,--- calculate a linear index "[0,..]". "(l,n)" in this case means "l"ower bound,--- length "n". And "(i,j)" is the normal index.------ TODO probably doesn't work right with non-zero base ?!--subwordIndex :: Subword s -> Subword t -> Int-subwordIndex (Subword (l:.n)) (Subword (i:.j)) = adr n (i,j) -- - adr n (l,n)-  where-    adr n (i,j) = (n+1)*i - triangularNumber i + j-{-# INLINE subwordIndex #-}--subwordFromIndex :: Subword s -> Int -> Subword t-subwordFromIndex = error "subwordFromIndex not implemented"-{-# INLINE subwordFromIndex #-}--- instance Index (Subword t) where-  linearIndex _ h i = subwordIndex h i+  linearIndex _ (Subword (_:.n)) (Subword (i:.j)) = toLinear n (i,j)   {-# Inline linearIndex #-}   smallestLinearIndex _ = error "still needed?"   {-# Inline smallestLinearIndex #-}-  largestLinearIndex h = upperTri h -1+  largestLinearIndex (Subword (i:.j)) = linearizeUppertri (i,j) - 1   {-# Inline largestLinearIndex #-}-  size _ h = upperTri h+  size _ (Subword (i:.j)) = linearizeUppertri (i,j)   {-# Inline size #-}   inBounds _ (Subword (_:.h)) (Subword (i:.j)) = 0<=i && i<=j && j<=h   {-# Inline inBounds #-}@@ -118,28 +92,6 @@   {-# Inline streamUp #-}   {-# Inline streamDown #-} -{--instance IndexStream z => IndexStream (z:.Subword I) where-  streamUp (ls:.Subword (l:._)) (hs:.Subword (_:.h)) = flatten mk step $ streamUp ls hs-    where mk z = return (z,h,h)-          step (z,i,j)-            | i < l     = return $ Done-            | j > h     = return $ Skip (z,i-1,i-1)-            | otherwise = return $ Yield (z:.subword i j) (z,i,j+1)-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline streamUp #-}-  streamDown (ls:.Subword (l:._)) (hs:.Subword (_:.h)) = flatten mk step $ streamDown ls hs-    where mk z = return (z,l,h)-          step (z,i,j)-            | i > h     = return $ Done-            | j < i     = return $ Skip (z,i+1,h)-            | otherwise = return $ Yield (z:.subword i j) (z,i,j-1)-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline streamDown #-}--}- -- | @Subword O@ (outside). -- -- Note: @streamUp@ really needs to use @streamDownMk@ / @streamDownStep@@@ -151,6 +103,8 @@   {-# Inline streamUp #-}   {-# Inline streamDown #-} +-- | @Subword C@ (complement)+ instance IndexStream z => IndexStream (z:.Subword C) where   streamUp   (ls:.Subword (l:._)) (hs:.Subword (_:.h)) = flatten (streamUpMk     h) (streamUpStep   l h) $ streamUp   ls hs   streamDown (ls:.Subword (l:._)) (hs:.Subword (_:.h)) = flatten (streamDownMk l h) (streamDownStep   h) $ streamDown ls hs@@ -178,17 +132,7 @@ {-# Inline [0] streamDownStep #-}  instance (IndexStream (Z:.Subword t)) => IndexStream (Subword t)-{- where-  streamUp l h = map (\(Z:.i) -> i) $ streamUp (Z:.l) (Z:.h)-  {-# INLINE streamUp #-}-  streamDown l h = map (\(Z:.i) -> i) $ streamDown (Z:.l) (Z:.h)-  {-# INLINE streamDown #-}--} ---instance IndexStream (Subword O)----instance IndexStream (Subword C)- instance Arbitrary (Subword t) where   arbitrary = do     a <- choose (0,20)@@ -197,4 +141,17 @@   shrink (Subword (i:.j))     | i<j       = [Subword (i:.j-1), Subword (i+1:.j)]     | otherwise = []++instance Monad m => Serial m (Subword t) where+  series = do+    i <- TS.getNonNegative <$> series+    j <- TS.getNonNegative <$> series+    guard $ i<=j+    return $ subword i j+    {-+    let nns :: Series m Int = TS.getNonNegative <$> series+    ps <- nns >< nns+    let qs = [ subword i j | (i,j) <- ps, i<=j ]+    return qs+    -}
Data/PrimitiveArray/Index/Unit.hs view
@@ -4,6 +4,7 @@  module Data.PrimitiveArray.Index.Unit where +import Control.Applicative (pure) import Control.DeepSeq (NFData(..)) import Data.Aeson (FromJSON,ToJSON) import Data.Binary (Binary)
− Data/PrimitiveArray/QuickCheck/Index/Set.hs 
@@ -1,32 +0,0 @@--module Data.PrimitiveArray.QuickCheck.Index.Set where--import Control.Applicative-import Data.Bits-import Data.Word (Word)-import Debug.Trace-import Test.QuickCheck hiding (Fixed(..), (.&.))--import Data.PrimitiveArray.Index.IOC-import Data.PrimitiveArray.Index.Set------ TODO what exactly does the mask fix? Only bits already @1@, or every bit--- as it is? The mask should actually freeze-fix those bits, where we are--- set to @1@!--prop_Fixed_BitSet_setSucc (u :: Word, Fixed m s :: Fixed (BitSet I)) = traceShow (tgo, tsu) $ tgo == tsu-  where tgo = go s-        tsu = (getFixed <$> setSucc (Fixed 0 0) (Fixed 0 h) (Fixed m s))-        fb1 = m .&. s -- fixed bits to 1-        fb0 = m .&. complement s  -- fixed bits to 0-        h   = bit (fromIntegral $ u `mod` 8) - 1-        go x -- continue creating successors, until the mask criterion is met (again).-          | Nothing <- ssx = Nothing-          | Just x' <- ssx-          , fb0 == m .&. complement x'-          , fb1 == m .&. x' = traceShow ('j',fb0,fb1,m,x,x') $ Just x'-          | Just x' <- ssx  = traceShow ('g',fb0,fb1,m,x,x') $ go x'-          where ssx = setSucc 0 h x-
PrimitiveArray.cabal view
@@ -1,5 +1,5 @@ Name:           PrimitiveArray-Version:        0.7.0.1+Version:        0.7.1.0 License:        BSD3 License-file:   LICENSE Maintainer:     choener@bioinf.uni-leipzig.de@@ -11,7 +11,7 @@ Category:       Data Build-type:     Simple Cabal-version:  >=1.10.0-tested-with:    GHC == 7.8.4, GHC == 7.10.3+tested-with:    GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 Synopsis:       Efficient multidimensional arrays Description:                 <http://www.bioinf.uni-leipzig.de/Software/gADP/ generalized Algebraic Dynamic Programming>@@ -56,22 +56,24 @@     Data.PrimitiveArray.Index.Set     Data.PrimitiveArray.Index.Subword     Data.PrimitiveArray.Index.Unit-    Data.PrimitiveArray.QuickCheck.Index.Set     Data.PrimitiveArray.Vector.Compat-  build-depends: base                     >= 4.7      &&  < 4.9-               , aeson                    >= 0.8      &&  < 0.11-               , binary                   >= 0.7      &&  < 0.8-               , bits                     >= 0.4      &&  < 0.5+  build-depends: base                     >= 4.7      &&  < 5.0+               , aeson                    >= 0.8      &&  < 1.1+               , binary                   >= 0.7      &&  < 0.9+               , bits                     >= 0.4      &&  < 0.6                , cereal                   >= 0.4      &&  < 0.6                , cereal-vector            >= 0.2      &&  < 0.3                , deepseq                  >= 1.3      &&  < 1.5                , hashable                 >= 1.2      &&  < 1.3-               , OrderedBits              >= 0.0.0.3  &&  < 0.0.2.0                , primitive                >= 0.5.4    &&  < 0.7                , QuickCheck               >= 2.7      &&  < 2.9+               , smallcheck               >= 1.1      &&  < 1.2                , vector                   >= 0.10     &&  < 0.12                , vector-binary-instances  >= 0.2      &&  < 0.3                , vector-th-unbox          >= 0.2      &&  < 0.3+               --+               , DPutils                  == 0.0.0.*+               , OrderedBits              == 0.0.1.*   default-extensions: BangPatterns                     , CPP                     , DefaultSignatures@@ -102,6 +104,10 @@     exitcode-stdio-1.0   main-is:     properties.hs+  other-modules:+    QuickCheck+    SmallCheck+    Common   ghc-options:     -threaded -rtsopts -with-rtsopts=-N   hs-source-dirs:@@ -109,13 +115,16 @@   default-language:     Haskell2010   default-extensions: CPP+                    , ScopedTypeVariables                     , TemplateHaskell   build-depends: base                , PrimitiveArray                , QuickCheck-               , test-framework               >= 0.8  && < 0.9-               , test-framework-quickcheck2   >= 0.3  && < 0.4-               , test-framework-th            >= 0.2  && < 0.3+               , smallcheck+               , tasty              >= 0.11+               , tasty-quickcheck   >= 0.8+               , tasty-smallcheck   >= 0.8+               , tasty-th           >= 0.1
changelog.md view
@@ -1,3 +1,10 @@+0.7.1.0+-------++- minor updates to dependencies+- tasty framework+- Subword/upper triangular indexing provided by DPutils+ 0.7.0.1 -------
+ tests/Common.hs view
@@ -0,0 +1,28 @@++module Common where++import Data.List (nub, sort, group)+import Control.Arrow ((&&&))++import Data.PrimitiveArray.Index.Class+++-- * generic functions++-- | Generates a list of, eg, @PointL@s. This are then grouped according to+-- the @linearIndex@. Within each group, there should only be @PointL@s+-- with the same value.++uniquenessTest :: (Ord a, Index a) => a -> [a] -> Bool+uniquenessTest low xs = all allEq ys && all allEq zs+  where hgh = maximum xs+        ys  = group . sort . map (linearIndex low hgh &&& id) $ xs+        zs  = group . sort . map (id &&& linearIndex low hgh) $ xs++-- | are all @xs@ equal to each other++allEq [] = True+allEq (x:xs) = all (x==) xs+++
+ tests/QuickCheck.hs view
@@ -0,0 +1,27 @@++module QuickCheck where++import Test.QuickCheck+import Test.Tasty.QuickCheck+import Test.Tasty.TH++import Data.PrimitiveArray.Index.Class+import Data.PrimitiveArray.Index.IOC+import Data.PrimitiveArray.Index.Point+import Data.PrimitiveArray.Index.Set+import Data.PrimitiveArray.Index.Subword++import Common++++-- * Uniqueness tests++prop_PointL_I_unique (xs :: [PointL I]) = uniquenessTest (pointLI 0) xs++prop_Subword_I_unique (xs :: [Subword I]) = uniquenessTest (subword 0 0) xs++++quickcheck_tests = $(testGroupGenerator)+
+ tests/SmallCheck.hs view
@@ -0,0 +1,33 @@++module SmallCheck where++import Control.Applicative+import Data.Bits+import Data.List (nub, sort, group)+import Data.Word (Word)+import Debug.Trace+import Test.Tasty+import Test.Tasty.TH+import Test.Tasty.SmallCheck+import Test.SmallCheck++import Data.PrimitiveArray.Index.IOC+import Data.PrimitiveArray.Index.Point+import Data.PrimitiveArray.Index.Set+import Data.PrimitiveArray.Index.Class+import Data.PrimitiveArray.Index.Subword++import Common++++-- * Uniqueness tests. The @xs@ lists are fairly small.++prop_PointL_I_unique (xs :: [PointL I]) = uniquenessTest (pointLI 0) xs++prop_Subword_I_unique (xs :: [Subword I]) = uniquenessTest (subword 0 0) xs++++smallcheck_tests = $(testGroupGenerator)+
tests/properties.hs view
@@ -1,17 +1,49 @@  module Main where -import           Test.Framework.Providers.QuickCheck2-import           Test.Framework.TH+import Control.Applicative+import Data.Bits+import Data.List (nub, sort, group)+import Data.Word (Word)+import Test.Tasty+import Test.Tasty.TH -import qualified  Data.PrimitiveArray.QuickCheck.Index.Set as QCS+import Data.PrimitiveArray.Index.IOC+import Data.PrimitiveArray.Index.Point+import Data.PrimitiveArray.Index.Set+import Data.PrimitiveArray.Index.Class +import QuickCheck+import SmallCheck  --- prop_Fixed_BitSet_setSucc = QCS.prop_Fixed_BitSet_setSucc +-- * Sets +-- TODO what exactly does the mask fix? Only bits already @1@, or every bit+-- as it is? The mask should actually freeze-fix those bits, where we are+-- set to @1@! +--prop_Fixed_BitSet_setSucc (u :: Word, Fixed m s :: Fixed (BitSet I)) = traceShow (tgo, tsu) $ tgo == tsu+--  where tgo = go s+--        tsu = (getFixed <$> setSucc (Fixed 0 0) (Fixed 0 h) (Fixed m s))+--        fb1 = m .&. s -- fixed bits to 1+--        fb0 = m .&. complement s  -- fixed bits to 0+--        h   = bit (fromIntegral $ u `mod` 8) - 1+--        go x -- continue creating successors, until the mask criterion is met (again).+--          | Nothing <- ssx = Nothing+--          | Just x' <- ssx+--          , fb0 == m .&. complement x'+--          , fb1 == m .&. x' = traceShow ('j',fb0,fb1,m,x,x') $ Just x'+--          | Just x' <- ssx  = traceShow ('g',fb0,fb1,m,x,x') $ go x'+--          where ssx = setSucc 0 h x+++ main :: IO ()-main = $(defaultMainGenerator)+main = do+  defaultMain $ testGroup ""+    [ quickcheck_tests+    , smallcheck_tests+    ]