diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,235 +1,253 @@ -Changes in 1.2.3.0 +2.1.1.0 [2026.02.28] +------------- +* Missing `Prod` and `Vector` instances are added for `ContVec`. - * Pattern `V1` added - * `COMPLETE` pragmas added for patterns `V1`,`V2`,`V3`,`V4` +2.1.0.0 [2026.01.27] +------------- +* New API for working with vectors that are not parametric in element: + `Data.Vector.Fixed.Mono`. It support data types like `data V2 = V2 !Double + !Double` as well as all existing data types. +* Support for GHC<9.2 dropped. +* `Prim` could be derived using `ViaFixed` by deriving via mechanism and add + data types defined in library now has `Prim` instance. +* `Foldable1` could be derived using `ViaFixed`. All types for which it could be + defined now has it. For GHC<9.6 `foldable1-classes-compat` is used. +* `ifoldl'` added. -Changes in 1.2.2.1 +2.0.0.0 [2025.07.10] +------------------ +* Type family `Dim` returns Peano numbers instead of standard type level + naturals. - * Newtype `StorableViaFixed` for deriving `Storable` instances added. + - `Index` type class restored and all indexing operation are performed in + - `Arity` simplified + - `CVecPeano` dropped and `ContVec` is parameterized using Peano numbers. +* In `ArityPeano` type class methods `reverseF` and `gunfoldF` are replaced + with more general `accumPeano` and `reducePeano`. -Changes in 1.2.1.1 +* `Unbox` vector are fully reworked. All uses of data types with `Unbox` + instances which are defined in the library except `Bool` should work without + changes. - * Fixed bug in `any` (#18) +* `Data.Vector.Fixed.Cont.arity` dropped. +* Type of `D.V.F.Cont.withFun` generalized. -Changes in 1.2.1.0 +* Type class `VectorN` dropped. Use `QuantifiedConstraints` instead. - * Support for GHC7.10 dropped. +* Show instance now has form `[...]` instead of `fromList [...]`. - * Pattern synonyms `V2`,`V3`,`V4` added. +* `ViaFixed` newtype wrapper for deriving instances is + added. `StorableViaFixed` is removed. - * `replicate{,M}` and `generate{,M}` added. +* `Data.Vector.Fixed.Storable.unsafeWith` ensures that pointer won't + get GC'd while function runs. - * Functions `mk6`, `mk7`, `mk8` added. +* `Data.Vector.Fixed.sequenceA` is deprecated in favor of `sequence`. +* `foldl'` and `ifoldl'` functions added. -Changes in 1.2.0.0 +* Implement `sum` as in terms of `foldl'`. - * `Show` instance for data type now respect precedence. -Changes in 1.1.0.0 +1.2.3.0 [2023-10-31] +-------------------- +* Pattern `V1` added +* `COMPLETE` pragmas added for patterns `V1`,`V2`,`V3`,`V4` - * GHC8.4 compatibility release. Semigroup instances added and - semigroup dependency added for GHC7.10 -Changes in 1.0.0.0 +1.2.2.1 [2022-12-29] +-------------------- +* Newtype `StorableViaFixed` for deriving `Storable` instances added. - * 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) +1.2.1.1 [2022-12-26] +-------------------- +* Fixed bug in `any` (#18) - * Module `Data.Vector.Fixed.Monomorphic` is dropped. - * Construction of N-ary vectors reworked. `Make` type class is gone. +1.2.1.0 [2021-11-13] +-------------------- +* Support for GHC7.10 dropped. +* Pattern synonyms `V2`,`V3`,`V4` added. +* `replicate{,M}` and `generate{,M}` added. +* Functions `mk6`, `mk7`, `mk8` added. - * Boxed arrays now use SmallArrays internally. - * `overlaps` is removed from API for mutable vectors. +1.2.0.0 [2018-09-02] +-------------------- +* `Show` instance for data type now respect precedence. - * `Data.Vector.Fixed.defaultRnf` is added. - * `Data.Vector.Fixed.Mutable.lengthI` is dropped. +1.1.0.0 [2018-03-11] +-------------------- +* GHC8.4 compatibility release. Semigroup instances added and + semigroup dependency added for GHC7.10 -Changes in 0.9.0.0 - * Simplification of `Arity` type class. This change shouldn't affect client - code. - - * Support for GHC < 7.8 is droppped. - - * Fixed bug in `any`. +1.0.0.0 [2017-11-06] +-------------------- +* 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.8.1.0 - - * `find` function added. +0.9.0.0 [2016-09-14] +-------------------- +* Simplification of `Arity` type class. This change shouldn't affect client + code. +* Support for GHC < 7.8 is droppped. +* Fixed bug in `any`. -Changes in 0.8.0.0 - - * NFData instances for all data type. - - * Storable instances for all data types and default implementation of - Storable's methods added. - - * {i,}zipWith3 and {i,}zipWithM_ added. +0.8.1.0 [2015-08-27] +-------------------- +* `find` function added. -Changes in 0.7.0.3 - - * GHC 7.10 support +0.8.0.0 [2015-04-06] +-------------------- +* NFData instances for all data type. +* Storable instances for all data types and default implementation of + Storable's methods added. +* {i,}zipWith3 and {i,}zipWithM_ added. -Changes in 0.7.0.0 - - * Type level addition for unary numbers added - - * `concat` function added - - * More consistent naming for functions for working with `Fun` +0.7.0.3 [2015-01-03] +-------------------- +* GHC 7.10 support -Changes in 0.6.4.0 - - * Isomorphism between Peano numbers and Nat added. (GHC >= 7.8) +0.7.0.0 [2014-08-15] +-------------------- +* Type level addition for unary numbers added +* `concat` function added +* More consistent naming for functions for working with `Fun` -Changes in 0.6.3.1 - - * Documentation fixes. +0.6.4.0 [2014-04-15] +-------------------- +* Isomorphism between Peano numbers and Nat added. (GHC >= 7.8) -Changes in 0.6.3.0 - - * Left scans added. +0.6.3.1 [2014-03-12] +-------------------- +* Documentation fixes. -Changes in 0.6.2.0 - - * `Vec1` type synonym for boxed/unboxed/etc. vectors added. - - * Vector instance for Data.Typeable.Proxy (GHC >= 7.8) +0.6.3.0 [2014-02-22] +-------------------- +* Left scans added. -Changes in 0.6.1.1 - - * GHC 7.8 support +0.6.2.0 [2014-02-07] +-------------------- +* `Vec1` type synonym for boxed/unboxed/etc. vectors added. +* Vector instance for Data.Typeable.Proxy (GHC >= 7.8) -Changes in 0.6.1.0 - - * `distribute` `collect` and their monadic variants added. +0.6.1.1 [2014-02-04] +-------------------- +* GHC 7.8 support -Changes in 0.6.0.0 - - * Data instance for all array-based vectors added. - - * Storable instance added for `Storable.Vec`. - - * Monoid instances added for all vectors. +0.6.1.0 [2014-01-24] +-------------------- +* `distribute` `collect` and their monadic variants added. -Changes in 0.5.1.0 +0.6.0.0 [2013-11-17] +-------------------- +* Data instance for all array-based vectors added. +* Storable instance added for `Storable.Vec`. +* Monoid instances added for all vectors. - * Zero-element vector `Empty'`is added. +0.5.1.0 [2013-08-06] +-------------------- +* Zero-element vector `Empty'`is added. -Changes in 0.5.0.0 - - * `ContVec` now behaves like normal vector. `Arity` type class is - reworked. `Id' data type is removed. - - * Construction of vector reworked. - - * `reverse`, `snoc`, `consV`, `fold` and `foldMap` are added. - - * Type changing maps and zips are added. - - * Vector indexing with type level numbers is added. - - * Twan van Laarhoven's lens added. (`element` and `elementTy`) - - * Ord instances added to vector data types defined in the library. +0.5.0.0 [2013-08-02] +-------------------- +* `ContVec` now behaves like normal vector. `Arity` type class is + reworked. `Id` data type is removed. +* Construction of vector reworked. +* `reverse`, `snoc`, `consV`, `fold` and `foldMap` are added. +* Type changing maps and zips are added. +* Vector indexing with type level numbers is added. +* Twan van Laarhoven's lens added. (`element` and `elementTy`) +* Ord instances added to vector data types defined in the library. -Changes in 0.4.4.0 - - * Functor and Applicative instances are added to Id. +0.4.4.0 [2013-06-13] +-------------------- +* Functor and Applicative instances are added to Id. -Changes in 0.4.3.0 - - * Typeable instance for S and Z added. +0.4.3.0 [2013-05-18] +-------------------- +* Typeable instance for S and Z added. -Changes in 0.4.2.0 - - * 1-tuple `Only` added. - - * `fromList'` and fromListM added. - - * apply functions from Arity type class generalized. +0.4.2.0 [2013-05-01] +-------------------- +* 1-tuple `Only` added. +* `fromList'` and fromListM added. +* apply functions from Arity type class generalized. -Changes in 0.4.1.0 - - * `cons` function added. - - * Getter for `Fun` data type added. +0.4.1.0 [2013-04-29] +-------------------- +* `cons` function added. +* Getter for `Fun` data type added. -Changes in 0.4.0.0 - - * Wrapper for monomorphics vectors is added. - - * `VecList` is reimplemented as GADT and constructors are exported. - - * Constructor of `ContVecT` is exported - - * Empty `ContVecT` is implemented as `empty`. - - * Typeable, Foldable and Traversable instances are added where - appropriate +0.4.0.0 [2013-04-04] +-------------------- +* Wrapper for monomorphics vectors is added. +* `VecList` is reimplemented as GADT and constructors are exported. +* Constructor of `ContVecT` is exported +* Empty `ContVecT` is implemented as `empty`. +* Typeable, Foldable and Traversable instances are added where + appropriate -Changes in 0.3.0.0 - - * Vector type class definition is moved to the D.V.F.Cont module. - - * Indexing function restored. - - * `unfoldr` added. +0.3.0.0 [2013-03-06] +-------------------- +* Vector type class definition is moved to the D.V.F.Cont module. +* Indexing function restored. +* `unfoldr` added. -Changes in 0.2.0.0 - - * Continuation-based vector added. - - * Right fold added. - - * tailWith, convertContinuation, and ! from - Data.Vector.Fixed removed. - - * Vector instance for tuples added. +0.2.0.0 [2013-02-10] +-------------------- +* Continuation-based vector added. +* Right fold added. +* tailWith, convertContinuation, and ! from + Data.Vector.Fixed removed. +* Vector instance for tuples added. -Changes in 0.1.2 - - * imap, imapM, ifoldl, ifoldM, zipWithM, izipWithM - functions are added. - - * VectorN type class added. +0.1.2 [2013-01-26] +------------------ +* imap, imapM, ifoldl, ifoldM, zipWithM, izipWithM + functions are added. +* VectorN type class added. -Changes in 0.1.1 - - * foldM and tailWith added. Type synonyms for numbers up to 6 are - added. Fun is reexported from Data.Vector.Fixed. +0.1.1 [2012-11-29] +------------------ +* foldM and tailWith added. Type synonyms for numbers up to 6 are + added. Fun is reexported from Data.Vector.Fixed. diff --git a/Data/Vector/Fixed.hs b/Data/Vector/Fixed.hs --- a/Data/Vector/Fixed.hs +++ b/Data/Vector/Fixed.hs @@ -1,37 +1,45 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -- | --- Generic API for vectors with fixed length. +-- @fixed-vector@ library provides general API for working with short +-- N-element arrays. Functions in this module work on data types which +-- are instances of 'Vector' type class. We provide instances for data +-- types from @base@: tuples, 'Data.Complex.Complex', and few others. +-- There are several length polymorphic arrays: -- --- For encoding of vector size library uses Peano naturals defined in --- the library. At come point in the future it would make sense to --- switch to new GHC type level numerals. +-- * Lazy boxed arrays "Data.Vector.Fixed.Boxed". -- --- [@Common pitfalls@] +-- * Strict boxed arrays "Data.Vector.Fixed.Strict". -- --- Library provide instances for tuples. But there's a catch. Tuples --- are monomorphic in element type. Let consider 2-tuple @(Int,Int)@. --- Vector type @v@ is @(,) Int@ and only allowed element type is --- @Int@. Because of that we cannot change element type and following --- code will fail: +-- * Arrays backed by single @ByteArray@: "Data.Vector.Fixed.Primitive". -- +-- * Arrays backed by pinned memory: "Data.Vector.Fixed.Storable". +-- +-- * Arrays which infer array representation from element data type: +-- "Data.Vector.Fixed.Unboxed" +-- +-- * Continuation based 'Data.Vector.Fixed.Cont.ContVec' which used +-- by library internally. +-- +-- Type level naturals don't have support for induction so all type +-- level computation with length and indices are done using Peano +-- numerals ('PeanoNum'). Type level naturals are only used as type +-- parameters for defining length of arrays. +-- +-- [@Instances for tuples@] +-- +-- Library provides instances for tuples. They however come with caveat. +-- Let look at 'Vector' instance for 2-tuple: +-- +-- > instance b ~ a => Vector ((,) b) a +-- +-- Tuple could only be @Vector@ instance if all elements have same +-- type. so first element fixes type of second one. Thus functions +-- which change element type like 'map' won't work: +-- -- > >>> map (== 1) ((1,2) :: (Int,Int)) -- > -- > :3:1: @@ -39,25 +47,29 @@ -- > In the expression: F.map (== 1) ((1, 2) :: (Int, Int)) -- > In an equation for `it': it = map (== 1) ((1, 2) :: (Int, Int)) -- --- To make it work we need to change vector type as well. Functions --- from module "Data.Vector.Fixed.Generic" provide this functionality. +-- This could be solved either by switching to @ContVec@ manually: -- --- > >>> map (== 1) ((1,2) :: (Int,Int)) :: (Bool,Bool) --- > (True,False) +-- >>> (vector . map (==1) . cvec) ((1, 2) :: Tuple2 Int) :: Tuple2 Bool +-- (True,False) +-- +-- or by using functions genereic in vector type from module +-- "Data.Vector.Fixed.Generic". module Data.Vector.Fixed ( -- * Vector type class - -- ** Vector size - Dim - -- ** Type class - , Vector(..) - , VectorN + Vector(..) + , Dim , Arity + , ArityPeano , Fun(..) , length - -- * Constructors + -- ** Peano numbers + , PeanoNum(..) + , C.Peano + , C.N1, C.N2, C.N3, C.N4, C.N5, C.N6, C.N7, C.N8 + -- * Construction and destructions -- $construction - -- ** Small dimensions - -- $smallDim + + -- ** Constructors , mk0 , mk1 , mk2 @@ -68,24 +80,19 @@ , mk7 , mk8 , mkN - -- ** Pattern for low-dimension vectors + -- ** Pattern synonyms , pattern V1 , pattern V2 , pattern V3 , pattern V4 - -- ** Continuation-based vectors - , ContVec - , empty - , vector - , C.cvec - -- ** Functions + -- * Functions + -- ** Creation , replicate , replicateM , generate , generateM , unfoldr , basis - -- * Modifying vectors -- ** Transformations , head , tail @@ -94,15 +101,12 @@ , concat , reverse -- ** Indexing & lenses - -- , C.Index + , C.Index , (!) , index , set , element , elementTy - -- ** Comparison - , eq - , ord -- ** Maps , map , mapM @@ -114,21 +118,22 @@ , scanl1 , sequence , sequence_ - , sequenceA , traverse , distribute , collect - -- * Folding + -- ** Folds , foldl + , foldl' , foldr , foldl1 , fold , foldMap , ifoldl + , ifoldl' , ifoldr , foldM , ifoldM - -- ** Special folds + -- *** Special folds , sum , maximum , minimum @@ -137,7 +142,7 @@ , all , any , find - -- * Zips + -- ** Zips , zipWith , zipWith3 , zipWithM @@ -146,16 +151,10 @@ , izipWith3 , izipWithM , izipWithM_ - -- * Storable methods - -- $storable - , StorableViaFixed(..) - , defaultAlignemnt - , defaultSizeOf - , defaultPeek - , defaultPoke - -- * NFData - , defaultRnf - -- * Conversion + -- *** Special zips + , eq + , ord + -- ** Conversion , convert , toList , fromList @@ -172,26 +171,49 @@ , Tuple3 , Tuple4 , Tuple5 + -- ** Continuation-based vectors + , ContVec + , empty + , vector + , cvec + -- * Instance deriving + , ViaFixed(..) + -- ** Storable + -- $storable + , defaultAlignemnt + , defaultSizeOf + , defaultPeek + , defaultPoke + -- ** NFData + , defaultRnf + -- * Deprecated functions + , sequenceA ) where -import Control.Applicative (Applicative(..),(<$>)) -import Control.DeepSeq (NFData(..)) +import Control.Applicative (Applicative(..)) +import Control.DeepSeq (NFData(..)) +import Control.Monad.Primitive (PrimBase(..)) import Data.Coerce -import Data.Data (Typeable,Data) -import Data.Monoid (Monoid(..)) -import Data.Semigroup (Semigroup(..)) -import qualified Data.Foldable as F -import qualified Data.Traversable as T -import Foreign.Storable (Storable(..)) -import Foreign.Ptr (castPtr) +import Data.Data (Data) +import Data.Monoid (Monoid(..)) +import Data.Semigroup (Semigroup(..)) +import Data.Foldable qualified as F +import Data.Traversable qualified as T +import Data.Foldable1 qualified as F1 +import Data.Primitive.Types (Prim(..)) +import Foreign.Storable (Storable(..)) import GHC.TypeLits +import GHC.Exts (Proxy#,proxy#,(*#),(+#),Int(..),Int#) +import GHC.ST (ST(..)) -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 Data.Vector.Fixed.Cont (Vector(..),Dim,length,ContVec,PeanoNum(..), + vector,cvec,empty,Arity,ArityPeano,Fun(..),accum,apply) +import Data.Vector.Fixed.Cont qualified as C +import Data.Vector.Fixed.Mono qualified as FM +import Data.Vector.Fixed.Internal as I +import Data.Vector.Fixed.Compat -import Prelude (Show(..),Eq(..),Ord(..),Functor(..),id,(.),($),undefined) +import Prelude (Show(..),Eq(..),Ord(..),Num(..),Functor(..),id,(.),($),(<$>),undefined,flip) -- $construction @@ -203,28 +225,26 @@ -- >>> mk3 'a' 'b' 'c' :: (Char,Char,Char) -- ('a','b','c') -- --- Alternatively one could use 'mkN'. See its documentation for --- examples. +-- Another way is to use pattern synonyms for construction and +-- inspection of vectors: -- --- Another option is to create tuple and 'convert' it to desired --- vector type. For example: +-- >>> V2 'a' 'b' :: (Char,Char) +-- ('a','b') -- --- > v = convert (x,y,z) +-- >>> case ('a','b') of V2 a b -> [a,b] +-- "ab" -- --- It will work on if type of @v@ is know from elsewhere. Same trick --- could be used to pattern match on the vector with opaque --- representation using view patterns +-- Last option is to use 'convert' to convert between different vector +-- types of same length. For example -- --- > function :: Vec N3 Double -> ... --- > function (convert -> (x,y,z)) = ... +-- > v = convert (x,y,z) -- --- For small vectors pattern synonyms @V2@, @V3$, @V4@ are provided --- that use same trick internally. - - --- $smallDim +-- This could be used in view patterns as well: -- --- Constructors for vectors with small dimensions. +-- > foo :: Vec3 Double -> Foo +-- > foo (convert -> (x,y,z)) = ... +-- +-- Pattern synonyms use this trick internally. -- $storable @@ -233,7 +253,6 @@ -- that individual elements of vector are stored as N-element array. - -- | Type-based vector with statically known length parametrized by -- GHC's type naturals newtype VecList (n :: Nat) a = VecList (VecPeano (C.Peano n) a) @@ -243,89 +262,115 @@ 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 = defaultRnf - {-# INLINE rnf #-} - -type instance Dim (VecList n) = n +type instance Dim (VecList n) = C.Peano n +type instance Dim (VecList n a) = C.Peano n +type instance Dim (VecPeano n) = n +type instance Dim (VecPeano n a) = n instance Arity n => Vector (VecList n) a where - construct = fmap VecList $ accum + construct = VecList <$> construct @(VecPeano (C.Peano n)) @a + inspect (VecList v) = inspect v + {-# INLINE construct #-} + {-# INLINE inspect #-} +instance Arity n => FM.Prod a (VecList n a) where + construct = construct + inspect = inspect + {-# INLINE construct #-} + {-# INLINE inspect #-} +instance Arity n => FM.Vector a (VecList n a) where + + +instance C.ArityPeano n => Vector (VecPeano n) a where + construct = accum (\(T_List f) a -> T_List (f . Cons a)) (\(T_List f) -> f Nil) - (T_List id :: T_List a (C.Peano n) (C.Peano n)) - inspect (VecList v) + (T_List id :: T_List a n n) + inspect v = inspect (apply step (Flip v) :: C.ContVec n a) where 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 +instance C.ArityPeano n => FM.Prod a (VecPeano n a) where + construct = construct + inspect = inspect + {-# INLINE construct #-} + {-# INLINE inspect #-} +instance C.ArityPeano n => FM.Vector a (VecPeano n a) where newtype Flip f a n = Flip (f n a) newtype T_List a n k = T_List (VecPeano k a -> VecPeano n a) --- Standard instances -instance (Show a, Arity n) => Show (VecList n a) where - show = show . foldr (:) [] -instance (Eq a, Arity n) => Eq (VecList n a) where - (==) = eq -instance (Ord a, Arity n) => Ord (VecList n a) where - compare = ord -instance Arity n => Functor (VecList n) where - fmap = map -instance Arity n => Applicative (VecList n) where - pure = replicate - (<*>) = zipWith ($) -instance Arity n => F.Foldable (VecList n) where - foldr = foldr + +deriving via ViaFixed (VecList n) instance (Arity n) => Functor (VecList n) +deriving via ViaFixed (VecList n) instance (Arity n) => Applicative (VecList n) +deriving via ViaFixed (VecList n) instance (Arity n) => F.Foldable (VecList n) +-- | @since @2.0.1.0 +deriving via ViaFixed (VecList n) + instance (Arity n, C.Peano n ~ S k) => F1.Foldable1 (VecList n) + instance Arity n => T.Traversable (VecList n) where - sequenceA = sequenceA - traverse = traverse -instance (Arity n, Monoid a) => Monoid (VecList n a) where - mempty = replicate mempty - mappend = (<>) - {-# INLINE mempty #-} - {-# INLINE mappend #-} + sequence = sequence + sequenceA = sequence + traverse = mapM + mapM = mapM + {-# INLINE sequence #-} + {-# INLINE sequenceA #-} + {-# INLINE mapM #-} + {-# INLINE traverse #-} -instance (Arity n, Semigroup a) => Semigroup (VecList n a) where - (<>) = zipWith (<>) - {-# INLINE (<>) #-} +deriving via ViaFixed (VecList n) a instance (Arity n, Show a) => Show (VecList n a) +deriving via ViaFixed (VecList n) a instance (Arity n, Eq a) => Eq (VecList n a) +deriving via ViaFixed (VecList n) a instance (Arity n, Ord a) => Ord (VecList n a) +deriving via ViaFixed (VecList n) a instance (Arity n, NFData a) => NFData (VecList n a) +deriving via ViaFixed (VecList n) a instance (Arity n, Semigroup a) => Semigroup (VecList n a) +deriving via ViaFixed (VecList n) a instance (Arity n, Monoid a) => Monoid (VecList n a) +deriving via ViaFixed (VecList n) a instance (Arity n, Storable a) => Storable (VecList n a) +-- | @since 2.0.1.0 +deriving via ViaFixed (VecList n) a instance (Arity n, Prim a) => Prim (VecList n a) -instance (Storable a, Arity n) => Storable (VecList n a) where - alignment = defaultAlignemnt - sizeOf = defaultSizeOf - peek = defaultPeek - poke = defaultPoke - {-# INLINE alignment #-} - {-# INLINE sizeOf #-} - {-# INLINE peek #-} - {-# INLINE poke #-} --- | Newtype for deriving 'Storable' instance for data types which has --- instance of 'Vector' -newtype StorableViaFixed v a = StorableViaFixed (v a) +deriving via ViaFixed (VecPeano n) instance (ArityPeano n) => Functor (VecPeano n) +deriving via ViaFixed (VecPeano n) instance (ArityPeano n) => Applicative (VecPeano n) +deriving via ViaFixed (VecPeano n) instance (ArityPeano n) => F.Foldable (VecPeano n) +-- | @since @2.0.1.0 +deriving via ViaFixed (VecPeano n) + instance (ArityPeano n, n ~ S k) => F1.Foldable1 (VecPeano n) -instance (Vector v a, Storable a) => Storable (StorableViaFixed v a) where - alignment = coerce (defaultAlignemnt @a @v) - sizeOf = coerce (defaultSizeOf @a @v) - peek = coerce (defaultPeek @a @v) - poke = coerce (defaultPoke @a @v) - {-# INLINE alignment #-} - {-# INLINE sizeOf #-} - {-# INLINE peek #-} - {-# INLINE poke #-} +instance ArityPeano n => T.Traversable (VecPeano n) where + sequence = sequence + sequenceA = sequence + traverse = mapM + mapM = mapM + {-# INLINE sequence #-} + {-# INLINE sequenceA #-} + {-# INLINE mapM #-} + {-# INLINE traverse #-} +deriving via ViaFixed (VecPeano n) a instance (ArityPeano n, Show a) => Show (VecPeano n a) +deriving via ViaFixed (VecPeano n) a instance (ArityPeano n, Eq a) => Eq (VecPeano n a) +deriving via ViaFixed (VecPeano n) a instance (ArityPeano n, Ord a) => Ord (VecPeano n a) +deriving via ViaFixed (VecPeano n) a instance (ArityPeano n, NFData a) => NFData (VecPeano n a) +deriving via ViaFixed (VecPeano n) a instance (ArityPeano n, Semigroup a) => Semigroup (VecPeano n a) +deriving via ViaFixed (VecPeano n) a instance (ArityPeano n, Monoid a) => Monoid (VecPeano n a) +deriving via ViaFixed (VecPeano n) a instance (ArityPeano n, Storable a) => Storable (VecPeano n a) +-- | @since 2.0.1.0 +deriving via ViaFixed (VecPeano n) a instance (ArityPeano n, Prim a) => Prim (VecPeano n a) + + -- | Single-element tuple. newtype Only a = Only a - deriving (Show,Eq,Ord,Typeable,Data,Functor,F.Foldable,T.Traversable) + deriving (Show,Eq,Ord,Data,Functor,F.Foldable,T.Traversable) +-- | @since @2.0.1.0 +deriving via ViaFixed Only instance F1.Foldable1 Only + + instance Monoid a => Monoid (Only a) where mempty = Only mempty mappend = (<>) @@ -337,39 +382,49 @@ instance NFData a => NFData (Only a) where rnf (Only a) = rnf a -type instance Dim Only = 1 +type instance Dim Only = C.N1 +type instance Dim (Only a) = C.N1 instance Vector Only a where construct = Fun Only inspect (Only a) (Fun f) = f a {-# INLINE construct #-} {-# INLINE inspect #-} +instance FM.Prod a (Only a) where + construct = construct + inspect = inspect + {-# INLINE construct #-} + {-# INLINE inspect #-} +instance FM.Vector a (Only a) where instance (Storable a) => Storable (Only a) where - alignment _ = alignment (undefined :: a) - sizeOf _ = sizeOf (undefined :: a) - peek p = Only <$> peek (castPtr p) - poke p (Only a) = poke (castPtr p) a - {-# INLINE alignment #-} - {-# INLINE sizeOf #-} - {-# INLINE peek #-} - {-# INLINE poke #-} + alignment = coerce (alignment @a) + sizeOf = coerce (sizeOf @a) + peek = coerce (peek @a) + poke = coerce (poke @a) -- | Empty tuple. data Empty a = Empty - deriving (Show,Eq,Ord,Typeable,Data,Functor,F.Foldable,T.Traversable) + deriving (Show,Eq,Ord,Data,Functor,F.Foldable,T.Traversable) instance NFData (Empty a) where rnf Empty = () -type instance Dim Empty = 0 +type instance Dim Empty = 'Z +type instance Dim (Empty a) = 'Z instance Vector Empty a where construct = Fun Empty inspect _ (Fun b) = b {-# INLINE construct #-} {-# INLINE inspect #-} +instance FM.Prod a (Empty a) where + construct = construct + inspect = inspect + {-# INLINE construct #-} + {-# INLINE inspect #-} +instance FM.Vector a (Empty a) where type Tuple2 a = (a,a) type Tuple3 a = (a,a,a) @@ -378,44 +433,207 @@ ---------------------------------------------------------------- +-- Deriving +---------------------------------------------------------------- + +-- | Newtype for deriving instance for data types which has instance +-- of 'Vector'. It supports 'Eq', 'Ord', 'Semigroup', 'Monoid', +-- 'Storable', 'NFData', 'Functor', 'Applicative', 'Foldable'. +newtype ViaFixed v a = ViaFixed (v a) + +type instance Dim (ViaFixed v) = Dim v +type instance Dim (ViaFixed v a) = Dim v + +instance Vector v a => Vector (ViaFixed v) a where + construct = ViaFixed <$> construct + inspect (ViaFixed v) = inspect v + {-# INLINE construct #-} + {-# INLINE inspect #-} + +instance Vector v a => FM.Prod a (ViaFixed v a) where + construct = ViaFixed <$> construct + inspect (ViaFixed v) = inspect v + {-# INLINE construct #-} + {-# INLINE inspect #-} +instance Vector v a => FM.Vector a (ViaFixed v a) where + +instance (Vector v a, Show a) => Show (ViaFixed v a) where + showsPrec = coerce (I.showsPrec @v @a) + +instance (Vector v a, Eq a) => Eq (ViaFixed v a) where + (==) = coerce (eq @v @a) + {-# INLINE (==) #-} + +instance (Vector v a, Ord a) => Ord (ViaFixed v a) where + compare = coerce (ord @v @a) + {-# INLINE compare #-} + +instance (Vector v a, NFData a) => NFData (ViaFixed v a) where + rnf = coerce (defaultRnf @a @v) + {-# INLINE rnf #-} + +instance (Vector v a, Semigroup a) => Semigroup (ViaFixed v a) where + (<>) = coerce (zipWith @v @a (<>)) + {-# INLINE (<>) #-} + +instance (Vector v a, Monoid a) => Monoid (ViaFixed v a) where + mempty = coerce (replicate @v @a mempty) + {-# INLINE mempty #-} + +instance (Vector v a, Storable a) => Storable (ViaFixed v a) where + alignment = coerce (defaultAlignemnt @a @v) + sizeOf = coerce (defaultSizeOf @a @v) + peek = coerce (defaultPeek @a @v) + poke = coerce (defaultPoke @a @v) + {-# INLINE alignment #-} + {-# INLINE sizeOf #-} + {-# INLINE peek #-} + {-# INLINE poke #-} + +-- | @since 2.0.1.0 +instance (Vector v a, Prim a) => Prim (ViaFixed v a) where + sizeOf# _ = sizeOf# (undefined :: a) *# dim where + dim = case C.peanoToInt (proxy# @(Dim v)) of I# i -> i + alignment# _ = alignment# (undefined :: a) + {-# INLINE sizeOf# #-} + {-# INLINE alignment# #-} + -- Bytearray + indexByteArray# ba k + = generate $ \(I# i) -> indexByteArray# ba (off +# i) + where + off = vectorOff (proxy# @(Dim v)) k + readByteArray# ba k + = internal + $ generateM + $ \(I# i) -> ST (\s -> readByteArray# ba (off +# i) s) + where + off = vectorOff (proxy# @(Dim v)) k + writeByteArray# ba k (ViaFixed vec) = + case loop of + ST st -> \s -> case st s of + (# s', () #) -> s' + where + off = vectorOff (proxy# @(Dim v)) k + loop = flip imapM_ vec $ \(I# i) a -> ST $ \s -> + (# writeByteArray# ba (off +# i) a s, () #) + {-# INLINE indexByteArray# #-} + {-# INLINE readByteArray# #-} + {-# INLINE writeByteArray# #-} + -- Addr + indexOffAddr# addr k + = generate $ \(I# i) -> indexOffAddr# addr (off +# i) + where + off = vectorOff (proxy# @(Dim v)) k + readOffAddr# ba k + = internal + $ generateM + $ \(I# i) -> ST (\s -> readOffAddr# ba (off +# i) s) + where + off = vectorOff (proxy# @(Dim v)) k + writeOffAddr# addr k (ViaFixed vec) = + case loop of + ST st -> \s -> case st s of + (# s', () #) -> s' + where + off = vectorOff (proxy# @(Dim v)) k + loop = flip imapM_ vec $ \(I# i) a -> ST $ \s -> + (# writeOffAddr# addr (off +# i) a s, () #) + {-# INLINE indexOffAddr# #-} + {-# INLINE readOffAddr# #-} + {-# INLINE writeOffAddr# #-} + + +vectorOff :: (ArityPeano n) => Proxy# n -> Int# -> Int# +{-# INLINE vectorOff #-} +vectorOff n k = + case C.peanoToInt n of + I# dim -> dim *# k + + +instance (forall a. Vector v a) => Functor (ViaFixed v) where + fmap = map + {-# INLINE fmap #-} + +instance (forall a. Vector v a) => Applicative (ViaFixed v) where + pure = replicate + (<*>) = zipWith ($) + liftA2 = zipWith + a <* _ = a + _ *> b = b + {-# INLINE pure #-} + {-# INLINE (<*>) #-} + {-# INLINE (<*) #-} + {-# INLINE (*>) #-} + {-# INLINE liftA2 #-} + +instance (forall a. Vector v a) => F.Foldable (ViaFixed v) where + foldMap' f = foldl' (\ acc a -> acc <> f a) mempty + foldr = foldr + foldl = foldl + foldl' = foldl' + toList = toList + sum = sum + product = foldl' (*) 0 + length = length + {-# INLINE foldMap' #-} + {-# INLINE foldr #-} + {-# INLINE foldl #-} + {-# INLINE foldl' #-} + {-# INLINE toList #-} + {-# INLINE sum #-} + {-# INLINE product #-} + {-# INLINE length #-} + + +-- | @since @2.0.1.0 +instance (forall a. Vector v a, Dim v ~ S k) => F1.Foldable1 (ViaFixed v) where + fold1 = foldl1 (<>) + foldMap1 f = F1.foldMap1 f . cvec + foldMap1' f = F1.foldMap1' f . cvec + toNonEmpty = F1.toNonEmpty . cvec + head = head + last = F1.last . cvec + maximum = maximum + minimum = minimum + {-# INLINE fold1 #-} + {-# INLINE foldMap1 #-} + {-# INLINE foldMap1' #-} + {-# INLINE toNonEmpty #-} + {-# INLINE maximum #-} + {-# INLINE minimum #-} + {-# INLINE head #-} + {-# INLINE last #-} + + +---------------------------------------------------------------- -- Patterns ---------------------------------------------------------------- -pattern V1 :: (Vector v a, Dim v ~ 1) => a -> v a +pattern V1 :: (Vector v a, Dim v ~ C.N1) => a -> v a pattern V1 x <- (convert -> (Only x)) where V1 x = mk1 x -#if MIN_VERSION_base(4,16,0) {-# INLINE V1 #-} {-# COMPLETE V1 #-} -#endif -pattern V2 :: (Vector v a, Dim v ~ 2) => a -> a -> v a +pattern V2 :: (Vector v a, Dim v ~ C.N2) => a -> a -> v a pattern V2 x y <- (convert -> (x,y)) where V2 x y = mk2 x y -#if MIN_VERSION_base(4,16,0) {-# INLINE V2 #-} {-# COMPLETE V2 #-} -#endif -pattern V3 :: (Vector v a, Dim v ~ 3) => a -> a -> a -> v a +pattern V3 :: (Vector v a, Dim v ~ C.N3) => a -> a -> a -> v a pattern V3 x y z <- (convert -> (x,y,z)) where V3 x y z = mk3 x y z -#if MIN_VERSION_base(4,16,0) {-# INLINE V3 #-} {-# COMPLETE V3 #-} -#endif -pattern V4 :: (Vector v a, Dim v ~ 4) => a -> a -> a -> a -> v a +pattern V4 :: (Vector v a, Dim v ~ C.N4) => a -> a -> a -> a -> v a pattern V4 t x y z <- (convert -> (t,x,y,z)) where V4 t x y z = mk4 t x y z -#if MIN_VERSION_base(4,16,0) {-# INLINE V4 #-} {-# COMPLETE V4 #-} -#endif - - - -- $setup -- -- >>> import Data.Char +-- >>> import Prelude (Int,Bool(..)) 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,14 +1,9 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} -- | --- Vector which could hold any value. +-- Lazy vector which could hold any value. For strict variant see +-- "Data.Vector.Fixed.Strict". module Data.Vector.Fixed.Boxed ( -- * Immutable Vec @@ -27,104 +22,104 @@ import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) import Data.Data +import Data.Primitive.Types (Prim) import qualified Data.Foldable as F +import qualified Data.Foldable1 as F1 import qualified Data.Traversable as T -import Foreign.Storable (Storable(..)) +import Foreign.Storable (Storable) import GHC.TypeLits +import GHC.Exts (proxy#) import Prelude ( Show(..),Eq(..),Ord(..),Functor(..),Monad(..) - , ($),($!),error,seq) + , ($!),error,(<$>)) +import Data.Vector.Fixed.Compat import Data.Vector.Fixed hiding (index) -import Data.Vector.Fixed.Mutable (Mutable, MVector(..), IVector(..), DimM, constructVec, inspectVec, arity, index) +import Data.Vector.Fixed.Mono qualified as FM +import Data.Vector.Fixed.Mutable (Mutable, MVector(..), IVector(..), DimM, constructVec, inspectVec, index) import qualified Data.Vector.Fixed.Cont as C -import qualified Data.Vector.Fixed.Internal as I - +import Data.Vector.Fixed.Cont (ArityPeano(..)) ---------------------------------------------------------------- -- Data type ---------------------------------------------------------------- --- | Vector with fixed length which can hold any value. +-- | Vector with fixed length which can hold any value. It's lazy and +-- doesn't evaluate elements. newtype Vec (n :: Nat) a = Vec (SmallArray a) -- | Mutable unboxed vector with fixed length newtype MVec (n :: Nat) s a = MVec (SmallMutableArray s a) -deriving instance Typeable Vec -deriving instance Typeable MVec - 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 - gfoldl = C.gfoldl - gunfold = C.gunfold - toConstr _ = con_Vec - dataTypeOf _ = ty_Vec - -ty_Vec :: DataType -ty_Vec = mkDataType "Data.Vector.Fixed.Boxed.Vec" [con_Vec] - -con_Vec :: Constr -con_Vec = mkConstr ty_Vec "Vec" [] Prefix - -instance (Storable a, Arity n) => Storable (Vec n a) where - alignment = defaultAlignemnt - sizeOf = defaultSizeOf - peek = defaultPeek - poke = defaultPoke - {-# INLINE alignment #-} - {-# INLINE sizeOf #-} - {-# INLINE peek #-} - {-# INLINE poke #-} - - +type instance Mutable (Vec n) = MVec n +type instance Dim (Vec n) = Peano n +type instance Dim (Vec n a) = Peano n +type instance DimM (MVec n) = Peano n ---------------------------------------------------------------- -- Instances ---------------------------------------------------------------- -instance (Arity n, Show a) => Show (Vec n a) where - showsPrec = I.showsPrec +deriving via ViaFixed (Vec n) instance Arity n => Functor (Vec n) +deriving via ViaFixed (Vec n) instance Arity n => Applicative (Vec n) +deriving via ViaFixed (Vec n) instance Arity n => F.Foldable (Vec n) +-- | @since @2.0.1.0 +deriving via ViaFixed (Vec n) + instance (Arity n, Peano n ~ S k) => F1.Foldable1 (Vec n) -instance (Arity n, NFData a) => NFData (Vec n a) where - rnf = foldl (\r a -> r `seq` rnf a) () - {-# INLINE rnf #-} +instance Arity n => T.Traversable (Vec n) where + sequence = sequence + sequenceA = sequence + traverse = mapM + mapM = mapM + {-# INLINE sequence #-} + {-# INLINE sequenceA #-} + {-# INLINE mapM #-} + {-# INLINE traverse #-} -type instance Mutable (Vec n) = MVec n +deriving via ViaFixed (Vec n) a instance (Arity n, Show a) => Show (Vec n a) +deriving via ViaFixed (Vec n) a instance (Arity n, Eq a) => Eq (Vec n a) +deriving via ViaFixed (Vec n) a instance (Arity n, Ord a) => Ord (Vec n a) +deriving via ViaFixed (Vec n) a instance (Arity n, NFData a) => NFData (Vec n a) +deriving via ViaFixed (Vec n) a instance (Arity n, Semigroup a) => Semigroup (Vec n a) +deriving via ViaFixed (Vec n) a instance (Arity n, Monoid a) => Monoid (Vec n a) +deriving via ViaFixed (Vec n) a instance (Arity n, Storable a) => Storable (Vec n a) +-- | @since 2.0.1.0 +deriving via ViaFixed (Vec n) a instance (Arity n, Prim a) => Prim (Vec n a) instance (Arity n) => MVector (MVec n) a where - new = do - v <- newSmallArray (arity (Proxy :: Proxy n)) uninitialised - return $ MVec v - {-# INLINE new #-} - copy = move - {-# INLINE copy #-} - move (MVec dst) (MVec src) = copySmallMutableArray dst 0 src 0 (arity (Proxy :: Proxy n)) - {-# INLINE move #-} - unsafeRead (MVec v) i = readSmallArray v i - {-# INLINE unsafeRead #-} - unsafeWrite (MVec v) i x = writeSmallArray v i x - {-# INLINE unsafeWrite #-} + basicNew = + MVec <$> newSmallArray (peanoToInt (proxy# @(Peano n))) uninitialised + basicReplicate a = + MVec <$> newSmallArray (peanoToInt (proxy# @(Peano n))) a + basicCopy (MVec dst) (MVec src) = + copySmallMutableArray dst 0 src 0 (peanoToInt (proxy# @(Peano n))) + basicClone (MVec src) = + MVec <$> cloneSmallMutableArray src 0 (peanoToInt (proxy# @(Peano n))) + basicUnsafeRead (MVec v) i = readSmallArray v i + basicUnsafeWrite (MVec v) i x = writeSmallArray v i x + {-# INLINE basicNew #-} + {-# INLINE basicReplicate #-} + {-# INLINE basicCopy #-} + {-# INLINE basicClone #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} instance (Arity n) => IVector (Vec n) a where - unsafeFreeze (MVec v) = do { a <- unsafeFreezeSmallArray v; return $! Vec a } - unsafeThaw (Vec v) = do { a <- unsafeThawSmallArray v; return $! MVec a } + basicUnsafeFreeze (MVec v) = do { a <- unsafeFreezeSmallArray v; return $! Vec a } + basicThaw (Vec v) = + MVec <$> thawSmallArray v 0 (peanoToInt (proxy# @(Peano n))) unsafeIndex (Vec v) i = indexSmallArray v i - {-# INLINE unsafeFreeze #-} - {-# INLINE unsafeThaw #-} - {-# INLINE unsafeIndex #-} - - - -type instance Dim (Vec n) = n -type instance DimM (MVec n) = n + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicThaw #-} + {-# INLINE unsafeIndex #-} instance (Arity n) => Vector (Vec n) a where construct = constructVec @@ -133,44 +128,24 @@ {-# INLINE construct #-} {-# INLINE inspect #-} {-# INLINE basicIndex #-} -instance (Arity n) => VectorN Vec n a - -instance (Arity n, Eq a) => Eq (Vec n a) where - (==) = eq - {-# INLINE (==) #-} -instance (Arity n, Ord a) => Ord (Vec n a) where - compare = ord - {-# INLINE compare #-} - -instance (Arity n, Monoid a) => Monoid (Vec n a) where - mempty = replicate mempty - mappend = (<>) - {-# INLINE mempty #-} - {-# INLINE mappend #-} - -instance (Arity n, Semigroup a) => Semigroup (Vec n a) where - (<>) = zipWith (<>) - {-# INLINE (<>) #-} - -instance Arity n => Functor (Vec n) where - {-# INLINE fmap #-} - fmap = map +instance (Arity n) => FM.Prod a (Vec n a) where + construct = constructVec + inspect = inspectVec + {-# INLINE construct #-} + {-# INLINE inspect #-} +instance (Arity n) => FM.Vector a (Vec n a) -instance Arity n => Applicative (Vec n) where - pure = replicate - (<*>) = zipWith ($) - {-# INLINE pure #-} - {-# INLINE (<*>) #-} +instance (Typeable n, Arity n, Data a) => Data (Vec n a) where + gfoldl = C.gfoldl + gunfold = C.gunfold + toConstr _ = con_Vec + dataTypeOf _ = ty_Vec -instance Arity n => F.Foldable (Vec n) where - foldr = foldr - {-# INLINE foldr #-} +ty_Vec :: DataType +ty_Vec = mkDataType "Data.Vector.Fixed.Boxed.Vec" [con_Vec] -instance Arity n => T.Traversable (Vec n) where - sequenceA = sequenceA - traverse = traverse - {-# INLINE sequenceA #-} - {-# INLINE traverse #-} +con_Vec :: Constr +con_Vec = mkConstr ty_Vec "Vec" [] Prefix uninitialised :: a uninitialised = error "Data.Vector.Fixed.Boxed: uninitialised element" diff --git a/Data/Vector/Fixed/Compat.hs b/Data/Vector/Fixed/Compat.hs new file mode 100644 --- /dev/null +++ b/Data/Vector/Fixed/Compat.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE CPP #-} +-- | Compatibility for old GHC +module Data.Vector.Fixed.Compat + ( +#if MIN_VERSION_base(4,17,0) + type(~) +#endif + ) where 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,18 +1,6 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- API for Church-encoded vectors. Implementation of function from -- "Data.Vector.Fixed" module uses these function internally in order @@ -20,6 +8,7 @@ module Data.Vector.Fixed.Cont ( -- * Type-level numbers PeanoNum(..) + , N1,N2,N3,N4,N5,N6,N7,N8 , Peano , Add -- * N-ary functions @@ -27,9 +16,9 @@ , Fun(..) , Arity , ArityPeano(..) - , arity , apply , applyM + , Index(..) -- ** Combinators , constFun , curryFirst @@ -39,16 +28,14 @@ , apLast , shuffleFun , withFun - -- * Vector type class + , dimapFun + -- * Vector type Boxedclass , Dim , Vector(..) - , VectorN , length -- * Vector as continuation , ContVec(..) - , CVecPeano(..) , consPeano - , toContVec , runContVec -- * Construction of ContVec , cvec @@ -108,9 +95,12 @@ , vector -- ** Folds , foldl + , foldl' , foldl1 + , foldl1' , foldr , ifoldl + , ifoldl' , ifoldr , foldM , ifoldM @@ -135,16 +125,19 @@ import Data.Kind (Type) 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 Data.Foldable qualified as F +import Data.Traversable qualified as T +import Data.List.NonEmpty qualified as NE +import Data.Foldable1 qualified as F1 +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 - , head,tail,mapM,mapM_,sequence,sequence_,concat +import GHC.Exts (Proxy#, proxy#) +import Prelude ( Bool(..), Int, Maybe(..), Either(..) + , Eq(..), Ord(..), Num(..), Functor(..), Applicative(..), Monad(..) + , Semigroup(..), Monoid(..) + , (.), ($), (&&), (||), (<$>), id, error, otherwise, fst ) - +import Data.Vector.Fixed.Compat ---------------------------------------------------------------- -- Naturals @@ -156,6 +149,16 @@ data PeanoNum = Z | S PeanoNum +type N1 = S Z +type N2 = S N1 +type N3 = S N2 +type N4 = S N3 +type N5 = S N4 +type N6 = S N5 +type N7 = S N6 +type N8 = S N7 + + -- | Convert type level natural to Peano representation type family Peano (n :: Nat) :: PeanoNum where Peano 0 = 'Z @@ -177,8 +180,9 @@ 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 wrapper which is used to make 'Fn' injective. It's a +-- function which takes @n@ parameters of type @a@ and returns value +-- of type @b@. newtype Fun n a b = Fun { unFun :: Fn n a b } @@ -200,12 +204,14 @@ {-# INLINE pure #-} {-# INLINE (<*>) #-} +-- | Reader instance ArityPeano n => Monad (Fun n a) where return = pure f >>= g = shuffleFun g <*> f {-# INLINE return #-} {-# INLINE (>>=) #-} +newtype T_Flip a b n = T_Flip (Fun n a b) data T_ap a b c n = T_ap (Fn n a b) (Fn n a c) @@ -214,14 +220,10 @@ -- 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) - ) +-- | Synonym for writing constrains using type level naturals. +type Arity n = ArityPeano (Peano n) --- | Type class for handling /n/-ary functions. +-- | Type class for defining and applying /n/-ary functions. class ArityPeano n where -- | Left fold over /n/ elements exposed as n-ary function. These -- elements are supplied as arguments to the function. @@ -230,12 +232,20 @@ -> t n -- ^ Initial value -> Fun n a b -- ^ Reduction function + -- | Same as @accum@ but allow use @ArityPeano@ at each step Note + -- that in general case this will lead to /O(n²)/ compilation time. + accumPeano + :: (forall k. ArityPeano 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 - -> (CVecPeano n a, t 'Z) + -> (ContVec n a, t 'Z) -- | Apply all parameters to the function using monadic -- actions. Note that for identity monad it's same as @@ -245,80 +255,107 @@ 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) + -> (f (ContVec n a), t 'Z) - -- | 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 - -- | 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 + -- | Perform N reduction steps. This function doesn't involve N-ary + -- function directly. + reducePeano :: (forall k. t ('S k) -> t k) -- ^ Reduction step + -> t n + -> t 'Z -newtype T_gunfold c r a n = T_gunfold (c (Fn n a r)) + -- | Conver peano number to int + peanoToInt :: Proxy# n -> Int + -- | Provide @ArityPeano@ dictionary for previous Peano number. GHC + -- cannot infer that when @ArityPeano n@ and @n ~ S k@ we have + -- instance for @k@ as well. So we have to provide such dictionary + -- manually. + -- + -- It's not possible to have non-⊥ implementation for @Z@ but + -- neither it's possible to call it. + dictionaryPred :: (n ~ S k) => Proxy# n -> (ArityPeano k => r) -> r +newtype T_gunfold c r a n = T_gunfold (c (Fn n a r)) + -- | Apply all parameters to the function. -apply :: Arity n +apply :: ArityPeano n => (forall k. t ('S k) -> (a, t k)) -- ^ Get value to apply to function - -> t (Peano n) -- ^ Initial value + -> t n -- ^ Initial value -> ContVec n a -- ^ N-ary function {-# INLINE apply #-} -apply step z = toContVec $ fst (applyFun step z) +apply step z = fst (applyFun step z) -- | Apply all parameters to the function using applicative actions. -applyM :: (Applicative f, Arity n) +applyM :: (Applicative f, ArityPeano n) => (forall k. t ('S k) -> (f a, t k)) -- ^ Get value to apply to function - -> t (Peano n) -- ^ Initial value + -> t n -- ^ Initial value -> f (ContVec n a) {-# INLINE applyM #-} -applyM f t = fmap toContVec $ fst $ applyFunM f t +applyM f t = fst $ applyFunM f t --- | Arity of function. -arity :: KnownNat n => proxy n -> Int -{-# INLINE arity #-} -arity = fromIntegral . natVal +-- | Type class for indexing of vector of length @n@ with statically +-- known index @k@ +class Index (k :: PeanoNum) (n :: PeanoNum) where + getF :: Proxy# k -> Fun n a a + putF :: Proxy# k -> a -> Fun n a r -> Fun n a r + lensF :: Functor f => Proxy# k -> (a -> f a) -> Fun n a r -> Fun n a (f r) + + + instance ArityPeano 'Z where - accum _ g t = Fun $ g t - applyFun _ t = (CVecPeano unFun, t) - applyFunM _ t = (pure (CVecPeano unFun), t) - {-# INLINE accum #-} - {-# INLINE applyFun #-} - {-# INLINE applyFunM #-} - reverseF = id - gunfoldF _ (T_gunfold c) = c - {-# INLINE reverseF #-} - {-# INLINE gunfoldF #-} + accum _ g t = Fun $ g t + accumPeano _ g t = Fun $ g t + applyFun _ t = (ContVec unFun, t) + applyFunM _ t = (pure (ContVec unFun), t) + reducePeano _ = id + peanoToInt _ = 0 + {-# INLINE accum #-} + {-# INLINE accumPeano #-} + {-# INLINE applyFun #-} + {-# INLINE applyFunM #-} + {-# INLINE reducePeano #-} + {-# INLINE peanoToInt #-} + dictionaryPred _ _ = error "dictionaryPred: IMPOSSIBLE" instance ArityPeano n => ArityPeano ('S n) where - accum f g t = Fun $ \a -> unFun $ accum f g (f t a) - 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 #-} - reverseF f = Fun $ \a -> unFun (reverseF $ apLast f a) - gunfoldF f c = gunfoldF f (apGunfold f c) - {-# INLINE reverseF #-} - {-# INLINE gunfoldF #-} + accum f g t = Fun $ \a -> unFun $ accum f g (f t a) + accumPeano f g t = Fun $ \a -> unFun $ accumPeano f g (f t a) + 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) + reducePeano f t = reducePeano f (f t) + peanoToInt _ = 1 + peanoToInt (proxy# @n) + {-# INLINE accum #-} + {-# INLINE applyFun #-} + {-# INLINE applyFunM #-} + {-# INLINE peanoToInt #-} + {-# INLINE reducePeano #-} + dictionaryPred _ r = r + {-# INLINE dictionaryPred #-} -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 n -apGunfold f (T_gunfold c) = T_gunfold $ f c -{-# INLINE apGunfold #-} +instance ArityPeano n => Index 'Z ('S n) where + getF _ = uncurryFirst pure + putF _ a f = Fun $ \_ -> unFun f a + lensF _ f fun = Fun $ \a -> unFun $ + (\g -> g <$> f a) <$> shuffleFun (curryFirst fun) + {-# INLINE getF #-} + {-# INLINE putF #-} + {-# INLINE lensF #-} -newtype T_Flip a b n = T_Flip (Fun n a b) +instance Index k n => Index (S k) (S n) where + getF _ = uncurryFirst $ \_ -> getF (proxy# @k) + putF _ a = withFun (putF (proxy# @k) a) + lensF _ f fun = withFun (lensF (proxy# @k) f) fun + {-# INLINE getF #-} + {-# INLINE putF #-} + {-# INLINE lensF #-} @@ -367,7 +404,7 @@ {-# 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 c) -> Fun ('S n) a b -> Fun ('S n) a c withFun f fun = Fun $ \a -> unFun $ f $ curryFirst fun a {-# INLINE withFun #-} @@ -382,18 +419,27 @@ newtype T_shuffle x a r n = T_shuffle (x -> Fn n a r) +-- | Apply function to parameters and result of @Fun@ simultaneously. +dimapFun :: ArityPeano n => (a -> b) -> (c -> d) -> Fun n b c -> Fun n a d +{-# INLINE dimapFun #-} +dimapFun fA fR fun + = accum (\(T_Flip g) a -> T_Flip (curryFirst g (fA a))) + (\(T_Flip x) -> fR (unFun x)) + (T_Flip fun) + + ---------------------------------------------------------------- -- Type class for fixed vectors ---------------------------------------------------------------- --- | Size of vector expressed as type-level natural. -type family Dim (v :: Type -> Type) :: Nat +-- | Size of vector expressed as Peano natural. +type family Dim (v :: k) :: PeanoNum -- | 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 from @N@ elements and another +-- for vector deconstruction. They must obey following law: -- -- > inspect v construct = v -- @@ -405,28 +451,23 @@ -- > 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 (Peano (Dim v)) a (v a) - -- | Deconstruction of vector. - inspect :: v a -> Fun (Peano (Dim v)) a b -> b +class ArityPeano (Dim v) => Vector v a where + -- | N-ary function for creation of vectors. It takes @N@ elements + -- of array as parameters and return vector. + construct :: Fun (Dim v) a (v a) + -- | Deconstruction of vector. It takes N-ary function as parameters + -- and applies vector's elements to it. + inspect :: v a -> Fun (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 basicIndex v i = index i (cvec v) {-# INLINE basicIndex #-} --- | Vector parametrized by length. In ideal world it should be: --- --- > forall n. (Arity n, Vector (v n) a, Dim (v n) ~ n) => VectorN v a --- --- Alas polymorphic constraints aren't allowed in haskell. -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. KnownNat (Dim v) => v a -> Int +length :: forall v a. ArityPeano (Dim v) => v a -> Int {-# INLINE length #-} -length _ = arity (Proxy :: Proxy (Dim v)) +length _ = peanoToInt (proxy# @(Dim v)) ---------------------------------------------------------------- @@ -435,62 +476,103 @@ -- | Vector represented as continuation. Alternative wording: it's -- Church encoded N-element vector. -newtype ContVec n a = ContVec (forall r. Fun (Peano n) a r -> r) - -type instance Dim (ContVec n) = n +newtype ContVec n a = ContVec (forall r. Fun n a r -> r) --- | Same as 'ContVec' but its length is expressed as Peano number. -newtype CVecPeano n a = CVecPeano (forall r. Fun n a r -> r) +type instance Dim (ContVec n) = n +type instance Dim (ContVec n a) = n --- | Cons values to the @CVecPeano@. -consPeano :: a -> CVecPeano n a -> CVecPeano ('S n) a -consPeano a (CVecPeano cont) = CVecPeano $ \f -> cont $ curryFirst f a +-- | Cons values to the @ContVec@. +consPeano :: a -> ContVec n a -> ContVec ('S n) a +consPeano a (ContVec cont) = ContVec $ \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 +instance ArityPeano n => Vector (ContVec n) a where construct = accum (\(T_mkN f) a -> T_mkN (f . consPeano a)) - (\(T_mkN f) -> toContVec $ f (CVecPeano unFun)) + (\(T_mkN f) -> f (ContVec unFun)) (T_mkN id) inspect (ContVec c) f = c f {-# INLINE construct #-} {-# INLINE inspect #-} -newtype T_mkN n_tot a n = T_mkN (CVecPeano n a -> CVecPeano n_tot a) +newtype T_mkN n_tot a n = T_mkN (ContVec n a -> ContVec n_tot a) -instance Arity n => VectorN ContVec n a -instance (Arity n) => Functor (ContVec n) where +instance (Eq a, ArityPeano n) => Eq (ContVec n a) where + a == b = and $ zipWith (==) a b + {-# INLINE (==) #-} + +instance (Ord a, ArityPeano n) => Ord (ContVec n a) where + compare a b = foldl mappend mempty $ zipWith compare a b + {-# INLINE compare #-} + +instance (ArityPeano n, Monoid a) => Monoid (ContVec n a) where + mempty = replicate mempty + {-# INLINE mempty #-} + +instance (ArityPeano n, Semigroup a) => Semigroup (ContVec n a) where + (<>) = zipWith (<>) + {-# INLINE (<>) #-} + + +instance (ArityPeano n) => Functor (ContVec n) where fmap = map {-# INLINE fmap #-} -instance (Arity n) => Applicative (ContVec n) where +instance (ArityPeano n) => Applicative (ContVec n) where pure = replicate (<*>) = zipWith ($) {-# INLINE pure #-} {-# INLINE (<*>) #-} -instance (Arity n) => F.Foldable (ContVec n) where - foldr = foldr - {-# INLINE foldr #-} +instance (ArityPeano n) => F.Foldable (ContVec n) where + foldMap' f = foldl' (\ acc a -> acc <> f a) mempty + foldr = foldr + foldl = foldl + foldl' = foldl' + toList = toList + sum = sum + product = foldl' (*) 0 + length = length + {-# INLINE foldMap' #-} + {-# INLINE foldr #-} + {-# INLINE foldl #-} + {-# INLINE foldl' #-} + {-# INLINE toList #-} + {-# INLINE sum #-} + {-# INLINE product #-} + {-# INLINE length #-} -instance (Arity n) => F.Traversable (ContVec n) where - sequenceA v = inspect v $ sequenceAF construct - {-# INLINE sequenceA #-} -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) - = accum (\(T_sequenceA f) a -> T_sequenceA (f <*> a)) - (\(T_sequenceA f) -> f) - (T_sequenceA (pure f0) :: T_sequenceA f a b n) +instance (ArityPeano n, n ~ S k) => F1.Foldable1 (ContVec n) where + fold1 = foldl1 (<>) + foldMap1 f = foldl1 (<>) . map f + foldMap1' f = foldl1' (<>) . map f + toNonEmpty v = dictionaryPred (proxy# @n) + $ head v NE.:| toList (tail v) + maximum = maximum + minimum = minimum + head = head + last = F1.last . F1.toNonEmpty + {-# INLINE fold1 #-} + {-# INLINE foldMap1 #-} + {-# INLINE foldMap1' #-} + {-# INLINE toNonEmpty #-} + {-# INLINE maximum #-} + {-# INLINE minimum #-} + {-# INLINE head #-} + {-# INLINE last #-} -newtype T_sequenceA f a b n = T_sequenceA (f (Fn n a b)) +instance (ArityPeano n) => T.Traversable (ContVec n) where + sequence = sequence + sequenceA = sequence + traverse = mapM + mapM = mapM + {-# INLINE sequence #-} + {-# INLINE sequenceA #-} + {-# INLINE mapM #-} + {-# INLINE traverse #-} @@ -499,19 +581,19 @@ ---------------------------------------------------------------- -- | Convert regular vector to continuation based one. -cvec :: (Vector v a, Dim v ~ n) => v a -> ContVec n a +cvec :: (Vector v a) => v a -> ContVec (Dim v) a cvec v = ContVec (inspect v) {-# INLINE[0] cvec #-} -- | Create empty vector. -empty :: ContVec 0 a +empty :: ContVec 'Z a {-# INLINE empty #-} empty = ContVec (\(Fun r) -> r) -- | Convert list to continuation-based vector. Will throw error if -- list is shorter than resulting vector. -fromList :: Arity n => [a] -> ContVec n a +fromList :: ArityPeano n => [a] -> ContVec n a {-# INLINE fromList #-} fromList xs = apply step (Const xs) @@ -521,22 +603,22 @@ -- | 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 +fromList' :: forall n a. ArityPeano n => [a] -> ContVec n a {-# INLINE fromList' #-} 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 + in case applyFun step (Const xs :: Const [a] n) of + (v,Const []) -> 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) +fromListM :: forall n a. ArityPeano n => [a] -> Maybe (ContVec n a) {-# INLINE fromListM #-} -fromListM xs = case applyFunM step (Const xs :: Const [a] (Peano n)) of - (Just v, Const []) -> Just (toContVec v) +fromListM xs = case applyFunM step (Const xs :: Const [a] n) of + (Just v, Const []) -> Just v _ -> Nothing where step (Const [] ) = (Nothing, Const []) @@ -544,46 +626,46 @@ -- | Convert vector to the list -toList :: (Arity n) => ContVec n a -> [a] +toList :: (ArityPeano n) => ContVec n a -> [a] toList = foldr (:) [] {-# INLINE toList #-} -- | Execute monadic action for every element of vector. Synonym for 'pure'. -replicate :: (Arity n) => a -> ContVec n a +replicate :: (ArityPeano n) => a -> ContVec n a {-# INLINE replicate #-} replicate a = apply (\Proxy -> (a, Proxy)) Proxy -- | Execute monadic action for every element of vector. -replicateM :: (Arity n, Applicative f) => f a -> f (ContVec n a) +replicateM :: (ArityPeano n, Applicative f) => f a -> f (ContVec n a) {-# INLINE replicateM #-} replicateM act = 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 +generate :: (ArityPeano n) => (Int -> a) -> ContVec n a {-# INLINE generate #-} generate f = apply (\(Const n) -> (f n, Const (n + 1))) (Const 0) -- | Generate vector from monadic function which maps element's index -- to its value. -generateM :: (Applicative f, Arity n) => (Int -> f a) -> f (ContVec n a) +generateM :: (Applicative f, ArityPeano n) => (Int -> f a) -> f (ContVec n a) {-# INLINE generateM #-} generateM f = applyM (\(Const n) -> (f n, Const (n + 1))) (Const 0) -- | Unfold vector. -unfoldr :: Arity n => (b -> (a,b)) -> b -> ContVec n a +unfoldr :: ArityPeano n => (b -> (a,b)) -> b -> ContVec n a {-# INLINE unfoldr #-} unfoldr f b0 = 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 +basis :: (Num a, ArityPeano n) => Int -> ContVec n a {-# INLINE basis #-} basis n0 = apply (\(Const n) -> (if n == 0 then 1 else 0, Const (n - 1))) @@ -591,35 +673,35 @@ -mk1 :: a -> ContVec 1 a +mk1 :: a -> ContVec N1 a mk1 a1 = ContVec $ \(Fun f) -> f a1 {-# INLINE mk1 #-} -mk2 :: a -> a -> ContVec 2 a +mk2 :: a -> a -> ContVec N2 a mk2 a1 a2 = ContVec $ \(Fun f) -> f a1 a2 {-# INLINE mk2 #-} -mk3 :: a -> a -> a -> ContVec 3 a +mk3 :: a -> a -> a -> ContVec N3 a mk3 a1 a2 a3 = ContVec $ \(Fun f) -> f a1 a2 a3 {-# INLINE mk3 #-} -mk4 :: a -> a -> a -> a -> ContVec 4 a +mk4 :: a -> a -> a -> a -> ContVec N4 a mk4 a1 a2 a3 a4 = ContVec $ \(Fun f) -> f a1 a2 a3 a4 {-# INLINE mk4 #-} -mk5 :: a -> a -> a -> a -> a -> ContVec 5 a +mk5 :: a -> a -> a -> a -> a -> ContVec N5 a mk5 a1 a2 a3 a4 a5 = ContVec $ \(Fun f) -> f a1 a2 a3 a4 a5 {-# INLINE mk5 #-} -mk6 :: a -> a -> a -> a -> a -> a -> ContVec 6 a +mk6 :: a -> a -> a -> a -> a -> a -> ContVec N6 a mk6 a1 a2 a3 a4 a5 a6 = ContVec $ \(Fun f) -> f a1 a2 a3 a4 a5 a6 {-# INLINE mk6 #-} -mk7 :: a -> a -> a -> a -> a -> a -> a -> ContVec 7 a +mk7 :: a -> a -> a -> a -> a -> a -> a -> ContVec N7 a mk7 a1 a2 a3 a4 a5 a6 a7 = ContVec $ \(Fun f) -> f a1 a2 a3 a4 a5 a6 a7 {-# INLINE mk7 #-} -mk8 :: a -> a -> a -> a -> a -> a -> a -> a -> ContVec 8 a +mk8 :: a -> a -> a -> a -> a -> a -> a -> a -> ContVec N8 a mk8 a1 a2 a3 a4 a5 a6 a7 a8 = ContVec $ \(Fun f) -> f a1 a2 a3 a4 a5 a6 a7 a8 {-# INLINE mk8 #-} @@ -629,23 +711,26 @@ ---------------------------------------------------------------- -- | Map over vector. Synonym for 'fmap' -map :: (Arity n) => (a -> b) -> ContVec n a -> ContVec n b +map :: (ArityPeano n) => (a -> b) -> ContVec n a -> ContVec n b {-# INLINE map #-} -map = imap . const +map f (ContVec contA) = ContVec $ + contA . mapF f -- | Apply function to every element of the vector and its index. -imap :: (Arity n) => (Int -> a -> b) -> ContVec n a -> ContVec n b +imap :: (ArityPeano n) => (Int -> a -> b) -> ContVec n a -> ContVec n b {-# INLINE imap #-} imap f (ContVec contA) = ContVec $ contA . imapF f -- | Effectful map over vector. -mapM :: (Arity n, Applicative f) => (a -> f b) -> ContVec n a -> f (ContVec n b) +mapM :: (ArityPeano n, Applicative f) => (a -> f b) -> ContVec n a -> f (ContVec n b) {-# INLINE mapM #-} -mapM = imapM . const +mapM f v + = inspect v + $ mapMF f construct -- | Apply monadic function to every element of the vector and its index. -imapM :: (Arity n, Applicative f) +imapM :: (ArityPeano n, Applicative f) => (Int -> a -> f b) -> ContVec n a -> f (ContVec n b) {-# INLINE imapM #-} imapM f v @@ -653,45 +738,65 @@ $ imapMF f construct -- | Apply monadic action to each element of vector and ignore result. -mapM_ :: (Arity n, Applicative f) => (a -> f b) -> ContVec n a -> f () +mapM_ :: (ArityPeano n, Applicative f) => (a -> f b) -> ContVec n a -> f () {-# INLINE mapM_ #-} 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, Applicative f) => (Int -> a -> f b) -> ContVec n a -> f () +imapM_ :: (ArityPeano n, Applicative f) => (Int -> a -> f b) -> ContVec n a -> f () {-# INLINE imapM_ #-} imapM_ f = ifoldl (\m i a -> m *> f i a *> pure ()) (pure ()) + +mapMF :: (ArityPeano n, Applicative f) + => (a -> f b) -> Fun n b r -> Fun n a (f r) +{-# INLINE mapMF #-} +mapMF f (Fun funB) = + accum (\(T_mapM m) a -> T_mapM (($) <$> m <*> f a)) + (\(T_mapM m) -> m) + (T_mapM (pure funB)) + 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) $ ($) <$> m <*> f i a) - (\(T_mapM _ m) -> m) - (T_mapM 0 (pure funB)) + accum (\(T_imapM i m) a -> T_imapM (i+1) $ ($) <$> m <*> f i a) + (\(T_imapM _ m) -> m) + (T_imapM 0 (pure funB)) -data T_mapM a m r n = T_mapM Int (m (Fn n a r)) +newtype T_mapM a m r n = T_mapM (m (Fn n a r)) +data T_imapM a m r n = T_imapM Int (m (Fn n a r)) + +mapF :: ArityPeano n + => (a -> b) -> Fun n b r -> Fun n a r +{-# INLINE mapF #-} +mapF f (Fun funB) = + accum (\(T_map g) b -> T_map (g (f b))) + (\(T_map r) -> r) + ( T_map funB) + imapF :: ArityPeano n => (Int -> a -> b) -> Fun n b r -> Fun n a r {-# INLINE imapF #-} imapF f (Fun funB) = - accum (\(T_map i g) b -> T_map (i+1) (g (f i b))) - (\(T_map _ r) -> r) - ( T_map 0 funB) + accum (\(T_imap i g) b -> T_imap (i+1) (g (f i b))) + (\(T_imap _ r) -> r) + ( T_imap 0 funB) -data T_map a r n = T_map Int (Fn n a r) +newtype T_map a r n = T_map (Fn n a r) +data T_imap a r n = T_imap Int (Fn n a r) -- | Left scan over vector -scanl :: (Arity n) => (b -> a -> b) -> b -> ContVec n a -> ContVec (n+1) b +scanl :: (ArityPeano n) => (b -> a -> b) -> b -> ContVec n a -> ContVec ('S n) b {-# INLINE scanl #-} scanl f b0 (ContVec cont) = ContVec $ cont . scanlF f b0 -- | Left scan over vector -scanl1 :: (Arity n) => (a -> a -> a) -> ContVec n a -> ContVec n a +scanl1 :: (ArityPeano n) => (a -> a -> a) -> ContVec n a -> ContVec n a {-# INLINE scanl1 #-} scanl1 f (ContVec cont) = ContVec $ cont . scanl1F f @@ -719,17 +824,17 @@ -- | Evaluate every action in the vector from left to right. -sequence :: (Arity n, Applicative f) => ContVec n (f a) -> f (ContVec n a) +sequence :: (ArityPeano 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, Applicative f) => ContVec n (f a) -> f () +sequence_ :: (ArityPeano n, Applicative f) => ContVec n (f a) -> f () sequence_ = mapM_ id {-# INLINE sequence_ #-} -- | The dual of sequenceA -distribute :: (Functor f, Arity n) => f (ContVec n a) -> ContVec n (f a) +distribute :: (Functor f, ArityPeano n) => f (ContVec n a) -> ContVec n (f a) {-# INLINE distribute #-} distribute f0 = apply step start @@ -740,64 +845,77 @@ , 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 :: (Functor f, ArityPeano n) => (a -> ContVec n b) -> f a -> ContVec n (f b) collect f = distribute . fmap f {-# INLINE collect #-} -- | /O(1)/ Tail of vector. -tail :: {-FIXME-} Arity n => ContVec (n+1) a -> ContVec n a +tail :: ContVec (S n) a -> ContVec n a tail (ContVec cont) = ContVec $ \f -> cont $ constFun f {-# INLINE tail #-} -- | /O(1)/ Prepend element to vector -cons :: {-FIXME-} Arity n => a -> ContVec n a -> ContVec (n+1) a +cons :: a -> ContVec n a -> ContVec ('S n) a cons a (ContVec cont) = ContVec $ \f -> cont $ curryFirst f a {-# INLINE cons #-} -- | Prepend single element vector to another vector. -consV :: {-FIXME-} Arity n => ContVec 1 a -> ContVec n a -> ContVec (n+1) a +consV :: ArityPeano n => ContVec N1 a -> ContVec n a -> ContVec ('S n) 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 (n+1) a +snoc :: ArityPeano n => a -> ContVec n a -> ContVec ('S n) a snoc a (ContVec cont) = ContVec $ \f -> cont $ apLast f a {-# INLINE snoc #-} + -- | Concatenate vector -concat :: ( Arity n - , Arity k - , Arity (n + k) - -- Tautology - , Peano (n + k) ~ Add (Peano n) (Peano k) +concat :: ( ArityPeano n + , ArityPeano k + , ArityPeano (n `Add` k) ) - => ContVec n a -> ContVec k a -> ContVec (n + k) a + => ContVec n a -> ContVec k a -> ContVec (Add n k) a {-# INLINE concat #-} concat v u = inspect u $ inspect v $ curryMany construct -- | Reverse order of elements in the vector -reverse :: Arity n => ContVec n a -> ContVec n a +reverse :: ArityPeano n => ContVec n a -> ContVec n a reverse (ContVec cont) = ContVec $ cont . reverseF {-# INLINE reverse #-} +reverseF :: forall n a b. ArityPeano n => Fun n a b -> Fun n a b +reverseF (Fun fun0) = accumPeano + step + (\(T_map b) -> b) + (T_map fun0 :: T_map a b n) + where + step :: forall k. ArityPeano k => T_map a b (S k) -> a -> T_map a b k + step (T_map f) a = T_map $ unFun $ apLast (Fun f :: Fun (S k) a b) a + + -- | Zip two vector together using function. -zipWith :: (Arity n) => (a -> b -> c) +zipWith :: (ArityPeano n) => (a -> b -> c) -> ContVec n a -> ContVec n b -> ContVec n c {-# INLINE zipWith #-} -zipWith = izipWith . const +zipWith f vecA vecB = ContVec $ \funC -> + inspect vecB + $ inspect vecA + $ zipWithF f funC -- | Zip three vectors together -zipWith3 :: (Arity n) => (a -> b -> c -> d) +zipWith3 :: (ArityPeano n) => (a -> b -> c -> d) -> ContVec n a -> ContVec n b -> ContVec n c -> ContVec n d {-# INLINE zipWith3 #-} -zipWith3 f v1 v2 v3 = zipWith (\a (b, c) -> f a b c) v1 (zipWith (,) v2 v3) +zipWith3 f v1 v2 v3 + = zipWith ($) (zipWith f v1 v2) v3 -- | Zip two vector together using function which takes element index -- as well. -izipWith :: (Arity n) => (Int -> a -> b -> c) +izipWith :: (ArityPeano n) => (Int -> a -> b -> c) -> ContVec n a -> ContVec n b -> ContVec n c {-# INLINE izipWith #-} izipWith f vecA vecB = ContVec $ \funC -> @@ -806,53 +924,86 @@ $ izipWithF f funC -- | Zip three vectors together -izipWith3 :: (Arity n) => (Int -> a -> b -> c -> d) +izipWith3 :: (ArityPeano n) => (Int -> a -> b -> c -> d) -> ContVec n a -> ContVec n b -> ContVec n c -> ContVec n d {-# INLINE izipWith3 #-} 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, Applicative f) => (a -> b -> f c) +zipWithM :: (ArityPeano 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, Applicative f) +zipWithM_ :: (ArityPeano 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, Applicative f) => (Int -> a -> b -> f c) +izipWithM :: (ArityPeano 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, Applicative f) +izipWithM_ :: (ArityPeano 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) +-- NOTE: [zipWith] +-- ~~~~~~~~~~~~~~~ +-- +-- It turns out it's very difficult to implement zipWith using +-- accum/apply. Key problem is we need to implement: +-- +-- > zipF :: Fun n (a,b) r → Fun n a (Fun b r) +-- +-- Induction step would be implementing +-- +-- > ((a,b) → Fun n (a,b) r) → (a → Fun n a (b → Fun b r)) +-- +-- in terms of zipF above. It will give us `Fun n a (Fun b r)` but +-- we'll need to move parameter `b` _inside_ `Fun n a`. This requires +-- `ArityPeano` constraint while accum's parameter has note. Even +-- worse this implementation has quadratic complexity. +-- +-- It's possible to make zipF method of ArityPeano but quadratic +-- complexity won't go away and starts cause slowdown even for modest +-- values of `n`: 5-6. For n above 10 compilation starts to fail with +-- "simplifier ticks exhausted error". +-- +-- It turns out easiest way is materialize list and then deconstruct. +-- GHC is able to eliminate it and it's very hard to beat this approach + +zipWithF :: (ArityPeano n) + => (a -> b -> c) -> Fun n c r -> Fun n a (Fun n b r) +{-# INLINE zipWithF #-} +zipWithF f (Fun g0) + = makeList + $ \v -> accum (\(T_zip (a:as) g) b -> T_zip as (g $ f a b)) + (\(T_zip _ x) -> x) + (T_zip v g0) + izipWithF :: (ArityPeano n) => (Int -> a -> b -> c) -> Fun n c r -> Fun n a (Fun n b r) {-# INLINE izipWithF #-} -izipWithF f (Fun g0) = - fmap (\v -> accum - (\(T_izip i (a:as) g) b -> T_izip (i+1) as (g $ f i a b)) - (\(T_izip _ _ x) -> x) - (T_izip 0 v g0) - ) makeList - +izipWithF f (Fun g0) + = makeList + $ \v -> accum (\(T_izip i (a:as) g) b -> T_izip (i+1) as (g $ f i a b)) + (\(T_izip _ _ x) -> x) + (T_izip 0 v g0) -makeList :: ArityPeano n => Fun n a [a] +makeList :: ArityPeano n => ([a] -> b) -> Fun n a b {-# INLINE makeList #-} -makeList = accum +makeList cont = accum (\(Const xs) x -> Const (xs . (x:))) - (\(Const xs) -> xs []) + (\(Const xs) -> cont (xs [])) (Const id) data T_izip a c r n = T_izip Int [a] (Fn n c r) +data T_zip a c r n = T_zip [a] (Fn n c r) @@ -862,29 +1013,27 @@ -- | Run continuation vector. It's same as 'inspect' but with -- arguments flipped. -runContVec :: Fun (Peano n) a r +runContVec :: Fun n a r -> ContVec n a -> r runContVec f (ContVec c) = c f {-# INLINE runContVec #-} -- | Convert continuation to the vector. -vector :: (Vector v a, Dim v ~ n) => ContVec n a -> v a +vector :: (Vector v a) => ContVec (Dim v) a -> v a vector = runContVec construct {-# INLINE[1] vector #-} -- | Finalizer function for getting head of the vector. -head :: (Arity n, 1<=n) => ContVec n a -> a +head :: forall n k a. (ArityPeano n, n ~ 'S k) => ContVec n a -> a {-# INLINE head #-} head - = runContVec - $ accum (\(Const m) a -> Const $ case m of { Nothing -> Just a; x -> x }) - (\(Const (Just x)) -> x) - (Const Nothing) - + = dictionaryPred (proxy# @n) + $ runContVec + $ uncurryFirst pure -- | /O(n)/ Get value at specified index. -index :: Arity n => Int -> ContVec n a -> a +index :: ArityPeano n => Int -> ContVec n a -> a {-# INLINE index #-} index n | n < 0 = error "Data.Vector.Fixed.Cont.index: index out of range" @@ -902,7 +1051,7 @@ -- | Twan van Laarhoven lens for continuation based vector -element :: (Arity n, Functor f) +element :: (ArityPeano n, Functor f) => Int -> (a -> f a) -> ContVec n a -> f (ContVec n a) {-# INLINE element #-} element i f v = inspect v @@ -931,107 +1080,153 @@ -- | Left fold over continuation vector. -foldl :: Arity n => (b -> a -> b) -> b -> ContVec n a -> b +foldl :: ArityPeano n => (b -> a -> b) -> b -> ContVec n a -> b {-# INLINE foldl #-} -foldl f = ifoldl (\b _ a -> f b a) +foldl f b0 = runContVec (foldlF f b0) +-- | Strict left fold over continuation vector. +foldl' :: ArityPeano n => (b -> a -> b) -> b -> ContVec n a -> b +{-# INLINE foldl' #-} +foldl' f b0 = runContVec (foldlF' f b0) + -- | Left fold over continuation vector. -ifoldl :: Arity n => (b -> Int -> a -> b) -> b -> ContVec n a -> b +ifoldl :: ArityPeano n => (b -> Int -> a -> b) -> b -> ContVec n a -> b {-# INLINE ifoldl #-} ifoldl f b v = inspect v $ accum (\(T_ifoldl i r) a -> T_ifoldl (i+1) (f r i a)) - (\(T_ifoldl _ r) -> r) + (\(T_ifoldl _ r) -> r) (T_ifoldl 0 b) +-- | Strict left fold over continuation vector. +ifoldl' :: ArityPeano n => (b -> Int -> a -> b) -> b -> ContVec n a -> b +{-# INLINE ifoldl' #-} +ifoldl' f b v + = inspect v + $ accum (\(T_ifoldl i !r) a -> T_ifoldl (i+1) (f r i a)) + (\(T_ifoldl _ r) -> r) + (T_ifoldl 0 b) + -- | Monadic left fold over continuation vector. -foldM :: (Arity n, Monad m) +foldM :: (ArityPeano n, Monad m) => (b -> a -> m b) -> b -> ContVec n a -> m b {-# INLINE foldM #-} foldM f x = foldl (\m a -> do{ b <- m; f b a}) (return x) -- | Monadic left fold over continuation vector. -ifoldM :: (Arity n, Monad m) +ifoldM :: (ArityPeano n, Monad m) => (b -> Int -> a -> m b) -> b -> ContVec n a -> m b {-# INLINE ifoldM #-} ifoldM f x = ifoldl (\m i a -> do{ b <- m; f b i a}) (return x) -data T_ifoldl b n = T_ifoldl !Int b --- Implementation of foldl1 is quite ugly. It could be expressed in --- terms of foldlF (worker function for foldl) --- --- > foldl1F f = Fun $ \a -> case foldlF f a :: Fun n a a of Fun g -> g --- --- But it require constraint `Arity n` whereas `Vector v a` gives --- `Arity (S n)`. Latter imply former but GHC cannot infer it. - --- | Left fold. -foldl1 :: (Arity n, 1 <= n) => (a -> a -> a) -> ContVec n a -> a +-- | Left fold without base case. It's total because it requires vector to be nonempty +foldl1 :: forall n k a. (ArityPeano n, n ~ 'S k) + => (a -> a -> a) -> ContVec n a -> a {-# INLINE foldl1 #-} foldl1 f - = runContVec - $ accum (\(Const r ) a -> Const $ Just $ maybe a (flip f a) r) - (\(Const (Just x)) -> x) - (Const Nothing) + = dictionaryPred (proxy# @n) + $ runContVec + $ uncurryFirst (foldlF f) +-- | Left fold without base case. It's total because it requires vector to be nonempty +foldl1' :: forall n k a. (ArityPeano n, n ~ 'S k) + => (a -> a -> a) -> ContVec n a -> a +{-# INLINE foldl1' #-} +foldl1' f + = dictionaryPred (proxy# @n) + $ runContVec + $ uncurryFirst (foldlF' f) + + +foldlF :: ArityPeano n => (b -> a -> b) -> b -> Fun n a b +{-# INLINE foldlF #-} +foldlF f b0 + = accum (\(T_foldl b) a -> T_foldl (f b a)) + (\(T_foldl b) -> b) + (T_foldl b0) + +foldlF' :: ArityPeano n => (b -> a -> b) -> b -> Fun n a b +{-# INLINE foldlF' #-} +foldlF' f b0 + = accum (\(T_foldl !b) a -> T_foldl (f b a)) + (\(T_foldl b) -> b) + (T_foldl b0) + +newtype T_foldl b n = T_foldl b +data T_ifoldl b n = T_ifoldl !Int b + + -- | Right fold over continuation vector -foldr :: Arity n => (a -> b -> b) -> b -> ContVec n a -> b +foldr :: ArityPeano n => (a -> b -> b) -> b -> ContVec n a -> b {-# INLINE foldr #-} -foldr = ifoldr . const +foldr f b0 = runContVec $ foldrF f b0 -- | Right fold over continuation vector -ifoldr :: Arity n => (Int -> a -> b -> b) -> b -> ContVec n a -> b +ifoldr :: ArityPeano n => (Int -> a -> b -> b) -> b -> ContVec n a -> b {-# INLINE ifoldr #-} -ifoldr f z - = runContVec - $ accum (\(T_ifoldr i g) a -> T_ifoldr (i+1) (g . f i a)) - (\(T_ifoldr _ g) -> g z) - (T_ifoldr 0 id) +ifoldr f b0 = runContVec $ ifoldrF f b0 + +foldrF :: ArityPeano n => (a -> b -> b) -> b -> Fun n a b +{-# INLINE foldrF #-} +foldrF f b0 = accum + (\(T_foldr g) a -> T_foldr (g . f a)) + (\(T_foldr g) -> g b0) + (T_foldr id) + +ifoldrF :: ArityPeano n => (Int -> a -> b -> b) -> b -> Fun n a b +{-# INLINE ifoldrF #-} +ifoldrF f b0 = accum + (\(T_ifoldr i g) a -> T_ifoldr (i+1) (g . f i a)) + (\(T_ifoldr _ g) -> g b0) + (T_ifoldr 0 id) + +data T_foldr b n = T_foldr (b -> b) data T_ifoldr b n = T_ifoldr Int (b -> b) + -- | Sum all elements in the vector. -sum :: (Num a, Arity n) => ContVec n a -> a -sum = foldl (+) 0 +sum :: (Num a, ArityPeano n) => ContVec n a -> a +sum = foldl' (+) 0 {-# INLINE sum #-} -- | Minimal element of vector. -minimum :: (Ord a, Arity n, 1<=n) => ContVec n a -> a +minimum :: (Ord a, ArityPeano n, n ~ 'S k) => ContVec n a -> a minimum = foldl1 min {-# INLINE minimum #-} -- | Maximal element of vector. -maximum :: (Ord a, Arity n, 1<=n) => ContVec n a -> a +maximum :: (Ord a, ArityPeano n, n ~ 'S k) => ContVec n a -> a maximum = foldl1 max {-# INLINE maximum #-} -- | Conjunction of elements of a vector. -and :: Arity n => ContVec n Bool -> Bool +and :: ArityPeano n => ContVec n Bool -> Bool and = foldr (&&) True {-# INLINE and #-} -- | Disjunction of all elements of a vector. -or :: Arity n => ContVec n Bool -> Bool +or :: ArityPeano n => ContVec n Bool -> Bool or = foldr (||) False {-# INLINE or #-} -- | Determines whether all elements of vector satisfy predicate. -all :: Arity n => (a -> Bool) -> ContVec n a -> Bool +all :: ArityPeano n => (a -> Bool) -> ContVec n a -> Bool all f = foldr (\x b -> f x && b) True {-# INLINE all #-} -- | Determines whether any of element of vector satisfy predicate. -any :: Arity n => (a -> Bool) -> ContVec n a -> Bool +any :: ArityPeano n => (a -> Bool) -> ContVec n a -> Bool any f = foldr (\x b -> f x || b) False {-# INLINE any #-} -- | The 'find' function takes a predicate and a vector and returns -- the leftmost element of the vector matching the predicate, -- or 'Nothing' if there is no such element. -find :: Arity n => (a -> Bool) -> ContVec n a -> Maybe a +find :: ArityPeano n => (a -> Bool) -> ContVec n a -> Maybe a find f = foldl (\r x -> r <|> if f x then Just x else Nothing) Nothing {-# INLINE find #-} @@ -1042,7 +1237,7 @@ -> v a -> c (v a) gfoldl f inj v = inspect v - $ gfoldlF f (inj $ unFun (construct :: Fun (Peano (Dim v)) a (v a))) + $ gfoldlF f (inj $ unFun (construct :: Fun (Dim v) a (v a))) -- | Generic 'Data.Data.gunfoldl' which could work with any -- vector. Since vector can only have one constructor argument for @@ -1051,22 +1246,24 @@ => (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> con -> c (v a) -gunfold f inj _ - = gunfoldF f gun +gunfold f inj _ = + case reducePeano step gun of + T_gunfold c -> c where - con = construct :: Fun (Peano (Dim v)) a (v a) - gun = T_gunfold (inj $ unFun con) :: T_gunfold c (v a) a (Peano (Dim v)) - + con = construct @v @a + gun = T_gunfold (inj $ unFun con) :: T_gunfold c (v a) a (Dim v) + -- + step :: forall k r. T_gunfold c r a ('S k) -> T_gunfold c r a k + step (T_gunfold c) = T_gunfold (f c) 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) - (T_gfoldl c0) + (\(T_mapM c) x -> T_mapM (f c x)) + (\(T_mapM c) -> c) + (T_mapM c0) -newtype T_gfoldl c r a n = T_gfoldl (c (Fn n a r)) ---------------------------------------------------------------- @@ -1105,7 +1302,8 @@ -- Instances ---------------------------------------------------------------- -type instance Dim Complex = 2 +type instance Dim Complex = N2 +type instance Dim (Complex a) = N2 instance Vector Complex a where construct = Fun (:+) @@ -1114,7 +1312,8 @@ {-# INLINE inspect #-} -type instance Dim Identity = 1 +type instance Dim Identity = N1 +type instance Dim (Identity a) = N1 instance Vector Identity a where construct = Fun Identity @@ -1123,7 +1322,8 @@ {-# INLINE inspect #-} -type instance Dim ((,) a) = 2 +type instance Dim ((,) a) = N2 +type instance Dim ((,) a b) = N2 -- | Note this instance (and other instances for tuples) is -- essentially monomorphic in element type. Vector type /v/ of 2 @@ -1136,7 +1336,8 @@ {-# INLINE inspect #-} -type instance Dim ((,,) a b) = 3 +type instance Dim ((,,) a b) = N3 +type instance Dim ((,,) a b c) = N3 instance (b~a, c~a) => Vector ((,,) b c) a where construct = Fun (,,) @@ -1145,7 +1346,8 @@ {-# INLINE inspect #-} -type instance Dim ((,,,) a b c) = 4 +type instance Dim ((,,,) a b c) = N4 +type instance Dim ((,,,) a b c d) = N4 instance (b~a, c~a, d~a) => Vector ((,,,) b c d) a where construct = Fun (,,,) @@ -1154,7 +1356,8 @@ {-# INLINE inspect #-} -type instance Dim ((,,,,) a b c d) = 5 +type instance Dim ((,,,,) a b c d) = N5 +type instance Dim ((,,,,) a b c d e) = N5 instance (b~a, c~a, d~a, e~a) => Vector ((,,,,) b c d e) a where construct = Fun (,,,,) @@ -1163,7 +1366,8 @@ {-# INLINE inspect #-} -type instance Dim ((,,,,,) a b c d e) = 6 +type instance Dim ((,,,,,) a b c d e) = N6 +type instance Dim ((,,,,,) a b c d e f) = N6 instance (b~a, c~a, d~a, e~a, f~a) => Vector ((,,,,,) b c d e f) a where construct = Fun (,,,,,) @@ -1172,7 +1376,8 @@ {-# INLINE inspect #-} -type instance Dim ((,,,,,,) a b c d e f) = 7 +type instance Dim ((,,,,,,) a b c d e f) = N7 +type instance Dim ((,,,,,,) a b c d e f g) = N7 instance (b~a, c~a, d~a, e~a, f~a, g~a) => Vector ((,,,,,,) b c d e f g) a where construct = Fun (,,,,,,) @@ -1180,7 +1385,8 @@ {-# INLINE construct #-} {-# INLINE inspect #-} -type instance Dim Proxy = 0 +type instance Dim Proxy = Z +type instance Dim (Proxy a) = Z instance Vector Proxy a where construct = Fun Proxy diff --git a/Data/Vector/Fixed/Generic.hs b/Data/Vector/Fixed/Generic.hs --- a/Data/Vector/Fixed/Generic.hs +++ b/Data/Vector/Fixed/Generic.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TypeFamilies #-} -- | -- More generic version of function from "Data.Vector.Fixed" -- module. They do not require that all vector have same type, only 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,26 +1,18 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} -- | -- Implementation of fixed-vectors module Data.Vector.Fixed.Internal where 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 GHC.Exts (proxy#) -import Data.Vector.Fixed.Cont (Vector(..),Dim,Arity,vector,Add) +import Data.Vector.Fixed.Cont (Vector(..),Dim,vector,Add,PeanoNum(..), + Peano,Index,ArityPeano) import qualified Data.Vector.Fixed.Cont as C import Prelude hiding ( replicate,map,zipWith,maximum,minimum,and,or,all,any @@ -33,39 +25,39 @@ -- Constructors ---------------------------------------------------------------- -mk0 :: (Vector v a, Dim v ~ 0) => v a +mk0 :: (Vector v a, Dim v ~ 'Z) => v a mk0 = vector C.empty {-# INLINE mk0 #-} -mk1 :: (Vector v a, Dim v ~ 1) => a -> v a +mk1 :: (Vector v a, Dim v ~ C.N1) => a -> v a mk1 a1 = vector $ C.mk1 a1 {-# INLINE mk1 #-} -mk2 :: (Vector v a, Dim v ~ 2) => a -> a -> v a +mk2 :: (Vector v a, Dim v ~ C.N2) => a -> a -> v a mk2 a1 a2 = vector $ C.mk2 a1 a2 {-# INLINE mk2 #-} -mk3 :: (Vector v a, Dim v ~ 3) => a -> a -> a -> v a +mk3 :: (Vector v a, Dim v ~ C.N3) => a -> a -> a -> v a mk3 a1 a2 a3 = vector $ C.mk3 a1 a2 a3 {-# INLINE mk3 #-} -mk4 :: (Vector v a, Dim v ~ 4) => a -> a -> a -> a -> v a +mk4 :: (Vector v a, Dim v ~ C.N4) => 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 ~ 5) => a -> a -> a -> a -> a -> v a +mk5 :: (Vector v a, Dim v ~ C.N5) => a -> a -> a -> a -> a -> v a mk5 a1 a2 a3 a4 a5 = vector $ C.mk5 a1 a2 a3 a4 a5 {-# INLINE mk5 #-} -mk6 :: (Vector v a, Dim v ~ 6) => a -> a -> a -> a -> a -> a -> v a +mk6 :: (Vector v a, Dim v ~ C.N6) => a -> a -> a -> a -> a -> a -> v a mk6 a1 a2 a3 a4 a5 a6 = vector $ C.mk6 a1 a2 a3 a4 a5 a6 {-# INLINE mk6 #-} -mk7 :: (Vector v a, Dim v ~ 7) => a -> a -> a -> a -> a -> a -> a -> v a +mk7 :: (Vector v a, Dim v ~ C.N7) => a -> a -> a -> a -> a -> a -> a -> v a mk7 a1 a2 a3 a4 a5 a6 a7 = vector $ C.mk7 a1 a2 a3 a4 a5 a6 a7 {-# INLINE mk7 #-} -mk8 :: (Vector v a, Dim v ~ 8) => a -> a -> a -> a -> a -> a -> a -> a -> v a +mk8 :: (Vector v a, Dim v ~ C.N8) => a -> a -> a -> a -> a -> a -> a -> a -> v a mk8 a1 a2 a3 a4 a5 a6 a7 a8 = vector $ C.mk8 a1 a2 a3 a4 a5 a6 a7 a8 {-# INLINE mk8 #-} @@ -77,14 +69,14 @@ -- -- or using @TypeApplications@ syntax: -- --- > v = mkN (Proxy @ (Int,Int,Int)) 1 2 3 +-- > v = mkN (Proxy @(Int,Int,Int)) 1 2 3 -- -- or if type of @v@ 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)) + => proxy (v a) -> C.Fn (Dim v) a (v a) +mkN _ = C.unFun (construct :: C.Fun (Dim v) a (v a)) ---------------------------------------------------------------- -- Generic functions @@ -96,14 +88,14 @@ -- -- >>> import Data.Vector.Fixed.Boxed (Vec2) -- >>> replicate 1 :: Vec2 Int --- fromList [1,1] +-- [1,1] -- -- >>> replicate 2 :: (Double,Double,Double) -- (2.0,2.0,2.0) -- -- >>> import Data.Vector.Fixed.Boxed (Vec4) -- >>> replicate "foo" :: Vec4 String --- fromList ["foo","foo","foo","foo"] +-- ["foo","foo","foo","foo"] replicate :: Vector v a => a -> v a {-# INLINE replicate #-} replicate @@ -116,11 +108,11 @@ -- -- >>> import Data.Vector.Fixed.Boxed (Vec2,Vec3) -- >>> replicateM (Just 3) :: Maybe (Vec3 Int) --- Just (fromList [3,3,3]) +-- Just [3,3,3] -- >>> replicateM (putStrLn "Hi!") :: IO (Vec2 ()) -- Hi! -- Hi! --- fromList [(),()] +-- [(),()] replicateM :: (Vector v a, Applicative f) => f a -> f (v a) {-# INLINE replicateM #-} replicateM @@ -134,11 +126,11 @@ -- -- >>> import Data.Vector.Fixed.Boxed (Vec3) -- >>> basis 0 :: Vec3 Int --- fromList [1,0,0] +-- [1,0,0] -- >>> basis 1 :: Vec3 Int --- fromList [0,1,0] +-- [0,1,0] -- >>> basis 3 :: Vec3 Int --- fromList [0,0,0] +-- [0,0,0] basis :: (Vector v a, Num a) => Int -> v a {-# INLINE basis #-} basis = vector . C.basis @@ -157,7 +149,7 @@ -- -- >>> import Data.Vector.Fixed.Unboxed (Vec4) -- >>> generate (^2) :: Vec4 Int --- fromList [0,1,4,9] +-- [0,1,4,9] generate :: (Vector v a) => (Int -> a) -> v a {-# INLINE generate #-} generate = vector . C.generate @@ -181,7 +173,7 @@ -- >>> let x = mk3 1 2 3 :: Vec3 Int -- >>> head x -- 1 -head :: (Vector v a, 1 <= Dim v) => v a -> a +head :: (Vector v a, Dim v ~ 'S k) => v a -> a {-# INLINE head #-} head = C.head . C.cvec @@ -193,27 +185,25 @@ -- >>> import Data.Complex -- >>> tail (1,2,3) :: Complex Double -- 2.0 :+ 3.0 -tail :: (Vector v a, Vector w a, Dim v ~ (Dim w + 1)) +tail :: (Vector v a, Vector w a, Dim v ~ 'S (Dim w)) => v a -> w a {-# INLINE tail #-} tail = vector . C.tail . C.cvec -- | Cons element to the vector -cons :: (Vector v a, Vector w a, Dim w ~ (Dim v + 1)) +cons :: (Vector v a, Vector w a, Dim w ~ 'S (Dim v)) => 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, Dim w ~ (Dim v + 1)) +snoc :: (Vector v a, Vector w a, Dim w ~ 'S (Dim v)) => 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 - , (Dim v + Dim u) ~ Dim w - -- Tautology - , C.Peano (Dim v + Dim u) ~ Add (C.Peano (Dim v)) (C.Peano (Dim u)) + , (Dim v `Add` Dim u) ~ Dim w ) => v a -> u a -> w a {-# INLINE concat #-} @@ -228,10 +218,10 @@ -- /O(n)/ but more efficient one is used when possible. (!) :: (Vector v a) => v a -> Int -> a {-# INLINE (!) #-} -v ! n = runIndex n (C.cvec v) +(!) v n = runIndex n (C.cvec v) -- Used in rewriting of index function. -runIndex :: Arity n => Int -> C.ContVec n r -> r +runIndex :: ArityPeano n => Int -> C.ContVec n r -> r runIndex = C.index {-# INLINE[0] runIndex #-} @@ -259,16 +249,18 @@ -- | Get element from vector at statically known index -index :: (Vector v a, KnownNat k, k + 1 <= Dim v) +index :: forall k v a proxy. (Vector v a, Index (Peano k) (Dim v)) => v a -> proxy k -> a {-# INLINE index #-} -index v k = v ! fromIntegral (natVal k) +index v _ = inspect v (C.getF (proxy# @(Peano k))) -- | Set n'th element in the vector -set :: (Vector v a, KnownNat k, k + 1 <= Dim v) => proxy k -> a -> v a -> v a +set :: forall k v a proxy. (Vector v a, Index (Peano k) (Dim v)) + => proxy k -> a -> v a -> v a {-# INLINE set #-} -set k a = runIdentity . element (fromIntegral (natVal k)) - (const (Identity a)) +set _ a v + = inspect v + $ C.putF (proxy# @(Peano k)) a construct -- | Twan van Laarhoven's lens for element of vector element :: (Vector v a, Functor f) => Int -> (a -> f a) -> (v a -> f (v a)) @@ -277,10 +269,11 @@ -- | Twan van Laarhoven's lens for element of vector with statically -- known index. -elementTy :: (Vector v a, KnownNat k, k + 1 <= Dim v, Functor f) +elementTy :: forall k v a f proxy. (Vector v a, Index (Peano k) (Dim v), Functor f) => proxy k -> (a -> f a) -> (v a -> f (v a)) {-# INLINE elementTy #-} -elementTy k = element (fromIntegral (natVal k)) +elementTy _ f v + = inspect v (C.lensF (proxy# @(Peano k)) f construct) -- | Left fold over vector foldl :: Vector v a => (b -> a -> b) -> b -> v a -> b @@ -288,6 +281,12 @@ foldl f x = C.foldl f x . C.cvec +-- | Strict left fold over vector +foldl' :: Vector v a => (b -> a -> b) -> b -> v a -> b +{-# INLINE foldl' #-} +foldl' f x = C.foldl' f x + . C.cvec + -- | Right fold over vector foldr :: Vector v a => (a -> b -> b) -> b -> v a -> b {-# INLINE foldr #-} @@ -296,7 +295,7 @@ -- | Left fold over vector -foldl1 :: (Vector v a, 1 <= Dim v) => (a -> a -> a) -> v a -> a +foldl1 :: (Vector v a, Dim v ~ 'S k) => (a -> a -> a) -> v a -> a {-# INLINE foldl1 #-} foldl1 f = C.foldl1 f . C.cvec @@ -328,6 +327,13 @@ ifoldl f z = C.ifoldl f z . C.cvec +-- | Strict left fold over vector. Function is applied to each element +-- and its index. +ifoldl' :: Vector v a => (b -> Int -> a -> b) -> b -> v a -> b +{-# INLINE ifoldl' #-} +ifoldl' f z = C.ifoldl' f z + . C.cvec + -- | Monadic fold over vector. foldM :: (Vector v a, Monad m) => (b -> a -> m b) -> b -> v a -> m b {-# INLINE foldM #-} @@ -356,7 +362,7 @@ -- >>> let x = mk3 1 2 3 :: Vec3 Int -- >>> maximum x -- 3 -maximum :: (Vector v a, 1 <= Dim v, Ord a) => v a -> a +maximum :: (Vector v a, Dim v ~ S k, Ord a) => v a -> a maximum = C.maximum . C.cvec {-# INLINE maximum #-} @@ -368,7 +374,7 @@ -- >>> let x = mk3 1 2 3 :: Vec3 Int -- >>> minimum x -- 1 -minimum :: (Vector v a, 1 <= Dim v, Ord a) => v a -> a +minimum :: (Vector v a, Dim v ~ S k, Ord a) => v a -> a minimum = C.minimum . C.cvec {-# INLINE minimum #-} @@ -484,7 +490,7 @@ . C.cvec -- | Left scan over vector -scanl :: (Vector v a, Vector w b, Dim w ~ (Dim v + 1)) +scanl :: (Vector v a, Vector w b, Dim w ~ 'S (Dim v)) => (b -> a -> b) -> b -> v a -> w b {-# INLINE scanl #-} scanl f x0 = vector . C.scanl f x0 . C.cvec @@ -499,7 +505,8 @@ sequenceA :: (Vector v a, Vector v (f a), Applicative f) => v (f a) -> f (v a) {-# INLINE sequenceA #-} -sequenceA = fmap vector . T.sequenceA . C.cvec +sequenceA = sequence +{-# DEPRECATED sequenceA "Use sequence instead" #-} -- | Analog of 'T.traverse' from 'T.Traversable'. traverse :: (Vector v a, Vector v b, Applicative f) @@ -531,11 +538,11 @@ -- >>> let b2 = basis 2 :: Vec3 Int -- >>> let vplus x y = zipWith (+) x y -- >>> vplus b0 b1 --- fromList [1,1,0] +-- [1,1,0] -- >>> vplus b0 b2 --- fromList [1,0,1] +-- [1,0,1] -- >>> vplus b1 b2 --- fromList [0,1,1] +-- [0,1,1] zipWith :: (Vector v a, Vector v b, Vector v c) => (a -> b -> c) -> v a -> v b -> v c {-# INLINE zipWith #-} @@ -598,7 +605,7 @@ -- | Zip two vector elementwise using monadic function and discard -- result izipWithM_ - :: (Vector v a, Vector v b, Vector v c, Applicative f, Vector v (f c)) + :: (Vector v a, Vector v b, Vector v c, Applicative f) => (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) @@ -612,12 +619,13 @@ defaultAlignemnt _ = alignment (undefined :: a) {-# INLINE defaultAlignemnt #-} + -- | Default implementation of 'sizeOf` for 'Storable' type class for -- fixed vectors defaultSizeOf :: forall a v. (Storable a, Vector v a) => v a -> Int -defaultSizeOf _ = sizeOf (undefined :: a) * C.arity (Proxy :: Proxy (Dim v)) +defaultSizeOf _ = sizeOf (undefined :: a) * C.peanoToInt (proxy# @(Dim v)) {-# INLINE defaultSizeOf #-} -- | Default implementation of 'peek' for 'Storable' type class for @@ -676,5 +684,5 @@ -- | Generic definition of 'Prelude.showsPrec' showsPrec :: (Vector v a, Show a) => Int -> v a -> ShowS -showsPrec d v = showParen (d > 10) $ showString "fromList " . Prelude.showsPrec 11 (toList v) +showsPrec _ = shows . toList {-# INLINE showsPrec #-} diff --git a/Data/Vector/Fixed/Mono.hs b/Data/Vector/Fixed/Mono.hs new file mode 100644 --- /dev/null +++ b/Data/Vector/Fixed/Mono.hs @@ -0,0 +1,981 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +module Data.Vector.Fixed.Mono + ( -- * Vector type class + Prod(..) + , Vector + , Dim + , C.Arity + , C.ArityPeano + , C.Fun(..) + , length + -- ** Peano numbers + , PeanoNum(..) + , Peano + , N1, N2, N3, N4, N5, N6, N7, N8 + -- * Construction and destructions + -- $construction + + -- ** Constructors + , mk0 + , mk1 + , mk2 + , mk3 + , mk4 + , mk5 + , mk6 + , mk7 + , mk8 + , mkN + -- ** Pattern synonyms + , pattern V1 + , pattern V2 + , pattern V3 + , pattern V4 + -- * Functions + -- ** Creation + , replicate + , replicateM + , generate + , generateM + , unfoldr + , basis + -- ** Transformations + , head + , tail + , cons + , snoc + , concat + , reverse + -- ** Indexing & lenses + , C.Index + , (!) + , index + , set + , element + , elementTy + -- ** Maps + , map + , gmap + , mapM + , gmapM + , mapM_ + , imap + , igmap + , imapM + , igmapM + , imapM_ + , scanl + , scanl1 + -- , traverse + -- ** Folds + , foldl + , foldl' + , foldr + , foldl1 + , fold + , foldMap + , ifoldl + , ifoldl' + , ifoldr + , foldM + , ifoldM + -- *** Special folds + , sum + , maximum + , minimum + , and + , or + , all + , any + , find + -- ** Zips + , zipWith + , zipWith3 + , zipWithM + , zipWithM_ + , izipWith + , izipWith3 + , izipWithM + , izipWithM_ + -- *** Special zips + , eq + , ord + -- ** Conversion + , convert + , toList + , fromList + , fromList' + , fromListM + , fromFoldable + -- ** Continuation-based vectors + , C.ContVec + , vector + , cvec + -- * Instance deriving + , ViaFixed(..) + ) where + +import Control.DeepSeq (NFData(..)) +import Control.Monad.Primitive (PrimBase(..)) +import Data.Complex +import Data.Foldable qualified as T +import Data.Primitive.Types (Prim(..)) +import Foreign.Ptr (castPtr) +import Foreign.Storable (Storable(..)) + +import GHC.Exts (Proxy#,proxy#,Int(..),Int#,(+#),(*#)) +import GHC.ST (ST(..)) + +import Prelude (Eq(..),Ord(..),Show(..),Num(..),Functor,Applicative,Monad + ,Semigroup(..),Monoid(..) + ,Bool,Maybe(..),Ordering + ,fmap,(<$>),(.),($),shows,flip,undefined + ) + +import Data.Vector.Fixed.Compat +import Data.Vector.Fixed.Cont qualified as C +import Data.Vector.Fixed.Cont (Dim,Add,ArityPeano,Peano,Index,PeanoNum(..), + N1,N2,N3,N4,N5,N6,N7,N8) + + + +---------------------------------------------------------------- +-- Classes +---------------------------------------------------------------- + + +class C.ArityPeano (Dim v) => Prod a v | v -> a where + inspect :: v -> C.Fun (Dim v) a r -> r + construct :: C.Fun (Dim v) a v + +class Prod a v => Vector a v + +-- | Convert regular vector to continuation based one. +cvec :: (Prod a v) => v -> C.ContVec (Dim v) a +cvec v = C.ContVec (inspect v) +{-# INLINE[0] cvec #-} + +-- | Convert continuation to the vector. +vector :: (Prod a v) => C.ContVec (Dim v) a -> v +vector = C.runContVec construct +{-# INLINE[1] vector #-} + +{-# RULES +"cvec/vector[mono]" forall v. + cvec (vector v) = v + #-} + + + +---------------------------------------------------------------- +-- Constructors +---------------------------------------------------------------- + +mk0 :: forall v a. (Vector a v, Dim v ~ 'Z) => v +mk0 = vector C.empty +{-# INLINE mk0 #-} + +mk1 :: forall v a. (Vector a v, Dim v ~ N1) => a -> v +mk1 a1 = vector $ C.mk1 a1 +{-# INLINE mk1 #-} + +mk2 :: forall v a. (Vector a v, Dim v ~ N2) => a -> a -> v +mk2 a1 a2 = vector $ C.mk2 a1 a2 +{-# INLINE mk2 #-} + +mk3 :: forall v a. (Vector a v, Dim v ~ N3) => a -> a -> a -> v +mk3 a1 a2 a3 = vector $ C.mk3 a1 a2 a3 +{-# INLINE mk3 #-} + +mk4 :: forall v a. (Vector a v, Dim v ~ N4) => a -> a -> a -> a -> v +mk4 a1 a2 a3 a4 = vector $ C.mk4 a1 a2 a3 a4 +{-# INLINE mk4 #-} + +mk5 :: forall v a. (Vector a v, Dim v ~ N5) => a -> a -> a -> a -> a -> v +mk5 a1 a2 a3 a4 a5 = vector $ C.mk5 a1 a2 a3 a4 a5 +{-# INLINE mk5 #-} + +mk6 :: forall v a. (Vector a v, Dim v ~ N6) => a -> a -> a -> a -> a -> a -> v +mk6 a1 a2 a3 a4 a5 a6 = vector $ C.mk6 a1 a2 a3 a4 a5 a6 +{-# INLINE mk6 #-} + +mk7 :: forall v a. (Vector a v, Dim v ~ N7) => a -> a -> a -> a -> a -> a -> a -> v +mk7 a1 a2 a3 a4 a5 a6 a7 = vector $ C.mk7 a1 a2 a3 a4 a5 a6 a7 +{-# INLINE mk7 #-} + +mk8 :: forall v a. (Vector a v, Dim v ~ N8) => a -> a -> a -> a -> a -> a -> a -> a -> v +mk8 a1 a2 a3 a4 a5 a6 a7 a8 = vector $ C.mk8 a1 a2 a3 a4 a5 a6 a7 a8 +{-# INLINE mk8 #-} + +-- | 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 :: Proxy (Int,Int,Int)) 1 2 3 +-- +-- or using @TypeApplications@ syntax: +-- +-- > v = mkN (Proxy @(Int,Int,Int)) 1 2 3 +-- +-- or if type of @v@ is fixed elsewhere +-- +-- > v = mkN [v] 1 2 3 +mkN :: forall proxy v a. (Vector a v) + => proxy v -> C.Fn (Dim v) a v +mkN _ = C.unFun (construct :: C.Fun (Dim v) a v) + +---------------------------------------------------------------- +-- Generic functions +---------------------------------------------------------------- + +-- | Length of vector. Function doesn't evaluate its argument. +length :: forall v. C.ArityPeano (Dim v) => v -> Int +{-# INLINE length #-} +length _ = C.peanoToInt (proxy# @(Dim v)) + +-- | Replicate value /n/ times. +-- +-- Examples: +-- +-- >>> import Data.Vector.Fixed.Boxed (Vec2) +-- >>> replicate 1 :: Vec2 Int +-- [1,1] +-- +-- >>> replicate 2 :: (Double,Double,Double) +-- (2.0,2.0,2.0) +-- +-- >>> import Data.Vector.Fixed.Boxed (Vec4) +-- >>> replicate "foo" :: Vec4 String +-- ["foo","foo","foo","foo"] +replicate :: forall v a. Vector a v => a -> v +{-# INLINE replicate #-} +replicate + = vector . C.replicate + + +-- | Execute monadic action for every element of vector. +-- +-- Examples: +-- +-- >>> import Data.Vector.Fixed.Boxed (Vec2,Vec3) +-- >>> replicateM (Just 3) :: Maybe (Vec3 Int) +-- Just [3,3,3] +-- >>> replicateM (putStrLn "Hi!") :: IO (Vec2 ()) +-- Hi! +-- Hi! +-- [(),()] +replicateM :: forall v f a. (Vector a v, Applicative f) => f a -> f (v) +{-# INLINE replicateM #-} +replicateM + = fmap vector . C.replicateM + + +-- | Unit vector along Nth axis. If index is larger than vector +-- dimensions returns zero vector. +-- +-- Examples: +-- +-- >>> import Data.Vector.Fixed.Boxed (Vec3) +-- >>> basis 0 :: Vec3 Int +-- [1,0,0] +-- >>> basis 1 :: Vec3 Int +-- [0,1,0] +-- >>> basis 3 :: Vec3 Int +-- [0,0,0] +basis :: forall v a. (Vector a v, Num a) => Int -> v +{-# INLINE basis #-} +basis = vector . C.basis + + +-- | Unfold vector. +unfoldr :: forall v a b. (Vector a v) => (b -> (a,b)) -> b -> v +{-# INLINE unfoldr #-} +unfoldr f = vector . C.unfoldr f + + +-- | Generate vector from function which maps element's index to its +-- value. +-- +-- Examples: +-- +-- >>> import Data.Vector.Fixed.Unboxed (Vec4) +-- >>> generate (^2) :: Vec4 Int +-- [0,1,4,9] +generate :: forall v a. (Vector a v) => (Int -> a) -> v +{-# INLINE generate #-} +generate = vector . C.generate + + +-- | Generate vector from monadic function which maps element's index +-- to its value. +generateM :: forall v f a. (Applicative f, Vector a v) => (Int -> f a) -> f v +{-# INLINE generateM #-} +generateM = fmap vector . C.generateM + + + +---------------------------------------------------------------- + +-- | First element of vector. +-- +-- Examples: +-- +-- >>> import Data.Vector.Fixed.Boxed (Vec3) +-- >>> let x = mk3 1 2 3 :: Vec3 Int +-- >>> head x +-- 1 +head :: forall v k a. (Vector a v, Dim v ~ 'S k) => v -> a +{-# INLINE head #-} +head = C.head . cvec + + +-- | Tail of vector. +-- +-- Examples: +-- +-- >>> import Data.Complex +-- >>> tail (1,2,3) :: Complex Double +-- 2.0 :+ 3.0 +tail :: forall v w a. (Vector a v, Vector a w, Dim v ~ 'S (Dim w)) + => v -> w +{-# INLINE tail #-} +tail = vector . C.tail . cvec + +-- | Cons element to the vector +cons :: forall v w a. (Vector a v, Vector a w, Dim w ~ 'S (Dim v)) + => a -> v -> w +{-# INLINE cons #-} +cons a = vector . C.cons a . cvec + +-- | Append element to the vector +snoc :: forall v w a. (Vector a v, Vector a w, Dim w ~ 'S (Dim v)) + => a -> v -> w +{-# INLINE snoc #-} +snoc a = vector . C.snoc a . cvec + +concat :: forall v u w a. + ( Vector a v, Vector a u, Vector a w + , (Dim v `Add` Dim u) ~ Dim w + ) + => v -> u -> w +{-# INLINE concat #-} +concat v u = vector $ C.concat (cvec v) (cvec u) + +-- | Reverse order of elements in the vector +reverse :: forall v a. Vector a v => v -> v +reverse = vector . C.reverse . cvec +{-# INLINE reverse #-} + + +-- | Retrieve vector's element at index. Generic implementation is +-- /O(n)/ but more efficient one is used when possible. +(!) :: forall v a. (Vector a v) => v -> Int -> a +{-# INLINE (!) #-} +v ! i = C.index i (cvec v) + +-- | Get element from vector at statically known index +index :: forall v k a proxy. (Vector a v, Index (Peano k) (Dim v)) + => v -> proxy k -> a +{-# INLINE index #-} +index v _ = inspect v (C.getF (proxy# @(Peano k))) + +-- | Set n'th element in the vector +set :: forall v k a proxy. (Vector a v, Index (Peano k) (Dim v)) + => proxy k -> a -> v -> v +{-# INLINE set #-} +set _ a v + = inspect v + $ C.putF (proxy# @(Peano k)) a construct + +-- | Twan van Laarhoven's lens for element of vector +element :: forall v f a. (Vector a v, Functor f) => Int -> (a -> f a) -> (v -> f v) +{-# INLINE element #-} +element i f v = vector `fmap` C.element i f (cvec v) + +-- | Twan van Laarhoven's lens for element of vector with statically +-- known index. +elementTy + :: forall v f k a proxy. (Vector a v, Index (Peano k) (Dim v), Functor f) + => proxy k -> (a -> f a) -> (v -> f v) +{-# INLINE elementTy #-} +elementTy _ f v + = inspect v (C.lensF (proxy# @(Peano k)) f construct) + +-- | Left fold over vector +foldl :: forall v b a. Vector a v => (b -> a -> b) -> b -> v -> b +{-# INLINE foldl #-} +foldl f x = C.foldl f x + . cvec + +-- | Strict left fold over vector +foldl' :: forall v b a. Vector a v => (b -> a -> b) -> b -> v -> b +{-# INLINE foldl' #-} +foldl' f x = C.foldl' f x + . cvec + +-- | Right fold over vector +foldr :: forall v b a. Vector a v => (a -> b -> b) -> b -> v -> b +{-# INLINE foldr #-} +foldr f x = C.foldr f x + . cvec + + +-- | Left fold over vector +foldl1 :: forall v a k. (Vector a v, Dim v ~ 'S k) => (a -> a -> a) -> v -> a +{-# INLINE foldl1 #-} +foldl1 f = C.foldl1 f + . cvec + +-- | Combine the elements of a structure using a monoid. Similar to +-- 'T.fold' +fold :: forall v m. (Vector m v, Monoid m) => v -> m +{-# INLINE fold #-} +fold = T.fold + . cvec + +-- | Map each element of the structure to a monoid, +-- and combine the results. Similar to 'T.foldMap' +foldMap :: forall v m a. (Vector a v, Monoid m) => (a -> m) -> v -> m +{-# INLINE foldMap #-} +foldMap f = T.foldMap f + . cvec + +-- | Right fold over vector +ifoldr :: forall v b a. Vector a v => (Int -> a -> b -> b) -> b -> v -> b +{-# INLINE ifoldr #-} +ifoldr f x = C.ifoldr f x + . cvec + +-- | Left fold over vector. Function is applied to each element and +-- its index. +ifoldl :: forall v b a. Vector a v => (b -> Int -> a -> b) -> b -> v -> b +{-# INLINE ifoldl #-} +ifoldl f z = C.ifoldl f z + . cvec + +-- | Strict left fold over vector. Function is applied to each element +-- and its index. +ifoldl' :: forall v b a. Vector a v => (b -> Int -> a -> b) -> b -> v -> b +{-# INLINE ifoldl' #-} +ifoldl' f z = C.ifoldl' f z + . cvec + +-- | Monadic fold over vector. +foldM :: forall v m b a. (Vector a v, Monad m) => (b -> a -> m b) -> b -> v -> m b +{-# INLINE foldM #-} +foldM f x = C.foldM f x . cvec + +-- | Left monadic fold over vector. Function is applied to each element and +-- its index. +ifoldM :: forall v m b a. (Vector a v, Monad m) => (b -> Int -> a -> m b) -> b -> v -> m b +{-# INLINE ifoldM #-} +ifoldM f x = C.ifoldM f x . cvec + + +---------------------------------------------------------------- + +-- | Sum all elements in the vector. +sum :: forall v a. (Vector a v, Num a) => v -> a +sum = C.sum . cvec +{-# INLINE sum #-} + +-- | Maximal element of vector. +-- +-- Examples: +-- +-- >>> import Data.Vector.Fixed.Boxed (Vec3) +-- >>> let x = mk3 1 2 3 :: Vec3 Int +-- >>> maximum x +-- 3 +maximum :: forall v a k. (Vector a v, Dim v ~ S k, Ord a) => v -> a +maximum = C.maximum . cvec +{-# INLINE maximum #-} + +-- | Minimal element of vector. +-- +-- Examples: +-- +-- >>> import Data.Vector.Fixed.Boxed (Vec3) +-- >>> let x = mk3 1 2 3 :: Vec3 Int +-- >>> minimum x +-- 1 +minimum :: forall v a k. (Vector a v, Dim v ~ S k, Ord a) => v -> a +minimum = C.minimum . cvec +{-# INLINE minimum #-} + +-- | Conjunction of all elements of a vector. +and :: forall v. (Vector Bool v) => v -> Bool +and = C.and . cvec +{-# INLINE and #-} + +-- | Disjunction of all elements of a vector. +or :: forall v. (Vector Bool v) => v -> Bool +or = C.or . cvec +{-# INLINE or #-} + +-- | Determines whether all elements of vector satisfy predicate. +all :: forall v a. (Vector a v) => (a -> Bool) -> v -> Bool +all f = (C.all f) . cvec +{-# INLINE all #-} + +-- | Determines whether any of element of vector satisfy predicate. +any :: forall v a. (Vector a v) => (a -> Bool) -> v -> Bool +any f = (C.any f) . cvec +{-# INLINE any #-} + +-- | The 'find' function takes a predicate and a vector and returns +-- the leftmost element of the vector matching the predicate, +-- or 'Nothing' if there is no such element. +find :: forall v a. (Vector a v) => (a -> Bool) -> v -> Maybe a +find f = (C.find f) . cvec +{-# INLINE find #-} + +---------------------------------------------------------------- + +-- | Test two vectors for equality. +-- +-- Examples: +-- +-- >>> import Data.Vector.Fixed.Boxed (Vec2) +-- >>> let v0 = basis 0 :: Vec2 Int +-- >>> let v1 = basis 1 :: Vec2 Int +-- >>> v0 `eq` v0 +-- True +-- >>> v0 `eq` v1 +-- False +eq :: (Vector a v, Eq a) => v -> v -> Bool +{-# INLINE eq #-} +eq v w = C.and + $ C.zipWith (==) (cvec v) (cvec w) + + +-- | Lexicographic ordering of two vectors. +ord :: (Vector a v, Ord a) => v -> v -> Ordering +{-# INLINE ord #-} +ord v w = C.foldl mappend mempty + $ C.zipWith compare (cvec v) (cvec w) + + +---------------------------------------------------------------- + +-- | Map over vector +map :: forall v a. (Vector a v) => (a -> a) -> v -> v +{-# INLINE map #-} +map f = vector + . C.map f + . cvec + +-- | Map over vector +gmap :: forall v w a b. (Vector a v, Vector b w, Dim v ~ Dim w) => (a -> b) -> v -> w +{-# INLINE gmap #-} +gmap f = vector + . C.map f + . cvec + +-- | Effectful map over vector. +mapM :: forall v f a. (Vector a v, Applicative f) => (a -> f a) -> v -> f v +{-# INLINE mapM #-} +mapM f = fmap vector + . C.mapM f + . cvec + +-- | Effectful map over vector. +gmapM :: forall v w f a b. (Vector a v, Vector b w, Applicative f, Dim v ~ Dim w) + => (a -> f b) -> v -> f w +{-# INLINE gmapM #-} +gmapM f = fmap vector + . C.mapM f + . cvec + +-- | Apply monadic action to each element of vector and ignore result. +mapM_ :: forall v f b a. (Vector a v, Applicative f) => (a -> f b) -> v -> f () +{-# INLINE mapM_ #-} +mapM_ f = C.mapM_ f + . cvec + + +-- | Apply function to every element of the vector and its index. +imap :: forall v a. (Vector a v) => (Int -> a -> a) -> v -> v +{-# INLINE imap #-} +imap f = vector + . C.imap f + . cvec + +-- | Apply function to every element of the vector and its index. +igmap :: forall v w a b. (Vector a v, Vector b w, Dim v ~ Dim w) + => (Int -> a -> b) -> v -> w +{-# INLINE igmap #-} +igmap f = vector + . C.imap f + . cvec + +-- | Apply monadic function to every element of the vector and its index. +imapM :: forall v f a. (Vector a v, Applicative f) + => (Int -> a -> f a) -> v -> f v +{-# INLINE imapM #-} +imapM f = fmap vector + . C.imapM f + . cvec + +-- | Apply monadic function to every element of the vector and its index. +igmapM :: forall v w f a b. (Vector a v, Vector b w, Dim v ~ Dim w, Applicative f) + => (Int -> a -> f b) -> v -> f w +{-# INLINE igmapM #-} +igmapM f = fmap vector + . C.imapM f + . cvec + +-- | Apply monadic function to every element of the vector and its +-- index and discard result. +imapM_ :: forall v f b a. (Vector a v, Applicative f) => (Int -> a -> f b) -> v -> f () +{-# INLINE imapM_ #-} +imapM_ f = C.imapM_ f + . cvec + +-- | Left scan over vector +scanl :: forall v w a b. (Vector a v, Vector b w, Dim w ~ 'S (Dim v)) + => (b -> a -> b) -> b -> v -> w +{-# INLINE scanl #-} +scanl f x0 = vector . C.scanl f x0 . cvec + +-- | Left scan over vector +scanl1 :: forall v a. (Vector a v) + => (a -> a -> a) -> v -> v +{-# INLINE scanl1 #-} +scanl1 f = vector . C.scanl1 f . cvec + + + +---------------------------------------------------------------- + +-- | Zip two vector together using function. +-- +-- Examples: +-- +-- >>> import Data.Vector.Fixed.Boxed (Vec3) +-- >>> let b0 = basis 0 :: Vec3 Int +-- >>> let b1 = basis 1 :: Vec3 Int +-- >>> let b2 = basis 2 :: Vec3 Int +-- >>> let vplus x y = zipWith (+) x y +-- >>> vplus b0 b1 +-- [1,1,0] +-- >>> vplus b0 b2 +-- [1,0,1] +-- >>> vplus b1 b2 +-- [0,1,1] +zipWith :: forall v a. (Vector a v) + => (a -> a -> a) -> v -> v -> v +{-# INLINE zipWith #-} +zipWith f v u = vector + $ C.zipWith f (cvec v) (cvec u) + +-- | Zip three vector together +zipWith3 + :: forall v a. (Vector a v) + => (a -> a -> a -> a) + -> v -> v -> v -> v +{-# INLINE zipWith3 #-} +zipWith3 f v1 v2 v3 + = vector + $ C.zipWith3 f (cvec v1) (cvec v2) (cvec v3) + +-- | Zip two vector together using monadic function. +zipWithM :: forall v f a. (Vector a v, Applicative f) + => (a -> a -> f a) -> v -> v -> f v +{-# INLINE zipWithM #-} +zipWithM f v u = fmap vector + $ C.zipWithM f (cvec v) (cvec u) + +-- | Zip two vector elementwise using monadic function and discard +-- result +zipWithM_ + :: forall v f b a. (Vector a v, Applicative f) + => (a -> a -> f b) -> v -> v -> f () +{-# INLINE zipWithM_ #-} +zipWithM_ f xs ys = C.zipWithM_ f (cvec xs) (cvec ys) + +-- | Zip two vector together using function which takes element index +-- as well. +izipWith :: forall v a. (Vector a v) + => (Int -> a -> a -> a) -> v -> v -> v +{-# INLINE izipWith #-} +izipWith f v u = vector + $ C.izipWith f (cvec v) (cvec u) + +-- | Zip three vector together +izipWith3 + :: forall v a. (Vector a v) + => (Int -> a -> a -> a -> a) + -> v -> v -> v + -> v +{-# INLINE izipWith3 #-} +izipWith3 f v1 v2 v3 + = vector + $ C.izipWith3 f (cvec v1) (cvec v2) (cvec v3) + +-- | Zip two vector together using monadic function which takes element +-- index as well.. +izipWithM :: forall v f a. (Vector a v, Applicative f) + => (Int -> a -> a -> f a) -> v -> v -> f v +{-# INLINE izipWithM #-} +izipWithM f v u = fmap vector + $ C.izipWithM f (cvec v) (cvec u) + +-- | Zip two vector elementwise using monadic function and discard +-- result +izipWithM_ + :: forall v f b a. (Vector a v, Applicative f) + => (Int -> a -> a -> f b) -> v -> v -> f () +{-# INLINE izipWithM_ #-} +izipWithM_ f xs ys = C.izipWithM_ f (cvec xs) (cvec ys) + + +---------------------------------------------------------------- + +-- | Convert between different vector types +convert :: forall v w a. (Vector a v, Vector a w, Dim v ~ Dim w) => v -> w +{-# INLINE convert #-} +convert = vector . cvec + +-- | Convert vector to the list +toList :: forall v a. (Vector a v) => v -> [a] +toList = foldr (:) [] +{-# INLINE toList #-} + +-- | Create vector form list. Will throw error if list is shorter than +-- resulting vector. +fromList :: forall v a. (Vector a v) => [a] -> v +{-# INLINE fromList #-} +fromList = vector . C.fromList + +-- | Create vector form list. Will throw error if list has different +-- length from resulting vector. +fromList' :: forall v a. (Vector a v) => [a] -> v +{-# INLINE fromList' #-} +fromList' = vector . C.fromList' + +-- | Create vector form list. Will return @Nothing@ if list has different +-- length from resulting vector. +fromListM :: forall v a. (Vector a v) => [a] -> Maybe v +{-# INLINE 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. +fromFoldable :: forall v f a. (Vector a v, T.Foldable f) => f a -> Maybe v +{-# INLINE fromFoldable #-} +fromFoldable = fromListM . T.toList + + + + +---------------------------------------------------------------- +-- +---------------------------------------------------------------- + +-- | Newtype for deriving instances. +newtype ViaFixed a v = ViaFixed v + +instance (Prod a v) => Prod a (ViaFixed a v) where + inspect (ViaFixed v) = inspect v + construct = ViaFixed <$> construct +instance (Prod a v) => Vector a (ViaFixed a v) + +type instance Dim (ViaFixed a v) = Dim v + +instance (Prod a v, Show a) => Show (ViaFixed a v) where + showsPrec _ = shows . toList + +instance (Prod a v, Eq a) => Eq (ViaFixed a v) where + (==) = eq + {-# INLINE (==) #-} + +instance (Prod a v, Ord a) => Ord (ViaFixed a v) where + compare = ord + {-# INLINE compare #-} + +instance (Prod a v, NFData a) => NFData (ViaFixed a v) where + rnf = foldl (\() a -> rnf a) () + {-# INLINE rnf #-} + +instance (Prod a v, Semigroup a) => Semigroup (ViaFixed a v) where + (<>) = zipWith (<>) + {-# INLINE (<>) #-} + +instance (Prod a v, Monoid a) => Monoid (ViaFixed a v) where + mempty = replicate mempty + {-# INLINE mempty #-} + +instance (Prod a v, Storable a) => Storable (ViaFixed a v) where + alignment _ = alignment (undefined :: a) + sizeOf _ = sizeOf (undefined :: a) * C.peanoToInt (proxy# @(Dim v)) + peek p = generateM (peekElemOff (castPtr p)) + poke p = imapM_ (pokeElemOff (castPtr p)) + {-# INLINE alignment #-} + {-# INLINE sizeOf #-} + {-# INLINE peek #-} + {-# INLINE poke #-} + +instance (Prod a v, Prim a) => Prim (ViaFixed a v) where + sizeOf# _ = sizeOf# (undefined :: a) *# dim where + dim = case C.peanoToInt (proxy# @(Dim v)) of I# i -> i + alignment# _ = alignment# (undefined :: a) + {-# INLINE sizeOf# #-} + {-# INLINE alignment# #-} + -- Bytearray + indexByteArray# ba k + = generate $ \(I# i) -> indexByteArray# ba (off +# i) + where + off = vectorOff (proxy# @(Dim v)) k + readByteArray# ba k + = internal + $ generateM + $ \(I# i) -> ST (\s -> readByteArray# ba (off +# i) s) + where + off = vectorOff (proxy# @(Dim v)) k + writeByteArray# ba k vec = + case loop of + ST st -> \s -> case st s of + (# s', () #) -> s' + where + off = vectorOff (proxy# @(Dim v)) k + loop = flip imapM_ vec $ \(I# i) a -> ST $ \s -> + (# writeByteArray# ba (off +# i) a s, () #) + {-# INLINE indexByteArray# #-} + {-# INLINE readByteArray# #-} + {-# INLINE writeByteArray# #-} + -- Addr + indexOffAddr# addr k + = generate $ \(I# i) -> indexOffAddr# addr (off +# i) + where + off = vectorOff (proxy# @(Dim v)) k + readOffAddr# ba k + = internal + $ generateM + $ \(I# i) -> ST (\s -> readOffAddr# ba (off +# i) s) + where + off = vectorOff (proxy# @(Dim v)) k + writeOffAddr# addr k vec = + case loop of + ST st -> \s -> case st s of + (# s', () #) -> s' + where + off = vectorOff (proxy# @(Dim v)) k + loop = flip imapM_ vec $ \(I# i) a -> ST $ \s -> + (# writeOffAddr# addr (off +# i) a s, () #) + {-# INLINE indexOffAddr# #-} + {-# INLINE readOffAddr# #-} + {-# INLINE writeOffAddr# #-} + + +vectorOff :: (ArityPeano n) => Proxy# n -> Int# -> Int# +{-# INLINE vectorOff #-} +vectorOff n k = + case C.peanoToInt n of + I# dim -> dim *# k + +---------------------------------------------------------------- +-- Patterns +---------------------------------------------------------------- + +pattern V1 :: (Vector a v, Dim v ~ N1) => a -> v +pattern V1 x <- (head -> x) where + V1 x = mk1 x +{-# INLINE V1 #-} +{-# COMPLETE V1 #-} + +pattern V2 :: (Vector a v, Dim v ~ N2) => a -> a -> v +pattern V2 x y <- (convert -> (x,y)) where + V2 x y = mk2 x y +{-# INLINE V2 #-} +{-# COMPLETE V2 #-} + +pattern V3 :: (Vector a v, Dim v ~ N3) => a -> a -> a -> v +pattern V3 x y z <- (convert -> (x,y,z)) where + V3 x y z = mk3 x y z +{-# INLINE V3 #-} +{-# COMPLETE V3 #-} + +pattern V4 :: (Vector a v, Dim v ~ N4) => a -> a -> a -> a -> v +pattern V4 t x y z <- (convert -> (t,x,y,z)) where + V4 t x y z = mk4 t x y z +{-# INLINE V4 #-} +{-# COMPLETE V4 #-} + +---------------------------------------------------------------- +-- Instances +---------------------------------------------------------------- + +instance (ArityPeano n) => Prod a (C.ContVec n a) where + inspect = C.inspect + construct = C.construct + {-# INLINE inspect #-} + {-# INLINE construct #-} +instance (ArityPeano n) => Vector a (C.ContVec n a) where + +instance Prod a (Complex a) where + inspect (r :+ i) (C.Fun f) = f r i + construct = C.Fun (:+) + {-# INLINE inspect #-} + {-# INLINE construct #-} +instance Vector a (Complex a) + +instance (a1 ~ a2) => Prod a1 (a1, a2) where + inspect (a1, a2) (C.Fun f) = f a1 a2 + construct = C.Fun (,) + {-# INLINE inspect #-} + {-# INLINE construct #-} + +instance (a1 ~ a2, a2 ~ a3) => Prod a1 (a1, a2, a3) where + inspect (a1, a2, a3) (C.Fun f) = f a1 a2 a3 + construct = C.Fun (,,) + {-# INLINE inspect #-} + {-# INLINE construct #-} + +instance (a1 ~ a2, a2 ~ a3, a3 ~ a4) => Prod a1 (a1, a2, a3, a4) where + inspect (a1, a2, a3, a4) (C.Fun f) = f a1 a2 a3 a4 + construct = C.Fun (,,,) + {-# INLINE inspect #-} + {-# INLINE construct #-} + +instance (a1 ~ a2, a2 ~ a3, a3 ~ a4, a4 ~ a5) => Prod a1 (a1, a2, a3, a4, a5) where + inspect (a1, a2, a3, a4, a5) (C.Fun f) = f a1 a2 a3 a4 a5 + construct = C.Fun (,,,,) + {-# INLINE inspect #-} + {-# INLINE construct #-} + +instance (a1 ~ a2, a2 ~ a3, a3 ~ a4, a4 ~ a5, a5 ~ a6 + ) => Prod a1 (a1, a2, a3, a4, a5, a6) where + inspect (a1, a2, a3, a4, a5, a6) (C.Fun f) = f a1 a2 a3 a4 a5 a6 + construct = C.Fun (,,,,,) + {-# INLINE inspect #-} + {-# INLINE construct #-} + +instance (a1 ~ a2, a2 ~ a3, a3 ~ a4, a4 ~ a5, a5 ~ a6, a6 ~ a7 + ) => Prod a1 (a1, a2, a3, a4, a5, a6, a7) where + inspect (a1, a2, a3, a4, a5, a6, a7) (C.Fun f) = f a1 a2 a3 a4 a5 a6 a7 + construct = C.Fun (,,,,,,) + {-# INLINE inspect #-} + {-# INLINE construct #-} + + + +instance (a1 ~ a2) => Vector a1 (a1, a2) +instance (a1 ~ a2, a2 ~ a3) => Vector a1 (a1, a2, a3) +instance (a1 ~ a2, a2 ~ a3, a3 ~ a4) => Vector a1 (a1, a2, a3, a4) +instance (a1 ~ a2, a2 ~ a3, a3 ~ a4, a4 ~ a5) => Vector a1 (a1, a2, a3, a4, a5) +instance (a1 ~ a2, a2 ~ a3, a3 ~ a4, a4 ~ a5, a5 ~ a6 + ) => Vector a1 (a1, a2, a3, a4, a5, a6) +instance (a1 ~ a2, a2 ~ a3, a3 ~ a4, a4 ~ a5, a5 ~ a6, a6 ~ a7 + ) => Vector a1 (a1, a2, a3, a4, a5, a6, a7) + + +-- $setup +-- +-- >>> import Data.Char +-- >>> import Prelude (Int,Bool(..),Double,IO,(^),String,putStrLn) + 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,10 +1,5 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} -- | -- 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 @@ -12,14 +7,17 @@ module Data.Vector.Fixed.Mutable ( -- * Mutable vectors Arity - , arity , Mutable , DimM , MVector(..) , lengthM + , new + , clone + , copy , read , write - , clone + , unsafeRead + , unsafeWrite -- * Creation , replicate , replicateM @@ -32,6 +30,7 @@ , index , freeze , thaw + , unsafeFreeze -- * Vector API , constructVec , inspectVec @@ -40,13 +39,14 @@ import Control.Applicative (Const(..)) import Control.Monad.ST import Control.Monad.Primitive -import Data.Typeable (Proxy(..)) import Data.Kind (Type) -import GHC.TypeLits -import Data.Vector.Fixed.Cont (Dim,PeanoNum(..),Peano,Arity,Fun(..),Vector(..),ContVec,arity,apply,accum,length) import Prelude hiding (read,length,replicate) +import GHC.Exts (proxy#) +import Data.Vector.Fixed.Cont (Dim,PeanoNum(..),Arity,ArityPeano(..),Fun(..),Vector(..), + ContVec,apply,accum,length) + ---------------------------------------------------------------- -- Type classes ---------------------------------------------------------------- @@ -55,34 +55,60 @@ type family Mutable (v :: Type -> Type) :: Type -> Type -> Type -- | Dimension for mutable vector. -type family DimM (v :: Type -> Type -> Type) :: Nat +type family DimM (v :: Type -> Type -> Type) :: PeanoNum -- | Type class for mutable vectors. -class (Arity (DimM v)) => MVector v a where - -- | 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 - => v (PrimState m) a -- ^ Target - -> v (PrimState m) a -- ^ Source - -> m () - -- | Copy vector. The two vectors may overlap. Since vectors' length - -- is encoded in the type there is no need in runtime checks. - move :: PrimMonad m - => v (PrimState m) a -- ^ Target - -> v (PrimState m) a -- ^ Source - -> m () - -- | Allocate new vector - new :: PrimMonad m => m (v (PrimState m) a) - -- | Read value at index without bound checks. - unsafeRead :: PrimMonad m => v (PrimState m) a -> Int -> m a - -- | Write value at index without bound checks. - unsafeWrite :: PrimMonad m => v (PrimState m) a -> Int -> a -> m () - +class (ArityPeano (DimM v)) => MVector v a where + -- | Copy vector. The two vectors may not overlap. Shouldn't be used + -- directly, use 'copy' instead. + basicCopy :: v s a -- ^ Target + -> v s a -- ^ Source + -> ST s () + -- | Allocate new uninitialized vector. Shouldn't be used + -- directly, use 'new' instead. + basicNew :: ST s (v s a) + -- | Allocate new vector initialized with given element. Shouldn't be used + -- directly, use 'replicate' instead. + basicReplicate :: a -> ST s (v s a) + {-# INLINE basicReplicate #-} + basicReplicate a = do + v <- basicNew + forI v $ \i -> basicUnsafeWrite v i a + pure v + -- | Create copy of existing vector. Shouldn't be used + -- directly, use 'clone' instead. + basicClone :: v s a -> ST s (v s a) + {-# INLINE basicClone #-} + basicClone src = do + dst <- basicNew + basicCopy dst src + pure src + -- | Read value at index without bound checks. Shouldn't be used + -- directly, use 'unsafeRead' instead. + basicUnsafeRead :: v s a -> Int -> ST s a + -- | Write value at index without bound checks. Shouldn't be used + -- directly, use 'unsafeWrite' instead. + basicUnsafeWrite :: v s a -> Int -> a -> ST s () -- | Length of mutable vector. Function doesn't evaluate its argument. -lengthM :: forall v s a. (Arity (DimM v)) => v s a -> Int -lengthM _ = arity (Proxy :: Proxy (DimM v)) +lengthM :: forall v s a. (ArityPeano (DimM v)) => v s a -> Int +lengthM _ = peanoToInt (proxy# @(DimM v)) +-- | Create new uninitialized mutable vector. +new :: (MVector v a, PrimMonad m) => m (v (PrimState m) a) +new = stToPrim basicNew +{-# INLINE new #-} + +-- | Copy vector. The two vectors may not overlap. Since vectors' +-- length is encoded in the type there is no need in runtime +-- checks of length. +copy :: (MVector v a, PrimMonad m) + => v (PrimState m) a -- ^ Target + -> v (PrimState m) a -- ^ Source + -> m () +{-# INLINE copy #-} +copy tgt src = stToPrim $ basicCopy tgt src + -- | Create copy of vector. -- -- Examples: @@ -93,14 +119,21 @@ -- >>> import qualified Data.Vector.Fixed.Mutable as M -- >>> let x = runST (do { v <- M.replicate 100; v' <- clone v; M.write v' 0 2; M.unsafeFreeze v' }) :: Vec3 Int -- >>> x --- fromList [2,100,100] +-- [2,100,100] clone :: (PrimMonad m, MVector v a) => v (PrimState m) a -> m (v (PrimState m) a) {-# INLINE clone #-} -clone v = do - u <- new - move u v - return u +clone = stToPrim . basicClone +-- | Read value at index without bound checks. +unsafeRead :: (MVector v a, PrimMonad m) => v (PrimState m) a -> Int -> m a +{-# INLINE unsafeRead #-} +unsafeRead v i = stToPrim $ basicUnsafeRead v i + +-- | Write value at index without bound checks. +unsafeWrite :: (MVector v a, PrimMonad m) => v (PrimState m) a -> Int -> a -> m () +{-# INLINE unsafeWrite #-} +unsafeWrite v i a = stToPrim $ basicUnsafeWrite v i a + -- | Read value at index with bound checks. read :: (PrimMonad m, MVector v a) => v (PrimState m) a -> Int -> m a {-# INLINE read #-} @@ -119,10 +152,7 @@ -- | Create new vector with all elements set to given value. replicate :: (PrimMonad m, MVector v a) => a -> m (v (PrimState m) a) {-# INLINE replicate #-} -replicate a = do - v <- new - forI v $ \i -> unsafeWrite v i a - pure v +replicate = stToPrim . basicReplicate -- | Create new vector with all elements are generated by provided -- monadic action. @@ -167,37 +197,19 @@ class (Dim v ~ DimM (Mutable v), MVector (Mutable v) a) => IVector v a where -- | Convert vector to immutable state. Mutable vector must not be -- modified afterwards. - unsafeFreeze :: PrimMonad m => Mutable v (PrimState m) a -> m (v a) - -- | /O(1)/ Unsafely convert immutable vector to mutable without - -- copying. Note that this is a very dangerous function and - -- generally it's only safe to read from the resulting vector. In - -- this case, the immutable vector could be used safely as well. - -- - -- Problems with mutation happen because GHC has a lot of freedom to - -- introduce sharing. As a result mutable vectors produced by - -- @unsafeThaw@ may or may not share the same underlying buffer. For - -- example: - -- - -- > foo = do - -- > let vec = F.generate 10 id - -- > mvec <- M.unsafeThaw vec - -- > do_something mvec - -- - -- Here GHC could lift @vec@ outside of foo which means that all calls to - -- @do_something@ will use same buffer with possibly disastrous - -- results. Whether such aliasing happens or not depends on the program in - -- question, optimization levels, and GHC flags. - -- - -- All in all, attempts to modify a vector produced by @unsafeThaw@ - -- fall out of domain of software engineering and into realm of - -- black magic, dark rituals, and unspeakable horrors. The only - -- advice that could be given is: "Don't attempt to mutate a vector - -- produced by @unsafeThaw@ unless you know how to prevent GHC from - -- aliasing buffers accidentally. We don't." - unsafeThaw :: PrimMonad m => v a -> m (Mutable v (PrimState m) a) + basicUnsafeFreeze :: Mutable v s a -> ST s (v a) + -- | Convert immutable vector to mutable by copying it. + basicThaw :: v a -> ST s (Mutable v s a) -- | Get element at specified index without bounds check. unsafeIndex :: v a -> Int -> a + +-- | Convert vector to immutable state. Mutable vector must not be +-- modified afterwards. +unsafeFreeze :: (IVector v a, PrimMonad m) => Mutable v (PrimState m) a -> m (v a) +{-# INLINE unsafeFreeze #-} +unsafeFreeze = stToPrim . basicUnsafeFreeze + index :: IVector v a => v a -> Int -> a {-# INLINE index #-} index v i | i < 0 || i >= length v = error "Data.Vector.Fixed.Mutable.!: index out of bounds" @@ -212,7 +224,7 @@ -- | Safely convert immutable vector to mutable. thaw :: (PrimMonad m, IVector v a) => v a -> m (Mutable v (PrimState m) a) {-# INLINE thaw #-} -thaw v = clone =<< unsafeThaw v +thaw = stToPrim . basicThaw @@ -221,22 +233,22 @@ ---------------------------------------------------------------- -- | Generic inspect implementation for array-based vectors. -inspectVec :: forall v a b. (Arity (Dim v), IVector v a) => v a -> Fun (Peano (Dim v)) a b -> b +inspectVec :: forall v a b. (ArityPeano (Dim v), IVector v a) => v a -> Fun (Dim v) a b -> b {-# INLINE inspectVec #-} inspectVec v = 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 0 :: Const Int (Dim v)) -- | Generic construct implementation for array-based vectors. -constructVec :: forall v a. (Arity (Dim v), IVector v a) => Fun (Peano (Dim v)) a (v a) +constructVec :: forall v a. (ArityPeano (Dim v), IVector v a) => Fun (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 (Peano (Dim v))) + (T_new 0 new :: T_new v a (Dim v)) data T_new v a n = T_new Int (forall s. ST s (Mutable v s a)) 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,12 +1,6 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- Unboxed vectors with fixed length. Vectors from -- "Data.Vector.Fixed.Unboxed" provide more flexibility at no @@ -32,17 +26,19 @@ import Data.Semigroup (Semigroup(..)) import Data.Primitive.ByteArray import Data.Primitive -import qualified Foreign.Storable as Foreign (Storable(..)) +import Data.Kind (Type) +import Foreign.Storable (Storable) import GHC.TypeLits +import GHC.Exts (proxy#) import Prelude (Show(..),Eq(..),Ord(..),Num(..)) -import Prelude (($),($!),undefined,seq) +import Prelude (($),($!),undefined,seq,(<$>)) import Data.Vector.Fixed hiding (index) -import Data.Vector.Fixed.Mutable (Mutable, MVector(..), IVector(..), DimM, constructVec, inspectVec, arity, index) +import Data.Vector.Fixed.Mono qualified as FM +import Data.Vector.Fixed.Mutable (Mutable, MVector(..), IVector(..), DimM, constructVec, inspectVec, index) import qualified Data.Vector.Fixed.Cont as C -import qualified Data.Vector.Fixed.Internal as I - +import Data.Vector.Fixed.Cont (ArityPeano(..)) ---------------------------------------------------------------- @@ -50,62 +46,59 @@ ---------------------------------------------------------------- -- | Unboxed vector with fixed length -newtype Vec (n :: Nat) a = Vec ByteArray +newtype Vec (n :: Nat) (a :: Type) = Vec ByteArray -- | Mutable unboxed vector with fixed length newtype MVec (n :: Nat) s a = MVec (MutableByteArray s) -deriving instance Typeable Vec -deriving instance Typeable MVec - type Vec1 = Vec 1 type Vec2 = Vec 2 type Vec3 = Vec 3 type Vec4 = Vec 4 type Vec5 = Vec 5 +type instance Mutable (Vec n) = MVec n +type instance Dim (Vec n) = Peano n +type instance Dim (Vec n a) = Peano n +type instance DimM (MVec n) = Peano n ---------------------------------------------------------------- -- Instances ---------------------------------------------------------------- -instance (Arity n, Prim a, Show a) => Show (Vec n a) where - showsPrec = I.showsPrec - instance (Arity n, Prim a, NFData a) => NFData (Vec n a) where - rnf = foldl (\r a -> r `seq` rnf a) () - {-# INLINE rnf #-} + rnf x = seq x () -type instance Mutable (Vec n) = MVec n +deriving via ViaFixed (Vec n) a instance (Arity n, Prim a, Show a) => Show (Vec n a) +deriving via ViaFixed (Vec n) a instance (Arity n, Prim a, Eq a) => Eq (Vec n a) +deriving via ViaFixed (Vec n) a instance (Arity n, Prim a, Ord a) => Ord (Vec n a) +deriving via ViaFixed (Vec n) a instance (Arity n, Prim a, Semigroup a) => Semigroup (Vec n a) +deriving via ViaFixed (Vec n) a instance (Arity n, Prim a, Monoid a) => Monoid (Vec n a) +deriving via ViaFixed (Vec n) a instance (Arity n, Prim a, Storable a) => Storable (Vec n a) +-- | @since 2.0.1.0 +deriving via ViaFixed (Vec n) a instance (Arity n, Prim a) => Prim (Vec n a) instance (Arity n, Prim a) => MVector (MVec n) a where - new = do - v <- newByteArray $! arity (Proxy :: Proxy n) + basicNew = do + v <- newByteArray $! peanoToInt (proxy# @(Peano n)) * sizeOf (undefined :: a) return $ MVec v - {-# INLINE new #-} - copy = move - {-# INLINE copy #-} - 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 #-} - unsafeWrite (MVec v) i x = writeByteArray v i x - {-# INLINE unsafeWrite #-} + {-# INLINE basicNew #-} + basicCopy (MVec dst) (MVec src) = copyMutableByteArray dst 0 src 0 (peanoToInt (proxy# @(Peano n))) + {-# INLINE basicCopy #-} + basicUnsafeRead (MVec v) i = readByteArray v i + {-# INLINE basicUnsafeRead #-} + basicUnsafeWrite (MVec v) i x = writeByteArray v i x + {-# INLINE basicUnsafeWrite #-} instance (Arity n, Prim a) => IVector (Vec n) a where - unsafeFreeze (MVec v) = do { a <- unsafeFreezeByteArray v; return $! Vec a } - unsafeThaw (Vec v) = do { a <- unsafeThawByteArray v; return $! MVec a } - unsafeIndex (Vec v) i = indexByteArray v i - {-# INLINE unsafeFreeze #-} - {-# INLINE unsafeThaw #-} - {-# INLINE unsafeIndex #-} - - - -type instance Dim (Vec n) = n -type instance DimM (MVec n) = n + basicUnsafeFreeze (MVec v) = do { a <- unsafeFreezeByteArray v; return $! Vec a } + basicThaw (Vec v) = MVec <$> thawByteArray v 0 (peanoToInt (proxy# @(Peano n))) + unsafeIndex (Vec v) i = indexByteArray v i + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicThaw #-} + {-# INLINE unsafeIndex #-} instance (Arity n, Prim a) => Vector (Vec n) a where construct = constructVec @@ -114,25 +107,12 @@ {-# INLINE construct #-} {-# INLINE inspect #-} {-# INLINE basicIndex #-} -instance (Arity n, Prim a) => VectorN Vec n a - -instance (Arity n, Prim a, Eq a) => Eq (Vec n a) where - (==) = eq - {-# INLINE (==) #-} -instance (Arity n, Prim a, Ord a) => Ord (Vec n a) where - compare = ord - {-# INLINE compare #-} - -instance (Arity n, Prim a, Monoid a) => Monoid (Vec n a) where - mempty = replicate mempty - mappend = (<>) - {-# INLINE mempty #-} - {-# INLINE mappend #-} - -instance (Arity n, Prim a, Semigroup a) => Semigroup (Vec n a) where - (<>) = zipWith (<>) - {-# INLINE (<>) #-} - +instance (Arity n, Prim a) => FM.Prod a (Vec n a) where + construct = constructVec + inspect = inspectVec + {-# INLINE construct #-} + {-# INLINE inspect #-} +instance (Arity n, Prim a) => FM.Vector a (Vec n a) instance (Typeable n, Arity n, Prim a, Data a) => Data (Vec n a) where gfoldl = C.gfoldl @@ -145,13 +125,3 @@ con_Vec :: Constr con_Vec = mkConstr ty_Vec "Vec" [] Prefix - -instance (Foreign.Storable a, Prim a, Arity n) => Foreign.Storable (Vec n a) where - alignment = defaultAlignemnt - sizeOf = defaultSizeOf - peek = defaultPeek - poke = defaultPoke - {-# INLINE alignment #-} - {-# INLINE sizeOf #-} - {-# INLINE peek #-} - {-# INLINE poke #-} 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,12 +1,6 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- Storable-based unboxed vectors. module Data.Vector.Fixed.Storable ( @@ -32,20 +26,24 @@ import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) import Data.Data +import Data.Primitive.Types (Prim) import Foreign.Ptr (castPtr) import Foreign.Storable -import Foreign.ForeignPtr import Foreign.Marshal.Array ( copyArray, moveArray ) -import GHC.ForeignPtr ( ForeignPtr(..), mallocPlainForeignPtrBytes ) +import GHC.ForeignPtr ( mallocPlainForeignPtrBytes ) import GHC.Ptr ( Ptr(..) ) +import GHC.Exts ( proxy# ) import GHC.TypeLits +import GHC.ForeignPtr ( unsafeWithForeignPtr ) +import Foreign.ForeignPtr ( ForeignPtr, withForeignPtr ) import Prelude ( Show(..),Eq(..),Ord(..),Num(..),Monad(..),IO,Int - , ($),undefined,seq) + , ($),undefined,seq,pure) import Data.Vector.Fixed hiding (index) -import Data.Vector.Fixed.Mutable (Mutable, MVector(..), IVector(..), DimM, constructVec, inspectVec, arity, index) +import Data.Vector.Fixed.Mono qualified as FM +import Data.Vector.Fixed.Mutable (Mutable, MVector(..), IVector(..), DimM, constructVec, inspectVec, index, new,unsafeFreeze) import qualified Data.Vector.Fixed.Cont as C -import qualified Data.Vector.Fixed.Internal as I +import Data.Vector.Fixed.Cont (ArityPeano(..)) @@ -59,15 +57,16 @@ -- | Storable-based mutable vector with fixed length newtype MVec (n :: Nat) s a = MVec (ForeignPtr a) -deriving instance Typeable Vec -deriving instance Typeable MVec - type Vec1 = Vec 1 type Vec2 = Vec 2 type Vec3 = Vec 3 type Vec4 = Vec 4 type Vec5 = Vec 5 +type instance Mutable (Vec n) = MVec n +type instance Dim (Vec n) = Peano n +type instance Dim (Vec n a) = Peano n +type instance DimM (MVec n) = Peano n ---------------------------------------------------------------- @@ -84,9 +83,11 @@ {-# INLINE unsafeFromForeignPtr #-} unsafeFromForeignPtr = Vec +-- | Pass pointer to the vector's data to the IO action. The data may +-- not be modified through the 'Ptr. unsafeWith :: (Ptr a -> IO b) -> Vec n a -> IO b {-# INLINE unsafeWith #-} -unsafeWith f (Vec fp) = f (getPtr fp) +unsafeWith f (Vec fp) = withForeignPtr fp f @@ -94,55 +95,47 @@ -- Instances ---------------------------------------------------------------- -instance (Arity n, Storable a, Show a) => Show (Vec n a) where - showsPrec = I.showsPrec - instance (Arity n, Storable a, NFData a) => NFData (Vec n a) where - rnf = foldl (\r a -> r `seq` rnf a) () - {-# INLINE rnf #-} + rnf x = seq x () -type instance Mutable (Vec n) = MVec n +deriving via ViaFixed (Vec n) a instance (Arity n, Storable a, Show a) => Show (Vec n a) +deriving via ViaFixed (Vec n) a instance (Arity n, Storable a, Eq a) => Eq (Vec n a) +deriving via ViaFixed (Vec n) a instance (Arity n, Storable a, Ord a) => Ord (Vec n a) +deriving via ViaFixed (Vec n) a instance (Arity n, Storable a, Semigroup a) => Semigroup (Vec n a) +deriving via ViaFixed (Vec n) a instance (Arity n, Storable a, Monoid a) => Monoid (Vec n a) instance (Arity n, Storable a) => MVector (MVec n) a where - new = unsafePrimToPrim $ do - fp <- mallocVector $ arity (Proxy :: Proxy n) + basicNew = unsafePrimToPrim $ do + fp <- mallocVector (peanoToInt (proxy# @(Peano n))) return $ MVec fp - {-# INLINE new #-} - copy (MVec fp) (MVec fq) - = unsafePrimToPrim - $ withForeignPtr fp $ \p -> - withForeignPtr fq $ \q -> - copyArray p q (arity (Proxy :: Proxy n)) - {-# INLINE copy #-} - move (MVec fp) (MVec fq) + {-# INLINE basicNew #-} + basicCopy (MVec fp) (MVec fq) = unsafePrimToPrim - $ withForeignPtr fp $ \p -> - withForeignPtr fq $ \q -> - moveArray p q (arity (Proxy :: Proxy n)) - {-# INLINE move #-} - unsafeRead (MVec fp) i + $ unsafeWithForeignPtr fp $ \p -> + unsafeWithForeignPtr fq $ \q -> + copyArray p q (peanoToInt (proxy# @(Peano n))) + {-# INLINE basicCopy #-} + basicUnsafeRead (MVec fp) i = unsafePrimToPrim - $ withForeignPtr fp (`peekElemOff` i) - {-# INLINE unsafeRead #-} - unsafeWrite (MVec fp) i x + $ unsafeWithForeignPtr fp (`peekElemOff` i) + {-# INLINE basicUnsafeRead #-} + basicUnsafeWrite (MVec fp) i x = unsafePrimToPrim - $ withForeignPtr fp $ \p -> pokeElemOff p i x - {-# INLINE unsafeWrite #-} - + $ unsafeWithForeignPtr fp $ \p -> pokeElemOff p i x + {-# INLINE basicUnsafeWrite #-} instance (Arity n, Storable a) => IVector (Vec n) a where - unsafeFreeze (MVec fp) = return $ Vec fp - unsafeThaw (Vec fp) = return $ MVec fp + basicUnsafeFreeze (MVec fp) = return $ Vec fp + basicThaw (Vec fp) = do + mv <- basicNew + basicCopy mv (MVec fp) + pure mv unsafeIndex (Vec fp) i = unsafeInlineIO - $ withForeignPtr fp (`peekElemOff` i) - {-# INLINE unsafeFreeze #-} - {-# INLINE unsafeThaw #-} - {-# INLINE unsafeIndex #-} - - -type instance Dim (Vec n) = n -type instance DimM (MVec n) = n + $ unsafeWithForeignPtr fp (`peekElemOff` i) + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicThaw #-} + {-# INLINE unsafeIndex #-} instance (Arity n, Storable a) => Vector (Vec n) a where construct = constructVec @@ -151,38 +144,28 @@ {-# INLINE construct #-} {-# INLINE inspect #-} {-# INLINE basicIndex #-} -instance (Arity n, Storable a) => VectorN Vec n a - -instance (Arity n, Storable a, Eq a) => Eq (Vec n a) where - (==) = eq - {-# INLINE (==) #-} -instance (Arity n, Storable a, Ord a) => Ord (Vec n a) where - compare = ord - {-# INLINE compare #-} - -instance (Arity n, Storable a, Monoid a) => Monoid (Vec n a) where - mempty = replicate mempty - mappend = (<>) - {-# INLINE mempty #-} - {-# INLINE mappend #-} - -instance (Arity n, Storable a, Semigroup a) => Semigroup (Vec n a) where - (<>) = zipWith (<>) - {-# INLINE (<>) #-} +instance (Arity n, Storable a) => FM.Prod a (Vec n a) where + construct = constructVec + inspect = inspectVec + {-# INLINE construct #-} + {-# INLINE inspect #-} +instance (Arity n, Storable a) => FM.Vector a (Vec n a) instance (Arity n, Storable a) => Storable (Vec n a) where - sizeOf _ = arity (Proxy :: Proxy n) - * sizeOf (undefined :: a) - alignment _ = alignment (undefined :: a) + sizeOf = defaultSizeOf + alignment = defaultAlignemnt peek ptr = do arr@(MVec fp) <- new - withForeignPtr fp $ \p -> - moveArray p (castPtr ptr) (arity (Proxy :: Proxy n)) + unsafeWithForeignPtr fp $ \p -> + moveArray p (castPtr ptr) (peanoToInt (proxy# @(Peano n))) unsafeFreeze arr poke ptr (Vec fp) - = withForeignPtr fp $ \p -> - moveArray (castPtr ptr) p (arity (Proxy :: Proxy n)) + = unsafeWithForeignPtr fp $ \p -> + moveArray (castPtr ptr) p (peanoToInt (proxy# @(Peano n))) +-- | @since 2.0.1.0 +deriving via ViaFixed (Vec n) a instance (Arity n, Storable a, Prim a) => Prim (Vec n a) + instance (Typeable n, Arity n, Storable a, Data a) => Data (Vec n a) where gfoldl = C.gfoldl gunfold = C.gunfold @@ -208,7 +191,3 @@ {-# INLINE mallocVector #-} mallocVector size = mallocPlainForeignPtrBytes (size * sizeOf (undefined :: a)) - -getPtr :: ForeignPtr a -> Ptr a -{-# INLINE getPtr #-} -getPtr (ForeignPtr addr _) = Ptr addr diff --git a/Data/Vector/Fixed/Strict.hs b/Data/Vector/Fixed/Strict.hs new file mode 100644 --- /dev/null +++ b/Data/Vector/Fixed/Strict.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Strict boxed vector which could hold any value. For lazy variant see +-- "Data.Vector.Fixed.Boxed". +module Data.Vector.Fixed.Strict where + +import Control.Applicative (Applicative(..)) +import Control.DeepSeq (NFData(..)) +import Data.Primitive.SmallArray +import Data.Monoid (Monoid(..)) +import Data.Semigroup (Semigroup(..)) +import Data.Data +import Data.Primitive.Types (Prim) +import qualified Data.Foldable as F +import qualified Data.Foldable1 as F1 +import qualified Data.Traversable as T +import Foreign.Storable (Storable) +import GHC.TypeLits +import GHC.Exts (proxy#) +import Prelude ( Show(..),Eq(..),Ord(..),Functor(..),Monad(..) + , ($!),error,(<$>)) + +import Data.Vector.Fixed hiding (index) +import Data.Vector.Fixed.Compat +import Data.Vector.Fixed.Mono qualified as FM +import Data.Vector.Fixed.Mutable (Mutable, MVector(..), IVector(..), DimM, constructVec, inspectVec, index) +import qualified Data.Vector.Fixed.Cont as C +import Data.Vector.Fixed.Cont (ArityPeano(..)) + + +---------------------------------------------------------------- +-- Data type +---------------------------------------------------------------- + +-- | Vector with fixed length which can hold any value. It's strict +-- and ensures that elements are evaluated to WHNF. +newtype Vec (n :: Nat) a = Vec (SmallArray a) + +-- | Mutable unboxed vector with fixed length +newtype MVec (n :: Nat) s a = MVec (SmallMutableArray s a) + +type Vec1 = Vec 1 +type Vec2 = Vec 2 +type Vec3 = Vec 3 +type Vec4 = Vec 4 +type Vec5 = Vec 5 + +type instance Mutable (Vec n) = MVec n +type instance Dim (Vec n) = Peano n +type instance Dim (Vec n a) = Peano n +type instance DimM (MVec n) = Peano n + + +---------------------------------------------------------------- +-- Instances +---------------------------------------------------------------- + +deriving via ViaFixed (Vec n) instance Arity n => Functor (Vec n) +deriving via ViaFixed (Vec n) instance Arity n => Applicative (Vec n) +deriving via ViaFixed (Vec n) instance Arity n => F.Foldable (Vec n) +-- | @since @2.0.1.0 +deriving via ViaFixed (Vec n) + instance (Arity n, Peano n ~ S k) => F1.Foldable1 (Vec n) + +instance Arity n => T.Traversable (Vec n) where + sequence = sequence + sequenceA = sequence + traverse = mapM + mapM = mapM + {-# INLINE sequence #-} + {-# INLINE sequenceA #-} + {-# INLINE mapM #-} + {-# INLINE traverse #-} + +deriving via ViaFixed (Vec n) a instance (Arity n, Show a) => Show (Vec n a) +deriving via ViaFixed (Vec n) a instance (Arity n, Eq a) => Eq (Vec n a) +deriving via ViaFixed (Vec n) a instance (Arity n, Ord a) => Ord (Vec n a) +deriving via ViaFixed (Vec n) a instance (Arity n, NFData a) => NFData (Vec n a) +deriving via ViaFixed (Vec n) a instance (Arity n, Semigroup a) => Semigroup (Vec n a) +deriving via ViaFixed (Vec n) a instance (Arity n, Monoid a) => Monoid (Vec n a) +deriving via ViaFixed (Vec n) a instance (Arity n, Storable a) => Storable (Vec n a) +-- | @since 2.0.1.0 +deriving via ViaFixed (Vec n) a instance (Arity n, Prim a) => Prim (Vec n a) + +instance (Arity n) => MVector (MVec n) a where + basicNew = + MVec <$> newSmallArray (peanoToInt (proxy# @(Peano n))) uninitialised + basicReplicate a = + MVec <$> newSmallArray (peanoToInt (proxy# @(Peano n))) a + basicCopy (MVec dst) (MVec src) = + copySmallMutableArray dst 0 src 0 (peanoToInt (proxy# @(Peano n))) + basicClone (MVec src) = + MVec <$> cloneSmallMutableArray src 0 (peanoToInt (proxy# @(Peano n))) + basicUnsafeRead (MVec v) i = readSmallArray v i + basicUnsafeWrite (MVec v) i !x = writeSmallArray v i x + {-# INLINE basicNew #-} + {-# INLINE basicReplicate #-} + {-# INLINE basicCopy #-} + {-# INLINE basicClone #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + +instance (Arity n) => IVector (Vec n) a where + basicUnsafeFreeze (MVec v) = do { a <- unsafeFreezeSmallArray v; return $! Vec a } + basicThaw (Vec v) = + MVec <$> thawSmallArray v 0 (peanoToInt (proxy# @(Peano n))) + unsafeIndex (Vec v) i = indexSmallArray v i + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicThaw #-} + {-# INLINE unsafeIndex #-} + +instance (Arity n) => Vector (Vec n) a where + construct = constructVec + inspect = inspectVec + basicIndex = index + {-# INLINE construct #-} + {-# INLINE inspect #-} + {-# INLINE basicIndex #-} +instance (Arity n) => FM.Prod a (Vec n a) where + construct = constructVec + inspect = inspectVec + {-# INLINE construct #-} + {-# INLINE inspect #-} +instance (Arity n) => FM.Vector a (Vec n a) + +instance (Typeable n, Arity n, Data a) => Data (Vec n a) where + gfoldl = C.gfoldl + gunfold = C.gunfold + toConstr _ = con_Vec + dataTypeOf _ = ty_Vec + +ty_Vec :: DataType +ty_Vec = mkDataType "Data.Vector.Fixed.Strict.Vec" [con_Vec] + +con_Vec :: Constr +con_Vec = mkConstr ty_Vec "Vec" [] Prefix + +uninitialised :: a +uninitialised = error "Data.Vector.Fixed.Strict: uninitialised element" 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,53 +1,57 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-} -- | --- Unboxed vectors with fixed length. +-- Adaptive array type which picks vector representation from type of +-- element of array. For example arrays of @Double@ are backed by +-- @ByteArray@, arrays of @Bool@ are represented as bit-vector, arrays +-- of tuples are products of arrays. 'Unbox' type class is used to +-- describe representation of an array. module Data.Vector.Fixed.Unboxed( - -- * Immutable - Vec + -- * Data type + Vec(..) , Vec1 , Vec2 , Vec3 , Vec4 , Vec5 - -- * Mutable - , MVec - -- * Type classes + -- * Type classes & derivation , Unbox + , UnboxViaPrim + -- * Concrete representations + , BitVec + , T2(..) + , T3(..) ) where import Control.Applicative (Const(..)) -import Control.Monad import Control.DeepSeq (NFData(..)) +import Data.Bits import Data.Complex +import Data.Coerce import Data.Data +import Data.Kind import Data.Functor.Identity (Identity(..)) import Data.Int (Int8, Int16, Int32, Int64 ) import Data.Monoid (Monoid(..),Dual(..),Sum(..),Product(..),All(..),Any(..)) import Data.Semigroup (Semigroup(..)) import Data.Ord (Down(..)) import Data.Word (Word,Word8,Word16,Word32,Word64) -import Foreign.Storable (Storable(..)) +import Data.Primitive.Types (Prim) +import Foreign.Storable (Storable) import GHC.TypeLits -import Prelude ( Show(..),Eq(..),Ord(..),Int,Double,Float,Char,Bool(..) - , ($),(.),seq) +import GHC.Exts (Proxy#, proxy#) +import Prelude ( Show(..),Eq(..),Ord(..),Num(..),Applicative(..) + , Int,Double,Float,Char,Bool(..),($),id) -import Data.Vector.Fixed (Dim,Vector(..),VectorN,eq,ord,replicate,zipWith,foldl, - defaultSizeOf,defaultAlignemnt,defaultPeek,defaultPoke - ) -import Data.Vector.Fixed.Mutable (Mutable, MVector(..), IVector(..), DimM, constructVec, inspectVec, Arity, index) -import qualified Data.Vector.Fixed.Cont as C -import qualified Data.Vector.Fixed.Primitive as P -import qualified Data.Vector.Fixed.Internal as I +import Data.Vector.Fixed (Dim,Vector(..),ViaFixed(..)) +import Data.Vector.Fixed qualified as F +import Data.Vector.Fixed.Compat +import Data.Vector.Fixed.Cont qualified as C +import Data.Vector.Fixed.Mono qualified as FM +import Data.Vector.Fixed.Cont (Peano,Arity,ArityPeano,Fun(..),curryFirst) +import Data.Vector.Fixed.Primitive qualified as P @@ -55,11 +59,9 @@ -- Data type ---------------------------------------------------------------- -data family Vec (n :: Nat) a -data family MVec (n :: Nat) s a - -deriving instance Typeable Vec -deriving instance Typeable MVec +-- | Adaptive array of dimension @n@ and containing elements of type +-- @a@. +newtype Vec (n :: Nat) a = Vec { getVecRepr :: VecRepr n a (EltRepr a) } type Vec1 = Vec 1 type Vec2 = Vec 2 @@ -67,52 +69,61 @@ type Vec4 = Vec 4 type Vec5 = Vec 5 -class (Arity n, IVector (Vec n) a, MVector (MVec n) a) => Unbox n a - - ----------------------------------------------------------------- --- Generic instances ----------------------------------------------------------------- - -instance (Arity n, Show a, Unbox n a) => Show (Vec n a) where - showsPrec = I.showsPrec - -instance (Arity n, Unbox n a, NFData a) => NFData (Vec n a) where - rnf = foldl (\r a -> r `seq` rnf a) () - {-# INLINE rnf #-} +-- | Type class which selects internal representation of unboxed vector. +-- +-- Crucial design constraint is this type class must be +-- GND-derivable. And this rules out anything mentioning 'Fun', +-- since all it's parameters has @nominal@ role. Thus 'Vector' is +-- not GND-derivable and we have to take somewhat roundabout +-- approach. +class ( Dim (VecRepr n a) ~ Peano n + , Vector (VecRepr n a) (EltRepr a) + ) => Unbox n a where + -- | Vector data type to use as a representation. + type VecRepr n a :: Type -> Type + -- | Element data type to use as a representation. + type EltRepr a :: Type + -- | Convert element to its representation + toEltRepr :: Proxy# n -> a -> EltRepr a + -- | Convert element from its representation + fromEltRepr :: Proxy# n -> EltRepr a -> a -type instance Mutable (Vec n) = MVec n +type instance Dim (Vec n) = Peano n +type instance Dim (Vec n a) = Peano n -type instance Dim (Vec n) = n -type instance DimM (MVec n) = n +instance (Arity n, Unbox n a) => Vector (Vec n) a where + inspect (Vec v) f + = inspect v + (C.dimapFun (fromEltRepr (proxy# @n)) id f) + construct + = C.dimapFun (toEltRepr (proxy# @n)) Vec + (construct @(VecRepr n a) @(EltRepr a)) + {-# INLINE inspect #-} + {-# INLINE construct #-} -instance (Unbox n a) => Vector (Vec n) a where - construct = constructVec - inspect = inspectVec - basicIndex = index +instance (Arity n, Unbox n a) => FM.Prod a (Vec n a) where + construct = construct + inspect = inspect {-# INLINE construct #-} {-# INLINE inspect #-} - {-# INLINE basicIndex #-} +instance (Arity n, Unbox n a) => FM.Vector a (Vec n a) -instance (Unbox n a) => VectorN Vec n a -instance (Unbox n a, Eq a) => Eq (Vec n a) where - (==) = eq - {-# INLINE (==) #-} -instance (Unbox n a, Ord a) => Ord (Vec n a) where - compare = ord - {-# INLINE compare #-} -instance (Unbox n a, Monoid a) => Monoid (Vec n a) where - mempty = replicate mempty - mappend = (<>) - {-# INLINE mempty #-} - {-# INLINE mappend #-} +---------------------------------------------------------------- +-- Generic instances +---------------------------------------------------------------- -instance (Unbox n a, Semigroup a) => Semigroup (Vec n a) where - (<>) = zipWith (<>) - {-# INLINE (<>) #-} +deriving via ViaFixed (Vec n) a instance (Unbox n a, Show a) => Show (Vec n a) +deriving via ViaFixed (Vec n) a instance (Unbox n a, Eq a) => Eq (Vec n a) +deriving via ViaFixed (Vec n) a instance (Unbox n a, Ord a) => Ord (Vec n a) +deriving via ViaFixed (Vec n) a instance (Unbox n a, NFData a) => NFData (Vec n a) +deriving via ViaFixed (Vec n) a instance (Unbox n a, Semigroup a) => Semigroup (Vec n a) +deriving via ViaFixed (Vec n) a instance (Unbox n a, Monoid a) => Monoid (Vec n a) +deriving via ViaFixed (Vec n) a instance (Unbox n a, Storable a) => Storable (Vec n a) +-- | @since 2.0.1.0 +deriving via ViaFixed (Vec n) a instance (Unbox n a, Prim a) => Prim (Vec n a) instance (Typeable n, Unbox n a, Data a) => Data (Vec n a) where gfoldl = C.gfoldl @@ -126,364 +137,196 @@ con_Vec :: Constr con_Vec = mkConstr ty_Vec "Vec" [] Prefix -instance (Storable a, Unbox n a) => Storable (Vec n a) where - alignment = defaultAlignemnt - sizeOf = defaultSizeOf - peek = defaultPeek - poke = defaultPoke - {-# INLINE alignment #-} - {-# INLINE sizeOf #-} - {-# INLINE peek #-} - {-# INLINE poke #-} - - ---------------------------------------------------------------- -- Data instances ---------------------------------------------------------------- --- Unit type -data instance MVec n s () = MV_Unit -data instance Vec n () = V_Unit +instance F.Arity n => Unbox n () where + type VecRepr n () = VecUnit n + type EltRepr () = () + toEltRepr _ = id + fromEltRepr _ = id + {-# INLINE toEltRepr #-} + {-# INLINE fromEltRepr #-} -instance Arity n => Unbox n () +data VecUnit (n :: Nat) a = VecUnit -instance Arity n => MVector (MVec n) () where - new = return MV_Unit - {-# INLINE new #-} - copy _ _ = return () - {-# INLINE move #-} - move _ _ = return () - {-# INLINE copy #-} - unsafeRead _ _ = return () - {-# INLINE unsafeRead #-} - unsafeWrite _ _ _ = return () - {-# INLINE unsafeWrite #-} +type instance Dim (VecUnit n) = Peano n +type instance Dim (VecUnit n a) = Peano n -instance Arity n => IVector (Vec n) () where - unsafeFreeze _ = return V_Unit - unsafeThaw _ = return MV_Unit - unsafeIndex _ _ = () - {-# INLINE unsafeFreeze #-} - {-# INLINE unsafeThaw #-} - {-# INLINE unsafeIndex #-} +instance F.Arity n => Vector (VecUnit n) () where + inspect _ fun + = C.runContVec fun + $ C.apply (\Proxy -> ((),Proxy)) Proxy + construct + = pure VecUnit + {-# INLINE inspect #-} + {-# INLINE construct #-} ---------------------------------------------------------------- -- Boolean -newtype instance MVec n s Bool = MV_Bool (P.MVec n s Word8) -newtype instance Vec n Bool = V_Bool (P.Vec n Word8) +-- | Bit vector represented as 64-bit word. This puts upper limit on +-- length of vector. It's not a big problem. 64-element will strain +-- GHC quite a bit. +data BitVec (n :: Nat) a = BitVec Word64 -instance Arity n => Unbox n Bool +type instance Dim (BitVec n) = Peano n +type instance Dim (BitVec n a) = Peano n -instance Arity n => MVector (MVec n) Bool where - new = MV_Bool `liftM` new - {-# INLINE new #-} - copy (MV_Bool v) (MV_Bool w) = copy v w - {-# INLINE copy #-} - move (MV_Bool v) (MV_Bool w) = move v w - {-# INLINE move #-} - unsafeRead (MV_Bool v) i = toBool `liftM` unsafeRead v i - {-# INLINE unsafeRead #-} - unsafeWrite (MV_Bool v) i b = unsafeWrite v i (fromBool b) - {-# INLINE unsafeWrite #-} +instance (n <= 64, Arity n, a ~ Bool) => Vector (BitVec n) a where + inspect (BitVec w) = inspect (C.generate (testBit w)) + construct = C.accum + (\(Const (i,w)) -> \case + True -> Const (i+1, setBit w i) + False -> Const (i+1, w)) + (\(Const (_,w)) -> BitVec w) + (Const (0,0)) -instance Arity n => IVector (Vec n) Bool where - unsafeFreeze (MV_Bool v) = V_Bool `liftM` unsafeFreeze v - unsafeThaw (V_Bool v) = MV_Bool `liftM` unsafeThaw v - unsafeIndex (V_Bool v) = toBool . unsafeIndex v - {-# INLINE unsafeFreeze #-} - {-# INLINE unsafeThaw #-} - {-# INLINE unsafeIndex #-} +instance (n <= 64, Arity n) => Unbox n Bool where + type VecRepr n Bool = BitVec n + type EltRepr Bool = Bool + toEltRepr _ = id + fromEltRepr _ = id + {-# INLINE toEltRepr #-} + {-# INLINE fromEltRepr #-} -fromBool :: Bool -> Word8 -{-# INLINE fromBool #-} -fromBool True = 1 -fromBool False = 0 -toBool :: Word8 -> Bool -{-# INLINE toBool #-} -toBool 0 = False -toBool _ = True - - ---------------------------------------------------------------- -- Primitive wrappers -#define primMV(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 = unsafeRead v i \ -; unsafeWrite (con v) i x = unsafeWrite v i x \ -; {-# INLINE new #-} \ -; {-# INLINE move #-} \ -; {-# INLINE copy #-} \ -; {-# INLINE unsafeRead #-} \ -; {-# INLINE unsafeWrite #-} \ -} - -#define primIV(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 = unsafeIndex v i \ -; {-# INLINE unsafeFreeze #-} \ -; {-# INLINE unsafeThaw #-} \ -; {-# INLINE unsafeIndex #-} \ -} - -#define primWrap(ty,con,mcon) \ -newtype instance MVec n s ty = mcon (P.MVec n s ty) ; \ -newtype instance Vec n ty = con (P.Vec n ty) ; \ -instance Arity n => Unbox n ty ; \ -primMV(ty, mcon ) ; \ -primIV(ty, con, mcon) - - - -primWrap(Int, V_Int, MV_Int ) -primWrap(Int8, V_Int8, MV_Int8 ) -primWrap(Int16, V_Int16, MV_Int16) -primWrap(Int32, V_Int32, MV_Int32) -primWrap(Int64, V_Int64, MV_Int64) +---------------------------------------------------------------- -primWrap(Word, V_Word, MV_Word ) -primWrap(Word8, V_Word8, MV_Word8 ) -primWrap(Word16, V_Word16, MV_Word16) -primWrap(Word32, V_Word32, MV_Word32) -primWrap(Word64, V_Word64, MV_Word64) +-- | Wrapper for deriving 'Unbox' for data types which are instances +-- of 'P.Prim' type class: +-- +-- > deriving via UnboxViaPrim Word instance (C.Arity n) => Unbox n Word +newtype UnboxViaPrim a = UnboxViaPrim a + deriving newtype P.Prim -primWrap(Char, V_Char, MV_Char ) -primWrap(Float, V_Float, MV_Float ) -primWrap(Double, V_Double, MV_Double) +instance (C.Arity n, P.Prim a) => Unbox n (UnboxViaPrim a) where + type VecRepr n (UnboxViaPrim a) = P.Vec n + type EltRepr (UnboxViaPrim a) = a + toEltRepr _ = coerce + fromEltRepr _ = coerce + +deriving via UnboxViaPrim Int instance (C.Arity n) => Unbox n Int +deriving via UnboxViaPrim Int8 instance (C.Arity n) => Unbox n Int8 +deriving via UnboxViaPrim Int16 instance (C.Arity n) => Unbox n Int16 +deriving via UnboxViaPrim Int32 instance (C.Arity n) => Unbox n Int32 +deriving via UnboxViaPrim Int64 instance (C.Arity n) => Unbox n Int64 +deriving via UnboxViaPrim Word instance (C.Arity n) => Unbox n Word +deriving via UnboxViaPrim Word8 instance (C.Arity n) => Unbox n Word8 +deriving via UnboxViaPrim Word16 instance (C.Arity n) => Unbox n Word16 +deriving via UnboxViaPrim Word32 instance (C.Arity n) => Unbox n Word32 +deriving via UnboxViaPrim Word64 instance (C.Arity n) => Unbox n Word64 +deriving via UnboxViaPrim Char instance (C.Arity n) => Unbox n Char +deriving via UnboxViaPrim Float instance (C.Arity n) => Unbox n Float +deriving via UnboxViaPrim Double instance (C.Arity n) => Unbox n Double ---------------------------------------------------------------- --- Complex -newtype instance MVec n s (Complex a) = MV_Complex (MVec n s (a,a)) -newtype instance Vec n (Complex a) = V_Complex (Vec n (a,a)) - -instance (Unbox n a) => Unbox n (Complex a) - -instance (Arity n, MVector (MVec n) a) => MVector (MVec n) (Complex a) where - new = MV_Complex `liftM` new - {-# INLINE new #-} - copy (MV_Complex v) (MV_Complex w) = copy v w - {-# INLINE copy #-} - move (MV_Complex v) (MV_Complex w) = move v w - {-# INLINE move #-} - unsafeRead (MV_Complex v) i = do (a,b) <- unsafeRead v i - return (a :+ b) - {-# INLINE unsafeRead #-} - unsafeWrite (MV_Complex v) i (a :+ b) = unsafeWrite v i (a,b) - {-# INLINE unsafeWrite #-} +-- Newtypes +---------------------------------------------------------------- -instance (Arity n, IVector (Vec n) a) => IVector (Vec n) (Complex a) where - unsafeFreeze (MV_Complex v) = V_Complex `liftM` unsafeFreeze v - {-# INLINE unsafeFreeze #-} - unsafeThaw (V_Complex v) = MV_Complex `liftM` unsafeThaw v - {-# INLINE unsafeThaw #-} - unsafeIndex (V_Complex v) i = - case unsafeIndex v i of (a,b) -> a :+ b - {-# INLINE unsafeIndex #-} +deriving newtype instance (Unbox n a) => Unbox n (Const a b) +deriving newtype instance (Unbox n a) => Unbox n (Identity a) +deriving newtype instance (Unbox n a) => Unbox n (Down a) +deriving newtype instance (Unbox n a) => Unbox n (Dual a) +deriving newtype instance (Unbox n a) => Unbox n (Sum a) +deriving newtype instance (Unbox n a) => Unbox n (Product a) +deriving newtype instance (n <= 64, Arity n) => Unbox n All +deriving newtype instance (n <= 64, Arity n) => Unbox n Any ---------------------------------------------------------------- -- Tuples -data instance MVec n s (a,b) = MV_2 !(MVec n s a) !(MVec n s b) -data instance Vec n (a,b) = V_2 !(Vec n a) !(Vec n b) - -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 - new = do as <- new - bs <- new - return $ MV_2 as bs - {-# INLINE new #-} - copy (MV_2 va vb) (MV_2 wa wb) = copy va wa >> copy vb wb - {-# INLINE copy #-} - move (MV_2 va vb) (MV_2 wa wb) = move va wa >> move vb wb - {-# INLINE move #-} - unsafeRead (MV_2 v w) i = do a <- unsafeRead v i - b <- unsafeRead w i - return (a,b) - {-# INLINE unsafeRead #-} - unsafeWrite (MV_2 v w) i (a,b) = unsafeWrite v i a >> unsafeWrite w i b - {-# INLINE unsafeWrite #-} - - -instance ( Arity n - , IVector (Vec n) a, IVector (Vec n) b - ) => IVector (Vec n) (a,b) where - unsafeFreeze (MV_2 v w) = do as <- unsafeFreeze v - bs <- unsafeFreeze w - return $ V_2 as bs - {-# INLINE unsafeFreeze #-} - unsafeThaw (V_2 v w) = do as <- unsafeThaw v - bs <- unsafeThaw w - return $ MV_2 as bs - {-# INLINE unsafeThaw #-} - unsafeIndex (V_2 v w) i = (unsafeIndex v i, unsafeIndex w i) - {-# INLINE unsafeIndex #-} - - - - -data instance MVec n s (a,b,c) = MV_3 !(MVec n s a) !(MVec n s b) !(MVec n s c) -data instance Vec n (a,b,c) = V_3 !(Vec n a) !(Vec n b) !(Vec n c) - -instance (Unbox n a, Unbox n b, Unbox n c) => Unbox n (a,b,c) - -instance (Arity n, MVector (MVec n) a, MVector (MVec n) b, MVector (MVec n) c - ) => MVector (MVec n) (a,b,c) where - new = do as <- new - bs <- new - cs <- new - return $ MV_3 as bs cs - {-# INLINE new #-} - copy (MV_3 va vb vc) (MV_3 wa wb wc) - = copy va wa >> copy vb wb >> copy vc wc - {-# INLINE copy #-} - move (MV_3 va vb vc) (MV_3 wa wb wc) - = move va wa >> move vb wb >> move vc wc - {-# INLINE move #-} - unsafeRead (MV_3 v w u) i = do a <- unsafeRead v i - b <- unsafeRead w i - c <- unsafeRead u i - return (a,b,c) - {-# INLINE unsafeRead #-} - unsafeWrite (MV_3 v w u) i (a,b,c) - = unsafeWrite v i a >> unsafeWrite w i b >> unsafeWrite u i c - {-# INLINE unsafeWrite #-} - -instance ( Arity n - , Vector (Vec n) a, Vector (Vec n) b, Vector (Vec n) c - , IVector (Vec n) a, IVector (Vec n) b, IVector (Vec n) c - ) => IVector (Vec n) (a,b,c) where - unsafeFreeze (MV_3 v w u) = do as <- unsafeFreeze v - bs <- unsafeFreeze w - cs <- unsafeFreeze u - return $ V_3 as bs cs - {-# INLINE unsafeFreeze #-} - unsafeThaw (V_3 v w u) = do as <- unsafeThaw v - bs <- unsafeThaw w - cs <- unsafeThaw u - return $ MV_3 as bs cs - {-# INLINE unsafeThaw #-} - 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) +-- | Representation for vector of 2-tuple as two vectors. +data T2 n a b x = T2 !(Vec n a) !(Vec n 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 #-} +type instance Dim (T2 n a b) = Peano n +type instance Dim (T2 n a b x) = Peano n -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 #-} +instance (Arity n, Unbox n a, Unbox n b) => Vector (T2 n a b) (a,b) where + inspect (T2 vA vB) + = inspect (C.zipWith (,) cvA cvB) + where + cvA = C.ContVec $ inspect vA + cvB = C.ContVec $ inspect vB + construct = pairF T2 construct construct + {-# INLINE construct #-} + {-# INLINE inspect #-} +pairF + :: ArityPeano n + => (x -> y -> z) + -> Fun n a x + -> Fun n b y + -> Fun n (a,b) z +{-# INLINE pairF #-} +pairF g funA funB = C.accum + (\(T_pair fA fB) (a,b) -> T_pair (curryFirst fA a) (curryFirst fB b)) + (\(T_pair (Fun x) (Fun y)) -> g x y) + (T_pair funA funB) ----------------------------------------------------------------- --- Newtype wrappers with kind * -> * +data T_pair a b x y n = T_pair (Fun n a x) (Fun n b y) -#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 #-} \ -} +-- | Representation for vector of 2-tuple as two vectors. +data T3 n a b c x = T3 !(Vec n a) !(Vec n b) !(Vec n c) -#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) +type instance Dim (T3 n a b c) = Peano n +type instance Dim (T3 n a b c x) = Peano n +instance (Arity n, Unbox n a, Unbox n b, Unbox n c) => Vector (T3 n a b c) (a,b,c) where + inspect (T3 vA vB vC) + = inspect (C.zipWith3 (,,) cvA cvB cvC) + where + cvA = C.ContVec $ inspect vA + cvB = C.ContVec $ inspect vB + cvC = C.ContVec $ inspect vC + construct = pair3F T3 construct construct construct + {-# INLINE construct #-} + {-# INLINE inspect #-} -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) +pair3F + :: ArityPeano n + => (x -> y -> z -> r) + -> Fun n a x + -> Fun n b y + -> Fun n c z + -> Fun n (a,b,c) r +{-# INLINE pair3F #-} +pair3F g funA funB funC = C.accum + (\(T_pair3 fA fB fC) (a,b,c) -> T_pair3 (curryFirst fA a) + (curryFirst fB b) + (curryFirst fC c)) + (\(T_pair3 (Fun x) (Fun y) (Fun z)) -> g x y z) + (T_pair3 funA funB funC) +data T_pair3 a b c x y z n = T_pair3 (Fun n a x) (Fun n b y) (Fun n c z) ----------------------------------------------------------------- --- 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) +instance (Unbox n a, Unbox n b) => Unbox n (a,b) where + type VecRepr n (a,b) = T2 n a b + type EltRepr (a,b) = (a,b) + toEltRepr _ = id + fromEltRepr _ = id -primNewMonoWrap(Any, Bool, V_Any, MV_Any) -primNewMonoWrap(All, Bool, V_All, MV_All) +instance (Unbox n a) => Unbox n (Complex a) where + -- NOTE: It would be nice to have ability to use single buffer say + -- for `Complex Double`. But buffers seems to be opaque + type VecRepr n (Complex a) = T2 n a a + type EltRepr (Complex a) = (a,a) + toEltRepr _ (r :+ i) = (r,i) + fromEltRepr _ (r,i) = r :+ i + {-# INLINE toEltRepr #-} + {-# INLINE fromEltRepr #-} diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/fixed-vector.cabal b/fixed-vector.cabal --- a/fixed-vector.cabal +++ b/fixed-vector.cabal @@ -1,101 +1,179 @@ +Cabal-Version: 3.0 +Build-Type: Simple + Name: fixed-vector -Version: 1.2.3.0 +Version: 2.1.1.0 Synopsis: Generic vectors with statically known size. Description: Generic library for vectors with statically known size. Implementation is based on Same functions could be used to work with both ADT based vector like - . + > data Vec3 a = a a a - . + Tuples are vectors too: - . + >>> sum (1,2,3) 6 - . + Vectors which are represented internally by arrays are provided by library. Both boxed and unboxed arrays are supported. - . + Library is structured as follows: - . - * Data.Vector.Fixed + + * __Data.Vector.Fixed__: Generic API. It's suitable for both ADT-based vector like Complex and array-based ones. - . - * Data.Vector.Fixed.Cont + + * __Data.Vector.Fixed.Cont__: Continuation based vectors. Internally all functions use them. - . - * Data.Vector.Fixed.Mutable + + * __Data.Vector.Fixed.Unboxed__: + Unboxed vectors which select best representation using types. + + * __Data.Vector.Fixed.Strict__: + Strict boxed vector which can hold elements of any type. + + * __Data.Vector.Fixed.Boxed__: + Lazy boxed vector which can hold elements of any type. + + * __Data.Vector.Fixed.Storable__: + Unboxed vectors of Storable types. + + * __Data.Vector.Fixed.Primitive__: + Unboxed vectors backed by single @ByteArray@ + + * __Data.Vector.Fixed.Mutable__: Type classes for array-based implementation and API for working with mutable state. - . - * Data.Vector.Fixed.Unboxed - Unboxed vectors. - . - * Data.Vector.Fixed.Boxed - Boxed vector which can hold elements of any type. - . - * Data.Vector.Fixed.Storable - Unboxed vectors of Storable types. - . - * Data.Vector.Fixed.Primitive - Unboxed vectors based on pritimive package. -Cabal-Version: >= 1.10 -License: BSD3 + +License: BSD-3-Clause License-File: LICENSE Author: Aleksey Khudyakov Maintainer: Aleksey Khudyakov Bug-reports: https://github.com/Shimuuar/fixed-vector/issues Category: Data -Build-Type: Simple -extra-source-files: +extra-doc-files: ChangeLog.md tested-with: - GHC ==8.4.4 - || ==8.6.5 - || ==8.8.4 - || ==8.10.7 - || ==9.0.1 - || ==9.2.8 - || ==9.4.7 - || ==9.6.3 + GHC ==9.4.7 + || ==9.6.7 + || ==9.8.4 + || ==9.10.2 + || ==9.12.2 + || ==9.14.1 source-repository head type: git location: http://github.com/Shimuuar/fixed-vector -Library +common language Ghc-options: -Wall -Wno-incomplete-uni-patterns Default-Language: Haskell2010 - Build-Depends: base >=4.11 && <5 + Default-Extensions: + -- GHC2021 sans PolyKinds + BangPatterns + ConstraintKinds + DataKinds + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DisambiguateRecordFields + DoAndIfThenElse + EmptyCase + EmptyDataDecls + EmptyDataDeriving + ExistentialQuantification + ExplicitNamespaces + FlexibleContexts + FlexibleInstances + ForeignFunctionInterface + GADTs + GADTSyntax + GeneralisedNewtypeDeriving + ImplicitPrelude + ImportQualifiedPost + InstanceSigs + KindSignatures + LambdaCase + MonoLocalBinds + MonomorphismRestriction + MultiParamTypeClasses + NamedFieldPuns + NamedWildCards + NumericUnderscores + PatternGuards + PostfixOperators + RankNTypes + RelaxedPolyRec + RoleAnnotations + ScopedTypeVariables + StandaloneDeriving + StandaloneKindSignatures + TupleSections + TypeApplications + TypeOperators + TypeSynonymInstances + -- + DerivingVia + PatternSynonyms + ViewPatterns + TypeFamilies + FunctionalDependencies + + +Library + import: language + Build-Depends: base >=4.16 && <5 , primitive >=0.6.2 , deepseq + if impl(ghc<9.6) + Build-Depends: foldable1-classes-compat >=0.1 Exposed-modules: -- API Data.Vector.Fixed.Cont Data.Vector.Fixed Data.Vector.Fixed.Generic + Data.Vector.Fixed.Mono -- Arrays Data.Vector.Fixed.Mutable Data.Vector.Fixed.Boxed + Data.Vector.Fixed.Strict Data.Vector.Fixed.Primitive Data.Vector.Fixed.Unboxed Data.Vector.Fixed.Storable Other-modules: Data.Vector.Fixed.Internal + Data.Vector.Fixed.Compat Test-Suite fixed-vector-doctests Default-Language: Haskell2010 - if impl(ghc < 8.0.1 ) + if impl(ghc < 9.2) buildable: False Type: exitcode-stdio-1.0 Hs-source-dirs: test Main-is: Doctests.hs - Build-Depends: base >=4.8 && <5 + Build-Depends: base >=4.14 && <5 , primitive >=0.6.2 -- Additional test dependencies. , doctest >= 0.18 , filemanip == 0.3.6.* + +Test-Suite fixed-vector-inspect + import: language + Type: exitcode-stdio-1.0 + Hs-source-dirs: test + Main-is: inspect.hs + Other-modules: Inspect.Obligations + Build-Depends: base >=4.8 && <5 + , template-haskell + , fixed-vector + , tasty >= 1.2 + , tasty-inspection-testing >= 0.1 diff --git a/test/Doctests.hs b/test/Doctests.hs --- a/test/Doctests.hs +++ b/test/Doctests.hs @@ -10,4 +10,61 @@ main :: IO () main = do sources <- find_sources - doctest $ sources + doctest $ exts ++ sources + + +exts :: [String] +exts = + [ "-XBangPatterns" + , "-XConstraintKinds" + , "-XDataKinds" + , "-XDeriveDataTypeable" + , "-XDeriveFoldable" + , "-XDeriveFunctor" + , "-XDeriveGeneric" + , "-XDeriveLift" + , "-XDeriveTraversable" + , "-XDerivingStrategies" + , "-XDisambiguateRecordFields" + , "-XDoAndIfThenElse" + , "-XEmptyCase" + , "-XEmptyDataDecls" + , "-XEmptyDataDeriving" + , "-XExistentialQuantification" + , "-XExplicitNamespaces" + , "-XFlexibleContexts" + , "-XFlexibleInstances" + , "-XForeignFunctionInterface" + , "-XGADTs" + , "-XGADTSyntax" + , "-XGeneralisedNewtypeDeriving" + , "-XImplicitPrelude" + , "-XImportQualifiedPost" + , "-XInstanceSigs" + , "-XKindSignatures" + , "-XLambdaCase" + , "-XMonoLocalBinds" + , "-XMonomorphismRestriction" + , "-XMultiParamTypeClasses" + , "-XNamedFieldPuns" + , "-XNamedWildCards" + , "-XNumericUnderscores" + , "-XPatternGuards" + , "-XPostfixOperators" + , "-XRankNTypes" + , "-XRelaxedPolyRec" + , "-XRoleAnnotations" + , "-XScopedTypeVariables" + , "-XStandaloneDeriving" + , "-XStandaloneKindSignatures" + , "-XTupleSections" + , "-XTypeApplications" + , "-XTypeOperators" + , "-XTypeSynonymInstances" + -- + , "-XDerivingVia" + , "-XPatternSynonyms" + , "-XViewPatterns" + , "-XTypeFamilies" + , "-XFunctionalDependencies" + ] diff --git a/test/Inspect/Obligations.hs b/test/Inspect/Obligations.hs new file mode 100644 --- /dev/null +++ b/test/Inspect/Obligations.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TemplateHaskell #-} +-- | +module Inspect.Obligations where + +import GHC.Exts +import Test.Tasty.Inspection +import Language.Haskell.TH (Name) + + +-- We don't allocate arrays in he function. It covers opaque data +-- types +noArrayAlloc :: Name -> Obligation +noArrayAlloc nm = doesNotUseAnyOf nm + [ 'newByteArray# + , 'newSmallArray# + ] + +noAllocation :: Name -> Obligation +noAllocation nm = mkObligation nm NoAllocation diff --git a/test/inspect.hs b/test/inspect.hs new file mode 100644 --- /dev/null +++ b/test/inspect.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fplugin=Test.Tasty.Inspection.Plugin #-} +{-# OPTIONS_GHC -dsuppress-idinfo #-} +module Main where + +import Test.Tasty +import Test.Tasty.Inspection + +import Data.Vector.Fixed qualified as F +import Data.Vector.Fixed.Unboxed qualified as FU +import Data.Vector.Fixed.Boxed qualified as FB +import Data.Vector.Fixed.Primitive qualified as FP + +import Inspect.Obligations + + + +simple_fusion_FU :: Int -> Int +simple_fusion_FU n = F.sum $ F.generate @FU.Vec3 (*n) + +simple_fusion_FB :: Int -> Int +simple_fusion_FB n = F.sum $ F.generate @FB.Vec3 (*n) + +simple_fusion_FP :: Int -> Int +simple_fusion_FP n = F.sum $ F.generate @FP.Vec3 (*n) + +fuse_mapM_ :: IO () +fuse_mapM_ = F.mapM_ print (F.mk3 1 2 3 :: FU.Vec3 Double) + +fuse_zipWith :: Int -> Int +fuse_zipWith n = F.sum $ F.zipWith (*) v u + where v,u :: FU.Vec3 Int + v = F.generate (*2) + u = F.replicate n + +fuse_zipWith_self :: Int -> Int +fuse_zipWith_self n = F.sum $ F.zipWith (*) u u + where u :: FU.Vec3 Int + u = F.replicate n + +-- More involved example with zipWith. It stresses optimizer and could be +-- used as a benchmark for optimization of compilation speed. +fuse_zipWithParam :: FP.Vec 3 Int -> FP.Vec 3 Int -> FP.Vec 3 Int -> Int +fuse_zipWithParam v1 v2 v3 = F.sum v12 + F.sum v13 + F.sum v23 where + v12 = F.zipWith (*) v1 v2 + v13 = F.zipWith (*) v1 v3 + v23 = F.zipWith (*) v2 v3 + +simple_foldl1 :: FP.Vec 4 Int -> Int +simple_foldl1 = F.foldl1 (+) . F.map (\n -> n*n) + + +---------------------------------------------------------------- +-- Tests +---------------------------------------------------------------- + +main :: IO () +main = defaultMain $ testGroup "inspect" + [ $(inspectObligations [ hasNoTypeClasses + , noArrayAlloc + ] 'simple_fusion_FU) + , $(inspectObligations [ hasNoTypeClasses + , noArrayAlloc + ] 'simple_fusion_FB) + , $(inspectObligations [ hasNoTypeClasses + , noArrayAlloc + ] 'simple_fusion_FP) + , $(inspectObligations [ hasNoTypeClasses + , noArrayAlloc + ] 'fuse_mapM_) + , testGroup "zipWith" + -- NOTE: zipWith uses lists internally but they should get + -- optimized away. Thus check that lists don't occur in core + [ $(inspectObligations [ hasNoTypeClasses + , flip hasNoType ''[] + , noArrayAlloc + ] 'fuse_zipWith) + , $(inspectObligations [ hasNoTypeClasses + , flip hasNoType ''[] + -- FIXME: Does not fuse when used nonlinearly + -- , noArrayAlloc + ] 'fuse_zipWith_self) + , $(inspectObligations [ hasNoTypeClasses + , flip hasNoType ''[] + , noArrayAlloc + ] 'fuse_zipWithParam) + , $(inspectObligations [ hasNoTypeClasses + , noArrayAlloc + ] 'simple_foldl1) + ] + ]