comfort-array 0.3.1 → 0.4

raw patch · 14 files changed

+721/−54 lines, 14 filesdep +ChasingBottomsdep +prelude-compatdep +semigroupsdep ~non-emptyPVP ok

version bump matches the API change (PVP)

Dependencies added: ChasingBottoms, prelude-compat, semigroups, tagged

Dependency ranges changed: non-empty

API changes (from Hackage documentation)

Files

• Changes.md +8/−0
• comfort-array.cabal +24/−7
• src/Data/Array/Comfort/Boxed.hs +31/−5
• src/Data/Array/Comfort/Boxed/Unchecked.hs +21/−5
• src/Data/Array/Comfort/Check.hs +24/−0
• src/Data/Array/Comfort/Container.hs +151/−0
• src/Data/Array/Comfort/Shape.hs +125/−10
• src/Data/Array/Comfort/Storable.hs +99/−17
• src/Data/Array/Comfort/Storable/Memory.hs +29/−0
• src/Data/Array/Comfort/Storable/Private.hs +7/−3
• src/Data/Array/Comfort/Storable/Unchecked.hs +99/−7
• test/Main.hs +2/−0
• test/Test/Shape.hs +8/−0
• test/Test/Storable.hs +93/−0

@@ -1,5 +1,13 @@ # Change log for the `comfort-array` package +## 0.4++ * `fromAssocations`: Make default value the first parameter.+   It is most oftenly zero and thus less variable than the array size.++ * `Shape.DeferredIndex`:+   Now uses the shape as the type parameter, not the index type.+ ## 0.3   * `Storable.Mutable.Array`: Replace `ForeignPtr` by `Array.Guarded.MutablePtr`.

@@ -1,5 +1,5 @@ Name:             comfort-array-Version:          0.3.1+Version:          0.4 License:          BSD3 License-File:     LICENSE Author:           Henning Thielemann <haskell@henning-thielemann.de>@@ -36,16 +36,24 @@   * @ZeroBased, OneBased@:     Arrays with fixed lower bound, either 0 or 1, respectively.   .+  * @Zero, ()@:+    Arrays with fixed size 0 or 1, respectively.+  .+  * @Enumeration@:+    Arrays with indices like 'LT', 'EQ', 'GT' and a shape of fixed size.+  .   * @(:+:)@:     The Append type constructor allows to respresent block arrays,     e.g. block matrices.-  .-  * @Enumeration@: Arrays with indices like 'LT', 'EQ', 'GT' and dummy shape.+    It also allows to represent non-empty arrays via @():+:sh@.   .   * @Set@: Use an arbitrary ordered set as index set.   .-  * @Triangular@: A 2D array with the shape of lower or upper triangular matrix.+  * @Triangular@:+    A 2D array with the shape of a lower or upper triangular matrix.   .+  * @Tagged@: Statically distinguish shapes and indices that are isomorphic.+  .   The @lapack@ package defines even more fancy shapes   like tall rectangular matrices, triangular matrices and banded matrices. @@ -56,7 +64,7 @@   Changes.md  Source-Repository this-  Tag:         0.3.1+  Tag:         0.4   Type:        darcs   Location:    http://hub.darcs.net/thielema/comfort-array/ @@ -70,15 +78,18 @@  Library   Build-Depends:-    primitive >=0.6.4 && <0.7,+    primitive >=0.6.4 && <0.8,     guarded-allocation >=0.0.1 && <0.1,     storable-record >=0.0.1 && <0.1,+    tagged >=0.7 && <0.9,     deepseq >=1.3 && <1.5,     QuickCheck >=2 && <3,+    semigroups >=0.18.3 && <1.0,     containers >=0.4 && <0.7,     transformers >=0.3 && <0.6,-    non-empty >=0.3 && <0.4,+    non-empty >=0.3.2 && <0.4,     utility-ht >=0.0.10 && <0.1,+    prelude-compat >=0.0 && <0.1,     base >=4.5 && <5    If flag(setIndex)@@ -101,15 +112,20 @@     Data.Array.Comfort.Storable.Mutable.Unchecked     Data.Array.Comfort.Storable.Mutable.Private     Data.Array.Comfort.Boxed+    Data.Array.Comfort.Container   Other-Modules:     Data.Array.Comfort.Shape.Set     Data.Array.Comfort.Shape.Utility     Data.Array.Comfort.Boxed.Unchecked+    Data.Array.Comfort.Storable.Memory+    Data.Array.Comfort.Check  Test-Suite comfort-array-test   Type: exitcode-stdio-1.0   Build-Depends:     comfort-array,+    ChasingBottoms >=1.2.2 && <1.4,+    tagged,     containers,     QuickCheck,     base@@ -119,5 +135,6 @@   Hs-Source-Dirs:   test   Main-Is:          Main.hs   Other-Modules:+    Test.Storable     Test.Shape     Test.Utility

@@ -1,13 +1,19 @@ module Data.Array.Comfort.Boxed (    Array,    shape,+   reshape,+   mapShape,    (!),    Array.toList,-   toAssociations,    Array.fromList,-   fromMap,    Array.vectorFromList,+   toAssociations,+   fromMap,+   toMap,+   fromContainer,+   toContainer,    indices,+   Array.replicate,     Array.map,    zipWith,@@ -17,6 +23,8 @@    ) where  import qualified Data.Array.Comfort.Boxed.Unchecked as Array+import qualified Data.Array.Comfort.Container as Container+import qualified Data.Array.Comfort.Check as Check import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Boxed.Unchecked (Array(Array)) @@ -26,25 +34,43 @@ import Control.Monad.ST (runST) import Control.Applicative ((<$>)) +import qualified Data.Foldable as Fold import qualified Data.Map as Map+import qualified Data.Set as Set import Data.Map (Map) import Data.Set (Set) import Data.Foldable (forM_) -import Prelude hiding (zipWith)+import Prelude hiding (zipWith, replicate)   shape :: Array.Array sh a -> sh shape = Array.shape +reshape :: (Shape.C sh0, Shape.C sh1) => sh1 -> Array sh0 a -> Array sh1 a+reshape = Check.reshape "Boxed" shape Array.reshape +mapShape ::+   (Shape.C sh0, Shape.C sh1) => (sh0 -> sh1) -> Array sh0 a -> Array sh1 a+mapShape f arr = reshape (f $ shape arr) arr++ indices :: (Shape.Indexed sh) => sh -> Array.Array sh (Shape.Index sh) indices sh = Array.fromList sh $ Shape.indices sh  fromMap :: (Ord k) => Map k a -> Array (Set k) a fromMap m = Array.fromList (Map.keysSet m) (Map.elems m) +toMap :: (Ord k) => Array (Set k) a -> Map k a+toMap arr = Map.fromAscList $ zip (Set.toAscList $ shape arr) (Array.toList arr) +fromContainer :: (Container.C f) => f a -> Array (Container.Shape f) a+fromContainer xs = Array.fromList (Container.toShape xs) (Fold.toList xs)++toContainer :: (Container.C f) => Array (Container.Shape f) a -> f a+toContainer arr = Container.fromList (Array.shape arr) (Array.toList arr)++ infixl 9 !  (!) :: (Shape.Indexed sh) => Array sh a -> Shape.Index sh -> a@@ -87,8 +113,8 @@ toAssociations arr = zip (Shape.indices $ shape arr) (Array.toList arr)  fromAssociations ::-   (Shape.Indexed sh) => sh -> a -> [(Shape.Index sh, a)] -> Array sh a-fromAssociations sh a xs = runST (do+   (Shape.Indexed sh) => a -> sh -> [(Shape.Index sh, a)] -> Array sh a+fromAssociations a sh xs = runST (do    marr <- Prim.newArray (Shape.size sh) a    forM_ xs $ \(ix,x) -> Prim.writeArray marr (Shape.offset sh ix) x    Array sh <$> Prim.unsafeFreezeArray marr)

@@ -8,13 +8,13 @@ import qualified Control.Monad.Trans.Class as MT import qualified Control.Monad.Trans.State as MS import Control.Monad (liftM)-import Control.Applicative ((<$>))+import Control.Applicative (Applicative, pure, (<*>), (<$>)) import Control.DeepSeq (NFData, rnf)  import qualified Data.Traversable as Trav import qualified Data.Foldable as Fold import qualified Data.List as List-import Prelude hiding (map, )+import Prelude hiding (map, zipWith, replicate)   data Array sh a =@@ -24,9 +24,12 @@    }  instance (Shape.C sh, Show sh, Show a) => Show (Array sh a) where-   show arr =-      "BoxedArray.fromList " ++-      showsPrec 11 (shape arr) (' ' : show (toListLazy arr))+   showsPrec p arr =+      showParen (p>10) $+         showString "BoxedArray.fromList " .+         showsPrec 11 (shape arr) .+         showChar ' ' .+         shows (toListLazy arr)   instance (Shape.C sh, NFData sh, NFData a) => NFData (Array sh a) where@@ -35,6 +38,14 @@ instance (Shape.C sh) => Functor (Array sh) where    fmap = map +{- |+We must restrict 'Applicative' to 'Shape.Static' because of 'pure'.+Because the shape is static, we do not need a size check in '(<*>)'.+-}+instance (Shape.Static sh) => Applicative (Array sh) where+   pure = replicate Shape.static+   (<*>) = zipWith ($)+ instance (Shape.C sh) => Fold.Foldable (Array sh) where    fold = Fold.fold . buffer    foldMap f = Fold.foldMap f . buffer@@ -78,6 +89,11 @@ vectorFromList xs =    let arr = Prim.fromList xs    in Array (Shape.ZeroBased $ Prim.sizeofArray arr) arr++replicate :: (Shape.C sh) => sh -> a -> Array sh a+replicate sh a =+   Array sh $+   STStrict.runST (Prim.unsafeFreezeArray  =<< Prim.newArray (Shape.size sh) a)  map :: (Shape.C sh) => (a -> b) -> Array sh a -> Array sh b map f (Array sh arr) = Array sh $ Prim.mapArray' f arr

@@ -0,0 +1,24 @@+module Data.Array.Comfort.Check where++import qualified Data.Array.Comfort.Shape as Shape++import Text.Printf (printf)+++{-# INLINE reshape #-}+reshape ::+   (Shape.C sh0, Shape.C sh1) =>+   String ->+   (array0 -> sh0) ->+   (sh1 -> array0 -> array1) ->+   sh1 -> array0 -> array1+reshape name shape uncheckedReshape sh1 arr =+   let n0 = Shape.size $ shape arr+       n1 = Shape.size sh1+   in if n0 == n1+         then uncheckedReshape sh1 arr+         else error $+              printf+                 ("Array.Comfort.%s.reshape: " +++                  "different sizes of old (%d) and new (%d) shape")+                 name n0 n1

@@ -0,0 +1,151 @@+{-# LANGUAGE TypeFamilies #-}+{- |+This module provides an array shape type,+that allows to store elements from a container+while preserving the container structure.+-}+module Data.Array.Comfort.Container (+   C(..), EqShape(..), NFShape(..),+   ) where++import qualified Data.Array.Comfort.Shape as Shape++import Control.DeepSeq (NFData, rnf)++import qualified Data.NonEmpty.Map as NonEmptyMap+import qualified Data.NonEmpty.Set as NonEmptySet+import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.NonEmpty as NonEmpty+import qualified Data.Empty as Empty+import qualified Data.Map as Map+import qualified Data.Set as Set+-- import qualified Data.Complex as Complex+import Data.Map (Map)+import Data.Set (Set)+import Data.Foldable (Foldable)+import Data.Maybe (fromMaybe)+-- import Data.Complex (Complex((:+)))++++class (Foldable f) => C f where+   data Shape f+   shapeSize :: Shape f -> Int+   fromList :: Shape f -> [a] -> f a+   toShape :: f a -> Shape f++class (C f) => NFShape f where+   rnfShape :: Shape f -> ()++class (C f) => EqShape f where+   eqShape :: Shape f -> Shape f -> Bool+++instance (NFShape f) => NFData (Shape f) where+   rnf = rnfShape++instance (EqShape f) => Eq (Shape f) where+   (==) = eqShape++instance (C f) => Shape.C (Shape f) where+   size = shapeSize+   uncheckedSize = shapeSize+++instance C [] where+   data Shape [] = ShapeList Int+      deriving (Show)+   shapeSize (ShapeList n) = n+   toShape = ShapeList . length+   fromList _ = id++instance EqShape [] where+   eqShape (ShapeList n)  (ShapeList m) = n==m++instance NFShape [] where+   rnfShape (ShapeList n) = rnf n+++{-+instance Foldable only available since GHC-8.0. :-(+Could be circumvented by Data.Orphans+but that one also pulls in lots of dangerous instances.++instance C Complex where+   data Shape Complex = ShapeComplex+   shapeSize ShapeComplex = 2+   toShape (_:+_) = ShapeComplex+   fromList ShapeComplex xs =+      case xs of+         [r,i] -> r Complex.:+ i+         _ -> error "ShapeComplex: not two elements"++instance EqShape Complex where+   eqShape ShapeComplex ShapeComplex = True++instance NFShape Complex where+   rnfShape ShapeComplex = ()+-}+++instance (C f) => C (NonEmpty.T f) where+   data Shape (NonEmpty.T f) = ShapeNonEmpty (Shape f)+   shapeSize (ShapeNonEmpty c) = 1 + shapeSize c+   toShape = ShapeNonEmpty . toShape . NonEmpty.tail+   fromList (ShapeNonEmpty c) xt =+      case xt of+         [] -> error "ShapeNonEmpty: empty list"+         x:xs -> NonEmpty.cons x $ fromList c xs++instance (EqShape f) => EqShape (NonEmpty.T f) where+   eqShape (ShapeNonEmpty a) (ShapeNonEmpty b) = a==b++instance (NFShape f) => NFShape (NonEmpty.T f) where+   rnfShape (ShapeNonEmpty c) = rnfShape c+++instance C Empty.T where+   data Shape Empty.T = ShapeEmpty+      deriving (Show)+   shapeSize ShapeEmpty = 0+   toShape Empty.Cons = ShapeEmpty+   fromList ShapeEmpty xs =+      case xs of+         [] -> Empty.Cons+         _ -> error "ShapeEmpty: not empty"++instance EqShape Empty.T where+   eqShape ShapeEmpty ShapeEmpty = True++instance NFShape Empty.T where+   rnfShape ShapeEmpty = ()+++instance (Ord k) => C (Map k) where+   data Shape (Map k) = ShapeMap (Set k)+      deriving (Show)+   shapeSize (ShapeMap set) = Set.size set+   toShape = ShapeMap . Map.keysSet+   fromList (ShapeMap set) = Map.fromAscList . zip (Set.toAscList set)++instance (Ord k) => EqShape (Map k) where+   eqShape (ShapeMap set0) (ShapeMap set1) = set0==set1++instance (NFData k, Ord k) => NFShape (Map k) where+   rnfShape (ShapeMap set) = rnf set+++instance (Ord k) => C (NonEmptyMap.T k) where+   data Shape (NonEmptyMap.T k) = ShapeNonEmptyMap (NonEmptySet.T k)+      deriving (Show)+   shapeSize (ShapeNonEmptyMap set) = NonEmptySet.size set+   toShape = ShapeNonEmptyMap . NonEmptyMap.keysSet+   fromList (ShapeNonEmptyMap set) =+      NonEmptyMap.fromAscList . NonEmptyC.zip (NonEmptySet.toAscList set) .+      fromMaybe (error "ShapeNonEmptyMap: empty list") . NonEmpty.fetch++instance (Ord k) => EqShape (NonEmptyMap.T k) where+   eqShape (ShapeNonEmptyMap set0) (ShapeNonEmptyMap set1) = set0==set1++instance (NFData k, Ord k) => NFShape (NonEmptyMap.T k) where+   rnfShape (ShapeNonEmptyMap set) = rnf set

@@ -4,14 +4,16 @@    C(..),    Indexed(..),    InvIndexed(..),+   Static(..), -   ZeroBased(..),+   Zero(Zero),+   ZeroBased(..), zeroBasedSplit,    OneBased(..),     Range(..),    Shifted(..),    Enumeration(..),-   Deferred(..), DeferredIndex, deferIndex, revealIndex,+   Deferred(..), DeferredIndex(..), deferIndex, revealIndex,     (:+:)(..), @@ -40,9 +42,13 @@  import qualified Data.Set as Set import qualified Data.NonEmpty as NonEmpty+import Data.Functor.Identity (Identity(Identity), runIdentity)+import Data.Function.HT (compose2)+import Data.Tagged (Tagged(Tagged, unTagged)) import Data.Set (Set) import Data.List.HT (tails) import Data.Tuple.HT (mapSnd, mapPair, swap, fst3, snd3, thd3)+import Data.Eq.HT (equating)   class C sh where@@ -80,7 +86,21 @@    uncheckedIndexFromOffset :: sh -> Int -> Index sh    uncheckedIndexFromOffset = indexFromOffset +class (C sh, Eq sh) => Static sh where+   static :: sh ++data Zero = Zero+   deriving (Eq, Ord, Show)++instance C Zero where+   size Zero = 0+   uncheckedSize Zero = 0++instance Static Zero where+   static = Zero++ instance C () where    size () = 1    uncheckedSize () = 1@@ -97,7 +117,10 @@    indexFromOffset () k = errorIndexFromOffset "()" k    uncheckedIndexFromOffset () _ = () +instance Static () where+   static = () + {- | 'ZeroBased' denotes a range starting at zero and has a certain length. -}@@ -139,7 +162,13 @@             else errorIndexFromOffset "ZeroBased" k0    uncheckedIndexFromOffset _ k = fromIntegral k +zeroBasedSplit :: (Real n) => n -> ZeroBased n -> ZeroBased n :+: ZeroBased n+zeroBasedSplit n (ZeroBased m) =+   if n<0+      then error "Shape.zeroBasedSplit: negative number of elements"+      else let k = min n m in ZeroBased k :+: ZeroBased (m-k) + {- | 'OneBased' denotes a range starting at one and has a certain length. -}@@ -334,6 +363,9 @@ intFromEnum :: (Enum n) => Enumeration n -> n -> Int intFromEnum Enumeration = fromEnum +instance (Enum n, Bounded n) => Static (Enumeration n) where+   static = Enumeration+ instance Storable (Enumeration n) where    {-# INLINE sizeOf #-}    {-# INLINE alignment #-}@@ -373,12 +405,36 @@ You can convert once using 'deferIndex' and 'revealIndex' whenever you need your application specific index type. No need for e.g. @Storable (Index sh)@, because 'Int' is already 'Storable'.+You get 'Indexed' and 'InvIndexed' instances+without the need for an 'Index' type.+The disadvantage is:+A deferred index should be bound to a specific shape, but this is not checked.+That is, you may obtain a deferred index for one shape+and accidentally abuse it for another shape without a warning.++Example:++> Shape> let sh2 = (ZeroBased (2::Int), ZeroBased (2::Int))+> Shape> let sh3 = (ZeroBased (3::Int), ZeroBased (3::Int))+> Shape> offset sh3 $ indexFromOffset sh2 3+> 4+> Shape> offset (Deferred sh3) $ indexFromOffset (Deferred sh2) 3+> 3 -} newtype Deferred sh = Deferred sh    deriving (Eq, Show) -newtype DeferredIndex ix = DeferredIndex Int-   deriving (Eq, Show)+{- |+'DeferredIndex' has an 'Ord' instance+that is based on the storage order in memory.+This way, you can put 'DeferredIndex' values+in a 'Set' or use them as keys in a 'Map'+even if @Index sh@ has no 'Ord' instance.+The downside is, that the ordering of @DeferredIndex sh@+may differ from the one of @Index sh@.+-}+newtype DeferredIndex sh = DeferredIndex Int+   deriving (Eq, Ord, Show)  instance (NFData sh) => NFData (Deferred sh) where    rnf (Deferred sh) = rnf sh@@ -388,25 +444,34 @@    uncheckedSize (Deferred sh) = uncheckedSize sh  instance (C sh) => Indexed (Deferred sh) where-   type Index (Deferred sh) = DeferredIndex (Index sh)+   type Index (Deferred sh) = DeferredIndex sh    indices (Deferred sh) = map DeferredIndex $ take (size sh) [0 ..]    offset (Deferred sh) (DeferredIndex k) = offset (ZeroBased $ size sh) k    uncheckedOffset _ (DeferredIndex k) = k+   sizeOffset (Deferred sh) =+      mapSnd (\offs (DeferredIndex k) -> offs k) $+      sizeOffset (ZeroBased $ size sh)+   uncheckedSizeOffset (Deferred sh) =+      mapSnd (\ _offs (DeferredIndex k) -> k) $+      uncheckedSizeOffset (ZeroBased $ size sh)    inBounds (Deferred sh) (DeferredIndex k) =       inBounds (ZeroBased $ size sh) k  instance (C sh) => InvIndexed (Deferred sh) where-   indexFromOffset sh k =+   indexFromOffset (Deferred sh) k =       DeferredIndex $ indexFromOffset (ZeroBased $ size sh) k    uncheckedIndexFromOffset _sh = DeferredIndex -deferIndex :: (Indexed sh, Index sh ~ ix) => sh -> ix -> DeferredIndex ix+deferIndex :: (Indexed sh, Index sh ~ ix) => sh -> ix -> DeferredIndex sh deferIndex sh ix = DeferredIndex $ offset sh ix -revealIndex :: (InvIndexed sh, Index sh ~ ix) => sh -> DeferredIndex ix -> ix+revealIndex :: (InvIndexed sh, Index sh ~ ix) => sh -> DeferredIndex sh -> ix revealIndex sh (DeferredIndex ix) = indexFromOffset sh ix -instance Storable (DeferredIndex ix) where+instance (Static sh) => Static (Deferred sh) where+   static = Deferred static++instance Storable (DeferredIndex sh) where    {-# INLINE sizeOf #-}    {-# INLINE alignment #-}    {-# INLINE peek #-}@@ -418,6 +483,30 @@   +instance (C sh) => C (Tagged s sh) where+   size (Tagged sh) = size sh+   uncheckedSize (Tagged sh) = uncheckedSize sh++instance (Indexed sh) => Indexed (Tagged s sh) where+   type Index (Tagged s sh) = Tagged s (Index sh)+   indices (Tagged sh) = map Tagged $ indices sh+   offset (Tagged sh) (Tagged k) = offset sh k+   uncheckedOffset (Tagged sh) (Tagged k) = uncheckedOffset sh k+   sizeOffset (Tagged sh) = mapSnd (. unTagged) $ sizeOffset sh+   uncheckedSizeOffset (Tagged sh) =+      mapSnd (. unTagged) $ uncheckedSizeOffset sh+   inBounds (Tagged sh) (Tagged k) = inBounds sh k++instance (InvIndexed sh) => InvIndexed (Tagged s sh) where+   indexFromOffset (Tagged sh) k = Tagged $ indexFromOffset sh k+   uncheckedIndexFromOffset (Tagged sh) k =+      Tagged $ uncheckedIndexFromOffset sh k++instance (Static sh) => Static (Tagged s sh) where+   static = Tagged static+++ {- | Row-major composition of two dimensions. -}@@ -452,7 +541,10 @@    uncheckedIndexFromOffset (sh0,sh1) k =       runInvIndex k $ liftA2 (,) (uncheckedPickLastIndex sh0) (pickIndex sh1) +instance (Static sh0, Static sh1) => Static (sh0,sh1) where+   static = (static, static) + instance (C sh0, C sh1, C sh2) => C (sh0,sh1,sh2) where    size (sh0,sh1,sh2) = size sh0 * size sh1 * size sh2    uncheckedSize (sh0,sh1,sh2) =@@ -493,6 +585,9 @@       runInvIndex k $       liftA3 (,,) (uncheckedPickLastIndex sh0) (pickIndex sh1) (pickIndex sh2) +instance (Static sh0, Static sh1, Static sh2) => Static (sh0,sh1,sh2) where+   static = (static, static, static)+ runInvIndex :: s -> Back.Backwards (MS.State s) a -> a runInvIndex k = flip MS.evalState k . Back.forwards @@ -545,8 +640,16 @@    Triangular {       triangularPart :: part,       triangularSize :: size-   } deriving (Eq, Show)+   } deriving (Show) +newtype Equal part = Equal {getEqual :: part -> part -> Bool}++equalPart :: (TriangularPart part) => part -> part -> Bool+equalPart = getEqual $ switchTriangularPart (Equal (==)) (Equal (==))++instance (TriangularPart part, Eq size) => Eq (Triangular part size) where+   x==y  =  compose2 equalPart triangularPart x y && equating triangularSize x y+ type LowerTriangular = Triangular Lower type UpperTriangular = Triangular Upper @@ -646,7 +749,16 @@ triangleRootDouble = triangleRoot . fromIntegral  +instance+   (TriangularPart part, Static size) =>+      Static (Triangular part size) where+   static = Triangular autoPart static +autoPart :: (TriangularPart part) => part+autoPart = runIdentity $ switchTriangularPart (Identity Lower) (Identity Upper)+++ infixr 5 :+:  data sh0:+:sh1 = sh0:+:sh1@@ -691,3 +803,6 @@       in if k < pivot             then Left $ uncheckedIndexFromOffset sh0 k             else Right $ uncheckedIndexFromOffset sh1 $ k-pivot++instance (Static sh0, Static sh1) => Static (sh0:+:sh1) where+   static = static:+:static

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies #-} module Data.Array.Comfort.Storable (    Array,    shape,@@ -6,56 +7,72 @@     (!),    Array.toList,+   Array.vectorFromList,+   toAssociations,    fromList,    fromMap,-   Array.vectorFromList,+   fromContainer,+   toContainer,    sample,    fromBoxed,    toBoxed,     Array.map,    Array.mapWithIndex,+   zipWith,    (//),    accumulate,    fromAssociations,++   Array.singleton,+   Array.append,+   Array.take, Array.drop,+   Array.takeLeft, Array.takeRight, Array.split,++   Array.sum, Array.product,+   minimum, argMinimum,+   maximum, argMaximum,+   limits,+   Array.foldl,+   foldl1,+   foldMap,    ) where  import qualified Data.Array.Comfort.Storable.Mutable.Unchecked as MutArrayNC import qualified Data.Array.Comfort.Storable.Mutable as MutArray import qualified Data.Array.Comfort.Storable.Unchecked as Array+import qualified Data.Array.Comfort.Storable.Memory as Memory+import qualified Data.Array.Comfort.Container as Container import qualified Data.Array.Comfort.Boxed as BoxedArray+import qualified Data.Array.Comfort.Check as Check import qualified Data.Array.Comfort.Shape as Shape-import Data.Array.Comfort.Storable.Unchecked (Array)+import Data.Array.Comfort.Storable.Unchecked (Array(Array)) +import System.IO.Unsafe (unsafePerformIO) import Foreign.Storable (Storable)+import Foreign.ForeignPtr (withForeignPtr)  import Control.Monad.ST (runST)  import qualified Data.Map as Map+import qualified Data.Foldable as Fold import qualified Data.List as List+import qualified Data.Tuple.Strict as StrictTuple import Data.Map (Map) import Data.Set (Set) import Data.Foldable (forM_)--import Text.Printf (printf)+import Data.Semigroup+         (Semigroup, (<>), Min(Min,getMin), Max(Max,getMax), Arg(Arg)) -import Prelude hiding (map)+import Prelude2010 hiding (map, zipWith, foldl1, minimum, maximum)+import Prelude ()   shape :: Array sh a -> sh shape = Array.shape  reshape :: (Shape.C sh0, Shape.C sh1) => sh1 -> Array sh0 a -> Array sh1 a-reshape sh1 arr =-   let n0 = Shape.size $ shape arr-       n1 = Shape.size sh1-   in if n0 == n1-         then Array.reshape sh1 arr-         else error $-              printf-                 ("Array.Comfort.Storable.reshape: " ++-                  "different sizes of old (%d) and new (%d) shape")-                 n0 n1+reshape = Check.reshape "Storable" shape Array.reshape  mapShape ::    (Shape.C sh0, Shape.C sh1) => (sh0 -> sh1) -> Array sh0 a -> Array sh1 a@@ -68,6 +85,14 @@ fromMap :: (Ord k, Storable a) => Map k a -> Array (Set k) a fromMap m = fromList (Map.keysSet m) (Map.elems m) +fromContainer ::+   (Container.C f, Storable a) => f a -> Array (Container.Shape f) a+fromContainer xs = fromList (Container.toShape xs) (Fold.toList xs)++toContainer ::+   (Container.C f, Storable a) => Array (Container.Shape f) a -> f a+toContainer arr = Container.fromList (Array.shape arr) (Array.toList arr)+ sample ::    (Shape.Indexed sh, Storable a) => sh -> (Shape.Index sh -> a) -> Array sh a sample sh f = Array.fromList sh $ List.map f $ Shape.indices sh@@ -79,7 +104,11 @@ toBoxed :: (Shape.C sh, Storable a) => Array sh a -> BoxedArray.Array sh a toBoxed arr = BoxedArray.fromList (Array.shape arr) $ Array.toList arr +toAssociations ::+   (Shape.Indexed sh, Storable a) => Array sh a -> [(Shape.Index sh, a)]+toAssociations arr = zip (Shape.indices $ shape arr) (Array.toList arr) + infixl 9 !  (!) :: (Shape.Indexed sh, Storable a) => Array sh a -> Shape.Index sh -> a@@ -88,6 +117,14 @@    MutArray.read marr ix)  +zipWith ::+   (Shape.C sh, Eq sh, Storable a, Storable b, Storable c) =>+   (a -> b -> c) -> Array sh a -> Array sh b -> Array sh c+zipWith f a b =+   if shape a == shape b+      then Array.zipWith f a b+      else error "zipWith: shapes mismatch"+ (//) ::    (Shape.Indexed sh, Storable a) =>    Array sh a -> [(Shape.Index sh, a)] -> Array sh a@@ -106,8 +143,53 @@  fromAssociations ::    (Shape.Indexed sh, Storable a) =>-   sh -> a -> [(Shape.Index sh, a)] -> Array sh a-fromAssociations sh a xs = runST (do+   a -> sh -> [(Shape.Index sh, a)] -> Array sh a+fromAssociations a sh xs = runST (do    marr <- MutArray.new sh a    forM_ xs $ uncurry $ MutArray.write marr    MutArrayNC.unsafeFreeze marr)++++{- |+It is a checked error if the vector is empty.+-}+minimum, maximum :: (Shape.C sh, Storable a, Ord a) => Array sh a -> a+minimum = foldl1 min+maximum = foldl1 max++{-# INLINE foldl1 #-}+foldl1 :: (Shape.C sh, Storable a) => (a -> a -> a) -> Array sh a -> a+foldl1 op (Array sh x) = unsafePerformIO $+   withForeignPtr x $ \xPtr ->+      Memory.foldl1 (const id) op (Shape.size sh) xPtr 1++{- |+> limits x = (minimum x, maximum x)+-}+limits :: (Shape.C sh, Storable a, Ord a) => Array sh a -> (a,a)+limits = StrictTuple.mapPair (getMin, getMax) . foldMap (\x -> (Min x, Max x))++{-# INLINE foldMap #-}+foldMap ::+   (Shape.C sh, Storable a, Ord a, Semigroup m) => (a -> m) -> Array sh a -> m+foldMap f (Array sh x) = unsafePerformIO $+   withForeignPtr x $ \xPtr ->+      Memory.foldl1 (const f) (<>) (Shape.size sh) xPtr 1+++argMinimum, argMaximum ::+   (Shape.InvIndexed sh, Shape.Index sh ~ ix, Storable a, Ord a) =>+   Array sh a -> (ix,a)+argMinimum xs = unArg xs $ getMin $ foldMapWithIndex (\k x -> Min (Arg x k)) xs+argMaximum xs = unArg xs $ getMax $ foldMapWithIndex (\k x -> Max (Arg x k)) xs++unArg ::+   (Shape.InvIndexed sh) => Array sh a -> Arg a Int -> (Shape.Index sh, a)+unArg xs (Arg x k) = (Shape.indexFromOffset (Array.shape xs) k, x)++{-# INLINE foldMapWithIndex #-}+foldMapWithIndex ::+   (Shape.C sh, Storable a, Semigroup m) => (Int -> a -> m) -> Array sh a -> m+foldMapWithIndex f (Array sh x) = unsafePerformIO $+   withForeignPtr x $ \xPtr -> Memory.foldl1 f (<>) (Shape.size sh) xPtr 1

@@ -0,0 +1,29 @@+module Data.Array.Comfort.Storable.Memory where++import Foreign.Marshal.Array (advancePtr)+import Foreign.Ptr (Ptr)+import Foreign.Storable (Storable, peek, peekElemOff)++import Control.Monad (foldM)++import Prelude hiding (foldl, foldl1)+++{-# INLINE foldl #-}+foldl ::+   (Storable a) => (Int -> b -> a -> b) -> b -> Int -> Ptr a -> Int -> IO b+foldl op b n xPtr incx =+   foldM (\x k -> do y <- peekElemOff xPtr (k*incx); return $! op k x y) b $+   take n $ iterate (+1) 0++{-# INLINE foldl1 #-}+foldl1 ::+   (Storable a) =>+   (Int -> a -> b) -> (b -> b -> b) -> Int -> Ptr a -> Int -> IO b+foldl1 f op n xPtr incx =+   if n<1+      then error "foldl1: empty vector"+      else do+         x0 <- peek xPtr+         foldl (\k b a -> op b (f (k+1) a))+            (f 0 x0) (n-1) (advancePtr xPtr incx) incx

@@ -23,11 +23,15 @@    }  instance (Shape.C sh, Show sh, Storable a, Show a) => Show (Array sh a) where-   show arr = runST (MutArray.show =<< unsafeThaw arr)+   showsPrec p arr =+      showParen (p>10) $ showString $ runST (MutArray.show =<< unsafeThaw arr)  instance (NFData sh) => NFData (Array sh a) where    rnf (Array sh fptr) = seq fptr (rnf sh) +instance (Shape.C sh, Eq sh, Storable a, Eq a) => Eq (Array sh a) where+   a@(Array sha _) == b@(Array shb _)  =  sha==shb && toList a == toList b+ reshape :: sh1 -> Array sh0 a -> Array sh1 a reshape sh (Array _ fptr) = Array sh fptr @@ -68,8 +72,8 @@  fromAssociations ::    (Shape.Indexed sh, Storable a) =>-   sh -> a -> [(Shape.Index sh, a)] -> Array sh a-fromAssociations sh a xs = runST (do+   a -> sh -> [(Shape.Index sh, a)] -> Array sh a+fromAssociations a sh xs = runST (do    marr <- MutArray.new sh a    forM_ xs $ uncurry $ MutArray.write marr    unsafeFreeze marr)

@@ -1,11 +1,12 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {- | The functions in this module miss any bound checking. -} module Data.Array.Comfort.Storable.Unchecked (    Priv.Array(Array, shape, buffer),    Priv.reshape,-   Priv.mapShape,+   mapShape,     (Priv.!),    unsafeCreate,@@ -17,26 +18,41 @@     map,    mapWithIndex,+   zipWith,    (Priv.//),    Priv.accumulate,    Priv.fromAssociations,++   singleton,+   append,+   take, drop,+   takeLeft, takeRight, split,++   sum, product,+   foldl,    ) where  import qualified Data.Array.Comfort.Storable.Unchecked.Monadic as Monadic import qualified Data.Array.Comfort.Storable.Private as Priv+import qualified Data.Array.Comfort.Storable.Memory as Memory import qualified Data.Array.Comfort.Shape as Shape-import Data.Array.Comfort.Storable.Private (Array(Array))+import Data.Array.Comfort.Storable.Private (Array(Array), mapShape)+import Data.Array.Comfort.Shape ((:+:)((:+:))) -import Foreign.Marshal.Array (advancePtr)+import System.IO.Unsafe (unsafePerformIO)+import Foreign.Marshal.Array (copyArray, advancePtr) import Foreign.Storable (Storable, poke, peek) import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (Ptr)  import Control.Monad.ST (runST)+import Control.Applicative (liftA2) -import Prelude hiding (map)+import qualified Data.List as List +import Prelude hiding (map, zipWith, foldl, take, drop, sum, product) + unsafeCreate ::    (Shape.C sh, Storable a) =>    sh -> (Ptr a -> IO ()) -> Array sh a@@ -60,8 +76,8 @@ map f (Array sh a) =    unsafeCreate sh $ \dstPtr ->    withForeignPtr a $ \srcPtr ->-   sequence_ $ take (Shape.size sh) $-      zipWith+   sequence_ $ List.take (Shape.size sh) $+      List.zipWith          (\src dst -> poke dst . f =<< peek src)          (iterate (flip advancePtr 1) srcPtr)          (iterate (flip advancePtr 1) dstPtr)@@ -73,8 +89,84 @@    unsafeCreate sh $ \dstPtr ->    withForeignPtr a $ \srcPtr ->    sequence_ $-      zipWith3+      List.zipWith3          (\ix src dst -> poke dst . f ix =<< peek src)          (Shape.indices sh)          (iterate (flip advancePtr 1) srcPtr)          (iterate (flip advancePtr 1) dstPtr)++zipWith ::+   (Shape.C sh, Storable a, Storable b, Storable c) =>+   (a -> b -> c) -> Array sh a -> Array sh b -> Array sh c+zipWith f (Array _sh a) (Array sh b) =+   unsafeCreate sh $ \dstPtr ->+   withForeignPtr a $ \srcAPtr ->+   withForeignPtr b $ \srcBPtr ->+   sequence_ $ List.take (Shape.size sh) $+      zipWith3+         (\srcA srcB dst -> poke dst =<< liftA2 f (peek srcA) (peek srcB))+         (iterate (flip advancePtr 1) srcAPtr)+         (iterate (flip advancePtr 1) srcBPtr)+         (iterate (flip advancePtr 1) dstPtr)+++singleton :: (Storable a) => a -> Array () a+singleton a = unsafeCreate () $ flip poke a++append ::+   (Shape.C shx, Shape.C shy, Storable a) =>+   Array shx a -> Array shy a -> Array (shx:+:shy) a+append (Array shX x) (Array shY y) =+   unsafeCreate (shX:+:shY) $ \zPtr ->+   withForeignPtr x $ \xPtr ->+   withForeignPtr y $ \yPtr -> do+      let sizeX = Shape.size shX+      let sizeY = Shape.size shY+      copyArray zPtr xPtr sizeX+      copyArray (advancePtr zPtr sizeX) yPtr sizeY++take, drop ::+   (Integral n, Storable a) =>+   n -> Array (Shape.ZeroBased n) a -> Array (Shape.ZeroBased n) a+take n = takeLeft . splitN n+drop n = takeRight . splitN n++splitN ::+   (Integral n, Storable a) =>+   n -> Array (Shape.ZeroBased n) a ->+   Array (Shape.ZeroBased n :+: Shape.ZeroBased n) a+splitN n = mapShape (Shape.zeroBasedSplit n)++takeLeft ::+   (Shape.C sh0, Shape.C sh1, Storable a) =>+   Array (sh0:+:sh1) a -> Array sh0 a+takeLeft (Array (sh0 :+: _sh1) x) =+   unsafeCreateWithSize sh0 $ \k yPtr ->+   withForeignPtr x $ \xPtr -> copyArray yPtr xPtr k++takeRight ::+   (Shape.C sh0, Shape.C sh1, Storable a) =>+   Array (sh0:+:sh1) a -> Array sh1 a+takeRight (Array (sh0:+:sh1) x) =+   unsafeCreateWithSize sh1 $ \k yPtr ->+   withForeignPtr x $ \xPtr ->+      copyArray yPtr (advancePtr xPtr (Shape.size sh0)) k++split ::+   (Shape.C sh0, Shape.C sh1, Storable a) =>+   Array (sh0:+:sh1) a -> (Array sh0 a, Array sh1 a)+split x = (takeLeft x, takeRight x)++++sum :: (Shape.C sh, Storable a, Num a) => Array sh a -> a+sum = foldl (+) 0++product :: (Shape.C sh, Storable a, Num a) => Array sh a -> a+product = foldl (*) 1++{-# INLINE foldl #-}+foldl :: (Shape.C sh, Storable a) => (b -> a -> b) -> b -> Array sh a -> b+foldl op a (Array sh x) = unsafePerformIO $+   withForeignPtr x $ \xPtr ->+      Memory.foldl (const op) a (Shape.size sh) xPtr 1

@@ -2,6 +2,7 @@ module Main where  import qualified Test.Shape as TestShape+import qualified Test.Storable as TestStorable import Test.Utility (prefix)  import qualified Test.QuickCheck as QC@@ -11,4 +12,5 @@ main =    mapM_ (\(name,prop) -> putStr (name ++ ": ") >> QC.quickCheck prop) $    prefix "Shape" TestShape.tests +++   prefix "Storable" TestStorable.tests ++    []

@@ -10,11 +10,15 @@ import Control.Applicative (liftA2, liftA3)  import qualified Data.Set as Set+import Data.Tagged (Tagged(Tagged))   genZeroBased :: Int -> QC.Gen (Shape.ZeroBased Int) genZeroBased n = fmap Shape.ZeroBased $ QC.choose (0,n) +tag :: sh -> Tagged Ordering sh+tag = Tagged+ tests :: [(String, QC.Property)] tests =    prefix "ZeroBased"@@ -41,6 +45,10 @@        fmap Set.fromList (QC.listOf (QC.choose ('a','z')))) ++    prefix "Deferred Shifted"       (ShapeTest.tests $ fmap Shape.Deferred $+       liftA2 Shape.Shifted+         (QC.choose (-10,10::Int)) (QC.choose (0,10::Int))) +++   prefix "Tagged Shifted"+      (ShapeTest.tests $ fmap tag $        liftA2 Shape.Shifted          (QC.choose (-10,10::Int)) (QC.choose (0,10::Int))) ++    prefix "Pair"

@@ -0,0 +1,93 @@+module Test.Storable where++import qualified Data.Array.Comfort.Storable as Array+import qualified Data.Array.Comfort.Shape as Shape+import Data.Array.Comfort.Storable (Array, (!))++import Foreign.Storable (Storable)++import qualified Test.QuickCheck as QC+import Test.ChasingBottoms.IsBottom (isBottom)++import Control.Applicative ((<$>))++import Data.Word (Word16)+++type ShapeInt = Shape.ZeroBased Int++genArray :: QC.Gen (Array ShapeInt Word16)+genArray = Array.vectorFromList <$> QC.arbitrary+++singleton :: (Storable a, Eq a) => a -> Bool+singleton x  =  x == Array.singleton x ! ()++appendTakeDrop ::+   (Storable a, Eq a) =>+   QC.NonNegative Int -> Array ShapeInt a -> Bool+appendTakeDrop (QC.NonNegative n) x =+   x ==+   Array.mapShape (Shape.ZeroBased . Shape.size)+      (Array.append (Array.take n x) (Array.drop n x))++takeLeftRightAppend ::+   (Storable a, Eq a) =>+   Array ShapeInt a -> Array ShapeInt a -> Bool+takeLeftRightAppend x y =+   let xy = Array.append x y+   in x == Array.takeLeft xy  &&  y == Array.takeRight xy+++sumList :: (Storable a, Num a, Eq a) => Array ShapeInt a -> Bool+sumList xs  =  Array.sum xs == sum (Array.toList xs)++productList :: (Storable a, Num a, Eq a) => Array ShapeInt a -> Bool+productList xs  =  Array.product xs == product (Array.toList xs)+++withNonEmpty ::+   (Array ShapeInt a -> b) ->+   (b -> Array ShapeInt a -> Bool) ->+   Array ShapeInt a -> Bool+withNonEmpty f law xs =+   let x = f xs+   in if Array.shape xs == Shape.ZeroBased 0+         then isBottom x+         else law x xs++minimumList :: (Storable a, Ord a) => Array ShapeInt a -> Bool+minimumList =+   withNonEmpty Array.minimum $ \x xs -> x == minimum (Array.toList xs)++maximumList :: (Storable a, Ord a) => Array ShapeInt a -> Bool+maximumList =+   withNonEmpty Array.maximum $ \x xs -> x == maximum (Array.toList xs)++limitsMinimumMaximum :: (Storable a, Ord a) => Array ShapeInt a -> Bool+limitsMinimumMaximum =+   withNonEmpty Array.limits $+      \xe xs -> xe == (Array.minimum xs, Array.maximum xs)+++tests :: [(String, QC.Property)]+tests =+   ("singleton", QC.property (singleton . (id :: Word16 -> Word16))) :+   ("appendTakeDrop",+      QC.forAll QC.arbitrary $ \n ->+      QC.forAll genArray $ \xs -> appendTakeDrop n xs) :+   ("takeLeftRightAppend",+      QC.forAll genArray $ \xs ->+      QC.forAll genArray $ \ys -> takeLeftRightAppend xs ys) :++   ("sum",+      QC.forAll genArray sumList) :+   ("product",+      QC.forAll genArray productList) :+   ("minimum",+      QC.forAll genArray minimumList) :+   ("maximum",+      QC.forAll genArray maximumList) :+   ("limitsMinimumMaximum",+      QC.forAll genArray limitsMinimumMaximum) :+   []