diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -1,4 +1,19 @@ 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 + +script: + - $script + notifications: irc: channels: @@ -6,3 +21,6 @@ skip_join: true template: - "\x0313sparse\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" + +env: + - mode="--enable-tests" script="cabal test --show-details=always" diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown new file mode 100644 --- /dev/null +++ b/CHANGELOG.markdown @@ -0,0 +1,11 @@ +0.7 +--- +* Switched to using an internal vector type that unboxes as much as it can. This lets type inference work much better when playing around at the ghci REPL. + +0.6 +--- +* Version bumped to exceed the # of Hans Hoglund's `sparse` package. He started and released his library during the creation of this library, but graciously offered to let me take over the name. His library is now on hackage as `sparser`. + +0.1 +--- +* Repository initialized. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,15 @@ +sparse +====== + +[![Build Status](https://secure.travis-ci.org/ekmett/sparse.png?branch=master)](http://travis-ci.org/ekmett/sparse) + +A sparse linear algebra playground based on Morton ordering. + +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 diff --git a/benchmarks/mm.hs b/benchmarks/mm.hs --- a/benchmarks/mm.hs +++ b/benchmarks/mm.hs @@ -1,42 +1,41 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} import Control.Applicative import Control.DeepSeq import Criterion.Main import Data.Array.Unboxed as A -import Data.Vector.Generic as G -import Data.Vector.Unboxed as U import Sparse.Matrix as M -import Sparse.Matrix.Heap as Heap +import Sparse.Matrix.Internal.Heap as Heap instance NFData (UArray i e) main :: IO () main = defaultMain [ bench "naive I_32" $ nf (\x -> mmul x x) $ array ((0,0),(31,31)) $ [ ((i, j), if i == j then 1 else 0) | i <- [0..31], j <- [0..31] ] - , bench "I_32 new" $ nf (\x -> x * x) (ident 32 :: Mat U.Vector Int) - , bench "I_64 new" $ nf (\x -> x * x) (ident 64 :: Mat U.Vector Int) - , bench "I_128 new" $ nf (\x -> x * x) (ident 128 :: Mat U.Vector Int) - -- , bench "I_256" $ nf (\x -> x * x) (ident 256 :: Mat U.Vector Int) - -- , bench "I_512" $ nf (\x -> x * x) (ident 1024 :: Mat U.Vector Int) - -- , bench "I_1024" $ nf (\x -> x * x) (ident 1024 :: Mat U.Vector Int) + , bench "I_32 new" $ nf (\x -> x * x) (ident 32 :: Mat Int) + , bench "I_64 new" $ nf (\x -> x * x) (ident 64 :: Mat Int) + , bench "I_128 new" $ nf (\x -> x * x) (ident 128 :: Mat Int) + -- , bench "I_256" $ nf (\x -> x * x) (ident 256 :: Mat Int) + -- , bench "I_512" $ nf (\x -> x * x) (ident 1024 :: Mat Int) + -- , bench "I_1024" $ nf (\x -> x * x) (ident 1024 :: Mat Int) , bench "naive 32x32" $ nf (\x -> mmul x x) $ listArray ((0,0),(31,31)) $ Prelude.replicate (32*32) 1 , bench "32x32 Int" $ nf (\x -> x * x) blockInt , bench "32x32 ()" $ nf (\x -> multiplyWith const (Heap.streamHeapWith const) x x) blockUnit - , bench "naive 128x128" $ nf (\x -> mmul x x) $ listArray ((0,0),(127,127)) $ Prelude.replicate (128*128) 1 - , bench "128x128 Int" $ nf (\x -> x * x) blockInt128 - , bench "128x128 ()" $ nf (\x -> multiplyWith const (Heap.streamHeapWith const) x x) blockUnit128 + , bench "naive 64x64" $ nf (\x -> mmul x x) $ listArray ((0,0),(63,63)) $ Prelude.replicate (64*64) 1 + , bench "64x64 Int" $ nf (\x -> x * x) blockInt64 + , bench "64x64 ()" $ nf (\x -> multiplyWith const (Heap.streamHeapWith const) x x) blockUnit64 ] -blockInt :: Mat U.Vector Int +blockInt :: Mat Int blockInt = M.fromList $ Prelude.zip (Key <$> [0..31] <*> [0..31]) (repeat 1) -blockInt128 :: Mat U.Vector Int -blockInt128 = M.fromList $ Prelude.zip (Key <$> [0..127] <*> [0..127]) (repeat 1) +blockInt64 :: Mat Int +blockInt64 = M.fromList $ Prelude.zip (Key <$> [0..63] <*> [0..63]) (repeat 1) -blockUnit :: Mat U.Vector () +blockUnit :: Mat () blockUnit = M.fromList $ Prelude.zip (Key <$> [0..31] <*> [0..31]) (repeat ()) -blockUnit128 :: Mat U.Vector () -blockUnit128 = M.fromList $ Prelude.zip (Key <$> [0..127] <*> [0..127]) (repeat ()) +blockUnit64 :: Mat () +blockUnit64 = M.fromList $ Prelude.zip (Key <$> [0..63] <*> [0..63]) (repeat ()) mmul :: UArray (Int,Int) Int -> UArray (Int,Int) Int -> UArray (Int,Int) Int mmul x y = accumArray (+) 0 ((i0,k0),(i1,k1)) $ do diff --git a/sparse.cabal b/sparse.cabal --- a/sparse.cabal +++ b/sparse.cabal @@ -1,6 +1,6 @@ name: sparse category: Data, Vector -version: 0.6 +version: 0.7 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE @@ -18,6 +18,8 @@ .travis.yml .gitignore .vim.custom + CHANGELOG.markdown + README.markdown description: A playground of sparse linear algebra primitives using Morton ordering @@ -48,8 +50,14 @@ default: True manual: True +-- You can disable the hlint test suite with -f-test-hlint +flag test-hlint + default: True + manual: True + +-- You can disable the optimizations -f-optimize for faster builds flag optimize - default: False + default: True manual: True flag llvm @@ -75,6 +83,7 @@ Sparse.Matrix.Internal.Fusion Sparse.Matrix.Internal.Heap Sparse.Matrix.Internal.Key + Sparse.Matrix.Internal.Vectored ghc-options: -Wall @@ -103,7 +112,7 @@ hybrid-vectors, lens, linear >= 1.2 && < 2, - QuickCheck >= 2.5, + QuickCheck >= 2.5 && < 2.6, sparse, test-framework >= 0.6, test-framework-quickcheck2 >= 0.3, @@ -111,6 +120,19 @@ transformers, vector +test-suite hlint + type: exitcode-stdio-1.0 + main-is: hlint.hs + ghc-options: -w -threaded -rtsopts -with-rtsopts=-N + hs-source-dirs: tests + + 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 @@ -140,7 +162,7 @@ benchmark mm type: exitcode-stdio-1.0 main-is: mm.hs - ghc-options: -Wall -O2 -threaded -fdicts-cheap -funbox-strict-fields -fsimpl-tick-factor=400000 + ghc-options: -Wall -O2 -threaded -funbox-strict-fields -fsimpl-tick-factor=400000 hs-source-dirs: benchmarks build-depends: array, diff --git a/src/Sparse/Matrix.hs b/src/Sparse/Matrix.hs --- a/src/Sparse/Matrix.hs +++ b/src/Sparse/Matrix.hs @@ -11,6 +11,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- -- | @@ -44,6 +45,8 @@ -- * Customization , addWith , multiplyWith + -- * Storage + , Vectored(..) -- * Lenses , _Mat, keys, values ) where @@ -54,7 +57,6 @@ import Control.Lens import Data.Bits import Data.Complex -import Data.Foldable import Data.Function (on) import qualified Data.Vector as V import qualified Data.Vector.Algorithms.Insertion as Sort @@ -68,6 +70,7 @@ import Prelude hiding (head, last, null) import Sparse.Matrix.Internal.Fusion as Fusion import Sparse.Matrix.Internal.Key +import Sparse.Matrix.Internal.Vectored as I import Sparse.Matrix.Internal.Heap as Heap hiding (head) import Text.Read @@ -76,7 +79,7 @@ -- * Distinguishable Zero -class Num a => Eq0 a where +class (Vectored a, Num a) => Eq0 a where -- | Return whether or not the element is 0. -- -- It may be okay to never return 'True', but you won't be @@ -114,7 +117,7 @@ -- @ -- 'addMats' = 'addWith0' '$' 'nonZero' ('+') -- @ - addMats :: G.Vector v a => Mat v a -> Mat v a -> Mat v a + addMats :: Mat a -> Mat a -> Mat a addMats = addWith0 $ nonZero (+) {-# INLINE addMats #-} @@ -147,61 +150,54 @@ -- * Sparse Matrices -- invariant: all vectors are the same length -data Mat v a = Mat {-# UNPACK #-} !Int !(U.Vector Word) !(U.Vector Word) !(v a) - deriving (Eq,Ord) +data Mat a = Mat {-# UNPACK #-} !Int !(U.Vector Word) !(U.Vector Word) !(I.Vector a) + -- deriving (Eq,Ord) -instance (G.Vector v a, Show a) => Show (Mat v a) where +deriving instance (Vectored a, Eq (I.Vector a)) => Eq (Mat a) +-- Mat n xs ys vs == Mat n' xs' ys' vs' = n == n' && xs == xs' && ys == ys' && vs == vs' + +deriving instance (Vectored a, Ord (I.Vector a)) => Ord (Mat a) + +instance (Vectored a, Show a) => Show (Mat a) where showsPrec d m = G.showsPrec d (m^._Mat) -instance (G.Vector v a, Read a) => Read (Mat v a) where - readPrec = (_Mat #) <$> G.readPrec +instance (Vectored a, Read a) => Read (Mat a) where + readPrec = (_Mat # ) <$> G.readPrec -instance NFData (v a) => NFData (Mat v a) where +instance NFData (I.Vector a) => NFData (Mat a) where rnf (Mat _ xs ys vs) = rnf xs `seq` rnf ys `seq` rnf vs `seq` () -- | bundle up the matrix in a form suitable for vector-algorithms -_Mat :: Iso (Mat u a) (Mat v b) (H.Vector U.Vector u (Key, a)) (H.Vector U.Vector v (Key, b)) +_Mat :: Vectored a => Iso' (Mat a) (H.Vector U.Vector (Vec a) (Key, a)) _Mat = iso (\(Mat n xs ys vs) -> H.V (V_Key n xs ys) vs) (\(H.V (V_Key n xs ys) vs) -> Mat n xs ys vs) {-# INLINE _Mat #-} -- | Access the keys of a matrix -keys :: Lens' (Mat v a) (U.Vector Key) +keys :: Lens' (Mat a) (U.Vector Key) keys f (Mat n xs ys vs) = f (V_Key n xs ys) <&> \ (V_Key n' xs' ys') -> Mat n' xs' ys' vs {-# INLINE keys #-} -- | Access the keys of a matrix -values :: Lens (Mat u a) (Mat v b) (u a) (v b) +values :: Lens (Mat a) (Mat b) (I.Vector a) (I.Vector b) values f (Mat n xs ys vs) = Mat n xs ys <$> f vs {-# INLINE values #-} -instance Functor v => Functor (Mat v) where - fmap = over (values.mapped) - {-# INLINE fmap #-} - -instance Foldable v => Foldable (Mat v) where - foldMap = foldMapOf (values.folded) - {-# INLINE foldMap #-} - -instance Traversable v => Traversable (Mat v) where - traverse = values.traverse - {-# INLINE traverse #-} - -type instance IxValue (Mat v a) = a -type instance Index (Mat v a) = Key +type instance IxValue (Mat a) = a +type instance Index (Mat a) = Key -- traverse a Vector eachV :: (Applicative f, G.Vector v a, G.Vector v b) => (a -> f b) -> v a -> f (v b) eachV f v = G.fromListN (G.length v) <$> traverse f (G.toList v) -instance (Applicative f, G.Vector v a, G.Vector v b) => Each f (Mat v a) (Mat v b) a b where +instance (Applicative f, Vectored a, a ~ b) => Each f (Mat a) (Mat b) a b where each f = _Mat $ eachV $ \(k,v) -> (,) k <$> indexed f k v {-# INLINE each #-} -instance (Functor f, Contravariant f, G.Vector v a) => Contains f (Mat v a) where +instance (Functor f, Contravariant f, Vectored a) => Contains f (Mat a) where contains = containsIx -instance (Applicative f, G.Vector v a) => Ixed f (Mat v a) where +instance (Applicative f, Vectored a) => Ixed f (Mat a) where ix ij@(Key i j) f m@(Mat n xs ys vs) | Just i' <- xs U.!? l, i == i' , Just j' <- ys U.!? l, j == j' = indexed f ij (vs G.! l) <&> \v -> Mat n xs ys (vs G.// [(l,v)]) @@ -209,40 +205,43 @@ where l = search (\k -> Key (xs U.! k) (ys U.! k) >= ij) 0 n {-# INLINE ix #-} -instance (G.Vector v a, Num a, Eq0 a) => Eq0 (Mat v a) where +instance Vectored a => Vectored (Mat a) where + type Vec (Mat a) = V.Vector -- boxed + +instance (Vectored a, Eq0 a) => Eq0 (Mat a) where isZero (Mat n _ _ _) = n == 0 {-# INLINE isZero #-} -- * Construction -- | Build a sparse matrix. -fromList :: G.Vector v a => [(Key, a)] -> Mat v a +fromList :: Vectored a => [(Key, a)] -> Mat a fromList xs = _Mat # H.modify (Sort.sortBy (compare `on` fst)) (H.fromList xs) {-# INLINABLE fromList #-} -- | Transpose a matrix -transpose :: G.Vector v a => Mat v a -> Mat v a +transpose :: Vectored a => Mat a -> Mat a transpose xs = xs & _Mat %~ H.modify (Sort.sortBy (compare `on` fst)) . H.map (first swap) {-# INLINE transpose #-} -- | @singleton@ makes a matrix with a singleton value at a given location -singleton :: G.Vector v a => Key -> a -> Mat v a +singleton :: Vectored a => Key -> a -> Mat a singleton k v = _Mat # H.singleton (k,v) {-# INLINE singleton #-} -- | @ident n@ makes an @n@ x @n@ identity matrix -- --- >>> ident 4 :: Mat U.Vector Int +-- >>> ident 4 -- fromList [(Key 0 0,1),(Key 1 1,1),(Key 2 2,1),(Key 3 3,1)] -ident :: (G.Vector v a, Num a) => Int -> Mat v a +ident :: (Vectored a, Num a) => Int -> Mat a ident w = Mat w (U.generate w fromIntegral) (U.generate w fromIntegral) (G.replicate w 1) {-# INLINE ident #-} -- | The empty matrix -- --- >>> empty :: Mat U.Vector Int +-- >>> empty :: Mat Int -- fromList [] -empty :: G.Vector v a => Mat v a +empty :: Vectored a => Mat a empty = Mat 0 U.empty U.empty G.empty {-# INLINE empty #-} @@ -250,24 +249,23 @@ -- | Count the number of non-zero entries in the matrix -- --- >>> size (ident 4 :: Mat U.Vector Int) +-- >>> size (ident 4) -- 4 -size :: Mat v a -> Int +size :: Mat a -> Int size (Mat n _ _ _) = n {-# INLINE size #-} -- | --- >>> null (empty :: Mat U.Vector Int) +-- >>> null (empty :: Mat Int) -- True -null :: Mat v a -> Bool +null :: Mat a -> Bool null (Mat n _ _ _) = n == 0 {-# INLINE null #-} -instance (G.Vector v a, Num a, Eq0 a) => Num (Mat v a) where - {-# SPECIALIZE instance (Num a, Eq0 a) => Num (Mat V.Vector a) #-} - {-# SPECIALIZE instance Num (Mat U.Vector Int) #-} - {-# SPECIALIZE instance Num (Mat U.Vector Double) #-} - {-# SPECIALIZE instance Num (Mat U.Vector (Complex Double)) #-} +instance (Vectored a, Eq0 a) => Num (Mat a) where + {-# SPECIALIZE instance Num (Mat Int) #-} + {-# SPECIALIZE instance Num (Mat Double) #-} + {-# SPECIALIZE instance Num (Mat (Complex Double)) #-} abs = over each abs {-# INLINE abs #-} signum = over each signum @@ -282,7 +280,7 @@ (-) = addWith0 $ nonZero (-) {-# INLINE (-) #-} (*) = multiplyWith (*) addHeap - {-# INLINEABLE (*) #-} + {-# INLINE (*) #-} -- * Utilities @@ -296,7 +294,7 @@ where m = l + div (h-l) 2 {-# INLINE search #-} -split1 :: G.Vector v a => Word -> Word -> Mat v a -> (Mat v a, Mat v a) +split1 :: Vectored a => Word -> Word -> Mat a -> (Mat a, Mat a) split1 ai bi (Mat n xs ys vs) = (m0,m1) where !aibi = xor ai bi @@ -308,7 +306,7 @@ !m1 = Mat (n-k) xs1 ys1 vs1 {-# INLINE split1 #-} -split2 :: G.Vector v a => Word -> Word -> Mat v a -> (Mat v a, Mat v a) +split2 :: Vectored a => Word -> Word -> Mat a -> (Mat a, Mat a) split2 aj bj (Mat n xs ys vs) = (m0,m1) where !ajbj = xor aj bj @@ -322,23 +320,23 @@ -- | Merge two matrices where the indices coincide into a new matrix. This provides for generalized -- addition, but where the summation of two non-zero entries is necessarily non-zero. -addWith :: G.Vector v a => (a -> a -> a) -> Mat v a -> Mat v a -> Mat v a +addWith :: Vectored a => (a -> a -> a) -> Mat a -> Mat a -> Mat a addWith f xs ys = _Mat # G.unstream (mergeStreamsWith f (G.stream (xs^._Mat)) (G.stream (ys^._Mat))) {-# INLINE addWith #-} -- | Merge two matrices where the indices coincide into a new matrix. This provides for generalized -- addition. Return 'Nothing' for zero. -addWith0 :: G.Vector v a => (a -> a -> Maybe a) -> Mat v a -> Mat v a -> Mat v a +addWith0 :: Vectored a => (a -> a -> Maybe a) -> Mat a -> Mat a -> Mat a addWith0 f xs ys = _Mat # G.unstream (mergeStreamsWith0 f (G.stream (xs^._Mat)) (G.stream (ys^._Mat))) {-# INLINE addWith0 #-} -- | Multiply two matrices using the specified multiplication and addition operation. -multiplyWith :: G.Vector v a => (a -> a -> a) -> (Maybe (Heap a) -> Stream (Key, a)) -> Mat v a -> Mat v a -> Mat v a +multiplyWith :: Vectored a => (a -> a -> a) -> (Maybe (Heap a) -> Stream (Key, a)) -> Mat a -> Mat a -> Mat a {-# INLINEABLE multiplyWith #-} multiplyWith times make x0 y0 = case compare (size x0) 1 of LT -> empty EQ | size y0 == 1 -> _Mat # (G.unstream $ hint $ make $ go11 (lo x0) (head x0) (lo y0) (head y0)) - | otherwise -> _Mat # (G.unstream $ hint $ make $ go12 (lo x0) (head x0) (lo y0) y0 (hi y0)) + | otherwise -> _Mat # (G.unstream $ hint $ make $ go12 (lo x0) (head x0) (lo y0) y0 (hi y0)) GT -> case compare (size y0) 1 of LT -> empty EQ -> _Mat # (G.unstream $ hint $ make $ go21 (lo x0) x0 (hi x0) (lo y0) (head y0)) @@ -405,6 +403,5 @@ hi (Mat _ xs ys _) = Key (U.last xs) (U.last ys) {-# INLINE hi #-} - head :: G.Vector v a => Mat v a -> a head (Mat _ _ _ vs) = G.head vs {-# INLINE head #-} diff --git a/src/Sparse/Matrix/Internal/Key.hs b/src/Sparse/Matrix/Internal/Key.hs --- a/src/Sparse/Matrix/Internal/Key.hs +++ b/src/Sparse/Matrix/Internal/Key.hs @@ -38,8 +38,8 @@ , compares , lts, les, eqs, nes, ges, gts -- * Unboxed vector constructors - , U.MVector(..) - , U.Vector(..) + , U.MVector(MV_Key) + , U.Vector(V_Key) ) where import Data.Bits diff --git a/src/Sparse/Matrix/Internal/Vectored.hs b/src/Sparse/Matrix/Internal/Vectored.hs new file mode 100644 --- /dev/null +++ b/src/Sparse/Matrix/Internal/Vectored.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Sparse.Matrix.Internal.Vectored + ( Vectored(..) + , Vector + -- * Internals + , V_Complex(V_Complex) + , MV_Complex(MV_Complex) + ) 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 qualified Sparse.Matrix.Internal.Key as Key +import Text.Read + +-- * Data types that know how to store themselves in a Vector optimally, maximizing the level of unboxing provided. + +type Vector a = Vec a a + +class (G.Vector (Vec a) a, Monoid (Vec a a)) => Vectored a where + type Vec a :: * -> * + type Vec a = U.Vector + +-- * Unboxed vectors + +instance Vectored () +instance Vectored Double +instance Vectored Float +instance Vectored Int +instance Vectored Int8 +instance Vectored Int16 +instance Vectored Int32 +instance Vectored Int64 +instance Vectored Key.Key +instance Vectored Word +instance Vectored Word8 +instance Vectored Word16 +instance Vectored Word32 +instance Vectored Word64 + +-- * Boxed vectors + +instance Vectored Integer where + type Vec Integer = B.Vector + +-- * Complex numbers are boxed or unboxed based on their components + +#ifndef HLINT +data MV_Complex :: * -> * -> * where + MV_Complex :: {-# UNPACK #-} !Int -> !(G.Mutable (Vec a) s a) -> !(G.Mutable (Vec a) s a) -> MV_Complex s (Complex a) + +data V_Complex :: * -> * where + V_Complex :: {-# UNPACK #-} !Int -> !(Vector a) -> !(Vector a) -> V_Complex (Complex a) +#endif + +type instance G.Mutable V_Complex = MV_Complex + +instance (Vectored 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 (Vectored 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 :: Vec a a) x + $ G.elemseq (undefined :: Vec a a) y z + +instance (Vectored a, RealFloat a, Show a, b ~ Complex a) => Show (V_Complex b) where + showsPrec = G.showsPrec + +instance (Vectored a, RealFloat a, Read a, b ~ Complex a) => Read (V_Complex b) where + readPrec = G.readPrec + readListPrec = readListPrecDefault + +instance (Vectored 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 (Vectored 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 (Vectored a, RealFloat a) => Vectored (Complex a) where + type Vec (Complex a) = V_Complex diff --git a/tests/hlint.hs b/tests/hlint.hs new file mode 100644 --- /dev/null +++ b/tests/hlint.hs @@ -0,0 +1,23 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Main (hlint) +-- Copyright : (C) 2013 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- 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 diff --git a/tests/properties.hs b/tests/properties.hs --- a/tests/properties.hs +++ b/tests/properties.hs @@ -31,10 +31,10 @@ sane :: Linear Int -> Linear Int sane = M.filter (not . M.null) -toLinear :: Mat U.Vector Int -> Linear Int +toLinear :: Mat Int -> Linear Int toLinear = sane . H.foldr (\(k,v) r -> r & at (k^._1) . nonEmpty . at (k^._2) ?~ v) M.empty . view _Mat -fromLinear :: Linear Int -> Mat U.Vector Int +fromLinear :: Linear Int -> Mat Int fromLinear m = SM.fromList $ do (i, n) <- M.toList m (j, a) <- M.toList n @@ -43,7 +43,7 @@ prop_to_from x = toLinear (fromLinear x) == sane x prop_from_to x = fromLinear (toLinear x) == x -prop_model :: Mat U.Vector Int -> Mat U.Vector Int -> Gen Prop +prop_model :: Mat Int -> Mat Int -> Gen Prop prop_model x y | z <- x * y, z' <- fromLinear (toLinear x !*! toLinear y) = label (show z Prelude.++ " == " Prelude.++ show z') (z == z')