diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,25 @@ +Changes in 1.0.0.0 + + * Vector length now expressed as GHC's type level literals. Underlying + implementation still uses Peano numbers to perform induction. This doesn't + change user facing API much. Notably `FlexibleInstances` and + `GADTs`/`TypeFamiles` are now required to write `Arity` constraint. + + * `Monad` constraint is relaxed to `Applicative` where applicable. Duplicate + functions are removed (`sequence` & `sequenceA` → `sequence`, etc) + + * Module `Data.Vector.Fixed.Monomorphic` is dropped. + + * Construction of N-ary vectors reworked. `Make` type class is gone. + + * Boxed arrays now use SmallArrays internally. + + * `overlaps` is removed from API for mutable vectors. + + * `Data.Vector.Fixed.defaultRnf` is added. + + * `Data.Vector.Fixed.Mutable.lengthI` is dropped. + Changes in 0.9.0.0 * Simplification of `Arity` type class. This change shouldn't affect client diff --git a/Data/Vector/Fixed.hs b/Data/Vector/Fixed.hs --- a/Data/Vector/Fixed.hs +++ b/Data/Vector/Fixed.hs @@ -1,10 +1,15 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- Generic API for vectors with fixed length. -- @@ -36,15 +41,6 @@ -- * Vector type class -- ** Vector size Dim - , Z - , S - -- ** Synonyms for small numerals - , N1 - , N2 - , N3 - , N4 - , N5 - , N6 -- ** Type class , Vector(..) , VectorN @@ -61,14 +57,12 @@ , mk3 , mk4 , mk5 - -- ** Consing + , mkN + -- ** Continuation-based vectors , ContVec , empty , vector - , (<|) - -- ** Variadic function - , Make - , mkN + , C.cvec -- ** Functions , replicate , replicateM @@ -85,7 +79,7 @@ , concat , reverse -- ** Indexing & lenses - , C.Index + -- , C.Index , (!) , index , set @@ -109,8 +103,6 @@ , traverse , distribute , collect - , distributeM - , collectM -- * Folding , foldl , foldr @@ -145,6 +137,8 @@ , defaultSizeOf , defaultPeek , defaultPoke + -- * NFData + , defaultRnf -- * Conversion , convert , toList @@ -154,6 +148,7 @@ , fromFoldable -- * Data types , VecList(..) + , VecPeano(..) , Only(..) , Empty(..) -- ** Tuple synonyms @@ -171,14 +166,14 @@ import qualified Data.Traversable as T import Foreign.Storable (Storable(..)) import Foreign.Ptr (castPtr) +import GHC.TypeLits -import Data.Vector.Fixed.Cont (Vector(..),VectorN,Dim,length,ContVec,vector, - empty,S,Z,Arity,Fun(..),accum,apply, - N1,N2,N3,N4,N5,N6,vector) +import Data.Vector.Fixed.Cont (Vector(..),VectorN,Dim,length,ContVec,PeanoNum(..), + vector,empty,Arity,Fun(..),accum,apply,vector) import qualified Data.Vector.Fixed.Cont as C import Data.Vector.Fixed.Internal -import Prelude (Show(..),Eq(..),Ord(..),Functor(..),id,(.),($),seq,undefined) +import Prelude (Show(..),Eq(..),Ord(..),Functor(..),id,(.),($),undefined) -- Needed for doctest import Prelude (Char) @@ -192,6 +187,9 @@ -- >>> mk3 'a' 'b' 'c' :: (Char,Char,Char) -- ('a','b','c') -- +-- Alternatively one could use 'mkN'. See its documentation for +-- examples +-- -- Another option is to create tuple and 'convert' it to desired -- vector type. For example: -- @@ -204,21 +202,8 @@ -- > function :: Vec N3 Double -> ... -- > function (convert -> (x,y,z)) = ... -- --- Third way is to use variadic function 'mkN'. It works similarly to --- 'Text.Printf.printf' except it produces result of type 'ContVec' --- which should be converted to vector of desired type by 'vector': --- --- >>> vector $ mkN 'a' 'b' 'c' :: (Char,Char,Char) --- ('a','b','c') --- --- Probably most generic way is to cons values to the @ContVec@ and --- convert it vector of desired type using 'vector': --- --- >>> vector $ 'a' <| 'b' <| 'c' <| empty :: (Char,Char,Char) --- ('a','b','c') - -- $smallDim -- -- Constructors for vectors with small dimensions. @@ -231,60 +216,39 @@ --------------------------------------------------------------------------------- --- We are trying to be clever with indexing here. It's not possible to --- write generic indexing function. For example it's necessary O(n) --- for VecList. It's however possible to write O(1) indexing for some --- vectors and we trying to use such functions where possible. --- --- We try to use presumable more efficient basicIndex --- --- 1. It should not interfere with deforestation. So we should --- rewrite only when deforestation rule already fired. --- (starting from phase 1). --- --- 2. Creation of vector is costlier than generic indexing so we should --- apply rule only when vector is created anyway --- --- In order to avoid firing this rule on implementation of (!) it has --- been necessary to move definition of all functions to internal module. - -{-# RULES -"fixed-vector:index/basicIndex"[1] forall vv i. - runIndex i (C.cvec vv) = C.basicIndex vv i - #-} - +-- | Type-based vector with statically known length parametrized by +-- GHC's type naturals +newtype VecList (n :: Nat) a = VecList (VecPeano (C.Peano n) a) --- | Vector based on the lists. Not very useful by itself but is --- necessary for implementation. -data VecList n a where - Nil :: VecList Z a - Cons :: a -> VecList n a -> VecList (S n) a +-- | Standard GADT-based vector with statically known length +-- parametrized by Peano numbers. +data VecPeano (n :: PeanoNum) a where + Nil :: VecPeano 'Z a + Cons :: a -> VecPeano n a -> VecPeano ('S n) a deriving (Typeable) instance (Arity n, NFData a) => NFData (VecList n a) where - rnf = foldl (\r a -> r `seq` rnf a) () + rnf = defaultRnf {-# INLINE rnf #-} --- Vector instance type instance Dim (VecList n) = n instance Arity n => Vector (VecList n) a where - construct = accum + construct = fmap VecList $ accum (\(T_List f) a -> T_List (f . Cons a)) (\(T_List f) -> f Nil) - (T_List id :: T_List a n n) - inspect v = inspect $ apply step (Flip v) + (T_List id :: T_List a (C.Peano n) (C.Peano n)) + inspect (VecList v) + = inspect (apply step (Flip v) :: C.ContVec n a) where - step :: Flip VecList a (S k) -> (a, Flip VecList a k) + step :: Flip VecPeano a ('S k) -> (a, Flip VecPeano a k) step (Flip (Cons a xs)) = (a, Flip xs) {-# INLINE construct #-} {-# INLINE inspect #-} instance Arity n => VectorN VecList n a newtype Flip f a n = Flip (f n a) - -newtype T_List a n k = T_List (VecList k a -> VecList n a) +newtype T_List a n k = T_List (VecPeano k a -> VecPeano n a) -- Standard instances @@ -340,7 +304,7 @@ instance NFData a => NFData (Only a) where rnf (Only a) = rnf a -type instance Dim Only = S Z +type instance Dim Only = 1 instance Vector Only a where construct = Fun Only @@ -360,7 +324,13 @@ -- | Empty tuple. -data Empty a = Empty deriving (Typeable, Data) +data Empty a = Empty + deriving (Show,Eq,Ord) +-- GHC7.10 wants standalone deriving for some reason: +-- > No instance for (Typeable a) +-- > arising from the 'deriving' clause of a data type declaration +deriving instance Typeable a => Typeable (Empty a) +deriving instance Data a => Data (Empty a) instance Functor Empty where fmap _ Empty = Empty @@ -373,7 +343,7 @@ instance NFData (Empty a) where rnf Empty = () -type instance Dim Empty = Z +type instance Dim Empty = 0 instance Vector Empty a where construct = Fun Empty diff --git a/Data/Vector/Fixed/Boxed.hs b/Data/Vector/Fixed/Boxed.hs --- a/Data/Vector/Fixed/Boxed.hs +++ b/Data/Vector/Fixed/Boxed.hs @@ -1,9 +1,12 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- Vector which could hold any value. module Data.Vector.Fixed.Boxed ( @@ -20,14 +23,15 @@ import Control.Applicative (Applicative(..)) import Control.DeepSeq (NFData(..)) -import Data.Primitive.Array +import Data.Primitive.SmallArray import Data.Monoid (Monoid(..)) import Data.Data import qualified Data.Foldable as F import qualified Data.Traversable as T import Foreign.Storable (Storable(..)) -import Prelude (Show(..),Eq(..),Ord(..),Functor(..),Monad(..)) -import Prelude ((++),($),($!),undefined,error,seq) +import GHC.TypeLits +import Prelude ( Show(..),Eq(..),Ord(..),Functor(..),Monad(..) + , (++),($),($!),error,seq) import Data.Vector.Fixed hiding (index) import Data.Vector.Fixed.Mutable @@ -40,19 +44,19 @@ ---------------------------------------------------------------- -- | Vector with fixed length which can hold any value. -newtype Vec n a = Vec (Array a) +newtype Vec (n :: Nat) a = Vec (SmallArray a) -- | Mutable unboxed vector with fixed length -newtype MVec n s a = MVec (MutableArray s a) +newtype MVec (n :: Nat) s a = MVec (SmallMutableArray s a) deriving instance Typeable Vec deriving instance Typeable MVec -type Vec1 = Vec (S Z) -type Vec2 = Vec (S (S Z)) -type Vec3 = Vec (S (S (S Z))) -type Vec4 = Vec (S (S (S (S Z)))) -type Vec5 = Vec (S (S (S (S (S Z))))) +type Vec1 = Vec 1 +type Vec2 = Vec 2 +type Vec3 = Vec 3 +type Vec4 = Vec 4 +type Vec5 = Vec 5 instance (Typeable n, Arity n, Data a) => Data (Vec n a) where @@ -94,25 +98,23 @@ type instance Mutable (Vec n) = MVec n instance (Arity n) => MVector (MVec n) a where - overlaps (MVec v) (MVec u) = sameMutableArray v u - {-# INLINE overlaps #-} new = do - v <- newArray (arity (undefined :: n)) uninitialised + v <- newSmallArray (arity (Proxy :: Proxy n)) uninitialised return $ MVec v {-# INLINE new #-} copy = move {-# INLINE copy #-} - move (MVec dst) (MVec src) = copyMutableArray dst 0 src 0 (arity (undefined :: n)) + move (MVec dst) (MVec src) = copySmallMutableArray dst 0 src 0 (arity (Proxy :: Proxy n)) {-# INLINE move #-} - unsafeRead (MVec v) i = readArray v i + unsafeRead (MVec v) i = readSmallArray v i {-# INLINE unsafeRead #-} - unsafeWrite (MVec v) i x = writeArray v i x + unsafeWrite (MVec v) i x = writeSmallArray v i x {-# INLINE unsafeWrite #-} instance (Arity n) => IVector (Vec n) a where - unsafeFreeze (MVec v) = do { a <- unsafeFreezeArray v; return $! Vec a } - unsafeThaw (Vec v) = do { a <- unsafeThawArray v; return $! MVec a } - unsafeIndex (Vec v) i = indexArray v i + unsafeFreeze (MVec v) = do { a <- unsafeFreezeSmallArray v; return $! Vec a } + unsafeThaw (Vec v) = do { a <- unsafeThawSmallArray v; return $! MVec a } + unsafeIndex (Vec v) i = indexSmallArray v i {-# INLINE unsafeFreeze #-} {-# INLINE unsafeThaw #-} {-# INLINE unsafeIndex #-} diff --git a/Data/Vector/Fixed/Cont.hs b/Data/Vector/Fixed/Cont.hs --- a/Data/Vector/Fixed/Cont.hs +++ b/Data/Vector/Fixed/Cont.hs @@ -1,40 +1,33 @@ -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DataKinds, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- API for Church-encoded vectors. Implementation of function from -- "Data.Vector.Fixed" module uses these function internally in order -- to provide shortcut fusion. module Data.Vector.Fixed.Cont ( -- * Type-level numbers - S - , Z + PeanoNum(..) + , Peano , Add - -- ** Isomorphism between Peano number and Nats - -- $natiso - , NatIso - , ToPeano - , ToNat - -- ** Synonyms for small numerals - , N1 - , N2 - , N3 - , N4 - , N5 - , N6 -- * N-ary functions , Fn , Fun(..) - , Arity(..) + , Arity + , ArityPeano(..) + , arity , apply , applyM -- ** Combinators @@ -51,9 +44,12 @@ , Vector(..) , VectorN , length - , Index(..) -- * Vector as continuation , ContVec(..) + , CVecPeano(..) + , consPeano + , toContVec + , runContVec -- * Construction of ContVec , cvec , fromList @@ -90,8 +86,6 @@ , sequence_ , distribute , collect - , distributeM - , collectM , tail , reverse -- ** Zips @@ -103,13 +97,10 @@ , zipWithM_ , izipWithM , izipWithM_ - -- * Running ContVec - , runContVec -- ** Getters , head , index , element - , elementTy -- ** Vector construction , vector -- ** Folds @@ -134,15 +125,16 @@ , gunfold ) where -import Control.Applicative (Applicative(..),(<$>),(<|>)) -import Control.Monad (liftM) +import Control.Applicative ((<|>)) import Data.Coerce -import Data.Complex (Complex(..)) -import Data.Data (Typeable,Data) -import Data.Typeable (Proxy(..)) -import GHC.TypeLits +import Data.Complex (Complex(..)) +import Data.Data (Data) +import Data.Functor.Identity (Identity(..)) +import Data.Typeable (Proxy(..)) import qualified Data.Foldable as F import qualified Data.Traversable as F +import Unsafe.Coerce (unsafeCoerce) +import GHC.TypeLits import Prelude hiding ( replicate,map,zipWith,zipWith3,maximum,minimum,and,or,any,all , foldl,foldr,foldl1,length,sum,reverse,scanl,scanl1 @@ -154,76 +146,46 @@ -- Naturals ---------------------------------------------------------------- --- | Type level zero -data Z deriving Typeable --- | Successor of n -data S n deriving Typeable - --- | Type family for sum of unary natural numbers. -type family Add n m :: * - -type instance Add Z n = n -type instance Add (S n) k = S (Add n k) - -type N1 = S Z -type N2 = S N1 -type N3 = S N2 -type N4 = S N3 -type N5 = S N4 -type N6 = S N5 - - --- $natiso --- --- It's only become possible to define isomorphism between Peano --- number and built-in @Nat@ number in GHC 7.8. It's however --- impossible to define their properties inductively. So Peano number --- are used everywhere. - --- | Isomorphism between two representations of natural numbers -class (ToNat a ~ b, ToPeano b ~ a) => NatIso (a :: *) (b :: Nat) where - --- | Convert Peano number to Nat -type family ToNat (a :: * ) :: Nat where - ToNat Z = 0 - ToNat (S k) = 1 + ToNat k - --- | Convert Nat number to Peano represenation -type family ToPeano (b :: Nat) :: * where - ToPeano 0 = Z - ToPeano n = S (ToPeano (n - 1)) +-- | Peano numbers. Since type level naturals don't support induction +-- we have to convert type nats to Peano representation first and +-- work with it, +data PeanoNum = Z + | S PeanoNum -instance NatIso Z 0 where -instance ( NatIso k (n - 1) - , ToPeano (n - 1) ~ k - , ToPeano n ~ S k - , n ~ (1 + (n - 1)) -- n is positive - ) => NatIso (S k) n where +-- | Convert type level natural to Peano representation +type family Peano (n :: Nat) :: PeanoNum where + Peano 0 = 'Z + Peano n = 'S (Peano (n - 1)) +-- | Type family for sum of unary natural numbers. +type family Add (n :: PeanoNum) (m :: PeanoNum) :: PeanoNum where + Add 'Z n = n + Add ('S n) k = 'S (Add n k) ---------------------------------------------------------------- -- N-ary functions ---------------------------------------------------------------- --- | Type family for n-ary functions. -type family Fn n a b -type instance Fn Z a b = b -type instance Fn (S n) a b = a -> Fn n a b +-- | Type family for n-ary functions. @n@ is number of parameters of +-- type @a@ and @b@ is result type. +type family Fn (n :: PeanoNum) (a :: *) (b :: *) where + Fn 'Z a b = b + Fn ('S n) a b = a -> Fn n a b -- | Newtype wrapper which is used to make 'Fn' injective. It's also a -- reader monad. newtype Fun n a b = Fun { unFun :: Fn n a b } -instance Arity n => Functor (Fun n a) where +instance ArityPeano n => Functor (Fun n a) where fmap f fun = accum (\(T_Flip g) a -> T_Flip (curryFirst g a)) (\(T_Flip x) -> f (unFun x)) (T_Flip fun) {-# INLINE fmap #-} -instance Arity n => Applicative (Fun n a) where +instance ArityPeano n => Applicative (Fun n a) where pure x = accum (\Proxy _ -> Proxy) (\Proxy -> x) Proxy @@ -234,14 +196,13 @@ {-# INLINE pure #-} {-# INLINE (<*>) #-} -instance Arity n => Monad (Fun n a) where +instance ArityPeano n => Monad (Fun n a) where return = pure f >>= g = shuffleFun g <*> f {-# INLINE return #-} {-# INLINE (>>=) #-} - -data T_ap a b c n = T_ap (Fn n a b) (Fn n a c) +data T_ap a b c n = T_ap (Fn n a b) (Fn n a c) @@ -249,114 +210,111 @@ -- Generic operations of N-ary functions ---------------------------------------------------------------- +-- | Type class for type level number for which we can defined +-- operations over N-ary functions. +type Arity n = ( ArityPeano (Peano n) + , KnownNat n + , Peano (n+1) ~ 'S (Peano n) + ) + -- | Type class for handling /n/-ary functions. -class Arity n where +class ArityPeano n where -- | Left fold over /n/ elements exposed as n-ary function. These -- elements are supplied as arguments to the function. - accum :: (forall k. t (S k) -> a -> t k) -- ^ Fold function - -> (t Z -> b) -- ^ Extract result of fold - -> t n -- ^ Initial value - -> Fun n a b -- ^ Reduction function + accum :: (forall k. t ('S k) -> a -> t k) -- ^ Fold function + -> (t 'Z -> b) -- ^ Extract result of fold + -> t n -- ^ Initial value + -> Fun n a b -- ^ Reduction function -- | Apply all parameters to the function. - applyFun :: (forall k. t (S k) -> (a, t k)) -- ^ Get value to apply to function - -> t n -- ^ Initial value - -> Fn n a b -- ^ N-ary function - -> (b, t Z) + applyFun :: (forall k. t ('S k) -> (a, t k)) + -- ^ Get value to apply to function + -> t n + -- ^ Initial value + -> (CVecPeano n a, t 'Z) -- | Apply all parameters to the function using monadic -- actions. Note that for identity monad it's same as -- applyFun. Ignoring newtypes: -- - -- > forall b. Fn n a b -> b ~ ContVecn n a - applyFunM :: Monad m - => (forall k. t (S k) -> m (a, t k)) -- ^ Get value to apply to function - -> t n -- ^ Initial value - -> m (ContVec n a, t Z) - -- | Arity of function. - arity :: n -> Int - + -- > forall b. Fn n a b -> b ~ ContVec n a + applyFunM :: Applicative f + => (forall k. t ('S k) -> (f a, t k)) -- ^ Get value to apply to function + -> t n -- ^ Initial value + -> (f (CVecPeano n a), t 'Z) - -- | Reverse order of parameters. + -- | Reverse order of parameters. It's implemented directly in type + -- class since expressing it in terms of @accum@ will require + -- putting ArityPeano constraint on step funcion reverseF :: Fun n a b -> Fun n a b - -- | Uncurry /n/ first parameters of n-ary function - uncurryMany :: Fun (Add n k) a b -> Fun n a (Fun k a b) - + -- | Worker function for 'gunfold' gunfoldF :: (Data a) => (forall b x. Data b => c (b -> x) -> c x) -> T_gunfold c r a n -> c r - newtype T_gunfold c r a n = T_gunfold (c (Fn n a r)) -- | Apply all parameters to the function. apply :: Arity n - => (forall k. t (S k) -> (a, t k)) -- ^ Get value to apply to function - -> t n -- ^ Initial value - -> ContVec n a -- ^ N-ary function + => (forall k. t ('S k) -> (a, t k)) -- ^ Get value to apply to function + -> t (Peano n) -- ^ Initial value + -> ContVec n a -- ^ N-ary function {-# INLINE apply #-} -apply step z = ContVec $ \(Fun f) -> fst $ applyFun step z f +apply step z = toContVec $ fst (applyFun step z) --- | Apply all parameters to the function using monadic actions. -applyM :: (Monad m, Arity n) - => (forall k. t (S k) -> m (a, t k)) -- ^ Get value to apply to function - -> t n -- ^ Initial value - -> m (ContVec n a) +-- | Apply all parameters to the function using applicative actions. +applyM :: (Applicative f, Arity n) + => (forall k. t ('S k) -> (f a, t k)) -- ^ Get value to apply to function + -> t (Peano n) -- ^ Initial value + -> f (ContVec n a) {-# INLINE applyM #-} -applyM f t = do (v,_) <- applyFunM f t - return v +applyM f t = fmap toContVec $ fst $ applyFunM f t -instance Arity Z where +-- | Arity of function. +arity :: KnownNat n => proxy n -> Int +{-# INLINE arity #-} +arity = fromIntegral . natVal + +instance ArityPeano 'Z where accum _ g t = Fun $ g t - applyFun _ t h = (h,t) - applyFunM _ t = return (empty, t) - arity _ = 0 + applyFun _ t = (CVecPeano unFun, t) + applyFunM _ t = (pure (CVecPeano unFun), t) {-# INLINE accum #-} {-# INLINE applyFun #-} {-# INLINE applyFunM #-} - {-# INLINE arity #-} reverseF = id gunfoldF _ (T_gunfold c) = c - uncurryMany = coerce {-# INLINE reverseF #-} {-# INLINE gunfoldF #-} - {-# INLINE uncurryMany #-} -instance Arity n => Arity (S n) where +instance ArityPeano n => ArityPeano ('S n) where accum f g t = Fun $ \a -> unFun $ accum f g (f t a) - applyFun f t h = case f t of (a,u) -> applyFun f u (h a) - applyFunM f t = do (a,t') <- f t - (vec,tZ) <- applyFunM f t' - return (cons a vec , tZ) - arity _ = 1 + arity (undefined :: n) + applyFun f t = let (a,t') = f t + (v,tZ) = applyFun f t' + in (consPeano a v, tZ) + applyFunM f t = let (a,t') = f t + (vec,t0) = applyFunM f t' + in (consPeano <$> a <*> vec, t0) {-# INLINE accum #-} {-# INLINE applyFun #-} {-# INLINE applyFunM #-} - {-# INLINE arity #-} reverseF f = Fun $ \a -> unFun (reverseF $ apLast f a) gunfoldF f c = gunfoldF f (apGunfold f c) - - uncurryMany :: forall k a b. Fun (Add (S n) k) a b -> Fun (S n) a (Fun k a b) - uncurryMany f - = coerce - (fmap uncurryMany (curryFirst f) :: a -> Fun n a (Fun k a b)) {-# INLINE reverseF #-} {-# INLINE gunfoldF #-} - {-# INLINE uncurryMany #-} apGunfold :: Data a => (forall b x. Data b => c (b -> x) -> c x) - -> T_gunfold c r a (S n) + -> T_gunfold c r a ('S n) -> T_gunfold c r a n apGunfold f (T_gunfold c) = T_gunfold $ f c {-# INLINE apGunfold #-} -newtype T_Flip a b n = T_Flip (Fun n a b) -newtype T_Counter n = T_Counter Int +newtype T_Flip a b n = T_Flip (Fun n a b) @@ -365,55 +323,52 @@ ---------------------------------------------------------------- -- | Prepend ignored parameter to function -constFun :: Fun n a b -> Fun (S n) a b +constFun :: Fun n a b -> Fun ('S n) a b constFun (Fun f) = Fun $ \_ -> f {-# INLINE constFun #-} -- | Curry first parameter of n-ary function -curryFirst :: Fun (S n) a b -> a -> Fun n a b +curryFirst :: Fun ('S n) a b -> a -> Fun n a b curryFirst = coerce {-# INLINE curryFirst #-} -- | Uncurry first parameter of n-ary function -uncurryFirst :: (a -> Fun n a b) -> Fun (S n) a b +uncurryFirst :: (a -> Fun n a b) -> Fun ('S n) a b uncurryFirst = coerce {-# INLINE uncurryFirst #-} -- | Curry last parameter of n-ary function -curryLast :: Arity n => Fun (S n) a b -> Fun n a (a -> b) +curryLast :: ArityPeano n => Fun ('S n) a b -> Fun n a (a -> b) {-# INLINE curryLast #-} -curryLast (Fun f0) = accum (\(T_fun f) a -> T_fun (f a)) - (\(T_fun f) -> f) - (T_fun f0) +-- NOTE: This function is essentially rearrangement of newtypes. Since +-- Fn is closed type family it couldn't be extended and it's +-- quite straightforward to show that both types have same +-- representation. Unfortunately GHC cannot infer it so we have +-- to unsafe-coerce it. +curryLast = unsafeCoerce -newtype T_fun a b n = T_fun (Fn (S n) a b) -- | Curry /n/ first parameters of n-ary function -curryMany :: forall n k a b. Arity n +curryMany :: forall n k a b. ArityPeano n => Fun (Add n k) a b -> Fun n a (Fun k a b) {-# INLINE curryMany #-} -curryMany (Fun f0) = accum - (\(T_curry f) a -> T_curry (f a)) - (\(T_curry f) -> Fun f) - ( T_curry f0 :: T_curry a b k n) - -newtype T_curry a b k n = T_curry (Fn (Add n k) a b) - +-- NOTE: It's same as curryLast +curryMany = unsafeCoerce -- | Apply last parameter to function. Unlike 'apFun' we need to -- traverse all parameters but last hence 'Arity' constraint. -apLast :: Arity n => Fun (S n) a b -> a -> Fun n a b +apLast :: ArityPeano n => Fun ('S n) a b -> a -> Fun n a b apLast f x = fmap ($ x) $ curryLast f {-# INLINE apLast #-} -- | Recursive step for the function -withFun :: (Fun n a b -> Fun n a b) -> Fun (S n) a b -> Fun (S n) a b +withFun :: (Fun n a b -> Fun n a b) -> Fun ('S n) a b -> Fun ('S n) a b withFun f fun = Fun $ \a -> unFun $ f $ curryFirst fun a {-# INLINE withFun #-} -- | Move function parameter to the result of N-ary function. -shuffleFun :: Arity n +shuffleFun :: ArityPeano n => (b -> Fun n a r) -> Fun n a (b -> r) {-# INLINE shuffleFun #-} shuffleFun f0 @@ -430,18 +385,27 @@ ---------------------------------------------------------------- -- | Size of vector expressed as type-level natural. -type family Dim (v :: * -> *) +type family Dim (v :: * -> *) :: Nat -- | Type class for vectors with fixed length. Instance should provide --- two functions: one to create vector and another for vector --- deconstruction. They must obey following law: +-- two functions: one to create vector and another for vector +-- deconstruction. They must obey following law: -- --- > inspect v construct = v +-- > inspect v construct = v +-- +-- For example instance for 2D vectors could be written as: +-- +-- > data V2 a = V2 a a +-- > +-- > type instance V2 = 2 +-- > instance Vector V2 a where +-- > construct = Fun V2 +-- > inspect (V2 a b) (Fun f) = f a b class Arity (Dim v) => Vector v a where -- | N-ary function for creation of vectors. - construct :: Fun (Dim v) a (v a) + construct :: Fun (Peano (Dim v)) a (v a) -- | Deconstruction of vector. - inspect :: v a -> Fun (Dim v) a b -> b + inspect :: v a -> Fun (Peano (Dim v)) a b -> b -- | Optional more efficient implementation of indexing. Shouldn't -- be used directly, use 'Data.Vector.Fixed.!' instead. basicIndex :: v a -> Int -> a @@ -456,34 +420,9 @@ class (Vector (v n) a, Dim (v n) ~ n) => VectorN v n a -- | Length of vector. Function doesn't evaluate its argument. -length :: forall v a. Arity (Dim v) => v a -> Int +length :: forall v a. KnownNat (Dim v) => v a -> Int {-# INLINE length #-} -length _ = arity (undefined :: Dim v) - --- | Type class for indexing of vector when index value is known at --- compile time. -class Index k n where - getF :: k -> Fun n a a - putF :: k -> a -> Fun n a r -> Fun n a r - lensF :: Functor f => k -> (a -> f a) -> Fun n a r -> Fun n a (f r) - -instance Arity n => Index Z (S n) where - getF _ = Fun $ \(a :: a) -> unFun (pure a :: Fun n a a) - putF _ a (Fun f) = Fun $ \_ -> f a - lensF _ f fun = Fun $ \(a :: a) -> unFun $ - (\g -> g <$> f a) <$> shuffleFun (curryFirst fun) - {-# INLINE getF #-} - {-# INLINE putF #-} - {-# INLINE lensF #-} - -instance Index k n => Index (S k) (S n) where - getF _ = Fun $ \(_::a) -> unFun (getF (undefined :: k) :: Fun n a a) - putF _ a (f :: Fun (S n) a b) - = withFun (putF (undefined :: k) a) f - lensF _ f fun = Fun $ \a -> unFun (lensF (undefined :: k) f (curryFirst fun a)) - {-# INLINE getF #-} - {-# INLINE putF #-} - {-# INLINE lensF #-} +length _ = arity (Proxy :: Proxy (Dim v)) ---------------------------------------------------------------- @@ -492,20 +431,31 @@ -- | Vector represented as continuation. Alternative wording: it's -- Church encoded N-element vector. -newtype ContVec n a = ContVec (forall r. Fun n a r -> r) +newtype ContVec n a = ContVec (forall r. Fun (Peano n) a r -> r) type instance Dim (ContVec n) = n +-- | Same as 'ContVec' but its length is expressed as Peano number. +newtype CVecPeano n a = CVecPeano (forall r. Fun n a r -> r) + +-- | Cons values to the @CVecPeano@. +consPeano :: a -> CVecPeano n a -> CVecPeano ('S n) a +consPeano a (CVecPeano cont) = CVecPeano $ \f -> cont $ curryFirst f a +{-# INLINE consPeano #-} + +toContVec :: CVecPeano (Peano n) a -> ContVec n a +toContVec = coerce + instance Arity n => Vector (ContVec n) a where construct = accum - (\(T_mkN f) a -> T_mkN (f . cons a)) - (\(T_mkN f) -> f empty) + (\(T_mkN f) a -> T_mkN (f . consPeano a)) + (\(T_mkN f) -> toContVec $ f (CVecPeano unFun)) (T_mkN id) inspect (ContVec c) f = c f {-# INLINE construct #-} {-# INLINE inspect #-} -newtype T_mkN n_tot a n = T_mkN (ContVec n a -> ContVec n_tot a) +newtype T_mkN n_tot a n = T_mkN (CVecPeano n a -> CVecPeano n_tot a) instance Arity n => VectorN ContVec n a @@ -528,7 +478,7 @@ sequenceA v = inspect v $ sequenceAF construct {-# INLINE sequenceA #-} -sequenceAF :: forall f n a b. (Applicative f, Arity n) +sequenceAF :: forall f n a b. (Applicative f, ArityPeano n) => Fun n a b -> Fun n (f a) (f b) {-# INLINE sequenceAF #-} sequenceAF (Fun f0) @@ -550,7 +500,7 @@ {-# INLINE[0] cvec #-} -- | Create empty vector. -empty :: ContVec Z a +empty :: ContVec 0 a {-# INLINE empty #-} empty = ContVec (\(Fun r) -> r) @@ -560,37 +510,33 @@ fromList :: Arity n => [a] -> ContVec n a {-# INLINE fromList #-} fromList xs = - apply step (T_flist xs) + apply step (Const xs) where - step (T_flist [] ) = error "Data.Vector.Fixed.Cont.fromList: too few elements" - step (T_flist (a:as)) = (a, T_flist as) + step (Const [] ) = error "Data.Vector.Fixed.Cont.fromList: too few elements" + step (Const (a:as)) = (a, Const as) -- | Same as 'fromList' bu throws error is list doesn't have same -- length as vector. fromList' :: forall n a. Arity n => [a] -> ContVec n a {-# INLINE fromList' #-} -fromList' xs = ContVec $ \(Fun fun) -> - let (r,rest) = applyFun step (T_flist xs :: T_flist a n) fun - step (T_flist [] ) = error "Data.Vector.Fixed.Cont.fromList': too few elements" - step (T_flist (a:as)) = (a, T_flist as) - in case rest of - T_flist [] -> r - _ -> error "Data.Vector.Fixed.Cont.fromList': too many elements" +fromList' xs = + let step (Const [] ) = error "Data.Vector.Fixed.Cont.fromList': too few elements" + step (Const (a:as)) = (a, Const as) + in case applyFun step (Const xs :: Const [a] (Peano n)) of + (v,Const []) -> toContVec v + _ -> error "Data.Vector.Fixed.Cont.fromList': too many elements" + -- | Convert list to continuation-based vector. Will fail with -- 'Nothing' if list doesn't have right length. fromListM :: forall n a. Arity n => [a] -> Maybe (ContVec n a) {-# INLINE fromListM #-} -fromListM xs = do - (v,rest) <- applyFunM step (T_flist xs :: T_flist a n) - case rest of - T_flist [] -> return v - _ -> Nothing +fromListM xs = case applyFunM step (Const xs :: Const [a] (Peano n)) of + (Just v, Const []) -> Just (toContVec v) + _ -> Nothing where - step (T_flist [] ) = Nothing - step (T_flist (a:as)) = return (a, T_flist as) - -newtype T_flist a n = T_flist [a] + step (Const [] ) = (Nothing, Const []) + step (Const (a:as)) = (Just a , Const as) -- | Convert vector to the list @@ -605,64 +551,59 @@ replicate a = apply (\Proxy -> (a, Proxy)) Proxy -- | Execute monadic action for every element of vector. -replicateM :: (Arity n, Monad m) => m a -> m (ContVec n a) +replicateM :: (Arity n, Applicative f) => f a -> f (ContVec n a) {-# INLINE replicateM #-} replicateM act - = applyM (\Proxy -> do { a <- act; return (a, Proxy)}) Proxy + = applyM (\Proxy -> (act, Proxy)) Proxy -- | Generate vector from function which maps element's index to its value. generate :: (Arity n) => (Int -> a) -> ContVec n a {-# INLINE generate #-} generate f = - apply (\(T_Counter n) -> (f n, T_Counter (n + 1))) - (T_Counter 0) + apply (\(Const n) -> (f n, Const (n + 1))) (Const 0) -- | Generate vector from monadic function which maps element's index -- to its value. -generateM :: (Monad m, Arity n) => (Int -> m a) -> m (ContVec n a) +generateM :: (Applicative f, Arity n) => (Int -> f a) -> f (ContVec n a) {-# INLINE generateM #-} generateM f = - applyM (\(T_Counter n) -> do { a <- f n; return (a, T_Counter (n + 1)) } ) - (T_Counter 0) + applyM (\(Const n) -> (f n, Const (n + 1))) (Const 0) -- | Unfold vector. unfoldr :: Arity n => (b -> (a,b)) -> b -> ContVec n a {-# INLINE unfoldr #-} unfoldr f b0 = - apply (\(T_unfoldr b) -> let (a,b') = f b in (a, T_unfoldr b')) - (T_unfoldr b0) - -newtype T_unfoldr b n = T_unfoldr b - + apply (\(Const b) -> let (a,b') = f b in (a, Const b')) + (Const b0) -- | Unit vector along Nth axis. basis :: (Num a, Arity n) => Int -> ContVec n a {-# INLINE basis #-} basis n0 = - apply (\(T_Counter n) -> (if n == 0 then 1 else 0, T_Counter (n - 1))) - (T_Counter n0) + apply (\(Const n) -> (if n == 0 then 1 else 0, Const (n - 1))) + (Const n0) -mk1 :: a -> ContVec N1 a +mk1 :: a -> ContVec 1 a mk1 a1 = ContVec $ \(Fun f) -> f a1 {-# INLINE mk1 #-} -mk2 :: a -> a -> ContVec N2 a +mk2 :: a -> a -> ContVec 2 a mk2 a1 a2 = ContVec $ \(Fun f) -> f a1 a2 {-# INLINE mk2 #-} -mk3 :: a -> a -> a -> ContVec N3 a +mk3 :: a -> a -> a -> ContVec 3 a mk3 a1 a2 a3 = ContVec $ \(Fun f) -> f a1 a2 a3 {-# INLINE mk3 #-} -mk4 :: a -> a -> a -> a -> ContVec N4 a +mk4 :: a -> a -> a -> a -> ContVec 4 a mk4 a1 a2 a3 a4 = ContVec $ \(Fun f) -> f a1 a2 a3 a4 {-# INLINE mk4 #-} -mk5 :: a -> a -> a -> a -> a -> ContVec N5 a +mk5 :: a -> a -> a -> a -> a -> ContVec 5 a mk5 a1 a2 a3 a4 a5 = ContVec $ \(Fun f) -> f a1 a2 a3 a4 a5 {-# INLINE mk5 #-} @@ -683,44 +624,42 @@ imap f (ContVec contA) = ContVec $ contA . imapF f --- | Monadic map over vector. -mapM :: (Arity n, Monad m) => (a -> m b) -> ContVec n a -> m (ContVec n b) +-- | Effectful map over vector. +mapM :: (Arity n, Applicative f) => (a -> f b) -> ContVec n a -> f (ContVec n b) {-# INLINE mapM #-} mapM = imapM . const -- | Apply monadic function to every element of the vector and its index. -imapM :: (Arity n, Monad m) => (Int -> a -> m b) -> ContVec n a -> m (ContVec n b) +imapM :: (Arity n, Applicative f) + => (Int -> a -> f b) -> ContVec n a -> f (ContVec n b) {-# INLINE imapM #-} imapM f v = inspect v $ imapMF f construct -- | Apply monadic action to each element of vector and ignore result. -mapM_ :: (Arity n, Monad m) => (a -> m b) -> ContVec n a -> m () +mapM_ :: (Arity n, Applicative f) => (a -> f b) -> ContVec n a -> f () {-# INLINE mapM_ #-} -mapM_ f = foldl (\m a -> m >> f a >> return ()) (return ()) +mapM_ f = foldl (\m a -> m *> f a *> pure ()) (pure ()) -- | Apply monadic action to each element of vector and its index and -- ignore result. -imapM_ :: (Arity n, Monad m) => (Int -> a -> m b) -> ContVec n a -> m () +imapM_ :: (Arity n, Applicative f) => (Int -> a -> f b) -> ContVec n a -> f () {-# INLINE imapM_ #-} -imapM_ f = ifoldl (\m i a -> m >> f i a >> return ()) (return ()) +imapM_ f = ifoldl (\m i a -> m *> f i a *> pure ()) (pure ()) -imapMF :: (Arity n, Monad m) - => (Int -> a -> m b) -> Fun n b r -> Fun n a (m r) +imapMF :: (ArityPeano n, Applicative f) + => (Int -> a -> f b) -> Fun n b r -> Fun n a (f r) {-# INLINE imapMF #-} imapMF f (Fun funB) = - accum (\(T_mapM i m) a -> T_mapM (i+1) $ do b <- f i a - fun <- m - return $ fun b - ) + accum (\(T_mapM i m) a -> T_mapM (i+1) $ ($) <$> m <*> f i a) (\(T_mapM _ m) -> m) - (T_mapM 0 (return funB)) + (T_mapM 0 (pure funB)) data T_mapM a m r n = T_mapM Int (m (Fn n a r)) -imapF :: Arity n +imapF :: ArityPeano n => (Int -> a -> b) -> Fun n b r -> Fun n a r {-# INLINE imapF #-} imapF f (Fun funB) = @@ -731,7 +670,7 @@ data T_map a r n = T_map Int (Fn n a r) -- | Left scan over vector -scanl :: (Arity n) => (b -> a -> b) -> b -> ContVec n a -> ContVec (S n) b +scanl :: (Arity n) => (b -> a -> b) -> b -> ContVec n a -> ContVec (n+1) b {-# INLINE scanl #-} scanl f b0 (ContVec cont) = ContVec $ cont . scanlF f b0 @@ -742,19 +681,19 @@ scanl1 f (ContVec cont) = ContVec $ cont . scanl1F f -scanlF :: forall n a b r. (Arity n) => (b -> a -> b) -> b -> Fun (S n) b r -> Fun n a r +scanlF :: forall n a b r. (ArityPeano n) => (b -> a -> b) -> b -> Fun ('S n) b r -> Fun n a r scanlF f b0 (Fun fun0) = accum step fini start where - step :: forall k. T_scanl r b (S k) -> a -> T_scanl r b k + step :: forall k. T_scanl r b ('S k) -> a -> T_scanl r b k step (T_scanl b fn) a = let b' = f b a in T_scanl b' (fn b') fini (T_scanl _ r) = r start = T_scanl b0 (fun0 b0) :: T_scanl r b n -scanl1F :: forall n a r. (Arity n) => (a -> a -> a) -> Fun n a r -> Fun n a r +scanl1F :: forall n a r. (ArityPeano n) => (a -> a -> a) -> Fun n a r -> Fun n a r scanl1F f (Fun fun0) = accum step fini start where - step :: forall k. T_scanl1 r a (S k) -> a -> T_scanl1 r a k + step :: forall k. T_scanl1 r a ('S k) -> a -> T_scanl1 r a k step (T_scanl1 Nothing fn) a = T_scanl1 (Just a) (fn a) step (T_scanl1 (Just x) fn) a = let a' = f x a in T_scanl1 (Just a') (fn a') fini (T_scanl1 _ r) = r @@ -765,12 +704,12 @@ -- | Evaluate every action in the vector from left to right. -sequence :: (Arity n, Monad m) => ContVec n (m a) -> m (ContVec n a) +sequence :: (Arity n, Applicative f) => ContVec n (f a) -> f (ContVec n a) sequence = mapM id {-# INLINE sequence #-} -- | Evaluate every action in the vector from left to right and ignore result. -sequence_ :: (Arity n, Monad m) => ContVec n (m a) -> m () +sequence_ :: (Arity n, Applicative f) => ContVec n (f a) -> f () sequence_ = mapM_ id {-# INLINE sequence_ #-} @@ -782,55 +721,43 @@ where -- It's not possible to use ContVec as accumulator type since `head' -- require Arity constraint on `k'. So we use plain lists - step (T_distribute f) = ( fmap (\(x:_) -> x) f - , T_distribute $ fmap (\(_:x) -> x) f) - start = T_distribute (fmap toList f0) + step (Const f) = ( fmap (\(x:_) -> x) f + , Const $ fmap (\(_:x) -> x) f) + start = Const (fmap toList f0) collect :: (Functor f, Arity n) => (a -> ContVec n b) -> f a -> ContVec n (f b) collect f = distribute . fmap f {-# INLINE collect #-} --- | The dual of sequence -distributeM :: (Monad m, Arity n) => m (ContVec n a) -> ContVec n (m a) -{-# INLINE distributeM #-} -distributeM f0 - = apply step start - where - step (T_distribute f) = ( liftM (\(x:_) -> x) f - , T_distribute $ liftM (\(_:x) -> x) f) - start = T_distribute (liftM toList f0) - -collectM :: (Monad m, Arity n) => (a -> ContVec n b) -> m a -> ContVec n (m b) -collectM f = distributeM . liftM f -{-# INLINE collectM #-} - -newtype T_distribute a f n = T_distribute (f [a]) - - -- | /O(1)/ Tail of vector. -tail :: ContVec (S n) a -> ContVec n a +tail :: {-FIXME-} Arity n => ContVec (n+1) a -> ContVec n a tail (ContVec cont) = ContVec $ \f -> cont $ constFun f {-# INLINE tail #-} -- | /O(1)/ Prepend element to vector -cons :: a -> ContVec n a -> ContVec (S n) a +cons :: {-FIXME-} Arity n => a -> ContVec n a -> ContVec (n+1) a cons a (ContVec cont) = ContVec $ \f -> cont $ curryFirst f a {-# INLINE cons #-} -- | Prepend single element vector to another vector. -consV :: ContVec (S Z) a -> ContVec n a -> ContVec (S n) a +consV :: {-FIXME-} Arity n => ContVec 1 a -> ContVec n a -> ContVec (n+1) a {-# INLINE consV #-} consV (ContVec cont1) (ContVec cont) = ContVec $ \f -> cont $ curryFirst f $ cont1 $ Fun id -- | /O(1)/ Append element to vector -snoc :: Arity n => a -> ContVec n a -> ContVec (S n) a +snoc :: Arity n => a -> ContVec n a -> ContVec (n+1) a snoc a (ContVec cont) = ContVec $ \f -> cont $ apLast f a {-# INLINE snoc #-} -- | Concatenate vector -concat :: (Arity n, Arity k, Arity (Add n k)) - => ContVec n a -> ContVec k a -> ContVec (Add n k) a +concat :: ( Arity n + , Arity k + , Arity (n + k) + -- Tautology + , Peano (n + k) ~ Add (Peano n) (Peano k) + ) + => ContVec n a -> ContVec k a -> ContVec (n + k) a {-# INLINE concat #-} concat v u = inspect u $ inspect v @@ -870,29 +797,29 @@ izipWith3 f v1 v2 v3 = izipWith (\i a (b, c) -> f i a b c) v1 (zipWith (,) v2 v3) -- | Zip two vector together using monadic function. -zipWithM :: (Arity n, Monad m) => (a -> b -> m c) - -> ContVec n a -> ContVec n b -> m (ContVec n c) +zipWithM :: (Arity n, Applicative f) => (a -> b -> f c) + -> ContVec n a -> ContVec n b -> f (ContVec n c) {-# INLINE zipWithM #-} zipWithM f v w = sequence $ zipWith f v w -zipWithM_ :: (Arity n, Monad m) - => (a -> b -> m c) -> ContVec n a -> ContVec n b -> m () +zipWithM_ :: (Arity n, Applicative f) + => (a -> b -> f c) -> ContVec n a -> ContVec n b -> f () {-# INLINE zipWithM_ #-} zipWithM_ f xs ys = sequence_ (zipWith f xs ys) -- | Zip two vector together using monadic function which takes element -- index as well.. -izipWithM :: (Arity n, Monad m) => (Int -> a -> b -> m c) - -> ContVec n a -> ContVec n b -> m (ContVec n c) +izipWithM :: (Arity n, Applicative f) => (Int -> a -> b -> f c) + -> ContVec n a -> ContVec n b -> f (ContVec n c) {-# INLINE izipWithM #-} izipWithM f v w = sequence $ izipWith f v w -izipWithM_ :: (Arity n, Monad m) - => (Int -> a -> b -> m c) -> ContVec n a -> ContVec n b -> m () +izipWithM_ :: (Arity n, Applicative f) + => (Int -> a -> b -> f c) -> ContVec n a -> ContVec n b -> f () {-# INLINE izipWithM_ #-} izipWithM_ f xs ys = sequence_ (izipWith f xs ys) -izipWithF :: (Arity n) +izipWithF :: (ArityPeano n) => (Int -> a -> b -> c) -> Fun n c r -> Fun n a (Fun n b r) {-# INLINE izipWithF #-} izipWithF f (Fun g0) = @@ -903,14 +830,12 @@ ) makeList -makeList :: Arity n => Fun n a [a] +makeList :: ArityPeano n => Fun n a [a] {-# INLINE makeList #-} makeList = accum - (\(T_mkList xs) x -> T_mkList (xs . (x:))) - (\(T_mkList xs) -> xs []) - (T_mkList id) - -newtype T_mkList a n = T_mkList ([a] -> [a]) + (\(Const xs) x -> Const (xs . (x:))) + (\(Const xs) -> xs []) + (Const id) data T_izip a c r n = T_izip Int [a] (Fn n c r) @@ -922,7 +847,7 @@ -- | Run continuation vector. It's same as 'inspect' but with -- arguments flipped. -runContVec :: Fun n a r +runContVec :: Fun (Peano n) a r -> ContVec n a -> r runContVec f (ContVec c) = c f @@ -934,18 +859,13 @@ {-# INLINE[1] vector #-} -- | Finalizer function for getting head of the vector. -head :: Arity (S n) => ContVec (S n) a -> a --- NOTE: we need constraint `Arity (S n)' instead of `Arity n' because --- `Vector v' entails `Arity (Dim v)' and GHC cannot figure out --- that `Arity (S n)' ⇒ `Arity n' +head :: (Arity n, 1<=n) => ContVec n a -> a {-# INLINE head #-} head = runContVec - $ accum (\(T_head m) a -> T_head $ case m of { Nothing -> Just a; x -> x }) - (\(T_head (Just x)) -> x) - (T_head Nothing) - -data T_head a n = T_head (Maybe a) + $ accum (\(Const m) a -> Const $ case m of { Nothing -> Just a; x -> x }) + (\(Const (Just x)) -> x) + (Const Nothing) -- | /O(n)/ Get value at specified index. @@ -954,18 +874,16 @@ index n | n < 0 = error "Data.Vector.Fixed.Cont.index: index out of range" | otherwise = runContVec $ accum - (\(T_Index x) a -> T_Index $ case x of - Left 0 -> Right a - Left i -> Left (i - 1) - r -> r + (\(Const x) a -> Const $ case x of + Left 0 -> Right a + Left i -> Left (i - 1) + r -> r ) - (\(T_Index x) -> case x of - Left _ -> error "Data.Vector.Fixed.index: index out of range" - Right a -> a + (\(Const x) -> case x of + Left _ -> error "Data.Vector.Fixed.index: index out of range" + Right a -> a ) - (T_Index (Left n)) - -newtype T_Index a n = T_Index (Either Int a) + (Const (Left n)) -- | Twan van Laarhoven lens for continuation based vector @@ -975,27 +893,18 @@ element i f v = inspect v $ elementF i f construct --- | Twan van Laarhoven's lens for element of vector with statically --- known index. -elementTy :: (Arity n, Index k n, Functor f) - => k -> (a -> f a) -> ContVec n a -> f (ContVec n a) -{-# INLINE elementTy #-} -elementTy k f v = inspect v - $ lensF k f construct - - -- | Helper for implementation of Twan van Laarhoven lens. -elementF :: forall a n f r. (Arity n, Functor f) +elementF :: forall a n f r. (ArityPeano n, Functor f) => Int -> (a -> f a) -> Fun n a r -> Fun n a (f r) {-# INLINE elementF #-} elementF n f (Fun fun0) = accum step fini start where - step :: forall k. T_lens f a r (S k) -> a -> T_lens f a r k + step :: forall k. T_lens f a r ('S k) -> a -> T_lens f a r k step (T_lens (Left (0,fun))) a = T_lens $ Right $ fmap fun $ f a step (T_lens (Left (i,fun))) a = T_lens $ Left (i-1, fun a) step (T_lens (Right fun)) a = T_lens $ Right $ fmap ($ a) fun -- - fini :: T_lens f a r Z -> f r + fini :: T_lens f a r 'Z -> f r fini (T_lens (Left _)) = error "Data.Vector.Fixed.lensF: Index out of range" fini (T_lens (Right r)) = r -- @@ -1045,15 +954,13 @@ -- `Arity (S n)`. Latter imply former but GHC cannot infer it. -- | Left fold. -foldl1 :: (Arity (S n)) => (a -> a -> a) -> ContVec (S n) a -> a +foldl1 :: (Arity n, 1 <= n) => (a -> a -> a) -> ContVec n a -> a {-# INLINE foldl1 #-} foldl1 f = runContVec - $ accum (\(T_foldl1 r ) a -> T_foldl1 $ Just $ maybe a (flip f a) r) - (\(T_foldl1 (Just x)) -> x) - (T_foldl1 Nothing) - -newtype T_foldl1 a n = T_foldl1 (Maybe a) + $ accum (\(Const r ) a -> Const $ Just $ maybe a (flip f a) r) + (\(Const (Just x)) -> x) + (Const Nothing) -- | Right fold over continuation vector foldr :: Arity n => (a -> b -> b) -> b -> ContVec n a -> b @@ -1077,12 +984,12 @@ {-# INLINE sum #-} -- | Minimal element of vector. -minimum :: (Ord a, Arity (S n)) => ContVec (S n) a -> a +minimum :: (Ord a, Arity n, 1<=n) => ContVec n a -> a minimum = foldl1 min {-# INLINE minimum #-} -- | Maximal element of vector. -maximum :: (Ord a, Arity (S n)) => ContVec (S n) a -> a +maximum :: (Ord a, Arity n, 1<=n) => ContVec n a -> a maximum = foldl1 max {-# INLINE maximum #-} @@ -1120,7 +1027,7 @@ -> v a -> c (v a) gfoldl f inj v = inspect v - $ gfoldlF f (inj $ unFun (construct :: Fun (Dim v) a (v a))) + $ gfoldlF f (inj $ unFun (construct :: Fun (Peano (Dim v)) a (v a))) -- | Generic 'Data.Data.gunfoldl' which could work with any -- vector. Since vector can only have one constructor argument for @@ -1132,13 +1039,13 @@ gunfold f inj _ = gunfoldF f gun where - con = construct :: Fun (Dim v) a (v a) - gun = T_gunfold (inj $ unFun con) :: T_gunfold c (v a) a (Dim v) + con = construct :: Fun (Peano (Dim v)) a (v a) + gun = T_gunfold (inj $ unFun con) :: T_gunfold c (v a) a (Peano (Dim v)) -gfoldlF :: (Arity n, Data a) - => (forall x y. Data x => c (x -> y) -> x -> c y) - -> c (Fn n a r) -> Fun n a (c r) +gfoldlF :: (ArityPeano n, Data a) + => (forall x y. Data x => c (x -> y) -> x -> c y) + -> c (Fn n a r) -> Fun n a (c r) gfoldlF f c0 = accum (\(T_gfoldl c) x -> T_gfoldl (f c x)) (\(T_gfoldl c) -> c) @@ -1147,6 +1054,8 @@ newtype T_gfoldl c r a n = T_gfoldl (c (Fn n a r)) +-- Const in GHC7.10 is not polykinded +newtype Const a n = Const a ---------------------------------------------------------------- -- Deforestation @@ -1184,17 +1093,26 @@ -- Instances ---------------------------------------------------------------- -type instance Dim Complex = N2 +type instance Dim Complex = 2 -instance RealFloat a => Vector Complex a where +instance Vector Complex a where construct = Fun (:+) inspect (x :+ y) (Fun f) = f x y {-# INLINE construct #-} {-# INLINE inspect #-} -type instance Dim ((,) a) = N2 +type instance Dim Identity = 1 +instance Vector Identity a where + construct = Fun Identity + inspect (Identity x) (Fun f) = f x + {-# INLINE construct #-} + {-# INLINE inspect #-} + + +type instance Dim ((,) a) = 2 + -- | Note this instance (and other instances for tuples) is -- essentially monomorphic in element type. Vector type /v/ of 2 -- element tuple @(Int,Int)@ is @(,) Int@ so it will only work @@ -1206,7 +1124,7 @@ {-# INLINE inspect #-} -type instance Dim ((,,) a b) = N3 +type instance Dim ((,,) a b) = 3 instance (b~a, c~a) => Vector ((,,) b c) a where construct = Fun (,,) @@ -1215,7 +1133,7 @@ {-# INLINE inspect #-} -type instance Dim ((,,,) a b c) = N4 +type instance Dim ((,,,) a b c) = 4 instance (b~a, c~a, d~a) => Vector ((,,,) b c d) a where construct = Fun (,,,) @@ -1224,7 +1142,7 @@ {-# INLINE inspect #-} -type instance Dim ((,,,,) a b c d) = N5 +type instance Dim ((,,,,) a b c d) = 5 instance (b~a, c~a, d~a, e~a) => Vector ((,,,,) b c d e) a where construct = Fun (,,,,) @@ -1233,7 +1151,7 @@ {-# INLINE inspect #-} -type instance Dim ((,,,,,) a b c d e) = N6 +type instance Dim ((,,,,,) a b c d e) = 6 instance (b~a, c~a, d~a, e~a, f~a) => Vector ((,,,,,) b c d e f) a where construct = Fun (,,,,,) @@ -1242,7 +1160,7 @@ {-# INLINE inspect #-} -type instance Dim ((,,,,,,) a b c d e f) = S N6 +type instance Dim ((,,,,,,) a b c d e f) = 7 instance (b~a, c~a, d~a, e~a, f~a, g~a) => Vector ((,,,,,,) b c d e f g) a where construct = Fun (,,,,,,) @@ -1250,9 +1168,8 @@ {-# INLINE construct #-} {-# INLINE inspect #-} -type instance Dim Proxy = Z +type instance Dim Proxy = 0 instance Vector Proxy a where construct = Fun Proxy inspect _ = unFun - diff --git a/Data/Vector/Fixed/Internal.hs b/Data/Vector/Fixed/Internal.hs --- a/Data/Vector/Fixed/Internal.hs +++ b/Data/Vector/Fixed/Internal.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -9,17 +11,18 @@ -- Implementation of fixed-vectors module Data.Vector.Fixed.Internal where -import Control.Applicative (Applicative) -import Control.Monad (liftM) -import Data.Monoid (Monoid(..)) +import Control.DeepSeq (NFData(..)) +import Data.Typeable (Proxy(..)) +import Data.Functor.Identity (Identity(..)) import qualified Data.Foldable as T import qualified Data.Traversable as T import Foreign.Storable (Storable(..)) import Foreign.Ptr (Ptr,castPtr) +import GHC.TypeLits -import Data.Vector.Fixed.Cont (Vector(..),Dim,S,Z,Arity,vector,Add) +import Data.Vector.Fixed.Cont (Vector(..),Dim,Arity,vector,Add) import qualified Data.Vector.Fixed.Cont as C -import Data.Vector.Fixed.Cont (ContVec,Index) + import Prelude hiding ( replicate,map,zipWith,maximum,minimum,and,or,all,any , foldl,foldr,foldl1,length,sum,reverse,scanl,scanl1 , head,tail,mapM,mapM_,sequence,sequence_,concat @@ -30,67 +33,42 @@ -- Constructors ---------------------------------------------------------------- --- | Variadic vector constructor. Resulting vector should be converted --- from 'ContVec' using 'vector' function. For example: --- --- >>> vector $ mkN 'a' 'b' 'c' :: (Char,Char,Char) --- ('a','b','c') -mkN :: Make (S Z) a r => a -> r -mkN = unGo $ make id -{-# INLINE mkN #-} - - --- | Type class for variadic vector constructors. -class Make n a r where - make :: (ContVec Z a -> ContVec n a) -> r - -instance (a'~a, Make (S n) a r) => Make n a' (a -> r) where - make f a = make (C.cons a . f) - {-# INLINE make #-} - -instance Arity n => Make n a (ContVec n a) where - make f = C.reverse $ f C.empty - {-# INLINE make #-} - -newtype Go r = Go { unGo :: r } - -instance Make Z a r => Make Z a (Go r) where - make f = Go $ make f - {-# INLINE make #-} - --- | Cons value to continuation based vector. -(<|) :: a -> ContVec n a -> ContVec (S n) a -(<|) = C.cons -{-# INLINE (<|) #-} - -infixr 1 <| - - -mk0 :: (Vector v a, Dim v ~ C.Z) => v a -mk0 = vector $ C.empty +mk0 :: (Vector v a, Dim v ~ 0) => v a +mk0 = vector C.empty {-# INLINE mk0 #-} -mk1 :: (Vector v a, Dim v ~ C.N1) => a -> v a +mk1 :: (Vector v a, Dim v ~ 1) => a -> v a mk1 a1 = vector $ C.mk1 a1 {-# INLINE mk1 #-} -mk2 :: (Vector v a, Dim v ~ C.N2) => a -> a -> v a +mk2 :: (Vector v a, Dim v ~ 2) => a -> a -> v a mk2 a1 a2 = vector $ C.mk2 a1 a2 {-# INLINE mk2 #-} -mk3 :: (Vector v a, Dim v ~ C.N3) => a -> a -> a -> v a +mk3 :: (Vector v a, Dim v ~ 3) => a -> a -> a -> v a mk3 a1 a2 a3 = vector $ C.mk3 a1 a2 a3 {-# INLINE mk3 #-} -mk4 :: (Vector v a, Dim v ~ C.N4) => a -> a -> a -> a -> v a +mk4 :: (Vector v a, Dim v ~ 4) => a -> a -> a -> a -> v a mk4 a1 a2 a3 a4 = vector $ C.mk4 a1 a2 a3 a4 {-# INLINE mk4 #-} -mk5 :: (Vector v a, Dim v ~ C.N5) => a -> a -> a -> a -> a -> v a +mk5 :: (Vector v a, Dim v ~ 5) => a -> a -> a -> a -> a -> v a mk5 a1 a2 a3 a4 a5 = vector $ C.mk5 a1 a2 a3 a4 a5 {-# INLINE mk5 #-} - +-- | N-ary constructor. Despite scary signature it's just N-ary +-- function with additional type parameter which is used to fix type +-- of vector being constructed. It could be used as: +-- +-- > v = mkN (Proxy @ (Int,Int,Int)) 1 2 3 +-- +-- Or if type of @r@ is fixed elsewhere +-- +-- > v = mkN [v] 1 2 3 +mkN :: forall proxy v a. (Vector v a) + => proxy (v a) -> C.Fn (C.Peano (Dim v)) a (v a) +mkN _ = C.unFun (construct :: C.Fun (C.Peano (Dim v)) a (v a)) ---------------------------------------------------------------- -- Generic functions @@ -127,10 +105,10 @@ -- Hi! -- Hi! -- fromList [(),()] -replicateM :: (Vector v a, Monad m) => m a -> m (v a) +replicateM :: (Vector v a, Applicative f) => f a -> f (v a) {-# INLINE replicateM #-} replicateM - = liftM vector . C.replicateM + = fmap vector . C.replicateM -- | Unit vector along Nth axis. If index is larger than vector @@ -171,9 +149,9 @@ -- | Generate vector from monadic function which maps element's index -- to its value. -generateM :: (Monad m, Vector v a) => (Int -> m a) -> m (v a) +generateM :: (Applicative f, Vector v a) => (Int -> f a) -> f (v a) {-# INLINE generateM #-} -generateM = liftM vector . C.generateM +generateM = fmap vector . C.generateM @@ -187,7 +165,7 @@ -- >>> let x = mk3 1 2 3 :: Vec3 Int -- >>> head x -- 1 -head :: (Vector v a, Dim v ~ S n) => v a -> a +head :: (Vector v a, 1 <= Dim v) => v a -> a {-# INLINE head #-} head = C.head . C.cvec @@ -199,24 +177,28 @@ -- >>> import Data.Complex -- >>> tail (1,2,3) :: Complex Double -- 2.0 :+ 3.0 -tail :: (Vector v a, Vector w a, Dim v ~ S (Dim w)) +tail :: (Vector v a, Vector w a, Dim v ~ (Dim w + 1)) => v a -> w a {-# INLINE tail #-} tail = vector . C.tail . C.cvec -- | Cons element to the vector -cons :: (Vector v a, Vector w a, S (Dim v) ~ Dim w) +cons :: (Vector v a, Vector w a, Dim w ~ (Dim v + 1)) => a -> v a -> w a {-# INLINE cons #-} cons a = vector . C.cons a . C.cvec -- | Append element to the vector -snoc :: (Vector v a, Vector w a, S (Dim v) ~ Dim w) +snoc :: (Vector v a, Vector w a, Dim w ~ (Dim v + 1)) => a -> v a -> w a {-# INLINE snoc #-} snoc a = vector . C.snoc a . C.cvec -concat :: (Vector v a, Vector u a, Vector w a, (Add (Dim v) (Dim u)) ~ Dim w) +concat :: ( Vector v a, Vector u a, Vector w a + , (Dim v + Dim u) ~ Dim w + -- Tautology + , C.Peano (Dim v + Dim u) ~ Add (C.Peano (Dim v)) (C.Peano (Dim u)) + ) => v a -> u a -> w a {-# INLINE concat #-} concat v u = vector $ C.concat (C.cvec v) (C.cvec u) @@ -237,17 +219,40 @@ runIndex = C.index {-# INLINE[0] runIndex #-} +-- We are trying to be clever with indexing here. It's not possible to +-- write generic indexing function. For example it's necessary O(n) +-- for VecList. It's however possible to write O(1) indexing for some +-- vectors and we trying to use such functions where possible. +-- +-- We try to use presumable more efficient basicIndex +-- +-- 1. It should not interfere with deforestation. So we should +-- rewrite only when deforestation rule already fired. +-- (starting from phase 1). +-- +-- 2. Creation of vector is costlier than generic indexing so we should +-- apply rule only when vector is created anyway +-- +-- In order to avoid firing this rule on implementation of (!) it has +-- been necessary to move definition of all functions to internal module. + +{-# RULES +"fixed-vector:index/basicIndex"[1] forall vv i. + runIndex i (C.cvec vv) = C.basicIndex vv i + #-} + + -- | Get element from vector at statically known index -index :: (Vector v a, C.Index k (Dim v)) => v a -> k -> a +index :: (Vector v a, KnownNat k, k + 1 <= Dim v) + => v a -> proxy k -> a {-# INLINE index #-} -index v k = C.runContVec (C.getF k) - $ C.cvec v +index v k = v ! fromIntegral (natVal k) -- | Set n'th element in the vector -set :: (Vector v a, C.Index k (Dim v)) => k -> a -> v a -> v a +set :: (Vector v a, KnownNat k, k + 1 <= Dim v) => proxy k -> a -> v a -> v a {-# INLINE set #-} -set k a v = inspect v - $ C.putF k a construct +set k a = runIdentity . element (fromIntegral (natVal k)) + (const (Identity a)) -- | Twan van Laarhoven's lens for element of vector element :: (Vector v a, Functor f) => Int -> (a -> f a) -> (v a -> f (v a)) @@ -256,12 +261,10 @@ -- | Twan van Laarhoven's lens for element of vector with statically -- known index. -elementTy :: (Vector v a, Index k (Dim v), Functor f) - => k -> (a -> f a) -> (v a -> f (v a)) +elementTy :: (Vector v a, KnownNat k, k + 1 <= Dim v, Functor f) + => proxy k -> (a -> f a) -> (v a -> f (v a)) {-# INLINE elementTy #-} -elementTy k f v = vector `fmap` C.elementTy k f (C.cvec v) - - +elementTy k = element (fromIntegral (natVal k)) -- | Left fold over vector foldl :: Vector v a => (b -> a -> b) -> b -> v a -> b @@ -277,7 +280,7 @@ -- | Left fold over vector -foldl1 :: (Vector v a, Dim v ~ S n) => (a -> a -> a) -> v a -> a +foldl1 :: (Vector v a, 1 <= Dim v) => (a -> a -> a) -> v a -> a {-# INLINE foldl1 #-} foldl1 f = C.foldl1 f . C.cvec @@ -337,7 +340,7 @@ -- >>> let x = mk3 1 2 3 :: Vec3 Int -- >>> maximum x -- 3 -maximum :: (Vector v a, Dim v ~ S n, Ord a) => v a -> a +maximum :: (Vector v a, 1 <= Dim v, Ord a) => v a -> a maximum = C.maximum . C.cvec {-# INLINE maximum #-} @@ -349,7 +352,7 @@ -- >>> let x = mk3 1 2 3 :: Vec3 Int -- >>> minimum x -- 1 -minimum :: (Vector v a, Dim v ~ S n, Ord a) => v a -> a +minimum :: (Vector v a, 1 <= Dim v, Ord a) => v a -> a minimum = C.minimum . C.cvec {-# INLINE minimum #-} @@ -417,27 +420,28 @@ . C.cvec -- | Evaluate every action in the vector from left to right. -sequence :: (Vector v a, Vector v (m a), Monad m) => v (m a) -> m (v a) +sequence :: (Vector v a, Vector v (f a), Applicative f) => v (f a) -> f (v a) {-# INLINE sequence #-} sequence = mapM id -- | Evaluate every action in the vector from left to right and ignore result -sequence_ :: (Vector v (m a), Monad m) => v (m a) -> m () +sequence_ :: (Vector v (f a), Applicative f) => v (f a) -> f () {-# INLINE sequence_ #-} sequence_ = mapM_ id --- | Monadic map over vector. -mapM :: (Vector v a, Vector v b, Monad m) => (a -> m b) -> v a -> m (v b) +-- | Effectful map over vector. +mapM :: (Vector v a, Vector v b, Applicative f) => (a -> f b) -> v a -> f (v b) {-# INLINE mapM #-} -mapM f = liftM vector +mapM f = fmap vector . C.mapM f . C.cvec -- | Apply monadic action to each element of vector and ignore result. -mapM_ :: (Vector v a, Monad m) => (a -> m b) -> v a -> m () +mapM_ :: (Vector v a, Applicative f) => (a -> f b) -> v a -> f () {-# INLINE mapM_ #-} -mapM_ f = foldl (\m a -> m >> f a >> return ()) (return ()) +mapM_ f = C.mapM_ f + . C.cvec -- | Apply function to every element of the vector and its index. @@ -449,21 +453,22 @@ . C.cvec -- | Apply monadic function to every element of the vector and its index. -imapM :: (Vector v a, Vector v b, Monad m) - => (Int -> a -> m b) -> v a -> m (v b) +imapM :: (Vector v a, Vector v b, Applicative f) + => (Int -> a -> f b) -> v a -> f (v b) {-# INLINE imapM #-} -imapM f = liftM vector +imapM f = fmap vector . C.imapM f . C.cvec -- | Apply monadic function to every element of the vector and its -- index and discard result. -imapM_ :: (Vector v a, Monad m) => (Int -> a -> m b) -> v a -> m () +imapM_ :: (Vector v a, Applicative f) => (Int -> a -> f b) -> v a -> f () {-# INLINE imapM_ #-} -imapM_ f = ifoldl (\m i a -> m >> f i a >> return ()) (return ()) +imapM_ f = C.imapM_ f + . C.cvec -- | Left scan over vector -scanl :: (Vector v a, Vector w b, Dim w ~ S (Dim v)) +scanl :: (Vector v a, Vector w b, Dim w ~ (Dim v + 1)) => (b -> a -> b) -> b -> v a -> w b {-# INLINE scanl #-} scanl f x0 = vector . C.scanl f x0 . C.cvec @@ -496,18 +501,8 @@ {-# INLINE collect #-} collect f = vector . C.collect (C.cvec . f) -distributeM :: (Vector v a, Vector v (m a), Monad m) - => m (v a) -> v (m a) -{-# INLINE distributeM #-} -distributeM = vector . C.distributeM . liftM C.cvec -collectM :: (Vector v a, Vector v b, Vector v (m b), Monad m) - => (a -> v b) -> m a -> v (m b) -{-# INLINE collectM #-} -collectM f = vector . C.collectM (C.cvec . f) - - ---------------------------------------------------------------- -- | Zip two vector together using function. @@ -543,17 +538,17 @@ $ C.zipWith3 f (C.cvec v1) (C.cvec v2) (C.cvec v3) -- | Zip two vector together using monadic function. -zipWithM :: (Vector v a, Vector v b, Vector v c, Monad m) - => (a -> b -> m c) -> v a -> v b -> m (v c) +zipWithM :: (Vector v a, Vector v b, Vector v c, Applicative f) + => (a -> b -> f c) -> v a -> v b -> f (v c) {-# INLINE zipWithM #-} -zipWithM f v u = liftM vector +zipWithM f v u = fmap vector $ C.zipWithM f (C.cvec v) (C.cvec u) -- | Zip two vector elementwise using monadic function and discard -- result zipWithM_ - :: (Vector v a, Vector v b, Monad m) - => (a -> b -> m c) -> v a -> v b -> m () + :: (Vector v a, Vector v b, Applicative f) + => (a -> b -> f c) -> v a -> v b -> f () {-# INLINE zipWithM_ #-} zipWithM_ f xs ys = C.zipWithM_ f (C.cvec xs) (C.cvec ys) @@ -578,17 +573,17 @@ -- | Zip two vector together using monadic function which takes element -- index as well.. -izipWithM :: (Vector v a, Vector v b, Vector v c, Monad m) - => (Int -> a -> b -> m c) -> v a -> v b -> m (v c) +izipWithM :: (Vector v a, Vector v b, Vector v c, Applicative f) + => (Int -> a -> b -> f c) -> v a -> v b -> f (v c) {-# INLINE izipWithM #-} -izipWithM f v u = liftM vector +izipWithM f v u = fmap vector $ C.izipWithM f (C.cvec v) (C.cvec u) -- | Zip two vector elementwise using monadic function and discard -- result izipWithM_ - :: (Vector v a, Vector v b, Vector v c, Monad m, Vector v (m c)) - => (Int -> a -> b -> m c) -> v a -> v b -> m () + :: (Vector v a, Vector v b, Vector v c, Applicative f, Vector v (f c)) + => (Int -> a -> b -> f c) -> v a -> v b -> f () {-# INLINE izipWithM_ #-} izipWithM_ f xs ys = C.izipWithM_ f (C.cvec xs) (C.cvec ys) @@ -606,7 +601,7 @@ defaultSizeOf :: forall a v. (Storable a, Vector v a) => v a -> Int -defaultSizeOf _ = sizeOf (undefined :: a) * C.arity (undefined :: Dim v) +defaultSizeOf _ = sizeOf (undefined :: a) * C.arity (Proxy :: Proxy (Dim v)) {-# INLINE defaultSizeOf #-} -- | Default implementation of 'peek' for 'Storable' type class for @@ -623,6 +618,9 @@ defaultPoke ptr = imapM_ (pokeElemOff (castPtr ptr)) +-- | Default implementation of 'rnf' from `NFData' type class +defaultRnf :: (NFData a, Vector v a) => v a -> () +defaultRnf = foldl (\() a -> rnf a) () ---------------------------------------------------------------- @@ -652,7 +650,7 @@ -- length from resulting vector. fromListM :: (Vector v a) => [a] -> Maybe (v a) {-# INLINE fromListM #-} -fromListM = liftM vector . C.fromListM +fromListM = fmap vector . C.fromListM -- | Create vector from 'Foldable' data type. Will return @Nothing@ if -- data type different number of elements that resulting vector. diff --git a/Data/Vector/Fixed/Monomorphic.hs b/Data/Vector/Fixed/Monomorphic.hs deleted file mode 100644 --- a/Data/Vector/Fixed/Monomorphic.hs +++ /dev/null @@ -1,379 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} --- | --- Wrapper function for working with monomorphic vectors. Standard API --- require vector to be parametric in their element type making it --- impossible to work with vectors like --- --- > data Vec3 = Vec3 Double Double Double --- --- This module provides newtype wrapper which allows use of functions --- from "Data.Vector.Fixed" with such data types and function which --- works with such vectors. --- --- Functions have same meaning as ones from "Data.Vector.Fixed" and --- documented there. -module Data.Vector.Fixed.Monomorphic ( - -- * Vector type class - -- ** Vector size - DimMono - , Z - , S - -- ** Synonyms for small numerals - , F.N1 - , F.N2 - , F.N3 - , F.N4 - , F.N5 - , F.N6 - -- ** Type class - , VectorMono(..) - , Arity - , Fun(..) - , length - -- * Constructors - -- $construction - -- ** Small dimensions - -- $smallDim - , mk1 - , mk2 - , mk3 - , mk4 - , mk5 - -- ** Functions - , replicate - , replicateM - , generate - , generateM - , unfoldr - , basis - -- * Modifying vectors - -- ** Transformations - , head - , tail - , reverse - , (!) - -- ** Comparison - , eq - -- ** Maps - , map - , mapM - , mapM_ - , imap - , imapM - , imapM_ - -- * Folding - , foldl - , foldr - , foldl1 - , ifoldl - , ifoldr - , fold - , foldMap - , foldM - , ifoldM - -- ** Special folds - , sum - , maximum - , minimum - , and - , or - , all - , any - , find - -- * Zips - , zipWith - , zipWithM - , izipWith - , izipWithM - -- * Conversion - , convert - , toList - , fromList - ) where - -import Control.Monad (liftM) -import Data.Monoid (Monoid) -import qualified Data.Vector.Fixed as F -import Data.Vector.Fixed.Cont (S,Z,Arity,Fun(..)) -import Prelude (Num,Eq,Ord,Functor(..),Monad(..),Int,Bool,(.),($),Maybe) - - - ----------------------------------------------------------------- --- Wrappers for monomorphic vectors ----------------------------------------------------------------- - --- | Wrapper for monomorphic vectors it provides 'Vector' instance for --- monomorphic vectors. Trick is to restrict type parameter @a@ to --- single possible value. -newtype Mono v a = Mono { getMono :: v } - -type instance F.Dim (Mono v) = DimMono v - -instance (VectorMono v, a ~ VectorElm v, Arity (DimMono v)) => F.Vector (Mono v) a where - construct = fmap Mono construct - inspect = inspect . getMono - basicIndex = basicIndex . getMono - {-# INLINE construct #-} - {-# INLINE inspect #-} - {-# INLINE basicIndex #-} - - --- | Dimensions of monomorphic vector. -type family DimMono v :: * - --- | Counterpart of 'Vector' type class for monomorphic vectors. -class Arity (DimMono v) => VectorMono v where - -- | Type of vector elements. - type VectorElm v :: * - -- | Construct vector - construct :: Fun (DimMono v) (VectorElm v) v - -- | Inspect vector - inspect :: v -> Fun (DimMono v) (VectorElm v) r -> r - -- | Optional more efficient implementation of indexing - basicIndex :: v -> Int -> VectorElm v - basicIndex v i = Mono v F.! i - {-# INLINE basicIndex #-} - --- | Length of vector -length :: Arity (DimMono v) => v -> Int -length = F.length . Mono -{-# INLINE length #-} - - ----------------------------------------------------------------- --- ----------------------------------------------------------------- - -mk1 :: (VectorMono v, VectorElm v ~ a, DimMono v ~ F.N1) - => a -> v -mk1 a1 = getMono $ F.mk1 a1 -{-# INLINE mk1 #-} - -mk2 :: (VectorMono v, VectorElm v ~ a, DimMono v ~ F.N2) - => a -> a-> v -mk2 a1 a2 = getMono $ F.mk2 a1 a2 -{-# INLINE mk2 #-} - -mk3 :: (VectorMono v, VectorElm v ~ a, DimMono v ~ F.N3) - => a -> a-> a -> v -mk3 a1 a2 a3 = getMono $ F.mk3 a1 a2 a3 -{-# INLINE mk3 #-} - -mk4 :: (VectorMono v, VectorElm v ~ a, DimMono v ~ F.N4) - => a -> a-> a -> a -> v -mk4 a1 a2 a3 a4 = getMono $ F.mk4 a1 a2 a3 a4 -{-# INLINE mk4 #-} - -mk5 :: (VectorMono v, VectorElm v ~ a, DimMono v ~ F.N5) - => a -> a-> a -> a -> a -> v -mk5 a1 a2 a3 a4 a5 = getMono $ F.mk5 a1 a2 a3 a4 a5 -{-# INLINE mk5 #-} - -replicate :: (VectorMono v, VectorElm v ~ a) => a -> v -{-# INLINE replicate #-} -replicate = getMono . F.replicate - -replicateM :: (VectorMono v, VectorElm v ~ a, Monad m) => m a -> m v -{-# INLINE replicateM #-} -replicateM a = getMono `liftM` F.replicateM a - -basis :: (VectorMono v, VectorElm v ~ a, Num a) => Int -> v -{-# INLINE basis #-} -basis = getMono . F.basis - -unfoldr :: (VectorMono v, VectorElm v ~ a) => (b -> (a,b)) -> b -> v -{-# INLINE unfoldr #-} -unfoldr f = getMono . F.unfoldr f - -generate :: (VectorMono v, VectorElm v ~ a) => (Int -> a) -> v -{-# INLINE generate #-} -generate = getMono . F.generate - -generateM :: (Monad m, VectorMono v, VectorElm v ~ a) => (Int -> m a) -> m v -{-# INLINE generateM #-} -generateM f = getMono `liftM` F.generateM f - - - ----------------------------------------------------------------- - -head :: (VectorMono v, VectorElm v ~ a, DimMono v ~ S n) => v -> a -{-# INLINE head #-} -head = F.head . Mono - -tail :: ( VectorMono v, VectorElm v ~ a - , VectorMono w, VectorElm w ~ a - , DimMono v ~ S (DimMono w)) - => v -> w -{-# INLINE tail #-} -tail v = getMono $ F.tail $ Mono v - -reverse :: (VectorMono v) => v -> v -reverse = getMono . F.reverse . Mono -{-# INLINE reverse #-} - -(!) :: (VectorMono v, VectorElm v ~ a) => v -> Int -> a -{-# INLINE (!) #-} -v ! n = Mono v F.! n - -foldl :: (VectorMono v, VectorElm v ~ a) - => (b -> a -> b) -> b -> v -> b -{-# INLINE foldl #-} -foldl f x = F.foldl f x . Mono - -foldr :: (VectorMono v, VectorElm v ~ a) - => (a -> b -> b) -> b -> v -> b -{-# INLINE foldr #-} -foldr f x = F.foldr f x . Mono - - -foldl1 :: (VectorMono v, VectorElm v ~ a, DimMono v ~ S n) - => (a -> a -> a) -> v -> a -{-# INLINE foldl1 #-} -foldl1 f = F.foldl1 f . Mono - -ifoldr :: (VectorMono v, VectorElm v ~ a) - => (Int -> a -> b -> b) -> b -> v -> b -{-# INLINE ifoldr #-} -ifoldr f x = F.ifoldr f x . Mono - -ifoldl :: (VectorMono v, VectorElm v ~ a) - => (b -> Int -> a -> b) -> b -> v -> b -{-# INLINE ifoldl #-} -ifoldl f z = F.ifoldl f z . Mono - -fold :: (VectorMono v, Monoid (VectorElm v)) => v -> VectorElm v -fold = F.fold . Mono -{-# INLINE fold #-} - -foldMap :: (VectorMono v, Monoid m) => (VectorElm v -> m) -> v -> m -foldMap f = F.foldMap f . Mono -{-# INLINE foldMap #-} - -foldM :: (VectorMono v, VectorElm v ~ a, Monad m) - => (b -> a -> m b) -> b -> v -> m b -{-# INLINE foldM #-} -foldM f x = F.foldM f x . Mono - -ifoldM :: (VectorMono v, VectorElm v ~ a, Monad m) => (b -> Int -> a -> m b) -> b -> v -> m b -{-# INLINE ifoldM #-} -ifoldM f x = F.ifoldM f x . Mono - - - ----------------------------------------------------------------- - -sum :: (VectorMono v, VectorElm v ~ a, Num a) => v -> a -sum = F.sum . Mono -{-# INLINE sum #-} - -maximum :: (VectorMono v, VectorElm v ~ a, DimMono v ~ S n, Ord a) => v -> a -maximum = F.maximum . Mono -{-# INLINE maximum #-} - -minimum :: (VectorMono v, VectorElm v ~ a, DimMono v ~ S n, Ord a) => v -> a -minimum = F.minimum . Mono -{-# INLINE minimum #-} - -and :: (VectorMono v, VectorElm v ~ Bool) => v -> Bool -and = F.and . Mono -{-# INLINE and #-} - -or :: (VectorMono v, VectorElm v ~ Bool) => v -> Bool -or = F.or . Mono -{-# INLINE or #-} - -all :: (VectorMono v, VectorElm v ~ a) => (a -> Bool) -> v -> Bool -all f = F.all f . Mono -{-# INLINE all #-} - -any :: (VectorMono v, VectorElm v ~ a) => (a -> Bool) -> v -> Bool -any f = F.any f . Mono -{-# INLINE any #-} - -find :: (VectorMono v, VectorElm v ~ a) => (a -> Bool) -> v -> Maybe a -find f = F.find f . Mono -{-# INLINE find #-} - ----------------------------------------------------------------- - -eq :: (VectorMono v, VectorElm v ~ a, Eq a) => v -> v -> Bool -{-# INLINE eq #-} -eq v w = F.eq (Mono v) (Mono w) - - ----------------------------------------------------------------- - -map :: (VectorMono v, VectorElm v ~ a) => (a -> a) -> v -> v -{-# INLINE map #-} -map f = getMono . F.map f . Mono - -mapM :: (VectorMono v, VectorElm v ~ a, Monad m) - => (a -> m a) -> v -> m v -{-# INLINE mapM #-} -mapM f v = getMono `liftM` F.mapM f (Mono v) - -mapM_ :: (VectorMono v, VectorElm v ~ a, Monad m) => (a -> m b) -> v -> m () -{-# INLINE mapM_ #-} -mapM_ f = F.mapM_ f . Mono - - -imap :: (VectorMono v, VectorElm v ~ a) => - (Int -> a -> a) -> v -> v -{-# INLINE imap #-} -imap f = getMono . F.imap f . Mono - -imapM :: (VectorMono v, VectorElm v ~ a, Monad m) - => (Int -> a -> m a) -> v -> m v -{-# INLINE imapM #-} -imapM f v = getMono `liftM` F.imapM f (Mono v) - -imapM_ :: (VectorMono v, VectorElm v ~ a, Monad m) => (Int -> a -> m b) -> v -> m () -{-# INLINE imapM_ #-} -imapM_ f = F.imapM_ f . Mono - - ----------------------------------------------------------------- - -zipWith :: (VectorMono v, VectorElm v ~ a) - => (a -> a -> a) -> v -> v -> v -{-# INLINE zipWith #-} -zipWith f v u = getMono $ F.zipWith f (Mono v) (Mono u) - - -zipWithM :: (VectorMono v, VectorElm v ~ a, Monad m) - => (a -> a -> m a) -> v -> v -> m v -{-# INLINE zipWithM #-} -zipWithM f v u = getMono `liftM` F.zipWithM f (Mono v) (Mono u) - -izipWith :: (VectorMono v, VectorElm v ~ a) - => (Int -> a -> a -> a) -> v -> v -> v -{-# INLINE izipWith #-} -izipWith f v u = getMono $ F.izipWith f (Mono v) (Mono u) - -izipWithM :: (VectorMono v, VectorElm v ~ a, Monad m) - => (Int -> a -> a -> m a) -> v -> v -> m v -{-# INLINE izipWithM #-} -izipWithM f v u = getMono `liftM` F.izipWithM f (Mono v) (Mono u) - - - ----------------------------------------------------------------- - -convert :: (VectorMono v, VectorMono w, VectorElm v ~ VectorElm w, DimMono v ~ DimMono w) - => v -> w -{-# INLINE convert #-} -convert = getMono . F.convert . Mono - -toList :: (VectorMono v, VectorElm v ~ a) => v -> [a] -toList = foldr (:) [] - -fromList :: (VectorMono v, VectorElm v ~ a) => [a] -> v -{-# INLINE fromList #-} -fromList = getMono . F.fromList - diff --git a/Data/Vector/Fixed/Mutable.hs b/Data/Vector/Fixed/Mutable.hs --- a/Data/Vector/Fixed/Mutable.hs +++ b/Data/Vector/Fixed/Mutable.hs @@ -1,8 +1,10 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Type classes for vectors which are implemented on top of the arrays -- and support in-place mutation. API is similar to one used in the @@ -21,7 +23,6 @@ -- * Immutable vectors , IVector(..) , index - , lengthI , freeze , thaw -- * Vector API @@ -31,8 +32,10 @@ import Control.Monad.ST import Control.Monad.Primitive -import Data.Vector.Fixed.Cont (Dim,Arity,Fun(..),S,Vector(..),arity,apply,accum) -import Prelude hiding (read) +import Data.Typeable (Proxy(..)) +import GHC.TypeLits +import Data.Vector.Fixed.Cont (Dim,PeanoNum(..),Peano,Arity,Fun(..),Vector(..),ContVec,arity,apply,accum,length) +import Prelude hiding (read,length) ---------------------------------------------------------------- @@ -43,12 +46,10 @@ type family Mutable (v :: * -> *) :: * -> * -> * -- | Dimension for mutable vector. -type family DimM (v :: * -> * -> *) :: * +type family DimM (v :: * -> * -> *) :: Nat -- | Type class for mutable vectors. class (Arity (DimM v)) => MVector v a where - -- | Checks whether vectors' buffers overlaps - overlaps :: v s a -> v s a -> Bool -- | Copy vector. The two vectors may not overlap. Since vectors' -- length is encoded in the type there is no need in runtime checks. copy :: PrimMonad m @@ -71,7 +72,7 @@ -- | Length of mutable vector. Function doesn't evaluate its argument. lengthM :: forall v s a. (Arity (DimM v)) => v s a -> Int -lengthM _ = arity (undefined :: DimM v) +lengthM _ = arity (Proxy :: Proxy (DimM v)) -- | Create copy of vector. clone :: (PrimMonad m, MVector v a) => v (PrimState m) a -> m (v (PrimState m) a) @@ -107,17 +108,10 @@ -- | Get element at specified index without bounds check. unsafeIndex :: v a -> Int -> a --- | Length of immutable vector. Function doesn't evaluate its argument. -lengthI :: IVector v a => v a -> Int -lengthI = lengthM . cast - where - cast :: v a -> Mutable v () a - cast _ = undefined - index :: IVector v a => v a -> Int -> a {-# INLINE index #-} -index v i | i < 0 || i >= lengthI v = error "Data.Vector.Fixed.Mutable.!: index out of bounds" - | otherwise = unsafeIndex v i +index v i | i < 0 || i >= length v = error "Data.Vector.Fixed.Mutable.!: index out of bounds" + | otherwise = unsafeIndex v i -- | Safely convert mutable vector to immutable. @@ -137,27 +131,29 @@ ---------------------------------------------------------------- -- | Generic inspect implementation for array-based vectors. -inspectVec :: forall v a b. (Arity (Dim v), IVector v a) => v a -> Fun (Dim v) a b -> b +inspectVec :: forall v a b. (Arity (Dim v), IVector v a) => v a -> Fun (Peano (Dim v)) a b -> b {-# INLINE inspectVec #-} inspectVec v - = inspect - $ apply (\(T_idx i) -> (unsafeIndex v i, T_idx (i+1))) - (T_idx 0) - -newtype T_idx n = T_idx Int + = inspect cv + where + cv :: ContVec (Dim v) a + cv = apply (\(Const i) -> (unsafeIndex v i, Const (i+1))) + (Const 0 :: Const Int (Peano (Dim v))) +-- Const in GHC7.10 is not polykinded +newtype Const a n = Const a -- | Generic construct implementation for array-based vectors. -constructVec :: forall v a. (Arity (Dim v), IVector v a) => Fun (Dim v) a (v a) +constructVec :: forall v a. (Arity (Dim v), IVector v a) => Fun (Peano (Dim v)) a (v a) {-# INLINE constructVec #-} constructVec = accum step (\(T_new _ st) -> runST $ unsafeFreeze =<< st :: v a) - (T_new 0 new :: T_new v a (Dim v)) + (T_new 0 new :: T_new v a (Peano (Dim v))) data T_new v a n = T_new Int (forall s. ST s (Mutable v s a)) -step :: (IVector v a) => T_new v a (S n) -> a -> T_new v a n +step :: (IVector v a) => T_new v a ('S n) -> a -> T_new v a n step (T_new i st) x = T_new (i+1) $ do mv <- st unsafeWrite mv i x diff --git a/Data/Vector/Fixed/Primitive.hs b/Data/Vector/Fixed/Primitive.hs --- a/Data/Vector/Fixed/Primitive.hs +++ b/Data/Vector/Fixed/Primitive.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Unboxed vectors with fixed length. Vectors from -- "Data.Vector.Fixed.Unboxed" provide more flexibility at no @@ -29,6 +31,7 @@ import Data.Primitive.ByteArray import Data.Primitive import qualified Foreign.Storable as Foreign (Storable(..)) +import GHC.TypeLits import Prelude (Show(..),Eq(..),Ord(..),Num(..)) import Prelude ((++),($),($!),undefined,seq) @@ -44,19 +47,19 @@ ---------------------------------------------------------------- -- | Unboxed vector with fixed length -newtype Vec n a = Vec ByteArray +newtype Vec (n :: Nat) a = Vec ByteArray -- | Mutable unboxed vector with fixed length -newtype MVec n s a = MVec (MutableByteArray s) +newtype MVec (n :: Nat) s a = MVec (MutableByteArray s) deriving instance Typeable Vec deriving instance Typeable MVec -type Vec1 = Vec (S Z) -type Vec2 = Vec (S (S Z)) -type Vec3 = Vec (S (S (S Z))) -type Vec4 = Vec (S (S (S (S Z)))) -type Vec5 = Vec (S (S (S (S (S Z))))) +type Vec1 = Vec 1 +type Vec2 = Vec 2 +type Vec3 = Vec 3 +type Vec4 = Vec 4 +type Vec5 = Vec 5 @@ -74,15 +77,14 @@ type instance Mutable (Vec n) = MVec n instance (Arity n, Prim a) => MVector (MVec n) a where - overlaps (MVec v) (MVec u) = sameMutableByteArray v u - {-# INLINE overlaps #-} new = do - v <- newByteArray $! arity (undefined :: n) * sizeOf (undefined :: a) + v <- newByteArray $! arity (Proxy :: Proxy n) + * sizeOf (undefined :: a) return $ MVec v {-# INLINE new #-} copy = move {-# INLINE copy #-} - move (MVec dst) (MVec src) = copyMutableByteArray dst 0 src 0 (arity (undefined :: n)) + move (MVec dst) (MVec src) = copyMutableByteArray dst 0 src 0 (arity (Proxy :: Proxy n)) {-# INLINE move #-} unsafeRead (MVec v) i = readByteArray v i {-# INLINE unsafeRead #-} diff --git a/Data/Vector/Fixed/Storable.hs b/Data/Vector/Fixed/Storable.hs --- a/Data/Vector/Fixed/Storable.hs +++ b/Data/Vector/Fixed/Storable.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Storable-based unboxed vectors. module Data.Vector.Fixed.Storable ( @@ -31,11 +33,12 @@ import Foreign.Ptr (castPtr) import Foreign.Storable import Foreign.ForeignPtr -import Foreign.Marshal.Array ( advancePtr, copyArray, moveArray ) +import Foreign.Marshal.Array ( copyArray, moveArray ) import GHC.ForeignPtr ( ForeignPtr(..), mallocPlainForeignPtrBytes ) import GHC.Ptr ( Ptr(..) ) -import Prelude (Show(..),Eq(..),Ord(..),Num(..),Monad(..),IO,Int) -import Prelude ((++),(&&),(||),($),undefined,seq) +import GHC.TypeLits +import Prelude ( Show(..),Eq(..),Ord(..),Num(..),Monad(..),IO,Int + , (++),($),undefined,seq) import Data.Vector.Fixed hiding (index) import Data.Vector.Fixed.Mutable @@ -48,19 +51,19 @@ ---------------------------------------------------------------- -- | Storable-based vector with fixed length -newtype Vec n a = Vec (ForeignPtr a) +newtype Vec (n :: Nat) a = Vec (ForeignPtr a) -- | Storable-based mutable vector with fixed length -newtype MVec n s a = MVec (ForeignPtr a) +newtype MVec (n :: Nat) s a = MVec (ForeignPtr a) deriving instance Typeable Vec deriving instance Typeable MVec -type Vec1 = Vec (S Z) -type Vec2 = Vec (S (S Z)) -type Vec3 = Vec (S (S (S Z))) -type Vec4 = Vec (S (S (S (S Z)))) -type Vec5 = Vec (S (S (S (S (S Z))))) +type Vec1 = Vec 1 +type Vec2 = Vec 2 +type Vec3 = Vec 3 +type Vec4 = Vec 4 +type Vec5 = Vec 5 @@ -98,29 +101,21 @@ type instance Mutable (Vec n) = MVec n instance (Arity n, Storable a) => MVector (MVec n) a where - overlaps (MVec fp) (MVec fq) - = between p q (q `advancePtr` n) || between q p (p `advancePtr` n) - where - between x y z = x >= y && x < z - p = getPtr fp - q = getPtr fq - n = arity (undefined :: n) - {-# INLINE overlaps #-} new = unsafePrimToPrim $ do - fp <- mallocVector $ arity (undefined :: n) + fp <- mallocVector $ arity (Proxy :: Proxy n) return $ MVec fp {-# INLINE new #-} copy (MVec fp) (MVec fq) = unsafePrimToPrim $ withForeignPtr fp $ \p -> withForeignPtr fq $ \q -> - copyArray p q (arity (undefined :: n)) + copyArray p q (arity (Proxy :: Proxy n)) {-# INLINE copy #-} move (MVec fp) (MVec fq) = unsafePrimToPrim $ withForeignPtr fp $ \p -> withForeignPtr fq $ \q -> - moveArray p q (arity (undefined :: n)) + moveArray p q (arity (Proxy :: Proxy n)) {-# INLINE move #-} unsafeRead (MVec fp) i = unsafePrimToPrim @@ -169,16 +164,17 @@ {-# INLINE mappend #-} instance (Arity n, Storable a) => Storable (Vec n a) where - sizeOf _ = arity (undefined :: n) * sizeOf (undefined :: a) + sizeOf _ = arity (Proxy :: Proxy n) + * sizeOf (undefined :: a) alignment _ = alignment (undefined :: a) peek ptr = do arr@(MVec fp) <- new withForeignPtr fp $ \p -> - moveArray p (castPtr ptr) (arity (undefined :: n)) + moveArray p (castPtr ptr) (arity (Proxy :: Proxy n)) unsafeFreeze arr poke ptr (Vec fp) = withForeignPtr fp $ \p -> - moveArray (castPtr ptr) p (arity (undefined :: n)) + moveArray (castPtr ptr) p (arity (Proxy :: Proxy n)) instance (Typeable n, Arity n, Storable a, Data a) => Data (Vec n a) where gfoldl = C.gfoldl diff --git a/Data/Vector/Fixed/Unboxed.hs b/Data/Vector/Fixed/Unboxed.hs --- a/Data/Vector/Fixed/Unboxed.hs +++ b/Data/Vector/Fixed/Unboxed.hs @@ -1,8 +1,10 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} @@ -23,18 +25,22 @@ , Unbox ) where +import Control.Applicative (Const(..)) import Control.Monad -import Control.DeepSeq (NFData(..)) +import Control.DeepSeq (NFData(..)) import Data.Complex -import Data.Monoid (Monoid(..)) import Data.Data -import Data.Int (Int8, Int16, Int32, Int64 ) -import Data.Word (Word,Word8,Word16,Word32,Word64) -import Foreign.Storable (Storable(..)) -import Prelude (Show(..),Eq(..),Ord(..),Int,Double,Float,Char,Bool(..)) -import Prelude ((++),(||),($),(.),seq) +import Data.Functor.Identity (Identity(..)) +import Data.Int (Int8, Int16, Int32, Int64 ) +import Data.Monoid (Monoid(..),Dual(..),Sum(..),Product(..),All(..),Any(..)) +import Data.Ord (Down(..)) +import Data.Word (Word,Word8,Word16,Word32,Word64) +import Foreign.Storable (Storable(..)) +import GHC.TypeLits +import Prelude ( Show(..),Eq(..),Ord(..),Int,Double,Float,Char,Bool(..) + , (++),($),(.),seq) -import Data.Vector.Fixed (Dim,Vector(..),VectorN,S,Z,toList,eq,ord,replicate,zipWith,foldl, +import Data.Vector.Fixed (Dim,Vector(..),VectorN,toList,eq,ord,replicate,zipWith,foldl, defaultSizeOf,defaultAlignemnt,defaultPeek,defaultPoke ) import Data.Vector.Fixed.Mutable @@ -47,17 +53,17 @@ -- Data type ---------------------------------------------------------------- -data family Vec n a -data family MVec n s a +data family Vec (n :: Nat) a +data family MVec (n :: Nat) s a deriving instance Typeable Vec deriving instance Typeable MVec -type Vec1 = Vec (S Z) -type Vec2 = Vec (S (S Z)) -type Vec3 = Vec (S (S (S Z))) -type Vec4 = Vec (S (S (S (S Z)))) -type Vec5 = Vec (S (S (S (S (S Z))))) +type Vec1 = Vec 1 +type Vec2 = Vec 2 +type Vec3 = Vec 3 +type Vec4 = Vec 4 +type Vec5 = Vec 5 class (Arity n, IVector (Vec n) a, MVector (MVec n) a) => Unbox n a @@ -137,8 +143,6 @@ instance Arity n => Unbox n () instance Arity n => MVector (MVec n) () where - overlaps _ _ = False - {-# INLINE overlaps #-} new = return MV_Unit {-# INLINE new #-} copy _ _ = return () @@ -169,8 +173,6 @@ instance Arity n => Unbox n Bool instance Arity n => MVector (MVec n) Bool where - overlaps (MV_Bool v) (MV_Bool w) = overlaps v w - {-# INLINE overlaps #-} new = MV_Bool `liftM` new {-# INLINE new #-} copy (MV_Bool v) (MV_Bool w) = copy v w @@ -206,13 +208,11 @@ -- Primitive wrappers #define primMV(ty,con) \ instance Arity n => MVector (MVec n) ty where { \ -; overlaps (con v) (con w) = overlaps v w \ ; new = con `liftM` new \ ; copy (con v) (con w) = copy v w \ ; move (con v) (con w) = move v w \ ; unsafeRead (con v) i = unsafeRead v i \ ; unsafeWrite (con v) i x = unsafeWrite v i x \ -; {-# INLINE overlaps #-} \ ; {-# INLINE new #-} \ ; {-# INLINE move #-} \ ; {-# INLINE copy #-} \ @@ -265,8 +265,6 @@ instance (Unbox n a) => Unbox n (Complex a) instance (Arity n, MVector (MVec n) a) => MVector (MVec n) (Complex a) where - overlaps (MV_Complex v) (MV_Complex w) = overlaps v w - {-# INLINE overlaps #-} new = MV_Complex `liftM` new {-# INLINE new #-} copy (MV_Complex v) (MV_Complex w) = copy v w @@ -280,7 +278,7 @@ {-# INLINE unsafeWrite #-} instance (Arity n, IVector (Vec n) a) => IVector (Vec n) (Complex a) where - unsafeFreeze (MV_Complex v) = V_Complex `liftM` unsafeFreeze v + unsafeFreeze (MV_Complex v) = V_Complex `liftM` unsafeFreeze v {-# INLINE unsafeFreeze #-} unsafeThaw (V_Complex v) = MV_Complex `liftM` unsafeThaw v {-# INLINE unsafeThaw #-} @@ -298,8 +296,6 @@ instance (Unbox n a, Unbox n b) => Unbox n (a,b) instance (Arity n, MVector (MVec n) a, MVector (MVec n) b) => MVector (MVec n) (a,b) where - overlaps (MV_2 va vb) (MV_2 wa wb) = overlaps va wa || overlaps vb wb - {-# INLINE overlaps #-} new = do as <- new bs <- new return $ MV_2 as bs @@ -340,9 +336,6 @@ instance (Arity n, MVector (MVec n) a, MVector (MVec n) b, MVector (MVec n) c ) => MVector (MVec n) (a,b,c) where - overlaps (MV_3 va vb vc) (MV_3 wa wb wc) - = overlaps va wa || overlaps vb wb || overlaps vc wc - {-# INLINE overlaps #-} new = do as <- new bs <- new cs <- new @@ -380,3 +373,111 @@ unsafeIndex (V_3 v w u) i = (unsafeIndex v i, unsafeIndex w i, unsafeIndex u i) {-# INLINE unsafeIndex #-} + + +---------------------------------------------------------------- +-- Newtype wrappers + +newtype instance MVec n s (Const a b) = MV_Const (MVec n s a) +newtype instance Vec n (Const a b) = V_Const (Vec n a) +instance Unbox n a => Unbox n (Const a b) + +instance (Unbox n a) => MVector (MVec n) (Const a b) where + new = MV_Const `liftM` new + copy (MV_Const v) (MV_Const w) = copy v w + move (MV_Const v) (MV_Const w) = move v w + unsafeRead (MV_Const v) i = Const `liftM` unsafeRead v i + unsafeWrite (MV_Const v) i (Const x) = unsafeWrite v i x + {-# INLINE new #-} + {-# INLINE move #-} + {-# INLINE copy #-} + {-# INLINE unsafeRead #-} + {-# INLINE unsafeWrite #-} + +instance (Unbox n a) => IVector (Vec n) (Const a b) where + unsafeFreeze (MV_Const v) = V_Const `liftM` unsafeFreeze v + unsafeThaw (V_Const v) = MV_Const `liftM` unsafeThaw v + unsafeIndex (V_Const v) i = Const (unsafeIndex v i) + {-# INLINE unsafeFreeze #-} + {-# INLINE unsafeThaw #-} + {-# INLINE unsafeIndex #-} + + +---------------------------------------------------------------- +-- Newtype wrappers with kind * -> * + +#define primNewMV(ty,con) \ +instance Unbox n a => MVector (MVec n) (ty a) where { \ +; new = con `liftM` new \ +; copy (con v) (con w) = copy v w \ +; move (con v) (con w) = move v w \ +; unsafeRead (con v) i = ty `liftM` unsafeRead v i \ +; unsafeWrite (con v) i (ty x) = unsafeWrite v i x \ +; {-# INLINE new #-} \ +; {-# INLINE move #-} \ +; {-# INLINE copy #-} \ +; {-# INLINE unsafeRead #-} \ +; {-# INLINE unsafeWrite #-} \ +} + +#define primNewIV(ty,con,mcon) \ +instance Unbox n a => IVector (Vec n) (ty a) where { \ +; unsafeFreeze (mcon v) = con `liftM` unsafeFreeze v \ +; unsafeThaw (con v) = mcon `liftM` unsafeThaw v \ +; unsafeIndex (con v) i = ty (unsafeIndex v i) \ +; {-# INLINE unsafeFreeze #-} \ +; {-# INLINE unsafeThaw #-} \ +; {-# INLINE unsafeIndex #-} \ +} + +#define primNewWrap(ty,con,mcon) \ +newtype instance MVec n s (ty a) = mcon (MVec n s a) ; \ +newtype instance Vec n (ty a) = con (Vec n a) ; \ +instance Unbox n a => Unbox n (ty a) ; \ +primNewMV(ty, mcon ) ; \ +primNewIV(ty, con, mcon) + + +primNewWrap(Identity, V_Identity, MV_Identity) +primNewWrap(Down, V_Down, MV_Down) +primNewWrap(Dual, V_Dual, MV_Dual) +primNewWrap(Sum, V_Sum, MV_Sum) +primNewWrap(Product, V_Product, MV_Product) + + +---------------------------------------------------------------- +-- Monomorphic newtype wrappers + +#define primNewMonoMV(ty,con) \ +instance Arity n => MVector (MVec n) ty where { \ +; new = con `liftM` new \ +; copy (con v) (con w) = copy v w \ +; move (con v) (con w) = move v w \ +; unsafeRead (con v) i = ty `liftM` unsafeRead v i \ +; unsafeWrite (con v) i (ty x) = unsafeWrite v i x \ +; {-# INLINE new #-} \ +; {-# INLINE move #-} \ +; {-# INLINE copy #-} \ +; {-# INLINE unsafeRead #-} \ +; {-# INLINE unsafeWrite #-} \ +} + +#define primNewMonoIV(ty,con,mcon) \ +instance Arity n => IVector (Vec n) ty where { \ +; unsafeFreeze (mcon v) = con `liftM` unsafeFreeze v \ +; unsafeThaw (con v) = mcon `liftM` unsafeThaw v \ +; unsafeIndex (con v) i = ty (unsafeIndex v i) \ +; {-# INLINE unsafeFreeze #-} \ +; {-# INLINE unsafeThaw #-} \ +; {-# INLINE unsafeIndex #-} \ +} + +#define primNewMonoWrap(ty,repr,con,mcon) \ +newtype instance MVec n s ty = mcon (MVec n s repr) ; \ +newtype instance Vec n ty = con (Vec n repr) ; \ +instance Arity n => Unbox n ty ; \ +primNewMonoMV(ty, mcon ) ; \ +primNewMonoIV(ty, con, mcon) + +primNewMonoWrap(Any, Bool, V_Any, MV_Any) +primNewMonoWrap(All, Bool, V_All, MV_All) diff --git a/fixed-vector.cabal b/fixed-vector.cabal --- a/fixed-vector.cabal +++ b/fixed-vector.cabal @@ -1,5 +1,5 @@ Name: fixed-vector -Version: 0.9.0.0 +Version: 1.0.0.0 Synopsis: Generic vectors with statically known size. Description: Generic library for vectors with statically known @@ -41,9 +41,6 @@ . * Data.Vector.Fixed.Primitive Unboxed vectors based on pritimive package. - . - * Data.Vector.Fixed.Monomorphic - Wrappers for monomorphic vectors Cabal-Version: >= 1.8 License: BSD3 @@ -57,24 +54,19 @@ ChangeLog.md source-repository head - type: hg - location: http://bitbucket.org/Shimuuar/fixed-vector -source-repository head type: git location: http://github.com/Shimuuar/fixed-vector Library Ghc-options: -Wall - Build-Depends: - base >=4.7 && <5, - deepseq, - primitive + Build-Depends: base >=4.8 && <5 + , primitive >=0.6.2 + , deepseq Exposed-modules: -- API Data.Vector.Fixed.Cont Data.Vector.Fixed Data.Vector.Fixed.Generic - Data.Vector.Fixed.Monomorphic -- Arrays Data.Vector.Fixed.Mutable Data.Vector.Fixed.Boxed @@ -88,9 +80,8 @@ Type: exitcode-stdio-1.0 Hs-source-dirs: test Main-is: Doctests.hs - Build-Depends: - base >=3 && <5, - primitive, - -- Additional test dependencies. - doctest >= 0.9, - filemanip == 0.3.6.* + Build-Depends: base >=4.8 && <5 + , primitive >=0.6.2 + -- Additional test dependencies. + , doctest >= 0.9 + , filemanip == 0.3.6.*