diff --git a/ChangeLog b/ChangeLog deleted file mode 100644 --- a/ChangeLog +++ /dev/null @@ -1,166 +0,0 @@ -Changes in 0.8.1.0 - - * `find` function added. - - -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. - - -Changes in 0.7.0.3 - - * GHC 7.10 support - - -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` - - -Changes in 0.6.4.0 - - * Isomorphism between Peano numbers and Nat added. (GHC >= 7.8) - - -Changes in 0.6.3.1 - - * Documentation fixes. - - -Changes in 0.6.3.0 - - * Left scans added. - - -Changes in 0.6.2.0 - - * `Vec1' type synonym for boxed/unboxed/etc. vectors added. - - * Vector instance for Data.Typeable.Proxy (GHC >= 7.8) - - -Changes in 0.6.1.1 - - * GHC 7.8 support - - -Changes in 0.6.1.0 - - * `distribute', `collect' and their monadic variants added. - - -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. - - -Changes in 0.5.1.0 - - * 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. - - -Changes in 0.4.4.0 - - * Functor and Applicative instances are added to Id. - - -Changes in 0.4.3.0 - - * 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. - - -Changes in 0.4.1.0 - - * `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 - - -Changes in 0.3.0.0 - - * 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. - - -Changes in 0.1.2 - - * 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. diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,253 @@ +2.1.1.0 [2026.02.28] +------------- +* Missing `Prod` and `Vector` instances are added for `ContVec`. + + +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. + + +2.0.0.0 [2025.07.10] +------------------ +* Type family `Dim` returns Peano numbers instead of standard type level + naturals. + + - `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`. + +* `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. + +* `Data.Vector.Fixed.Cont.arity` dropped. + +* Type of `D.V.F.Cont.withFun` generalized. + +* Type class `VectorN` dropped. Use `QuantifiedConstraints` instead. + +* Show instance now has form `[...]` instead of `fromList [...]`. + +* `ViaFixed` newtype wrapper for deriving instances is + added. `StorableViaFixed` is removed. + +* `Data.Vector.Fixed.Storable.unsafeWith` ensures that pointer won't + get GC'd while function runs. + +* `Data.Vector.Fixed.sequenceA` is deprecated in favor of `sequence`. + +* `foldl'` and `ifoldl'` functions added. + +* Implement `sum` as in terms of `foldl'`. + + +1.2.3.0 [2023-10-31] +-------------------- +* Pattern `V1` added +* `COMPLETE` pragmas added for patterns `V1`,`V2`,`V3`,`V4` + + +1.2.2.1 [2022-12-29] +-------------------- +* Newtype `StorableViaFixed` for deriving `Storable` instances added. + + +1.2.1.1 [2022-12-26] +-------------------- +* Fixed bug in `any` (#18) + + +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. + + +1.2.0.0 [2018-09-02] +-------------------- +* `Show` instance for data type now respect precedence. + + +1.1.0.0 [2018-03-11] +-------------------- +* GHC8.4 compatibility release. Semigroup instances added and + semigroup dependency added for GHC7.10 + + +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. + + +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`. + + +0.8.1.0 [2015-08-27] +-------------------- +* `find` function added. + + +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. + + +0.7.0.3 [2015-01-03] +-------------------- +* GHC 7.10 support + + +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` + + +0.6.4.0 [2014-04-15] +-------------------- +* Isomorphism between Peano numbers and Nat added. (GHC >= 7.8) + + +0.6.3.1 [2014-03-12] +-------------------- +* Documentation fixes. + + +0.6.3.0 [2014-02-22] +-------------------- +* Left scans added. + + +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) + + +0.6.1.1 [2014-02-04] +-------------------- +* GHC 7.8 support + + +0.6.1.0 [2014-01-24] +-------------------- +* `distribute` `collect` and their monadic variants added. + + +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. + +0.5.1.0 [2013-08-06] +-------------------- +* Zero-element vector `Empty'`is added. + + +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. + + +0.4.4.0 [2013-06-13] +-------------------- +* Functor and Applicative instances are added to Id. + + +0.4.3.0 [2013-05-18] +-------------------- +* Typeable instance for S and Z added. + + +0.4.2.0 [2013-05-01] +-------------------- +* 1-tuple `Only` added. +* `fromList'` and fromListM added. +* apply functions from Arity type class generalized. + + +0.4.1.0 [2013-04-29] +-------------------- +* `cons` function added. +* Getter for `Fun` data type added. + + +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 + + +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. + + +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. + + +0.1.2 [2013-01-26] +------------------ +* imap, imapM, ifoldl, ifoldM, zipWithM, izipWithM + functions are added. +* VectorN type class added. + + +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,25 +1,45 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} -- | --- 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: @@ -27,56 +47,52 @@ -- > 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 - , Z - , S - -- ** Synonyms for small numerals - , N1 - , N2 - , N3 - , N4 - , N5 - , N6 - -- ** 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 , mk3 , mk4 , mk5 - -- ** Consing - , ContVec - , empty - , vector - , (<|) - -- ** Variadic function - , Make + , mk6 + , mk7 + , mk8 , mkN - -- ** Functions + -- ** Pattern synonyms + , pattern V1 + , pattern V2 + , pattern V3 + , pattern V4 + -- * Functions + -- ** Creation , replicate , replicateM , generate , generateM , unfoldr , basis - -- * Modifying vectors -- ** Transformations , head , tail @@ -91,9 +107,6 @@ , set , element , elementTy - -- ** Comparison - , eq - , ord -- ** Maps , map , mapM @@ -105,23 +118,22 @@ , scanl1 , sequence , sequence_ - , sequenceA , traverse , distribute , collect - , distributeM - , collectM - -- * Folding + -- ** Folds , foldl + , foldl' , foldr , foldl1 , fold , foldMap , ifoldl + , ifoldl' , ifoldr , foldM , ifoldM - -- ** Special folds + -- *** Special folds , sum , maximum , minimum @@ -130,7 +142,7 @@ , all , any , find - -- * Zips + -- ** Zips , zipWith , zipWith3 , zipWithM @@ -139,13 +151,10 @@ , izipWith3 , izipWithM , izipWithM_ - -- * Storable methods - -- $storable - , defaultAlignemnt - , defaultSizeOf - , defaultPeek - , defaultPoke - -- * Conversion + -- *** Special zips + , eq + , ord + -- ** Conversion , convert , toList , fromList @@ -154,6 +163,7 @@ , fromFoldable -- * Data types , VecList(..) + , VecPeano(..) , Only(..) , Empty(..) -- ** Tuple synonyms @@ -161,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 Data.Data (Typeable,Data) -import Data.Monoid (Monoid(..)) -import qualified Data.Foldable as F -import qualified Data.Traversable as T -import Foreign.Storable (Storable(..)) -import Foreign.Ptr (castPtr) +import Control.Applicative (Applicative(..)) +import Control.DeepSeq (NFData(..)) +import Control.Monad.Primitive (PrimBase(..)) +import Data.Coerce +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,vector, - empty,S,Z,Arity,Fun(..),accum,apply, - N1,N2,N3,N4,N5,N6,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,(.),($),seq,undefined) --- Needed for doctest -import Prelude (Char) +import Prelude (Show(..),Eq(..),Ord(..),Num(..),Functor(..),id,(.),($),(<$>),undefined,flip) -- $construction @@ -188,40 +221,30 @@ -- There are several ways to construct fixed vectors except using -- their constructor if it's available. For small ones it's possible -- to use functions 'mk1', 'mk2', etc. --- +-- -- >>> mk3 'a' 'b' 'c' :: (Char,Char,Char) -- ('a','b','c') -- --- Another option is to create tuple and 'convert' it to desired --- vector type. For example: --- --- > v = convert (x,y,z) +-- Another way is to use pattern synonyms for construction and +-- inspection of vectors: -- --- 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 +-- >>> V2 'a' 'b' :: (Char,Char) +-- ('a','b') -- --- > function :: Vec N3 Double -> ... --- > function (convert -> (x,y,z)) = ... +-- >>> case ('a','b') of V2 a b -> [a,b] +-- "ab" -- --- Third way is to use variadic function 'mkN'. It works similarly to --- 'Text.Printf.printf' except it produces result of type 'ContVec' --- which should be converted to vector of desired type by 'vector': +-- Last option is to use 'convert' to convert between different vector +-- types of same length. For example -- --- >>> vector $ mkN 'a' 'b' 'c' :: (Char,Char,Char) --- ('a','b','c') +-- > v = convert (x,y,z) -- --- Probably most generic way is to cons values to the @ContVec@ and --- convert it vector of desired type using 'vector': +-- This could be used in view patterns as well: -- --- >>> vector $ 'a' <| 'b' <| 'c' <| empty :: (Char,Char,Char) --- ('a','b','c') - - - --- $smallDim +-- > foo :: Vec3 Double -> Foo +-- > foo (convert -> (x,y,z)) = ... -- --- Constructors for vectors with small dimensions. +-- Pattern synonyms use this trick internally. -- $storable @@ -230,158 +253,387 @@ -- 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) --------------------------------------------------------------------------------- --- We are trying to be clever with indexing here. It's not possible to --- write generic indexing function. For example it's necessary O(n) --- for VecList. It's however possible to write O(1) indexing for some --- vectors and we trying to use such functions where possible. --- --- We try to use presumable more efficient basicIndex --- --- 1. It should not interfere with deforestation. So we should --- rewrite only when deforestation rule already fired. --- (starting from phase 1). --- --- 2. Creation of vector is costlier than generic indexing so we should --- apply rule only when vector is created anyway --- --- In order to avoid firing this rule on implementation of (!) it has --- been necessary to move definition of all functions to internal module. +-- | Standard GADT-based vector with statically known length +-- parametrized by Peano numbers. +data VecPeano (n :: PeanoNum) a where + Nil :: VecPeano 'Z a + Cons :: a -> VecPeano n a -> VecPeano ('S n) a -{-# RULES -"fixed-vector:index/basicIndex"[1] forall vv i. - runIndex i (C.cvec vv) = C.basicIndex vv i - #-} +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 = 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 --- | Vector based on the lists. Not very useful by itself but is --- necessary for implementation. -data VecList n a where - Nil :: VecList Z a - Cons :: a -> VecList n a -> VecList (S n) a - deriving (Typeable) -instance (Arity n, NFData a) => NFData (VecList n a) where - rnf = foldl (\r a -> r `seq` rnf a) () - {-# INLINE rnf #-} - --- Vector instance -type instance Dim (VecList n) = n - -instance Arity n => Vector (VecList n) a where - construct = Fun $ accum +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 n n) - inspect v (Fun f) = apply step (Flip v) f + inspect v + = inspect (apply step (Flip v) :: C.ContVec n a) where - step :: Flip VecList a (S k) -> (a, Flip VecList a k) + step :: Flip VecPeano a ('S k) -> (a, Flip VecPeano a k) step (Flip (Cons a xs)) = (a, Flip xs) {-# INLINE construct #-} {-# INLINE inspect #-} -instance Arity n => VectorN VecList n a +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) -newtype T_List a n k = T_List (VecList k a -> VecList 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 = zipWith mappend - {-# INLINE mempty #-} - {-# INLINE mappend #-} + sequence = sequence + sequenceA = sequence + traverse = mapM + mapM = mapM + {-# INLINE sequence #-} + {-# INLINE sequenceA #-} + {-# INLINE mapM #-} + {-# INLINE traverse #-} -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 #-} +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) +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 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) + deriving (Show,Eq,Ord,Data,Functor,F.Foldable,T.Traversable) -instance Functor Only where - fmap f (Only a) = Only (f a) -instance F.Foldable Only where - foldr = foldr -instance T.Traversable Only where - sequenceA (Only f) = Only <$> f - traverse f (Only a) = Only <$> f a +-- | @since @2.0.1.0 +deriving via ViaFixed Only instance F1.Foldable1 Only + + instance Monoid a => Monoid (Only a) where - mempty = Only mempty - Only a `mappend` Only b = Only $ mappend a b + mempty = Only mempty + mappend = (<>) +instance (Semigroup a) => Semigroup (Only a) where + (<>) = coerce ((<>) @a) + {-# INLINE (<>) #-} + instance NFData a => NFData (Only a) where rnf (Only a) = rnf a -type instance Dim Only = S Z +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 (Typeable, Data) - -instance Functor Empty where - fmap _ Empty = Empty -instance F.Foldable Empty where - foldr = foldr -instance T.Traversable Empty where - sequenceA Empty = pure Empty - traverse _ Empty = pure Empty +data Empty a = Empty + deriving (Show,Eq,Ord,Data,Functor,F.Foldable,T.Traversable) instance NFData (Empty a) where rnf Empty = () -type instance Dim Empty = Z +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) type Tuple4 a = (a,a,a,a) type Tuple5 a = (a,a,a,a,a) + + +---------------------------------------------------------------- +-- 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 ~ C.N1) => a -> v a +pattern V1 x <- (convert -> (Only x)) where + V1 x = mk1 x +{-# INLINE V1 #-} +{-# COMPLETE V1 #-} + +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 +{-# INLINE V2 #-} +{-# COMPLETE V2 #-} + +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 +{-# INLINE V3 #-} +{-# COMPLETE V3 #-} + +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 +{-# INLINE V4 #-} +{-# COMPLETE V4 #-} + +-- $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,12 +1,9 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# 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 @@ -21,112 +18,108 @@ import Control.Applicative (Applicative(..)) import Control.DeepSeq (NFData(..)) -import Data.Primitive.Array +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 Prelude (Show(..),Eq(..),Ord(..),Functor(..),Monad(..)) -import Prelude ((++),($),($!),undefined,error,seq) +import Foreign.Storable (Storable) +import GHC.TypeLits +import GHC.Exts (proxy#) +import Prelude ( Show(..),Eq(..),Ord(..),Functor(..),Monad(..) + , ($!),error,(<$>)) +import Data.Vector.Fixed.Compat import Data.Vector.Fixed hiding (index) -import Data.Vector.Fixed.Mutable -import qualified Data.Vector.Fixed.Cont as C - +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. -newtype Vec n a = Vec (Array a) +-- | 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 s a = MVec (MutableArray s a) - -#if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable Vec -deriving instance Typeable MVec -#else -deriving instance Typeable2 Vec -deriving instance Typeable3 MVec -#endif - -type Vec1 = Vec (S Z) -type Vec2 = Vec (S (S Z)) -type Vec3 = Vec (S (S (S Z))) -type Vec4 = Vec (S (S (S (S Z)))) -type Vec5 = Vec (S (S (S (S (S Z))))) - - -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 #-} +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 ---------------------------------------------------------------- -instance (Arity n, Show a) => Show (Vec n a) where - show v = "fromList " ++ show (toList v) +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 - overlaps (MVec v) (MVec u) = sameMutableArray v u - {-# INLINE overlaps #-} - new = do - v <- newArray (arity (undefined :: n)) uninitialised - return $ MVec v - {-# INLINE new #-} - copy = move - {-# INLINE copy #-} - move (MVec dst) (MVec src) = copyMutableArray dst 0 src 0 (arity (undefined :: n)) - {-# INLINE move #-} - unsafeRead (MVec v) i = readArray v i - {-# INLINE unsafeRead #-} - unsafeWrite (MVec v) i x = writeArray 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 <- unsafeFreezeArray v; return $! Vec a } - unsafeThaw (Vec v) = do { a <- unsafeThawArray v; return $! MVec a } - unsafeIndex (Vec v) i = indexArray 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 <- 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 @@ -135,40 +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 = zipWith mappend - {-# INLINE mempty #-} - {-# INLINE mappend #-} - -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,1309 +1,1393 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE GADTs #-} --- Needed for NatIso -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE DataKinds, TypeOperators, UndecidableInstances #-} -#endif --- | --- API for Church-encoded vectors. Implementation of function from --- "Data.Vector.Fixed" module uses these function internally in order --- to provide shortcut fusion. -module Data.Vector.Fixed.Cont ( - -- * Type-level numbers - S - , Z - , Add - -- ** Isomorphism between Peano number and Nats - -- $natiso -#if __GLASGOW_HASKELL__ >= 708 - , NatIso - , ToPeano - , ToNat -#endif - -- ** Synonyms for small numerals - , N1 - , N2 - , N3 - , N4 - , N5 - , N6 - -- * N-ary functions - , Fn - , Fun(..) - , Arity(..) - , apply - , applyM - , WitSum(..) - -- ** Combinators - , constFun - , curryFirst - , uncurryFirst - , curryLast - , curryMany - , uncurryMany - , apLast - , shuffleFun - , withFun - -- * Vector type class - , Dim - , Vector(..) - , VectorN - , length - , Index(..) - -- * Vector as continuation - , ContVec(..) - -- * Construction of ContVec - , cvec - , fromList - , fromList' - , fromListM - , toList - , replicate - , replicateM - , generate - , generateM - , unfoldr - , basis - -- ** Constructors - , empty - , cons - , consV - , snoc - , concat - , mk1 - , mk2 - , mk3 - , mk4 - , mk5 - -- * Transformations - , map - , imap - , mapM - , imapM - , mapM_ - , imapM_ - , scanl - , scanl1 - , sequence - , sequence_ - , distribute - , collect - , distributeM - , collectM - , tail - , reverse - -- ** Zips - , zipWith - , zipWith3 - , izipWith - , izipWith3 - , zipWithM - , zipWithM_ - , izipWithM - , izipWithM_ - -- * Running ContVec - , runContVec - -- ** Getters - , head - , index - , element - , elementTy - -- ** Vector construction - , vector - -- ** Folds - , foldl - , foldl1 - , foldr - , ifoldl - , ifoldr - , foldM - , ifoldM - -- *** Special folds - , sum - , minimum - , maximum - , and - , or - , all - , any - , find - -- ** Data.Data.Data - , gfoldl - , gunfold - ) where - -import Control.Applicative (Applicative(..),(<$>),(<|>)) -import Control.Monad (liftM) -import Data.Complex (Complex(..)) -import Data.Data (Typeable,Data) -#if __GLASGOW_HASKELL__ >= 708 -import Data.Typeable (Proxy(..)) -import GHC.TypeLits -#endif -import qualified Data.Foldable as F -import qualified Data.Traversable as F - -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 - ) - - ----------------------------------------------------------------- --- Naturals ----------------------------------------------------------------- - --- | Type level zero -data Z deriving Typeable --- | Successor of n -data S n deriving Typeable - --- | Type family for sum of unary natural numbers. -type family Add n m :: * - -type instance Add Z n = n -type instance Add (S n) k = S (Add n k) - -type N1 = S Z -type N2 = S N1 -type N3 = S N2 -type N4 = S N3 -type N5 = S N4 -type N6 = S N5 - - --- $natiso --- --- It's only become possible to define isomorphism between Peano --- number and built-in @Nat@ number in GHC 7.8. It's however --- impossible to define their properties inductively. So Peano number --- are used everywhere. - -#if __GLASGOW_HASKELL__ >= 708 --- | Isomorphism between two representations of natural numbers -class (ToNat a ~ b, ToPeano b ~ a) => NatIso (a :: *) (b :: Nat) where - --- | Convert Peano number to Nat -type family ToNat (a :: * ) :: Nat where - ToNat Z = 0 - ToNat (S k) = 1 + ToNat k - --- | Convert Nat number to Peano represenation -type family ToPeano (b :: Nat) :: * where - ToPeano 0 = Z - ToPeano n = S (ToPeano (n - 1)) - -instance NatIso Z 0 where -instance ( NatIso k (n - 1) - , ToPeano (n - 1) ~ k - , ToPeano n ~ S k - , n ~ (1 + (n - 1)) -- n is positive - ) => NatIso (S k) n where -#endif - - ----------------------------------------------------------------- --- N-ary functions ----------------------------------------------------------------- - --- | Type family for n-ary functions. -type family Fn n a b -type instance Fn Z a b = b -type instance Fn (S n) a b = a -> Fn n a b - --- | Newtype wrapper which is used to make 'Fn' injective. It's also a --- reader monad. -newtype Fun n a b = Fun { unFun :: Fn n a b } - - -instance Arity n => Functor (Fun n a) where - fmap (f :: b -> c) (Fun g0 :: Fun n a b) - = Fun $ accum - (\(T_fmap g) a -> T_fmap (g a)) - (\(T_fmap x) -> f x) - (T_fmap g0 :: T_fmap a b n) - {-# INLINE fmap #-} - -instance Arity n => Applicative (Fun n a) where - pure (x :: x) = Fun $ accum (\(T_pure r) (_::a) -> T_pure r) - (\(T_pure r) -> r) - (T_pure x :: T_pure x n) - (Fun f0 :: Fun n a (p -> q)) <*> (Fun g0 :: Fun n a p) - = Fun $ accum (\(T_ap f g) a -> T_ap (f a) (g a)) - (\(T_ap f g) -> f g) - (T_ap f0 g0 :: T_ap a (p -> q) p n) - {-# INLINE pure #-} - {-# INLINE (<*>) #-} - -instance Arity n => Monad (Fun n a) where - return = pure - f >>= g = shuffleFun g <*> f - {-# INLINE return #-} - {-# INLINE (>>=) #-} - - -newtype T_fmap a b n = T_fmap (Fn n a b) -data T_pure a n = T_pure a -data T_ap a b c n = T_ap (Fn n a b) (Fn n a c) - - - ----------------------------------------------------------------- --- Generic operations of N-ary functions ----------------------------------------------------------------- - --- | Type class for handling /n/-ary functions. -class Arity n where - -- | Left fold over /n/ elements exposed as n-ary function. These - -- elements are supplied as arguments to the function. - accum :: (forall k. t (S k) -> a -> t k) -- ^ Fold function - -> (t Z -> b) -- ^ Extract result of fold - -> t n -- ^ Initial value - -> Fn n a b -- ^ Reduction function - - -- | Apply all parameters to the function. - applyFun :: (forall k. t (S k) -> (a, t k)) -- ^ Get value to apply to function - -> t n -- ^ Initial value - -> Fn n a b -- ^ N-ary function - -> (b, t Z) - - -- | Apply all parameters to the function using monadic - -- actions. Note that for identity monad it's same as - -- applyFun. Ignoring newtypes: - -- - -- > forall b. Fn n a b -> b ~ ContVecn n a - applyFunM :: Monad m - => (forall k. t (S k) -> m (a, t k)) -- ^ Get value to apply to function - -> t n -- ^ Initial value - -> m (ContVec n a, t Z) - -- | Arity of function. - arity :: n -> Int - - -- | Reverse order of parameters. - 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 - -- | Proof that `Fn (n+k) a b ~ Fn n a (Fn k a b)` - witSum :: WitSum n k a b - - -newtype T_gunfold c r a n = T_gunfold (c (Fn n a r)) - --- | Value that carry proof that `Fn (Add n k) a b ~ Fn n a (Fn k a b)` -data WitSum n k a b where - WitSum :: (Fn (Add n k) a b ~ Fn n a (Fn k a b)) => WitSum n k a b - - --- | Apply all parameters to the function. -apply :: Arity n - => (forall k. t (S k) -> (a, t k)) -- ^ Get value to apply to function - -> t n -- ^ Initial value - -> Fn n a b -- ^ N-ary function - -> b -{-# INLINE apply #-} -apply step z f = fst $ applyFun step z f - --- | Apply all parameters to the function using monadic actions. -applyM :: (Monad m, Arity n) - => (forall k. t (S k) -> m (a, t k)) -- ^ Get value to apply to function - -> t n -- ^ Initial value - -> m (ContVec n a) -{-# INLINE applyM #-} -applyM f t = do (v,_) <- applyFunM f t - return v - -instance Arity Z where - accum _ g t = g t - applyFun _ t h = (h,t) - applyFunM _ t = return (empty, t) - arity _ = 0 - {-# INLINE accum #-} - {-# INLINE applyFun #-} - {-# INLINE applyFunM #-} - {-# INLINE arity #-} - reverseF = id - gunfoldF _ (T_gunfold c) = c - {-# INLINE reverseF #-} - {-# INLINE gunfoldF #-} - witSum = WitSum - {-# INLINE witSum #-} - -instance Arity n => Arity (S n) where - accum f g t = \a -> accum f g (f t a) - applyFun f t h = case f t of (a,u) -> applyFun f u (h a) - applyFunM f t = do (a,t') <- f t - (vec,tZ) <- applyFunM f t' - return (cons a vec , tZ) - arity _ = 1 + arity (undefined :: n) - {-# INLINE accum #-} - {-# INLINE applyFun #-} - {-# INLINE applyFunM #-} - {-# INLINE arity #-} - reverseF f = Fun $ \a -> unFun (reverseF $ apLast f a) - gunfoldF f c = gunfoldF f (apGunfold f c) - {-# INLINE reverseF #-} - {-# INLINE gunfoldF #-} - witSum = witSumWorker - {-# INLINE witSum #-} - -witSumWorker :: forall n k a b. Arity n => WitSum (S n) k a b -{-# INLINE witSumWorker #-} -witSumWorker = case witSum :: WitSum n k a b of - WitSum -> WitSum - -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 #-} - - - ----------------------------------------------------------------- --- Combinators ----------------------------------------------------------------- - --- | Prepend ignored parameter to function -constFun :: Fun n a b -> Fun (S n) a b -constFun (Fun f) = Fun $ \_ -> f -{-# INLINE constFun #-} - --- | Curry first parameter of n-ary function -curryFirst :: Fun (S n) a b -> a -> Fun n a b -curryFirst (Fun f) x = Fun (f x) -{-# INLINE curryFirst #-} - --- | Uncurry first parameter of n-ary function -uncurryFirst :: (a -> Fun n a b) -> Fun (S n) a b -uncurryFirst f = Fun $ fmap unFun f -{-# INLINE uncurryFirst #-} - --- | Curry last parameter of n-ary function -curryLast :: forall n a b. Arity n => Fun (S n) a b -> Fun n a (a -> b) -{-# INLINE curryLast #-} -curryLast (Fun f0) = Fun $ accum (\(T_fun f) a -> T_fun (f a)) - (\(T_fun f) -> f) - (T_fun f0 :: T_fun a b n) - -newtype T_fun a b n = T_fun (Fn (S n) a b) - --- | Curry /n/ first parameters of n-ary function -curryMany :: forall n k a b. Arity n - => Fun (Add n k) a b -> Fun n a (Fun k a b) -{-# INLINE curryMany #-} -curryMany (Fun f0) = Fun $ accum - (\(T_curry f) a -> T_curry (f a)) - (\(T_curry f) -> Fun f :: Fun k a b) - ( T_curry f0 :: T_curry a b k n) - -newtype T_curry a b k n = T_curry (Fn (Add n k) a b) - --- | Uncurry /n/ first parameters of n-ary function -uncurryMany :: forall n k a b. Arity n - => Fun n a (Fun k a b) -> Fun (Add n k) a b -{-# INLINE uncurryMany #-} -uncurryMany f = - case witSum :: WitSum n k a b of - WitSum -> - case fmap unFun f :: Fun n a (Fn k a b) of - Fun g -> Fun g - - --- | Apply last parameter to function. Unlike 'apFun' we need to --- traverse all parameters but last hence 'Arity' constraint. -apLast :: Arity n => Fun (S n) a b -> a -> Fun n a b -apLast f x = fmap ($ x) $ curryLast f -{-# INLINE apLast #-} - --- | Recursive step for the function -withFun :: (Fun n a b -> Fun n a b) -> Fun (S n) a b -> Fun (S n) a b -withFun f fun = Fun $ \a -> unFun $ f $ curryFirst fun a -{-# INLINE withFun #-} - - --- | Move function parameter to the result of N-ary function. -shuffleFun :: forall n a b r. Arity n - => (b -> Fun n a r) -> Fun n a (b -> r) -{-# INLINE shuffleFun #-} -shuffleFun f0 - = Fun $ accum (\(T_shuffle f) a -> T_shuffle $ \x -> f x a) - (\(T_shuffle f) -> f) - (T_shuffle (fmap unFun f0) :: T_shuffle b a r n) - -newtype T_shuffle x a r n = T_shuffle (x -> Fn n a r) - - - ----------------------------------------------------------------- --- Type class for fixed vectors ----------------------------------------------------------------- - --- | Size of vector expressed as type-level natural. -type family Dim (v :: * -> *) - --- | 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: --- --- > inspect v construct = v -class Arity (Dim v) => Vector v a where - -- | N-ary function for creation of vectors. - construct :: Fun (Dim v) a (v a) - -- | Deconstruction of vector. - 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. Arity (Dim v) => v a -> Int -{-# INLINE length #-} -length _ = arity (undefined :: Dim v) - --- | Type class for indexing of vector when index value is known at --- compile time. -class Index k n where - getF :: k -> Fun n a a - putF :: k -> a -> Fun n a r -> Fun n a r - lensF :: Functor f => k -> (a -> f a) -> Fun n a r -> Fun n a (f r) - -instance Arity n => Index Z (S n) where - getF _ = Fun $ \(a :: a) -> unFun (pure a :: Fun n a a) - putF _ a (Fun f) = Fun $ \_ -> f a - lensF _ f fun = Fun $ \(a :: a) -> unFun $ - (\g -> g <$> f a) <$> shuffleFun (curryFirst fun) - {-# INLINE getF #-} - {-# INLINE putF #-} - {-# INLINE lensF #-} - -instance Index k n => Index (S k) (S n) where - getF _ = Fun $ \(_::a) -> unFun (getF (undefined :: k) :: Fun n a a) - putF _ a (f :: Fun (S n) a b) - = withFun (putF (undefined :: k) a) f - lensF _ f fun = Fun $ \a -> unFun (lensF (undefined :: k) f (curryFirst fun a)) - {-# INLINE getF #-} - {-# INLINE putF #-} - {-# INLINE lensF #-} - - ----------------------------------------------------------------- --- Cont. vectors and their instances ----------------------------------------------------------------- - --- | Vector represented as continuation. Alternative wording: it's --- Church encoded N-element vector. -newtype ContVec n a = ContVec (forall r. Fun n a r -> r) - -type instance Dim (ContVec n) = n - -instance Arity n => Vector (ContVec n) a where - construct = Fun $ - accum (\(T_mkN f) a -> T_mkN (f . cons a)) - (\(T_mkN f) -> f empty) - (T_mkN id :: T_mkN n a n) - inspect (ContVec c) f = c f - {-# INLINE construct #-} - {-# INLINE inspect #-} - -newtype T_mkN n_tot a n = T_mkN (ContVec n a -> ContVec n_tot a) - -instance Arity n => VectorN ContVec n a - - -instance (Arity n) => Functor (ContVec n) where - fmap = map - {-# INLINE fmap #-} - -instance (Arity n) => Applicative (ContVec n) where - pure = replicate - (<*>) = zipWith ($) - {-# INLINE pure #-} - {-# INLINE (<*>) #-} - -instance (Arity n) => F.Foldable (ContVec n) where - foldr = foldr - {-# INLINE foldr #-} - -instance (Arity n) => F.Traversable (ContVec n) where - sequenceA v = inspect v $ sequenceAF construct - {-# INLINE sequenceA #-} - -sequenceAF :: forall f n a b. (Applicative f, Arity n) - => Fun n a b -> Fun n (f a) (f b) -{-# INLINE sequenceAF #-} -sequenceAF (Fun f0) - = Fun $ accum (\(T_sequenceA f) a -> T_sequenceA (f <*> a)) - (\(T_sequenceA f) -> f) - (T_sequenceA (pure f0) :: T_sequenceA f a b n) - -newtype T_sequenceA f a b n = T_sequenceA (f (Fn n a b)) - - - ----------------------------------------------------------------- --- Construction ----------------------------------------------------------------- - --- | Convert regular vector to continuation based one. -cvec :: (Vector v a, Dim v ~ n) => v a -> ContVec n a -cvec v = ContVec (inspect v) -{-# INLINE[0] cvec #-} - --- | Create empty vector. -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 :: forall n a. Arity n => [a] -> ContVec n a -{-# INLINE fromList #-} -fromList xs = ContVec $ \(Fun fun) -> - apply step - (T_flist xs :: T_flist a n) - fun - where - step (T_flist [] ) = error "Data.Vector.Fixed.Cont.fromList: too few elements" - step (T_flist (a:as)) = (a, T_flist as) - --- | Same as 'fromList' bu throws error is list doesn't have same --- length as vector. -fromList' :: forall n a. Arity n => [a] -> ContVec n a -{-# INLINE fromList' #-} -fromList' xs = ContVec $ \(Fun fun) -> - let (r,rest) = applyFun step (T_flist xs :: T_flist a n) fun - step (T_flist [] ) = error "Data.Vector.Fixed.Cont.fromList': too few elements" - step (T_flist (a:as)) = (a, T_flist as) - in case rest of - T_flist [] -> r - _ -> error "Data.Vector.Fixed.Cont.fromList': too many elements" - --- | Convert list to continuation-based vector. Will fail with --- 'Nothing' if list doesn't have right length. -fromListM :: forall n a. Arity n => [a] -> Maybe (ContVec n a) -{-# INLINE fromListM #-} -fromListM xs = do - (v,rest) <- applyFunM step (T_flist xs :: T_flist a n) - case rest of - T_flist [] -> return v - _ -> Nothing - where - step (T_flist [] ) = Nothing - step (T_flist (a:as)) = return (a, T_flist as) - -data T_flist a n = T_flist [a] - - --- | Convert vector to the list -toList :: (Arity n) => ContVec n a -> [a] -toList = foldr (:) [] -{-# INLINE toList #-} - - --- | Execute monadic action for every element of vector. Synonym for 'pure'. -replicate :: forall n a. (Arity n) - => a -> ContVec n a -{-# INLINE replicate #-} -replicate a = ContVec $ \(Fun fun) -> - apply (\T_replicate -> (a, T_replicate)) - (T_replicate :: T_replicate n) - fun - --- | Execute monadic action for every element of vector. -replicateM :: forall m n a. (Arity n, Monad m) - => m a -> m (ContVec n a) -{-# INLINE replicateM #-} -replicateM act = - applyM (\T_replicate -> do { a <- act; return (a, T_replicate) } ) - (T_replicate :: T_replicate n) - - -data T_replicate n = T_replicate - - --- | Generate vector from function which maps element's index to its value. -generate :: forall n a. (Arity n) => (Int -> a) -> ContVec n a -{-# INLINE generate #-} -generate f = ContVec $ \(Fun fun) -> - apply (\(T_generate n) -> (f n, T_generate (n + 1))) - (T_generate 0 :: T_generate n) - fun - --- | Generate vector from monadic function which maps element's index --- to its value. -generateM :: forall m n a. (Monad m, Arity n) - => (Int -> m a) -> m (ContVec n a) -{-# INLINE generateM #-} -generateM f = - applyM (\(T_generate n) -> do { a <- f n; return (a, T_generate (n + 1)) } ) - (T_generate 0 :: T_generate n) - - -newtype T_generate n = T_generate Int - --- | Unfold vector. -unfoldr :: forall n b a. Arity n => (b -> (a,b)) -> b -> ContVec n a -{-# INLINE unfoldr #-} -unfoldr f b0 = ContVec $ \(Fun fun) -> - apply (\(T_unfoldr b) -> let (a,b') = f b in (a, T_unfoldr b')) - (T_unfoldr b0 :: T_unfoldr b n) - fun - -newtype T_unfoldr b n = T_unfoldr b - - --- | Unit vector along Nth axis. -basis :: forall n a. (Num a, Arity n) => Int -> ContVec n a -{-# INLINE basis #-} -basis n0 = ContVec $ \(Fun fun) -> - apply (\(T_basis n) -> ((if n == 0 then 1 else 0) :: a, T_basis (n - 1))) - (T_basis n0 :: T_basis n) - fun - -newtype T_basis n = T_basis Int - - -mk1 :: a -> ContVec N1 a -mk1 a1 = ContVec $ \(Fun f) -> f a1 -{-# INLINE mk1 #-} - -mk2 :: a -> a -> ContVec N2 a -mk2 a1 a2 = ContVec $ \(Fun f) -> f a1 a2 -{-# INLINE mk2 #-} - -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 N4 a -mk4 a1 a2 a3 a4 = ContVec $ \(Fun f) -> f a1 a2 a3 a4 -{-# INLINE mk4 #-} - -mk5 :: a -> a -> a -> a -> a -> ContVec N5 a -mk5 a1 a2 a3 a4 a5 = ContVec $ \(Fun f) -> f a1 a2 a3 a4 a5 -{-# INLINE mk5 #-} - - - ----------------------------------------------------------------- --- Transforming vectors ----------------------------------------------------------------- - --- | Map over vector. Synonym for 'fmap' -map :: (Arity n) => (a -> b) -> ContVec n a -> ContVec n b -{-# INLINE map #-} -map = imap . const - --- | Apply function to every element of the vector and its index. -imap :: (Arity n) => (Int -> a -> b) -> ContVec n a -> ContVec n b -{-# INLINE imap #-} -imap f (ContVec contA) = ContVec $ - contA . imapF f - --- | Monadic map over vector. -mapM :: (Arity n, Monad m) => (a -> m b) -> ContVec n a -> m (ContVec n b) -{-# INLINE mapM #-} -mapM = imapM . const - --- {- --- | Apply monadic function to every element of the vector and its index. -imapM :: (Arity n, Monad m) => (Int -> a -> m b) -> ContVec n a -> m (ContVec n b) -{-# INLINE imapM #-} -imapM f v - = inspect v - $ imapMF f construct - --- | Apply monadic action to each element of vector and ignore result. -mapM_ :: (Arity n, Monad m) => (a -> m b) -> ContVec n a -> m () -{-# INLINE mapM_ #-} -mapM_ f = foldl (\m a -> m >> f a >> return ()) (return ()) - --- | Apply monadic action to each element of vector and its index and --- ignore result. -imapM_ :: (Arity n, Monad m) => (Int -> a -> m b) -> ContVec n a -> m () -{-# INLINE imapM_ #-} -imapM_ f = ifoldl (\m i a -> m >> f i a >> return ()) (return ()) - - -imapMF :: forall m n a b r. (Arity n, Monad m) - => (Int -> a -> m b) -> Fun n b r -> Fun n a (m r) -{-# INLINE imapMF #-} -imapMF f (Fun funB) = Fun $ - accum (\(T_mapM i m) a -> T_mapM (i+1) $ do b <- f i a - fun <- m - return $ fun b - ) - (\(T_mapM _ m) -> m) - (T_mapM 0 (return funB) :: T_mapM b m r n) - -data T_mapM a m r n = T_mapM Int (m (Fn n a r)) - -imapF :: forall n a b r. Arity n - => (Int -> a -> b) -> Fun n b r -> Fun n a r -{-# INLINE imapF #-} -imapF f (Fun funB) = Fun $ - accum (\(T_map i g) b -> T_map (i+1) (g (f i b))) - (\(T_map _ r) -> r) - ( T_map 0 funB :: T_map b r n) - -data T_map a r n = T_map Int (Fn n a r) - --- | Left scan over vector -scanl :: (Arity n) => (b -> a -> b) -> b -> ContVec n a -> ContVec (S n) b -{-# 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 -{-# INLINE scanl1 #-} -scanl1 f (ContVec cont) = ContVec $ - cont . scanl1F f - -scanlF :: forall n a b r. (Arity n) => (b -> a -> b) -> b -> Fun (S n) b r -> Fun n a r -scanlF f b0 (Fun fun0) = Fun - $ accum step fini start - where - step :: forall k. T_scanl r b (S k) -> a -> T_scanl r b k - step (T_scanl b fn) a = let b' = f b a in T_scanl b' (fn b') - fini (T_scanl _ r) = r - start = T_scanl b0 (fun0 b0) :: T_scanl r b n - -scanl1F :: forall n a r. (Arity n) => (a -> a -> a) -> Fun n a r -> Fun n a r -scanl1F f (Fun fun0) = Fun $ accum step fini start - where - step :: forall k. T_scanl1 r a (S k) -> a -> T_scanl1 r a k - step (T_scanl1 Nothing fn) a = T_scanl1 (Just a) (fn a) - step (T_scanl1 (Just x) fn) a = let a' = f x a in T_scanl1 (Just a') (fn a') - fini (T_scanl1 _ r) = r - start = T_scanl1 Nothing fun0 :: T_scanl1 r a n - -data T_scanl r a n = T_scanl a (Fn n a r) -data T_scanl1 r a n = T_scanl1 (Maybe a) (Fn n a r) - - --- | Evaluate every action in the vector from left to right. -sequence :: (Arity n, Monad m) => ContVec n (m a) -> m (ContVec n a) -sequence = mapM id -{-# INLINE sequence #-} - --- | Evaluate every action in the vector from left to right and ignore result. -sequence_ :: (Arity n, Monad m) => ContVec n (m a) -> m () -sequence_ = mapM_ id -{-# INLINE sequence_ #-} - --- | The dual of sequenceA -distribute :: forall f n a. (Functor f, Arity n) - => f (ContVec n a) -> ContVec n (f a) -{-# INLINE distribute #-} -distribute f0 - = ContVec $ \(Fun fun) -> apply step start fun - where - -- It's not possible to use ContVec as accumulator type since `head' - -- require Arity constraint on `k'. So we use plain lists - step :: forall k. T_distribute a f (S k) -> (f a, T_distribute a f k) - step (T_distribute f) = ( fmap (\(x:_) -> x) f - , T_distribute $ fmap (\(_:x) -> x) f) - start :: T_distribute a f n - start = T_distribute (fmap toList f0) - -collect :: (Functor f, Arity n) => (a -> ContVec n b) -> f a -> ContVec n (f b) -collect f = distribute . fmap f -{-# INLINE collect #-} - --- | The dual of sequence -distributeM :: forall m n a. (Monad m, Arity n) - => m (ContVec n a) -> ContVec n (m a) -{-# INLINE distributeM #-} -distributeM f0 - = ContVec $ \(Fun fun) -> apply step start fun - where - step :: forall k. T_distribute a m (S k) -> (m a, T_distribute a m k) - step (T_distribute f) = ( liftM (\(x:_) -> x) f - , T_distribute $ liftM (\(_:x) -> x) f) - start :: T_distribute a m n - start = T_distribute (liftM toList f0) - -collectM :: (Monad m, Arity n) => (a -> ContVec n b) -> m a -> ContVec n (m b) -collectM f = distributeM . liftM f -{-# INLINE collectM #-} - -newtype T_distribute a f n = T_distribute (f [a]) - - --- | /O(1)/ Tail of vector. -tail :: ContVec (S n) a -> ContVec n a -tail (ContVec cont) = ContVec $ \f -> cont $ constFun f -{-# INLINE tail #-} - --- | /O(1)/ Prepend element to vector -cons :: a -> ContVec n a -> ContVec (S n) a -cons a (ContVec cont) = ContVec $ \f -> cont $ curryFirst f a -{-# INLINE cons #-} - --- | Prepend single element vector to another vector. -consV :: forall n a. ContVec (S Z) 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 (S n) a -snoc a (ContVec cont) = ContVec $ \f -> cont $ apLast f a -{-# INLINE snoc #-} - --- | Concatenate vector -concat :: (Arity n, Arity k, Arity (Add n k)) - => ContVec n a -> ContVec k a -> ContVec (Add n k) a -{-# 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 (ContVec cont) = ContVec $ cont . reverseF -{-# INLINE reverse #-} - --- | Zip two vector together using function. -zipWith :: (Arity n) => (a -> b -> c) - -> ContVec n a -> ContVec n b -> ContVec n c -{-# INLINE zipWith #-} -zipWith = izipWith . const - --- | Zip three vectors together -zipWith3 :: (Arity 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) - --- | Zip two vector together using function which takes element index --- as well. -izipWith :: (Arity n) => (Int -> a -> b -> c) - -> ContVec n a -> ContVec n b -> ContVec n c -{-# INLINE izipWith #-} -izipWith f vecA vecB = ContVec $ \funC -> - inspect vecB - $ inspect vecA - $ izipWithF f funC - --- | Zip three vectors together -izipWith3 :: (Arity 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, Monad m) => (a -> b -> m c) - -> ContVec n a -> ContVec n b -> m (ContVec n c) -{-# INLINE zipWithM #-} -zipWithM f v w = sequence $ zipWith f v w - -zipWithM_ :: (Arity n, Monad m) - => (a -> b -> m c) -> ContVec n a -> ContVec n b -> m () -{-# INLINE zipWithM_ #-} -zipWithM_ f xs ys = sequence_ (zipWith f xs ys) - --- | Zip two vector together using monadic function which takes element --- index as well.. -izipWithM :: (Arity n, Monad m) => (Int -> a -> b -> m c) - -> ContVec n a -> ContVec n b -> m (ContVec n c) -{-# INLINE izipWithM #-} -izipWithM f v w = sequence $ izipWith f v w - -izipWithM_ :: (Arity n, Monad m) - => (Int -> a -> b -> m c) -> ContVec n a -> ContVec n b -> m () -{-# INLINE izipWithM_ #-} -izipWithM_ f xs ys = sequence_ (izipWith f xs ys) - -izipWithF :: forall n a b c r. (Arity n) - => (Int -> a -> b -> c) -> Fun n c r -> Fun n a (Fun n b r) -{-# INLINE izipWithF #-} -izipWithF f (Fun g0) = - fmap (\v -> Fun $ 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 :: (T_izip a c r n)) - ) makeList - - -makeList :: forall n a. Arity n => Fun n a [a] -{-# INLINE makeList #-} -makeList = Fun $ accum - (\(T_mkList xs) x -> T_mkList (xs . (x:))) - (\(T_mkList xs) -> xs []) - (T_mkList id :: T_mkList a n) - -newtype T_mkList a n = T_mkList ([a] -> [a]) - -data T_izip a c r n = T_izip Int [a] (Fn n c r) - - - ----------------------------------------------------------------- --- Running vector ----------------------------------------------------------------- - --- | Run continuation vector. It's same as 'inspect' but with --- arguments flipped. -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 = runContVec construct -{-# INLINE[1] vector #-} - --- | Finalizer function for getting head of the vector. -head :: forall n a. Arity (S n) => ContVec (S n) a -> a --- NOTE: we need constraint `Arity (S n)' instead of `Arity n' because --- `Vector v' entails `Arity (Dim v)' and GHC cannot figure out --- that `Arity (S n)' ⇒ `Arity n' -{-# INLINE head #-} -head - = runContVec $ Fun - $ accum (\(T_head m) a -> T_head $ case m of { Nothing -> Just a; x -> x }) - (\(T_head (Just x)) -> x) - (T_head Nothing :: T_head a (S n)) - -data T_head a n = T_head (Maybe a) - - --- | /O(n)/ Get value at specified index. -index :: forall n a. Arity n => Int -> ContVec n a -> a -{-# INLINE index #-} -index n - | n < 0 = error "Data.Vector.Fixed.Cont.index: index out of range" - | otherwise = runContVec $ Fun $ accum - (\(T_Index x) a -> T_Index $ case x of - Left 0 -> Right a - Left i -> Left (i - 1) - r -> r - ) - (\(T_Index x) -> case x of - Left _ -> error "Data.Vector.Fixed.index: index out of range" - Right a -> a - ) - ( T_Index (Left n) :: T_Index a n) - -newtype T_Index a n = T_Index (Either Int a) - - --- | Twan van Laarhoven lens for continuation based vector -element :: (Arity n, Functor f) - => Int -> (a -> f a) -> ContVec n a -> f (ContVec n a) -{-# INLINE element #-} -element i f v = inspect v - $ elementF i f construct - --- | Twan van Laarhoven's lens for element of vector with statically --- known index. -elementTy :: (Arity n, Index k n, Functor f) - => k -> (a -> f a) -> ContVec n a -> f (ContVec n a) -{-# INLINE elementTy #-} -elementTy k f v = inspect v - $ lensF k f construct - - --- | Helper for implementation of Twan van Laarhoven lens. -elementF :: forall a n f r. (Arity n, Functor f) - => Int -> (a -> f a) -> Fun n a r -> Fun n a (f r) -{-# INLINE elementF #-} -elementF n f (Fun fun0) = Fun $ accum step fini start - where - step :: forall k. T_lens f a r (S k) -> a -> T_lens f a r k - step (T_lens (Left (0,fun))) a = T_lens $ Right $ fmap fun $ f a - step (T_lens (Left (i,fun))) a = T_lens $ Left (i-1, fun a) - step (T_lens (Right fun)) a = T_lens $ Right $ fmap ($ a) fun - -- - fini :: T_lens f a r Z -> f r - fini (T_lens (Left _)) = error "Data.Vector.Fixed.lensF: Index out of range" - fini (T_lens (Right r)) = r - -- - start :: T_lens f a r n - start = T_lens $ Left (n,fun0) - -data T_lens f a r n = T_lens (Either (Int,(Fn n a r)) (f (Fn n a r))) - - - --- | Left fold over continuation vector. -foldl :: Arity n => (b -> a -> b) -> b -> ContVec n a -> b -{-# INLINE foldl #-} -foldl f = ifoldl (\b _ a -> f b a) - --- | Left fold over continuation vector. -ifoldl :: forall n a b. Arity n - => (b -> Int -> a -> b) -> b -> ContVec n a -> b -{-# INLINE ifoldl #-} -ifoldl f b v - = inspect v $ Fun - $ accum (\(T_ifoldl i r) a -> T_ifoldl (i+1) (f r i a)) - (\(T_ifoldl _ r) -> r) - (T_ifoldl 0 b :: T_ifoldl b n) - --- | Monadic left fold over continuation vector. -foldM :: (Arity 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) - => (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. - -newtype T_foldl1 a n = T_foldl1 (Maybe a) - --- | Left fold. -foldl1 :: forall n a. (Arity (S n)) - => (a -> a -> a) -> ContVec (S n) a -> a -{-# INLINE foldl1 #-} -foldl1 f - = runContVec $ Fun - $ accum (\(T_foldl1 r ) a -> T_foldl1 $ Just $ maybe a (flip f a) r) - (\(T_foldl1 (Just x)) -> x) - (T_foldl1 Nothing :: T_foldl1 a (S n)) - --- | Right fold over continuation vector -foldr :: Arity n => (a -> b -> b) -> b -> ContVec n a -> b -{-# INLINE foldr #-} -foldr = ifoldr . const - --- | Right fold over continuation vector -ifoldr :: forall n a b. Arity n - => (Int -> a -> b -> b) -> b -> ContVec n a -> b -{-# INLINE ifoldr #-} -ifoldr f z - = runContVec $ Fun - $ accum (\(T_ifoldr i g) a -> T_ifoldr (i+1) (g . f i a)) - (\(T_ifoldr _ g) -> g z) - (T_ifoldr 0 id :: T_ifoldr b n) - - -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 -{-# INLINE sum #-} - --- | Minimal element of vector. -minimum :: (Ord a, Arity (S n)) => ContVec (S n) a -> a -minimum = foldl1 min -{-# INLINE minimum #-} - --- | Maximal element of vector. -maximum :: (Ord a, Arity (S n)) => ContVec (S n) a -> a -maximum = foldl1 max -{-# INLINE maximum #-} - --- | Conjunction of elements of a vector. -and :: Arity 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 = foldr (||) False -{-# INLINE or #-} - --- | Determines whether all elements of vector satisfy predicate. -all :: Arity 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 f = foldr (\x b -> f x && b) True -{-# 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 f = foldl (\r x -> r <|> if f x then Just x else Nothing) Nothing -{-# INLINE find #-} - --- | Generic 'Data.Data.gfoldl' which could work with any vector. -gfoldl :: forall c v a. (Vector v a, Data a) - => (forall x y. Data x => c (x -> y) -> x -> c y) - -> (forall x . x -> c x) - -> v a -> c (v a) -gfoldl f inj v - = inspect v - $ 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 --- constructor is ignored. -gunfold :: forall con c v a. (Vector v a, Data a) - => (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 - where - con = construct :: Fun (Dim v) a (v a) - gun = T_gunfold (inj $ unFun con) :: T_gunfold c (v a) a (Dim v) - - -gfoldlF :: forall c r a n. (Arity n, Data a) - => (forall x y. Data x => c (x -> y) -> x -> c y) - -> c (Fn n a r) -> Fun n a (c r) -gfoldlF f c0 = Fun $ accum - (\(T_gfoldl c) x -> T_gfoldl (f c x)) - (\(T_gfoldl c) -> c) - (T_gfoldl c0 :: T_gfoldl c r a n) - -newtype T_gfoldl c r a n = T_gfoldl (c (Fn n a r)) - - - ----------------------------------------------------------------- --- Deforestation ----------------------------------------------------------------- - --- Deforestation uses following assertion: if we convert continuation --- to vector and immediately back to the continuation we can eliminate --- intermediate vector. This optimization can however turn --- nonterminating programs into terminating. --- --- > runContVec head $ cvec $ vector $ mk2 () ⊥ --- --- If intermediate vector is strict in its elements expression above --- evaluates to ⊥ too. But if we apply rewrite rule resuling expression: --- --- > runContVec head $ mk2 () ⊥ --- --- will evaluate to () since ContVec is not strict in its elements. --- It has been considered acceptable. --- --- --- In order to get rule fire reliably (it still doesn't). `vector' in --- inlined starting from phase 1. `cvec' is inlined even later (only --- during phase 0) because it need to participate in rewriting of --- indexing functions. - - -{-# RULES -"cvec/vector" forall v. - cvec (vector v) = v - #-} - - ----------------------------------------------------------------- --- Instances ----------------------------------------------------------------- - -type instance Dim Complex = N2 - -instance RealFloat a => Vector Complex a where - construct = Fun (:+) - inspect (x :+ y) (Fun f) = f x y - {-# INLINE construct #-} - {-# INLINE inspect #-} - - -type instance Dim ((,) a) = N2 - --- | Note this instance (and other instances for tuples) is --- essentially monomorphic in element type. Vector type /v/ of 2 --- element tuple @(Int,Int)@ is @(,) Int@ so it will only work --- with elements of type @Int@. -instance (b~a) => Vector ((,) b) a where - construct = Fun (,) - inspect (a,b) (Fun f) = f a b - {-# INLINE construct #-} - {-# INLINE inspect #-} - - -type instance Dim ((,,) a b) = N3 - -instance (b~a, c~a) => Vector ((,,) b c) a where - construct = Fun (,,) - inspect (a,b,c) (Fun f) = f a b c - {-# INLINE construct #-} - {-# INLINE inspect #-} - - -type instance Dim ((,,,) a b c) = N4 - -instance (b~a, c~a, d~a) => Vector ((,,,) b c d) a where - construct = Fun (,,,) - inspect (a,b,c,d) (Fun f) = f a b c d - {-# INLINE construct #-} - {-# INLINE inspect #-} - - -type instance Dim ((,,,,) a b c d) = N5 - -instance (b~a, c~a, d~a, e~a) => Vector ((,,,,) b c d e) a where - construct = Fun (,,,,) - inspect (a,b,c,d,e) (Fun f) = f a b c d e - {-# INLINE construct #-} - {-# INLINE inspect #-} - - -type instance Dim ((,,,,,) a b c d e) = N6 - -instance (b~a, c~a, d~a, e~a, f~a) => Vector ((,,,,,) b c d e f) a where - construct = Fun (,,,,,) - inspect (a,b,c,d,e,f) (Fun fun) = fun a b c d e f - {-# INLINE construct #-} - {-# INLINE inspect #-} - - -type instance Dim ((,,,,,,) a b c d e f) = S N6 - -instance (b~a, c~a, d~a, e~a, f~a, g~a) => Vector ((,,,,,,) b c d e f g) a where - construct = Fun (,,,,,,) - inspect (a,b,c,d,e,f,g) (Fun fun) = fun a b c d e f g - {-# INLINE construct #-} - {-# INLINE inspect #-} - -#if __GLASGOW_HASKELL__ >= 708 -type instance Dim Proxy = Z - -instance Vector Proxy a where - construct = Fun Proxy - inspect _ = unFun -#endif +{-# 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 +-- to provide shortcut fusion. +module Data.Vector.Fixed.Cont ( + -- * Type-level numbers + PeanoNum(..) + , N1,N2,N3,N4,N5,N6,N7,N8 + , Peano + , Add + -- * N-ary functions + , Fn + , Fun(..) + , Arity + , ArityPeano(..) + , apply + , applyM + , Index(..) + -- ** Combinators + , constFun + , curryFirst + , uncurryFirst + , curryLast + , curryMany + , apLast + , shuffleFun + , withFun + , dimapFun + -- * Vector type Boxedclass + , Dim + , Vector(..) + , length + -- * Vector as continuation + , ContVec(..) + , consPeano + , runContVec + -- * Construction of ContVec + , cvec + , fromList + , fromList' + , fromListM + , toList + , replicate + , replicateM + , generate + , generateM + , unfoldr + , basis + -- ** Constructors + , empty + , cons + , consV + , snoc + , concat + , mk1 + , mk2 + , mk3 + , mk4 + , mk5 + , mk6 + , mk7 + , mk8 + -- * Transformations + , map + , imap + , mapM + , imapM + , mapM_ + , imapM_ + , scanl + , scanl1 + , sequence + , sequence_ + , distribute + , collect + , tail + , reverse + -- ** Zips + , zipWith + , zipWith3 + , izipWith + , izipWith3 + , zipWithM + , zipWithM_ + , izipWithM + , izipWithM_ + -- ** Getters + , head + , index + , element + -- ** Vector construction + , vector + -- ** Folds + , foldl + , foldl' + , foldl1 + , foldl1' + , foldr + , ifoldl + , ifoldl' + , ifoldr + , foldM + , ifoldM + -- *** Special folds + , sum + , minimum + , maximum + , and + , or + , all + , any + , find + -- ** Data.Data.Data + , gfoldl + , gunfold + ) where + +import Control.Applicative ((<|>), Const(..)) +import Data.Coerce +import Data.Complex (Complex(..)) +import Data.Data (Data) +import Data.Kind (Type) +import Data.Functor.Identity (Identity(..)) +import Data.Typeable (Proxy(..)) +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 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 +---------------------------------------------------------------- + +-- | Peano numbers. Since type level naturals don't support induction +-- we have to convert type nats to Peano representation first and +-- work with it, +data PeanoNum = Z + | S PeanoNum + +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 + Peano n = 'S (Peano (n - 1)) + +-- | Type family for sum of unary natural numbers. +type family Add (n :: PeanoNum) (m :: PeanoNum) :: PeanoNum where + Add 'Z n = n + Add ('S n) k = 'S (Add n k) + + +---------------------------------------------------------------- +-- N-ary functions +---------------------------------------------------------------- + +-- | Type family for n-ary functions. @n@ is number of parameters of +-- type @a@ and @b@ is result type. +type family Fn (n :: PeanoNum) (a :: Type) (b :: Type) where + Fn 'Z a b = b + Fn ('S n) a b = a -> Fn n a b + +-- | Newtype wrapper which is used to make 'Fn' injective. It's 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 } + + +instance ArityPeano n => Functor (Fun n a) where + fmap f fun + = accum (\(T_Flip g) a -> T_Flip (curryFirst g a)) + (\(T_Flip x) -> f (unFun x)) + (T_Flip fun) + {-# INLINE fmap #-} + +instance ArityPeano n => Applicative (Fun n a) where + pure x = accum (\Proxy _ -> Proxy) + (\Proxy -> x) + Proxy + (Fun f0 :: Fun n a (p -> q)) <*> (Fun g0 :: Fun n a p) + = accum (\(T_ap f g) a -> T_ap (f a) (g a)) + (\(T_ap f g) -> f g) + (T_ap f0 g0 :: T_ap a (p -> q) p n) + {-# 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) + + + +---------------------------------------------------------------- +-- Generic operations of N-ary functions +---------------------------------------------------------------- + +-- | Synonym for writing constrains using type level naturals. +type Arity n = ArityPeano (Peano n) + +-- | 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. + accum :: (forall k. t ('S k) -> a -> t k) -- ^ Fold function + -> (t 'Z -> b) -- ^ Extract result of fold + -> t n -- ^ Initial value + -> Fun n a b -- ^ Reduction function + + -- | 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 + -> (ContVec n a, t 'Z) + + -- | Apply all parameters to the function using monadic + -- actions. Note that for identity monad it's same as + -- applyFun. Ignoring newtypes: + -- + -- > forall b. Fn n a b -> b ~ ContVec n a + applyFunM :: Applicative f + => (forall k. t ('S k) -> (f a, t k)) -- ^ Get value to apply to function + -> t n -- ^ Initial value + -> (f (ContVec n a), t 'Z) + + + -- | 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 + + -- | 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 :: ArityPeano n + => (forall k. t ('S k) -> (a, t k)) -- ^ Get value to apply to function + -> t n -- ^ Initial value + -> ContVec n a -- ^ N-ary function +{-# INLINE apply #-} +apply step z = fst (applyFun step z) + +-- | Apply all parameters to the function using applicative actions. +applyM :: (Applicative f, ArityPeano n) + => (forall k. t ('S k) -> (f a, t k)) -- ^ Get value to apply to function + -> t n -- ^ Initial value + -> f (ContVec n a) +{-# INLINE applyM #-} +applyM f t = fst $ applyFunM f t + + +-- | 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 + 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) + 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 #-} + + +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 #-} + +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 #-} + + + +---------------------------------------------------------------- +-- Combinators +---------------------------------------------------------------- + +-- | Prepend ignored parameter to function +constFun :: Fun n a b -> Fun ('S n) a b +constFun (Fun f) = Fun $ \_ -> f +{-# INLINE constFun #-} + +-- | Curry first parameter of n-ary function +curryFirst :: Fun ('S n) a b -> a -> Fun n a b +curryFirst = coerce +{-# INLINE curryFirst #-} + +-- | Uncurry first parameter of n-ary function +uncurryFirst :: (a -> Fun n a b) -> Fun ('S n) a b +uncurryFirst = coerce +{-# INLINE uncurryFirst #-} + +-- | Curry last parameter of n-ary function +curryLast :: ArityPeano n => Fun ('S n) a b -> Fun n a (a -> b) +{-# INLINE curryLast #-} +-- NOTE: This function is essentially rearrangement of newtypes. Since +-- Fn is closed type family it couldn't be extended and it's +-- quite straightforward to show that both types have same +-- representation. Unfortunately GHC cannot infer it so we have +-- to unsafe-coerce it. +curryLast = unsafeCoerce + + +-- | Curry /n/ first parameters of n-ary function +curryMany :: forall n k a b. ArityPeano n + => Fun (Add n k) a b -> Fun n a (Fun k a b) +{-# INLINE curryMany #-} +-- NOTE: It's same as curryLast +curryMany = unsafeCoerce + + +-- | Apply last parameter to function. Unlike 'apFun' we need to +-- traverse all parameters but last hence 'Arity' constraint. +apLast :: ArityPeano n => Fun ('S n) a b -> a -> Fun n a b +apLast f x = fmap ($ x) $ curryLast f +{-# INLINE apLast #-} + +-- | Recursive step for the function +withFun :: (Fun n a b -> Fun n a c) -> Fun ('S n) a b -> Fun ('S n) a c +withFun f fun = Fun $ \a -> unFun $ f $ curryFirst fun a +{-# INLINE withFun #-} + +-- | Move function parameter to the result of N-ary function. +shuffleFun :: ArityPeano n + => (b -> Fun n a r) -> Fun n a (b -> r) +{-# INLINE shuffleFun #-} +shuffleFun f0 + = accum (\(T_shuffle f) a -> T_shuffle $ \x -> f x a) + (\(T_shuffle f) -> f) + (T_shuffle (fmap unFun f0)) + +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 Peano natural. +type family Dim (v :: k) :: PeanoNum + +-- | Type class for vectors with fixed length. Instance should provide +-- two functions: one to create vector from @N@ elements and another +-- for vector deconstruction. They must obey following law: +-- +-- > inspect v construct = v +-- +-- For example instance for 2D vectors could be written as: +-- +-- > data V2 a = V2 a a +-- > +-- > type instance V2 = 2 +-- > instance Vector V2 a where +-- > construct = Fun V2 +-- > inspect (V2 a b) (Fun f) = f a b +class 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 #-} + +-- | Length of vector. Function doesn't evaluate its argument. +length :: forall v a. ArityPeano (Dim v) => v a -> Int +{-# INLINE length #-} +length _ = peanoToInt (proxy# @(Dim v)) + + +---------------------------------------------------------------- +-- Cont. vectors and their instances +---------------------------------------------------------------- + +-- | Vector represented as continuation. Alternative wording: it's +-- Church encoded N-element vector. +newtype ContVec n a = ContVec (forall r. Fun n a r -> r) + +type instance Dim (ContVec n) = n +type instance Dim (ContVec n a) = n + +-- | 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 #-} + +instance ArityPeano n => Vector (ContVec n) a where + construct = accum + (\(T_mkN f) a -> T_mkN (f . consPeano a)) + (\(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 (ContVec n a -> ContVec n_tot a) + + + +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 (ArityPeano n) => Applicative (ContVec n) where + pure = replicate + (<*>) = zipWith ($) + {-# INLINE pure #-} + {-# INLINE (<*>) #-} + +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 (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 #-} + +instance (ArityPeano n) => T.Traversable (ContVec n) where + sequence = sequence + sequenceA = sequence + traverse = mapM + mapM = mapM + {-# INLINE sequence #-} + {-# INLINE sequenceA #-} + {-# INLINE mapM #-} + {-# INLINE traverse #-} + + + +---------------------------------------------------------------- +-- Construction +---------------------------------------------------------------- + +-- | Convert regular vector to continuation based one. +cvec :: (Vector v a) => v a -> ContVec (Dim v) a +cvec v = ContVec (inspect v) +{-# INLINE[0] cvec #-} + +-- | Create empty vector. +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 :: ArityPeano n => [a] -> ContVec n a +{-# INLINE fromList #-} +fromList xs = + apply step (Const xs) + where + step (Const [] ) = error "Data.Vector.Fixed.Cont.fromList: too few elements" + step (Const (a:as)) = (a, Const as) + +-- | Same as 'fromList' bu throws error is list doesn't have same +-- length as vector. +fromList' :: forall n a. 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] 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. ArityPeano n => [a] -> Maybe (ContVec n a) +{-# INLINE fromListM #-} +fromListM xs = case applyFunM step (Const xs :: Const [a] n) of + (Just v, Const []) -> Just v + _ -> Nothing + where + step (Const [] ) = (Nothing, Const []) + step (Const (a:as)) = (Just a , Const as) + + +-- | Convert vector to the list +toList :: (ArityPeano n) => ContVec n a -> [a] +toList = foldr (:) [] +{-# INLINE toList #-} + + +-- | Execute monadic action for every element of vector. Synonym for 'pure'. +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 :: (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 :: (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, 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 :: 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, ArityPeano n) => Int -> ContVec n a +{-# INLINE basis #-} +basis n0 = + apply (\(Const n) -> (if n == 0 then 1 else 0, Const (n - 1))) + (Const n0) + + + +mk1 :: a -> ContVec N1 a +mk1 a1 = ContVec $ \(Fun f) -> f a1 +{-# INLINE mk1 #-} + +mk2 :: a -> a -> ContVec N2 a +mk2 a1 a2 = ContVec $ \(Fun f) -> f a1 a2 +{-# INLINE mk2 #-} + +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 N4 a +mk4 a1 a2 a3 a4 = ContVec $ \(Fun f) -> f a1 a2 a3 a4 +{-# INLINE mk4 #-} + +mk5 :: a -> a -> a -> a -> a -> ContVec N5 a +mk5 a1 a2 a3 a4 a5 = ContVec $ \(Fun f) -> f a1 a2 a3 a4 a5 +{-# INLINE mk5 #-} + +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 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 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 #-} + + +---------------------------------------------------------------- +-- Transforming vectors +---------------------------------------------------------------- + +-- | Map over vector. Synonym for 'fmap' +map :: (ArityPeano n) => (a -> b) -> ContVec n a -> ContVec n b +{-# INLINE map #-} +map f (ContVec contA) = ContVec $ + contA . mapF f + +-- | Apply function to every element of the vector and its index. +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 :: (ArityPeano n, Applicative f) => (a -> f b) -> ContVec n a -> f (ContVec n b) +{-# INLINE mapM #-} +mapM f v + = inspect v + $ mapMF f construct + +-- | Apply monadic function to every element of the vector and its index. +imapM :: (ArityPeano n, Applicative f) + => (Int -> a -> f b) -> ContVec n a -> f (ContVec n b) +{-# INLINE imapM #-} +imapM f v + = inspect v + $ imapMF f construct + +-- | Apply monadic action to each element of vector and ignore result. +mapM_ :: (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_ :: (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_imapM i m) a -> T_imapM (i+1) $ ($) <$> m <*> f i a) + (\(T_imapM _ m) -> m) + (T_imapM 0 (pure funB)) + +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_imap i g) b -> T_imap (i+1) (g (f i b))) + (\(T_imap _ r) -> r) + ( T_imap 0 funB) + +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 :: (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 :: (ArityPeano n) => (a -> a -> a) -> ContVec n a -> ContVec n a +{-# INLINE scanl1 #-} +scanl1 f (ContVec cont) = ContVec $ + cont . scanl1F f + +scanlF :: forall n a b r. (ArityPeano n) => (b -> a -> b) -> b -> Fun ('S n) b r -> Fun n a r +scanlF f b0 (Fun fun0) + = accum step fini start + where + step :: forall k. T_scanl r b ('S k) -> a -> T_scanl r b k + step (T_scanl b fn) a = let b' = f b a in T_scanl b' (fn b') + fini (T_scanl _ r) = r + start = T_scanl b0 (fun0 b0) :: T_scanl r b n + +scanl1F :: forall n a r. (ArityPeano n) => (a -> a -> a) -> Fun n a r -> Fun n a r +scanl1F f (Fun fun0) = accum step fini start + where + step :: forall k. T_scanl1 r a ('S k) -> a -> T_scanl1 r a k + step (T_scanl1 Nothing fn) a = T_scanl1 (Just a) (fn a) + step (T_scanl1 (Just x) fn) a = let a' = f x a in T_scanl1 (Just a') (fn a') + fini (T_scanl1 _ r) = r + start = T_scanl1 Nothing fun0 :: T_scanl1 r a n + +data T_scanl r a n = T_scanl a (Fn n a r) +data T_scanl1 r a n = T_scanl1 (Maybe a) (Fn n a r) + + +-- | Evaluate every action in the vector from left to right. +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_ :: (ArityPeano n, Applicative f) => ContVec n (f a) -> f () +sequence_ = mapM_ id +{-# INLINE sequence_ #-} + +-- | The dual of sequenceA +distribute :: (Functor f, ArityPeano n) => f (ContVec n a) -> ContVec n (f a) +{-# INLINE distribute #-} +distribute f0 + = apply step start + where + -- It's not possible to use ContVec as accumulator type since `head' + -- require Arity constraint on `k'. So we use plain lists + step (Const f) = ( fmap (\(x:_) -> x) f + , Const $ fmap (\(_:x) -> x) f) + start = Const (fmap toList f0) + +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 :: ContVec (S n) a -> ContVec n a +tail (ContVec cont) = ContVec $ \f -> cont $ constFun f +{-# INLINE tail #-} + +-- | /O(1)/ Prepend element to vector +cons :: a -> ContVec n a -> ContVec ('S n) a +cons a (ContVec cont) = ContVec $ \f -> cont $ curryFirst f a +{-# INLINE cons #-} + +-- | Prepend single element vector to another vector. +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 :: 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 :: ( ArityPeano n + , ArityPeano k + , ArityPeano (n `Add` k) + ) + => 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 :: 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 :: (ArityPeano n) => (a -> b -> c) + -> ContVec n a -> ContVec n b -> ContVec n c +{-# INLINE zipWith #-} +zipWith f vecA vecB = ContVec $ \funC -> + inspect vecB + $ inspect vecA + $ zipWithF f funC + +-- | Zip three vectors together +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 ($) (zipWith f v1 v2) v3 + +-- | Zip two vector together using function which takes element index +-- as well. +izipWith :: (ArityPeano n) => (Int -> a -> b -> c) + -> ContVec n a -> ContVec n b -> ContVec n c +{-# INLINE izipWith #-} +izipWith f vecA vecB = ContVec $ \funC -> + inspect vecB + $ inspect vecA + $ izipWithF f funC + +-- | Zip three vectors together +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 :: (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_ :: (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 :: (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_ :: (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) + = 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 => ([a] -> b) -> Fun n a b +{-# INLINE makeList #-} +makeList cont = accum + (\(Const xs) x -> Const (xs . (x:))) + (\(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) + + + +---------------------------------------------------------------- +-- Running vector +---------------------------------------------------------------- + +-- | Run continuation vector. It's same as 'inspect' but with +-- arguments flipped. +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) => ContVec (Dim v) a -> v a +vector = runContVec construct +{-# INLINE[1] vector #-} + +-- | Finalizer function for getting head of the vector. +head :: forall n k a. (ArityPeano n, n ~ 'S k) => ContVec n a -> a +{-# INLINE head #-} +head + = dictionaryPred (proxy# @n) + $ runContVec + $ uncurryFirst pure + +-- | /O(n)/ Get value at specified index. +index :: ArityPeano n => Int -> ContVec n a -> a +{-# INLINE index #-} +index n + | n < 0 = error "Data.Vector.Fixed.Cont.index: index out of range" + | otherwise = runContVec $ accum + (\(Const x) a -> Const $ case x of + Left 0 -> Right a + Left i -> Left (i - 1) + r -> r + ) + (\(Const x) -> case x of + Left _ -> error "Data.Vector.Fixed.index: index out of range" + Right a -> a + ) + (Const (Left n)) + + +-- | Twan van Laarhoven lens for continuation based vector +element :: (ArityPeano n, Functor f) + => Int -> (a -> f a) -> ContVec n a -> f (ContVec n a) +{-# INLINE element #-} +element i f v = inspect v + $ elementF i f construct + +-- | Helper for implementation of Twan van Laarhoven lens. +elementF :: forall a n f r. (ArityPeano n, Functor f) + => Int -> (a -> f a) -> Fun n a r -> Fun n a (f r) +{-# INLINE elementF #-} +elementF n f (Fun fun0) = accum step fini start + where + step :: forall k. T_lens f a r ('S k) -> a -> T_lens f a r k + step (T_lens (Left (0,fun))) a = T_lens $ Right $ fmap fun $ f a + step (T_lens (Left (i,fun))) a = T_lens $ Left (i-1, fun a) + step (T_lens (Right fun)) a = T_lens $ Right $ fmap ($ a) fun + -- + fini :: T_lens f a r 'Z -> f r + fini (T_lens (Left _)) = error "Data.Vector.Fixed.lensF: Index out of range" + fini (T_lens (Right r)) = r + -- + start :: T_lens f a r n + start = T_lens $ Left (n,fun0) + +data T_lens f a r n = T_lens (Either (Int,(Fn n a r)) (f (Fn n a r))) + + + +-- | 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) + +-- | 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 :: 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) + +-- | 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 :: (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 :: (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) + + +-- | 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) + +-- | 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 :: ArityPeano n => (a -> b -> b) -> b -> ContVec n a -> b +{-# INLINE foldr #-} +foldr f b0 = runContVec $ foldrF f b0 + +-- | Right fold over continuation vector +ifoldr :: ArityPeano n => (Int -> a -> b -> b) -> b -> ContVec n a -> b +{-# INLINE ifoldr #-} +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, ArityPeano n) => ContVec n a -> a +sum = foldl' (+) 0 +{-# INLINE sum #-} + +-- | Minimal element of vector. +minimum :: (Ord a, ArityPeano n, n ~ 'S k) => ContVec n a -> a +minimum = foldl1 min +{-# INLINE minimum #-} + +-- | Maximal element of vector. +maximum :: (Ord a, ArityPeano n, n ~ 'S k) => ContVec n a -> a +maximum = foldl1 max +{-# INLINE maximum #-} + +-- | Conjunction of elements of a vector. +and :: ArityPeano n => ContVec n Bool -> Bool +and = foldr (&&) True +{-# INLINE and #-} + +-- | Disjunction of all elements of a vector. +or :: ArityPeano n => ContVec n Bool -> Bool +or = foldr (||) False +{-# INLINE or #-} + +-- | Determines whether all elements of vector satisfy predicate. +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 :: 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 :: 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 #-} + +-- | Generic 'Data.Data.gfoldl' which could work with any vector. +gfoldl :: forall c v a. (Vector v a, Data a) + => (forall x y. Data x => c (x -> y) -> x -> c y) + -> (forall x . x -> c x) + -> v a -> c (v a) +gfoldl f inj v + = inspect v + $ 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 +-- constructor is ignored. +gunfold :: forall con c v a. (Vector v a, Data a) + => (forall b r. Data b => c (b -> r) -> c r) + -> (forall r. r -> c r) + -> con -> c (v a) +gunfold f inj _ = + case reducePeano step gun of + T_gunfold c -> c + where + 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_mapM c) x -> T_mapM (f c x)) + (\(T_mapM c) -> c) + (T_mapM c0) + + + +---------------------------------------------------------------- +-- Deforestation +---------------------------------------------------------------- + +-- Deforestation uses following assertion: if we convert continuation +-- to vector and immediately back to the continuation we can eliminate +-- intermediate vector. This optimization can however turn +-- nonterminating programs into terminating. +-- +-- > runContVec head $ cvec $ vector $ mk2 () ⊥ +-- +-- If intermediate vector is strict in its elements expression above +-- evaluates to ⊥ too. But if we apply rewrite rule resuling expression: +-- +-- > runContVec head $ mk2 () ⊥ +-- +-- will evaluate to () since ContVec is not strict in its elements. +-- It has been considered acceptable. +-- +-- +-- In order to get rule fire reliably (it still doesn't). `vector' in +-- inlined starting from phase 1. `cvec' is inlined even later (only +-- during phase 0) because it need to participate in rewriting of +-- indexing functions. + + +{-# RULES +"cvec/vector" forall v. + cvec (vector v) = v + #-} + + +---------------------------------------------------------------- +-- Instances +---------------------------------------------------------------- + +type instance Dim Complex = N2 +type instance Dim (Complex a) = N2 + +instance Vector Complex a where + construct = Fun (:+) + inspect (x :+ y) (Fun f) = f x y + {-# INLINE construct #-} + {-# INLINE inspect #-} + + +type instance Dim Identity = N1 +type instance Dim (Identity a) = N1 + +instance Vector Identity a where + construct = Fun Identity + inspect (Identity x) (Fun f) = f x + {-# INLINE construct #-} + {-# INLINE inspect #-} + + +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 +-- element tuple @(Int,Int)@ is @(,) Int@ so it will only work +-- with elements of type @Int@. +instance (b~a) => Vector ((,) b) a where + construct = Fun (,) + inspect (a,b) (Fun f) = f a b + {-# INLINE construct #-} + {-# INLINE inspect #-} + + +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 (,,) + inspect (a,b,c) (Fun f) = f a b c + {-# INLINE construct #-} + {-# INLINE inspect #-} + + +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 (,,,) + inspect (a,b,c,d) (Fun f) = f a b c d + {-# INLINE construct #-} + {-# INLINE inspect #-} + + +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 (,,,,) + inspect (a,b,c,d,e) (Fun f) = f a b c d e + {-# INLINE construct #-} + {-# INLINE inspect #-} + + +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 (,,,,,) + inspect (a,b,c,d,e,f) (Fun fun) = fun a b c d e f + {-# INLINE construct #-} + {-# INLINE inspect #-} + + +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 (,,,,,,) + inspect (a,b,c,d,e,f,g) (Fun fun) = fun a b c d e f g + {-# INLINE construct #-} + {-# INLINE inspect #-} + +type instance Dim Proxy = Z +type instance Dim (Proxy a) = Z + +instance Vector Proxy a where + construct = Fun Proxy + inspect _ = unFun 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,25 +1,20 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} -- | -- Implementation of fixed-vectors module Data.Vector.Fixed.Internal where -import Control.Applicative (Applicative) -import Control.Monad (liftM) -import Data.Monoid (Monoid(..)) +import Control.DeepSeq (NFData(..)) import qualified Data.Foldable as T import qualified Data.Traversable as T import Foreign.Storable (Storable(..)) import Foreign.Ptr (Ptr,castPtr) +import GHC.Exts (proxy#) -import Data.Vector.Fixed.Cont (Vector(..),Dim,S,Z,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 Data.Vector.Fixed.Cont (ContVec,Index) + import Prelude hiding ( replicate,map,zipWith,maximum,minimum,and,or,all,any , foldl,foldr,foldl1,length,sum,reverse,scanl,scanl1 , head,tail,mapM,mapM_,sequence,sequence_,concat @@ -30,44 +25,8 @@ -- Constructors ---------------------------------------------------------------- --- | Variadic vector constructor. Resulting vector should be converted --- from 'ContVec' using 'vector' function. For example: --- --- >>> vector $ mkN 'a' 'b' 'c' :: (Char,Char,Char) --- ('a','b','c') -mkN :: Make (S Z) a r => a -> r -mkN = unGo $ make id -{-# INLINE mkN #-} - - --- | Type class for variadic vector constructors. -class Make n a r where - make :: (ContVec Z a -> ContVec n a) -> r - -instance (a'~a, Make (S n) a r) => Make n a' (a -> r) where - make f a = make (C.cons a . f) - {-# INLINE make #-} - -instance Arity n => Make n a (ContVec n a) where - make f = C.reverse $ f C.empty - {-# INLINE make #-} - -newtype Go r = Go { unGo :: r } - -instance Make Z a r => Make Z a (Go r) where - make f = Go $ make f - {-# INLINE make #-} - --- | Cons value to continuation based vector. -(<|) :: a -> ContVec n a -> ContVec (S n) a -(<|) = C.cons -{-# INLINE (<|) #-} - -infixr 1 <| - - -mk0 :: (Vector v a, Dim v ~ C.Z) => v a -mk0 = vector $ C.empty +mk0 :: (Vector v a, Dim v ~ 'Z) => v a +mk0 = vector C.empty {-# INLINE mk0 #-} mk1 :: (Vector v a, Dim v ~ C.N1) => a -> v a @@ -90,8 +49,35 @@ mk5 a1 a2 a3 a4 a5 = vector $ C.mk5 a1 a2 a3 a4 a5 {-# INLINE mk5 #-} +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 ~ 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 ~ 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 #-} + +-- | 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 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 ---------------------------------------------------------------- @@ -102,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 @@ -122,15 +108,15 @@ -- -- >>> 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, Monad m) => m a -> m (v a) +-- [(),()] +replicateM :: (Vector v a, Applicative f) => f a -> f (v a) {-# INLINE replicateM #-} replicateM - = liftM vector . C.replicateM + = fmap vector . C.replicateM -- | Unit vector along Nth axis. If index is larger than vector @@ -140,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 @@ -163,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 @@ -171,9 +157,9 @@ -- | Generate vector from monadic function which maps element's index -- to its value. -generateM :: (Monad m, Vector v a) => (Int -> m a) -> m (v a) +generateM :: (Applicative f, Vector v a) => (Int -> f a) -> f (v a) {-# INLINE generateM #-} -generateM = liftM vector . C.generateM +generateM = fmap vector . C.generateM @@ -187,7 +173,7 @@ -- >>> let x = mk3 1 2 3 :: Vec3 Int -- >>> head x -- 1 -head :: (Vector v a, Dim v ~ S n) => v a -> a +head :: (Vector v a, Dim v ~ 'S k) => v a -> a {-# INLINE head #-} head = C.head . C.cvec @@ -199,24 +185,26 @@ -- >>> import Data.Complex -- >>> tail (1,2,3) :: Complex Double -- 2.0 :+ 3.0 -tail :: (Vector v a, Vector w a, Dim v ~ S (Dim w)) +tail :: (Vector v a, Vector w a, Dim v ~ '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, S (Dim v) ~ Dim w) +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, S (Dim v) ~ Dim w) +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, (Add (Dim v) (Dim u)) ~ Dim w) +concat :: ( Vector v a, Vector u a, Vector w a + , (Dim v `Add` Dim u) ~ Dim w + ) => v a -> u a -> w a {-# INLINE concat #-} concat v u = vector $ C.concat (C.cvec v) (C.cvec u) @@ -230,24 +218,49 @@ -- /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 #-} +-- We are trying to be clever with indexing here. It's not possible to +-- write generic indexing function. For example it's necessary O(n) +-- for VecList. It's however possible to write O(1) indexing for some +-- vectors and we trying to use such functions where possible. +-- +-- We try to use presumable more efficient basicIndex +-- +-- 1. It should not interfere with deforestation. So we should +-- rewrite only when deforestation rule already fired. +-- (starting from phase 1). +-- +-- 2. Creation of vector is costlier than generic indexing so we should +-- apply rule only when vector is created anyway +-- +-- In order to avoid firing this rule on implementation of (!) it has +-- been necessary to move definition of all functions to internal module. + +{-# RULES +"fixed-vector:index/basicIndex"[1] forall vv i. + runIndex i (C.cvec vv) = C.basicIndex vv i + #-} + + -- | Get element from vector at statically known index -index :: (Vector v a, C.Index k (Dim v)) => v a -> k -> a +index :: forall k v a proxy. (Vector v a, Index (Peano k) (Dim v)) + => v a -> proxy k -> a {-# INLINE index #-} -index v k = C.runContVec (C.getF k) - $ C.cvec v +index v _ = inspect v (C.getF (proxy# @(Peano k))) -- | Set n'th element in the vector -set :: (Vector v a, C.Index k (Dim v)) => 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 v = inspect v - $ C.putF k a construct +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)) @@ -256,12 +269,11 @@ -- | Twan van Laarhoven's lens for element of vector with statically -- known index. -elementTy :: (Vector v a, Index k (Dim v), Functor f) - => k -> (a -> f a) -> (v a -> f (v a)) +elementTy :: 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 f v = vector `fmap` C.elementTy k f (C.cvec v) - - +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 @@ -269,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 #-} @@ -277,7 +295,7 @@ -- | Left fold over vector -foldl1 :: (Vector v a, Dim v ~ S n) => (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 @@ -309,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 #-} @@ -337,7 +362,7 @@ -- >>> let x = mk3 1 2 3 :: Vec3 Int -- >>> maximum x -- 3 -maximum :: (Vector v a, Dim v ~ S n, Ord a) => v a -> a +maximum :: (Vector v a, Dim v ~ S k, Ord a) => v a -> a maximum = C.maximum . C.cvec {-# INLINE maximum #-} @@ -349,7 +374,7 @@ -- >>> let x = mk3 1 2 3 :: Vec3 Int -- >>> minimum x -- 1 -minimum :: (Vector v a, Dim v ~ S n, Ord a) => v a -> a +minimum :: (Vector v a, Dim v ~ S k, Ord a) => v a -> a minimum = C.minimum . C.cvec {-# INLINE minimum #-} @@ -417,27 +442,28 @@ . C.cvec -- | Evaluate every action in the vector from left to right. -sequence :: (Vector v a, Vector v (m a), Monad m) => v (m a) -> m (v a) +sequence :: (Vector v a, Vector v (f a), Applicative f) => v (f a) -> f (v a) {-# INLINE sequence #-} sequence = mapM id -- | Evaluate every action in the vector from left to right and ignore result -sequence_ :: (Vector v (m a), Monad m) => v (m a) -> m () +sequence_ :: (Vector v (f a), Applicative f) => v (f a) -> f () {-# INLINE sequence_ #-} sequence_ = mapM_ id --- | Monadic map over vector. -mapM :: (Vector v a, Vector v b, Monad m) => (a -> m b) -> v a -> m (v b) +-- | Effectful map over vector. +mapM :: (Vector v a, Vector v b, Applicative f) => (a -> f b) -> v a -> f (v b) {-# INLINE mapM #-} -mapM f = liftM vector +mapM f = fmap vector . C.mapM f . C.cvec -- | Apply monadic action to each element of vector and ignore result. -mapM_ :: (Vector v a, Monad m) => (a -> m b) -> v a -> m () +mapM_ :: (Vector v a, Applicative f) => (a -> f b) -> v a -> f () {-# INLINE mapM_ #-} -mapM_ f = foldl (\m a -> m >> f a >> return ()) (return ()) +mapM_ f = C.mapM_ f + . C.cvec -- | Apply function to every element of the vector and its index. @@ -449,21 +475,22 @@ . C.cvec -- | Apply monadic function to every element of the vector and its index. -imapM :: (Vector v a, Vector v b, Monad m) - => (Int -> a -> m b) -> v a -> m (v b) +imapM :: (Vector v a, Vector v b, Applicative f) + => (Int -> a -> f b) -> v a -> f (v b) {-# INLINE imapM #-} -imapM f = liftM vector +imapM f = fmap vector . C.imapM f . C.cvec -- | Apply monadic function to every element of the vector and its -- index and discard result. -imapM_ :: (Vector v a, Monad m) => (Int -> a -> m b) -> v a -> m () +imapM_ :: (Vector v a, Applicative f) => (Int -> a -> f b) -> v a -> f () {-# INLINE imapM_ #-} -imapM_ f = ifoldl (\m i a -> m >> f i a >> return ()) (return ()) +imapM_ f = C.imapM_ f + . C.cvec -- | Left scan over vector -scanl :: (Vector v a, Vector w b, Dim w ~ S (Dim v)) +scanl :: (Vector v a, Vector w b, Dim w ~ 'S (Dim v)) => (b -> a -> b) -> b -> v a -> w b {-# INLINE scanl #-} scanl f x0 = vector . C.scanl f x0 . C.cvec @@ -478,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) @@ -496,18 +524,8 @@ {-# INLINE collect #-} collect f = vector . C.collect (C.cvec . f) -distributeM :: (Vector v a, Vector v (m a), Monad m) - => m (v a) -> v (m a) -{-# INLINE distributeM #-} -distributeM = vector . C.distributeM . liftM C.cvec -collectM :: (Vector v a, Vector v b, Vector v (m b), Monad m) - => (a -> v b) -> m a -> v (m b) -{-# INLINE collectM #-} -collectM f = vector . C.collectM (C.cvec . f) - - ---------------------------------------------------------------- -- | Zip two vector together using function. @@ -520,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 #-} @@ -543,17 +561,17 @@ $ C.zipWith3 f (C.cvec v1) (C.cvec v2) (C.cvec v3) -- | Zip two vector together using monadic function. -zipWithM :: (Vector v a, Vector v b, Vector v c, Monad m) - => (a -> b -> m c) -> v a -> v b -> m (v c) +zipWithM :: (Vector v a, Vector v b, Vector v c, Applicative f) + => (a -> b -> f c) -> v a -> v b -> f (v c) {-# INLINE zipWithM #-} -zipWithM f v u = liftM vector +zipWithM f v u = fmap vector $ C.zipWithM f (C.cvec v) (C.cvec u) -- | Zip two vector elementwise using monadic function and discard -- result zipWithM_ - :: (Vector v a, Vector v b, Monad m) - => (a -> b -> m c) -> v a -> v b -> m () + :: (Vector v a, Vector v b, Applicative f) + => (a -> b -> f c) -> v a -> v b -> f () {-# INLINE zipWithM_ #-} zipWithM_ f xs ys = C.zipWithM_ f (C.cvec xs) (C.cvec ys) @@ -578,17 +596,17 @@ -- | Zip two vector together using monadic function which takes element -- index as well.. -izipWithM :: (Vector v a, Vector v b, Vector v c, Monad m) - => (Int -> a -> b -> m c) -> v a -> v b -> m (v c) +izipWithM :: (Vector v a, Vector v b, Vector v c, Applicative f) + => (Int -> a -> b -> f c) -> v a -> v b -> f (v c) {-# INLINE izipWithM #-} -izipWithM f v u = liftM vector +izipWithM f v u = fmap vector $ C.izipWithM f (C.cvec v) (C.cvec u) -- | Zip two vector elementwise using monadic function and discard -- result izipWithM_ - :: (Vector v a, Vector v b, Vector v c, Monad m, Vector v (m c)) - => (Int -> a -> b -> m c) -> v a -> v b -> m () + :: (Vector v a, Vector v b, Vector v c, Applicative f) + => (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) @@ -601,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 (undefined :: Dim v) +defaultSizeOf _ = sizeOf (undefined :: a) * C.peanoToInt (proxy# @(Dim v)) {-# INLINE defaultSizeOf #-} -- | Default implementation of 'peek' for 'Storable' type class for @@ -623,6 +642,9 @@ defaultPoke ptr = imapM_ (pokeElemOff (castPtr ptr)) +-- | Default implementation of 'rnf' from `NFData' type class +defaultRnf :: (NFData a, Vector v a) => v a -> () +defaultRnf = foldl (\() a -> rnf a) () ---------------------------------------------------------------- @@ -652,10 +674,15 @@ -- length from resulting vector. fromListM :: (Vector v a) => [a] -> Maybe (v a) {-# INLINE fromListM #-} -fromListM = liftM vector . C.fromListM +fromListM = fmap vector . C.fromListM -- | Create vector from 'Foldable' data type. Will return @Nothing@ if -- data type different number of elements that resulting vector. fromFoldable :: (Vector v a, T.Foldable f) => f a -> Maybe (v a) {-# INLINE fromFoldable #-} fromFoldable = fromListM . T.toList + +-- | Generic definition of 'Prelude.showsPrec' +showsPrec :: (Vector v a, Show a) => Int -> v a -> ShowS +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/Monomorphic.hs b/Data/Vector/Fixed/Monomorphic.hs deleted file mode 100644 --- a/Data/Vector/Fixed/Monomorphic.hs +++ /dev/null @@ -1,379 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} --- | --- Wrapper function for working with monomorphic vectors. Standard API --- require vector to be parametric in their element type making it --- impossible to work with vectors like --- --- > data Vec3 = Vec3 Double Double Double --- --- This module provides newtype wrapper which allows use of functions --- from "Data.Vector.Fixed" with such data types and function which --- works with such vectors. --- --- Functions have same meaning as ones from "Data.Vector.Fixed" and --- documented there. -module Data.Vector.Fixed.Monomorphic ( - -- * Vector type class - -- ** Vector size - DimMono - , Z - , S - -- ** Synonyms for small numerals - , F.N1 - , F.N2 - , F.N3 - , F.N4 - , F.N5 - , F.N6 - -- ** Type class - , VectorMono(..) - , Arity - , Fun(..) - , length - -- * Constructors - -- $construction - -- ** Small dimensions - -- $smallDim - , mk1 - , mk2 - , mk3 - , mk4 - , mk5 - -- ** Functions - , replicate - , replicateM - , generate - , generateM - , unfoldr - , basis - -- * Modifying vectors - -- ** Transformations - , head - , tail - , reverse - , (!) - -- ** Comparison - , eq - -- ** Maps - , map - , mapM - , mapM_ - , imap - , imapM - , imapM_ - -- * Folding - , foldl - , foldr - , foldl1 - , ifoldl - , ifoldr - , fold - , foldMap - , foldM - , ifoldM - -- ** Special folds - , sum - , maximum - , minimum - , and - , or - , all - , any - , find - -- * Zips - , zipWith - , zipWithM - , izipWith - , izipWithM - -- * Conversion - , convert - , toList - , fromList - ) where - -import Control.Monad (liftM) -import Data.Monoid (Monoid) -import qualified Data.Vector.Fixed as F -import Data.Vector.Fixed.Cont (S,Z,Arity,Fun(..)) -import Prelude (Num,Eq,Ord,Functor(..),Monad(..),Int,Bool,(.),($),Maybe) - - - ----------------------------------------------------------------- --- Wrappers for monomorphic vectors ----------------------------------------------------------------- - --- | Wrapper for monomorphic vectors it provides 'Vector' instance for --- monomorphic vectors. Trick is to restrict type parameter @a@ to --- single possible value. -newtype Mono v a = Mono { getMono :: v } - -type instance F.Dim (Mono v) = DimMono v - -instance (VectorMono v, a ~ VectorElm v, Arity (DimMono v)) => F.Vector (Mono v) a where - construct = fmap Mono construct - inspect = inspect . getMono - basicIndex = basicIndex . getMono - {-# INLINE construct #-} - {-# INLINE inspect #-} - {-# INLINE basicIndex #-} - - --- | Dimensions of monomorphic vector. -type family DimMono v :: * - --- | Counterpart of 'Vector' type class for monomorphic vectors. -class Arity (DimMono v) => VectorMono v where - -- | Type of vector elements. - type VectorElm v :: * - -- | Construct vector - construct :: Fun (DimMono v) (VectorElm v) v - -- | Inspect vector - inspect :: v -> Fun (DimMono v) (VectorElm v) r -> r - -- | Optional more efficient implementation of indexing - basicIndex :: v -> Int -> VectorElm v - basicIndex v i = Mono v F.! i - {-# INLINE basicIndex #-} - --- | Length of vector -length :: Arity (DimMono v) => v -> Int -length = F.length . Mono -{-# INLINE length #-} - - ----------------------------------------------------------------- --- ----------------------------------------------------------------- - -mk1 :: (VectorMono v, VectorElm v ~ a, DimMono v ~ F.N1) - => a -> v -mk1 a1 = getMono $ F.mk1 a1 -{-# INLINE mk1 #-} - -mk2 :: (VectorMono v, VectorElm v ~ a, DimMono v ~ F.N2) - => a -> a-> v -mk2 a1 a2 = getMono $ F.mk2 a1 a2 -{-# INLINE mk2 #-} - -mk3 :: (VectorMono v, VectorElm v ~ a, DimMono v ~ F.N3) - => a -> a-> a -> v -mk3 a1 a2 a3 = getMono $ F.mk3 a1 a2 a3 -{-# INLINE mk3 #-} - -mk4 :: (VectorMono v, VectorElm v ~ a, DimMono v ~ F.N4) - => a -> a-> a -> a -> v -mk4 a1 a2 a3 a4 = getMono $ F.mk4 a1 a2 a3 a4 -{-# INLINE mk4 #-} - -mk5 :: (VectorMono v, VectorElm v ~ a, DimMono v ~ F.N5) - => a -> a-> a -> a -> a -> v -mk5 a1 a2 a3 a4 a5 = getMono $ F.mk5 a1 a2 a3 a4 a5 -{-# INLINE mk5 #-} - -replicate :: (VectorMono v, VectorElm v ~ a) => a -> v -{-# INLINE replicate #-} -replicate = getMono . F.replicate - -replicateM :: (VectorMono v, VectorElm v ~ a, Monad m) => m a -> m v -{-# INLINE replicateM #-} -replicateM a = getMono `liftM` F.replicateM a - -basis :: (VectorMono v, VectorElm v ~ a, Num a) => Int -> v -{-# INLINE basis #-} -basis = getMono . F.basis - -unfoldr :: (VectorMono v, VectorElm v ~ a) => (b -> (a,b)) -> b -> v -{-# INLINE unfoldr #-} -unfoldr f = getMono . F.unfoldr f - -generate :: (VectorMono v, VectorElm v ~ a) => (Int -> a) -> v -{-# INLINE generate #-} -generate = getMono . F.generate - -generateM :: (Monad m, VectorMono v, VectorElm v ~ a) => (Int -> m a) -> m v -{-# INLINE generateM #-} -generateM f = getMono `liftM` F.generateM f - - - ----------------------------------------------------------------- - -head :: (VectorMono v, VectorElm v ~ a, DimMono v ~ S n) => v -> a -{-# INLINE head #-} -head = F.head . Mono - -tail :: ( VectorMono v, VectorElm v ~ a - , VectorMono w, VectorElm w ~ a - , DimMono v ~ S (DimMono w)) - => v -> w -{-# INLINE tail #-} -tail v = getMono $ F.tail $ Mono v - -reverse :: (VectorMono v) => v -> v -reverse = getMono . F.reverse . Mono -{-# INLINE reverse #-} - -(!) :: (VectorMono v, VectorElm v ~ a) => v -> Int -> a -{-# INLINE (!) #-} -v ! n = Mono v F.! n - -foldl :: (VectorMono v, VectorElm v ~ a) - => (b -> a -> b) -> b -> v -> b -{-# INLINE foldl #-} -foldl f x = F.foldl f x . Mono - -foldr :: (VectorMono v, VectorElm v ~ a) - => (a -> b -> b) -> b -> v -> b -{-# INLINE foldr #-} -foldr f x = F.foldr f x . Mono - - -foldl1 :: (VectorMono v, VectorElm v ~ a, DimMono v ~ S n) - => (a -> a -> a) -> v -> a -{-# INLINE foldl1 #-} -foldl1 f = F.foldl1 f . Mono - -ifoldr :: (VectorMono v, VectorElm v ~ a) - => (Int -> a -> b -> b) -> b -> v -> b -{-# INLINE ifoldr #-} -ifoldr f x = F.ifoldr f x . Mono - -ifoldl :: (VectorMono v, VectorElm v ~ a) - => (b -> Int -> a -> b) -> b -> v -> b -{-# INLINE ifoldl #-} -ifoldl f z = F.ifoldl f z . Mono - -fold :: (VectorMono v, Monoid (VectorElm v)) => v -> VectorElm v -fold = F.fold . Mono -{-# INLINE fold #-} - -foldMap :: (VectorMono v, Monoid m) => (VectorElm v -> m) -> v -> m -foldMap f = F.foldMap f . Mono -{-# INLINE foldMap #-} - -foldM :: (VectorMono v, VectorElm v ~ a, Monad m) - => (b -> a -> m b) -> b -> v -> m b -{-# INLINE foldM #-} -foldM f x = F.foldM f x . Mono - -ifoldM :: (VectorMono v, VectorElm v ~ a, Monad m) => (b -> Int -> a -> m b) -> b -> v -> m b -{-# INLINE ifoldM #-} -ifoldM f x = F.ifoldM f x . Mono - - - ----------------------------------------------------------------- - -sum :: (VectorMono v, VectorElm v ~ a, Num a) => v -> a -sum = F.sum . Mono -{-# INLINE sum #-} - -maximum :: (VectorMono v, VectorElm v ~ a, DimMono v ~ S n, Ord a) => v -> a -maximum = F.maximum . Mono -{-# INLINE maximum #-} - -minimum :: (VectorMono v, VectorElm v ~ a, DimMono v ~ S n, Ord a) => v -> a -minimum = F.minimum . Mono -{-# INLINE minimum #-} - -and :: (VectorMono v, VectorElm v ~ Bool) => v -> Bool -and = F.and . Mono -{-# INLINE and #-} - -or :: (VectorMono v, VectorElm v ~ Bool) => v -> Bool -or = F.or . Mono -{-# INLINE or #-} - -all :: (VectorMono v, VectorElm v ~ a) => (a -> Bool) -> v -> Bool -all f = F.all f . Mono -{-# INLINE all #-} - -any :: (VectorMono v, VectorElm v ~ a) => (a -> Bool) -> v -> Bool -any f = F.any f . Mono -{-# INLINE any #-} - -find :: (VectorMono v, VectorElm v ~ a) => (a -> Bool) -> v -> Maybe a -find f = F.find f . Mono -{-# INLINE find #-} - ----------------------------------------------------------------- - -eq :: (VectorMono v, VectorElm v ~ a, Eq a) => v -> v -> Bool -{-# INLINE eq #-} -eq v w = F.eq (Mono v) (Mono w) - - ----------------------------------------------------------------- - -map :: (VectorMono v, VectorElm v ~ a) => (a -> a) -> v -> v -{-# INLINE map #-} -map f = getMono . F.map f . Mono - -mapM :: (VectorMono v, VectorElm v ~ a, Monad m) - => (a -> m a) -> v -> m v -{-# INLINE mapM #-} -mapM f v = getMono `liftM` F.mapM f (Mono v) - -mapM_ :: (VectorMono v, VectorElm v ~ a, Monad m) => (a -> m b) -> v -> m () -{-# INLINE mapM_ #-} -mapM_ f = F.mapM_ f . Mono - - -imap :: (VectorMono v, VectorElm v ~ a) => - (Int -> a -> a) -> v -> v -{-# INLINE imap #-} -imap f = getMono . F.imap f . Mono - -imapM :: (VectorMono v, VectorElm v ~ a, Monad m) - => (Int -> a -> m a) -> v -> m v -{-# INLINE imapM #-} -imapM f v = getMono `liftM` F.imapM f (Mono v) - -imapM_ :: (VectorMono v, VectorElm v ~ a, Monad m) => (Int -> a -> m b) -> v -> m () -{-# INLINE imapM_ #-} -imapM_ f = F.imapM_ f . Mono - - ----------------------------------------------------------------- - -zipWith :: (VectorMono v, VectorElm v ~ a) - => (a -> a -> a) -> v -> v -> v -{-# INLINE zipWith #-} -zipWith f v u = getMono $ F.zipWith f (Mono v) (Mono u) - - -zipWithM :: (VectorMono v, VectorElm v ~ a, Monad m) - => (a -> a -> m a) -> v -> v -> m v -{-# INLINE zipWithM #-} -zipWithM f v u = getMono `liftM` F.zipWithM f (Mono v) (Mono u) - -izipWith :: (VectorMono v, VectorElm v ~ a) - => (Int -> a -> a -> a) -> v -> v -> v -{-# INLINE izipWith #-} -izipWith f v u = getMono $ F.izipWith f (Mono v) (Mono u) - -izipWithM :: (VectorMono v, VectorElm v ~ a, Monad m) - => (Int -> a -> a -> m a) -> v -> v -> m v -{-# INLINE izipWithM #-} -izipWithM f v u = getMono `liftM` F.izipWithM f (Mono v) (Mono u) - - - ----------------------------------------------------------------- - -convert :: (VectorMono v, VectorMono w, VectorElm v ~ VectorElm w, DimMono v ~ DimMono w) - => v -> w -{-# INLINE convert #-} -convert = getMono . F.convert . Mono - -toList :: (VectorMono v, VectorElm v ~ a) => v -> [a] -toList = foldr (:) [] - -fromList :: (VectorMono v, VectorElm v ~ a) => [a] -> v -{-# INLINE fromList #-} -fromList = getMono . F.fromList - diff --git a/Data/Vector/Fixed/Mutable.hs b/Data/Vector/Fixed/Mutable.hs --- a/Data/Vector/Fixed/Mutable.hs +++ b/Data/Vector/Fixed/Mutable.hs @@ -1,8 +1,5 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Rank2Types #-} +{-# 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 @@ -10,77 +7,133 @@ module Data.Vector.Fixed.Mutable ( -- * Mutable vectors Arity - , arity , Mutable , DimM , MVector(..) , lengthM + , new + , clone + , copy , read , write - , clone + , unsafeRead + , unsafeWrite + -- * Creation + , replicate + , replicateM + , generate + , generateM + -- * Loops + , forI -- * Immutable vectors , IVector(..) , index - , lengthI , freeze , thaw + , unsafeFreeze -- * Vector API , constructVec , inspectVec ) where +import Control.Applicative (Const(..)) import Control.Monad.ST import Control.Monad.Primitive -import Data.Vector.Fixed.Cont (Dim,Arity,Fun(..),S,arity,apply,accum) -import Prelude hiding (read) +import Data.Kind (Type) +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 ---------------------------------------------------------------- -- | Mutable counterpart of fixed-length vector. -type family Mutable (v :: * -> *) :: * -> * -> * +type family Mutable (v :: Type -> Type) :: Type -> Type -> Type -- | Dimension for mutable vector. -type family DimM (v :: * -> * -> *) :: * +type family DimM (v :: Type -> Type -> Type) :: PeanoNum -- | Type class for mutable vectors. -class (Arity (DimM v)) => MVector v a where - -- | Checks whether vectors' buffers overlaps - overlaps :: v s a -> v s a -> Bool - -- | Copy vector. The two vectors may not overlap. Since vectors' - -- length is encoded in the type there is no need in runtime checks. - copy :: PrimMonad m - => 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 (undefined :: 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: +-- +-- >>> import Control.Monad.ST (runST) +-- >>> import Data.Vector.Fixed (mk3) +-- >>> import Data.Vector.Fixed.Boxed (Vec3) +-- >>> 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 +-- [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 v u - 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 #-} @@ -96,28 +149,71 @@ | otherwise = unsafeWrite v i x +-- | 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 = stToPrim . basicReplicate + +-- | Create new vector with all elements are generated by provided +-- monadic action. +replicateM :: (PrimMonad m, MVector v a) => m a -> m (v (PrimState m) a) +{-# INLINE replicateM #-} +replicateM m = do + v <- new + forI v $ \i -> unsafeWrite v i =<< m + pure v + +-- | Create new vector with using function from index to value. +generate :: (PrimMonad m, MVector v a) => (Int -> a) -> m (v (PrimState m) a) +{-# INLINE generate #-} +generate f = do + v <- new + forI v $ \i -> unsafeWrite v i $ f i + pure v + +-- | Create new vector with using monadic function from index to value. +generateM :: (PrimMonad m, MVector v a) => (Int -> m a) -> m (v (PrimState m) a) +{-# INLINE generateM #-} +generateM f = do + v <- new + forI v $ \i -> unsafeWrite v i =<< f i + pure v + +-- | Loop which calls function for each index +forI :: (PrimMonad m, MVector v a) => v (PrimState m) a -> (Int -> m ()) -> m () +{-# INLINE forI #-} +forI v f = go 0 + where + go i | i >= n = pure () + | otherwise = f i >> go (i+1) + n = lengthM v + + +---------------------------------------------------------------- +-- Immutable +---------------------------------------------------------------- + -- | Type class for immutable vectors 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) - -- | Convert immutable vector to mutable. Immutable vector must not - -- be used afterwards. - 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 --- | Length of immutable vector. Function doesn't evaluate its argument. -lengthI :: IVector v a => v a -> Int -lengthI = lengthM . cast - where - cast :: v a -> Mutable v () a - cast _ = undefined +-- | 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 >= lengthI v = error "Data.Vector.Fixed.Mutable.!: index out of bounds" - | otherwise = unsafeIndex v i +index v i | i < 0 || i >= length v = error "Data.Vector.Fixed.Mutable.!: index out of bounds" + | otherwise = unsafeIndex v i -- | Safely convert mutable vector to immutable. @@ -128,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 @@ -137,27 +233,26 @@ ---------------------------------------------------------------- -- | Generic inspect implementation for array-based vectors. -inspectVec :: forall v a b. (Arity (Dim v), IVector v a) => v a -> Fun (Dim v) a b -> b +inspectVec :: forall v a b. (ArityPeano (Dim v), IVector v a) => v a -> Fun (Dim v) a b -> b {-# INLINE inspectVec #-} -inspectVec v (Fun f) - = apply (\(T_idx i) -> (unsafeIndex v i, T_idx (i+1))) - (T_idx 0 :: T_idx (Dim v)) - f - -newtype T_idx n = T_idx Int - +inspectVec v + = inspect cv + where + cv :: ContVec (Dim v) a + cv = apply (\(Const i) -> (unsafeIndex v i, Const (i+1))) + (Const 0 :: Const Int (Dim v)) -- | Generic construct implementation for array-based vectors. -constructVec :: forall v a. (Arity (Dim v), IVector v a) => Fun (Dim v) a (v a) +constructVec :: forall v a. (ArityPeano (Dim v), IVector v a) => Fun (Dim v) a (v a) {-# INLINE constructVec #-} -constructVec = Fun $ +constructVec = accum step (\(T_new _ st) -> runST $ unsafeFreeze =<< st :: v a) (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)) -step :: (IVector v a) => T_new v a (S n) -> a -> T_new v a n +step :: (IVector v a) => T_new v a ('S n) -> a -> T_new v a n step (T_new i st) x = T_new (i+1) $ do mv <- st unsafeWrite mv i x diff --git a/Data/Vector/Fixed/Primitive.hs b/Data/Vector/Fixed/Primitive.hs --- a/Data/Vector/Fixed/Primitive.hs +++ b/Data/Vector/Fixed/Primitive.hs @@ -1,10 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- Unboxed vectors with fixed length. Vectors from -- "Data.Vector.Fixed.Unboxed" provide more flexibility at no @@ -27,17 +23,22 @@ import Control.DeepSeq (NFData(..)) import Data.Data import Data.Monoid (Monoid(..)) +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 -import qualified Data.Vector.Fixed.Cont as C - +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(..)) ---------------------------------------------------------------- @@ -45,68 +46,59 @@ ---------------------------------------------------------------- -- | Unboxed vector with fixed length -newtype Vec n a = Vec ByteArray +newtype Vec (n :: Nat) (a :: Type) = Vec ByteArray -- | Mutable unboxed vector with fixed length -newtype MVec n s a = MVec (MutableByteArray s) - -#if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable Vec -deriving instance Typeable MVec -#else -deriving instance Typeable2 Vec -deriving instance Typeable3 MVec -#endif +newtype MVec (n :: Nat) s a = MVec (MutableByteArray s) -type Vec1 = Vec (S Z) -type Vec2 = Vec (S (S Z)) -type Vec3 = Vec (S (S (S Z))) -type Vec4 = Vec (S (S (S (S Z)))) -type Vec5 = Vec (S (S (S (S (S Z))))) +type Vec1 = Vec 1 +type Vec2 = Vec 2 +type Vec3 = Vec 3 +type Vec4 = Vec 4 +type Vec5 = Vec 5 +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 - show v = "fromList " ++ show (toList v) - 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 - overlaps (MVec v) (MVec u) = sameMutableByteArray v u - {-# INLINE overlaps #-} - new = do - v <- newByteArray $! arity (undefined :: n) * sizeOf (undefined :: a) + 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 (undefined :: 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 @@ -115,20 +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 = zipWith mappend - {-# INLINE mempty #-} - {-# INLINE mappend #-} +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 @@ -141,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,10 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- Storable-based unboxed vectors. module Data.Vector.Fixed.Storable ( @@ -28,19 +24,26 @@ import Control.Monad.Primitive import Control.DeepSeq (NFData(..)) 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 ( advancePtr, copyArray, moveArray ) -import GHC.ForeignPtr ( ForeignPtr(..), mallocPlainForeignPtrBytes ) +import Foreign.Marshal.Array ( copyArray, moveArray ) +import GHC.ForeignPtr ( mallocPlainForeignPtrBytes ) import GHC.Ptr ( Ptr(..) ) -import Prelude (Show(..),Eq(..),Ord(..),Num(..),Monad(..),IO,Int) -import Prelude ((++),(&&),(||),($),undefined,seq) +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,pure) import Data.Vector.Fixed hiding (index) -import Data.Vector.Fixed.Mutable -import qualified Data.Vector.Fixed.Cont as C +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 Data.Vector.Fixed.Cont (ArityPeano(..)) @@ -49,25 +52,21 @@ ---------------------------------------------------------------- -- | Storable-based vector with fixed length -newtype Vec n a = Vec (ForeignPtr a) +newtype Vec (n :: Nat) a = Vec (ForeignPtr a) -- | Storable-based mutable vector with fixed length -newtype MVec n s a = MVec (ForeignPtr a) - -#if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable Vec -deriving instance Typeable MVec -#else -deriving instance Typeable2 Vec -deriving instance Typeable3 MVec -#endif +newtype MVec (n :: Nat) s a = MVec (ForeignPtr a) -type Vec1 = Vec (S Z) -type Vec2 = Vec (S (S Z)) -type Vec3 = Vec (S (S (S Z))) -type Vec4 = Vec (S (S (S (S Z)))) -type Vec5 = Vec (S (S (S (S (S Z))))) +type Vec1 = Vec 1 +type Vec2 = Vec 2 +type Vec3 = Vec 3 +type Vec4 = Vec 4 +type Vec5 = Vec 5 +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,63 +95,47 @@ -- Instances ---------------------------------------------------------------- -instance (Arity n, Storable a, Show a) => Show (Vec n a) where - show v = "fromList " ++ show (toList v) - 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 - overlaps (MVec fp) (MVec fq) - = between p q (q `advancePtr` n) || between q p (p `advancePtr` n) - where - between x y z = x >= y && x < z - p = getPtr fp - q = getPtr fq - n = arity (undefined :: n) - {-# INLINE overlaps #-} - new = unsafePrimToPrim $ do - fp <- mallocVector $ arity (undefined :: n) + 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 (undefined :: 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 (undefined :: 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 @@ -159,33 +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 = zipWith mappend - {-# INLINE mempty #-} - {-# INLINE mappend #-} +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 (undefined :: 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 (undefined :: 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 (undefined :: 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 @@ -211,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,45 +1,57 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -- | --- 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.Monad -import Control.DeepSeq (NFData(..)) +import Control.Applicative (Const(..)) +import Control.DeepSeq (NFData(..)) +import Data.Bits import Data.Complex -import Data.Monoid (Monoid(..)) +import Data.Coerce import Data.Data -import Data.Int (Int8, Int16, Int32, Int64 ) -import Data.Word (Word,Word8,Word16,Word32,Word64) -import Foreign.Storable (Storable(..)) -import Prelude (Show(..),Eq(..),Ord(..),Int,Double,Float,Char,Bool(..)) -import Prelude ((++),(||),($),(.),seq) +import Data.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 Data.Primitive.Types (Prim) +import Foreign.Storable (Storable) +import GHC.TypeLits +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,S,Z,toList,eq,ord,replicate,zipWith,foldl, - defaultSizeOf,defaultAlignemnt,defaultPeek,defaultPoke - ) -import Data.Vector.Fixed.Mutable -import qualified Data.Vector.Fixed.Cont as C -import qualified Data.Vector.Fixed.Primitive as P +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 @@ -47,66 +59,72 @@ -- Data type ---------------------------------------------------------------- -data family Vec n a -data family MVec n s a - -#if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable Vec -deriving instance Typeable MVec -#else -deriving instance Typeable2 Vec -deriving instance Typeable3 MVec -#endif - -type Vec1 = Vec (S Z) -type Vec2 = Vec (S (S Z)) -type Vec3 = Vec (S (S (S Z))) -type Vec4 = Vec (S (S (S (S Z)))) -type Vec5 = Vec (S (S (S (S (S Z))))) - -class (Arity n, IVector (Vec n) a, MVector (MVec n) a) => Unbox n a - - ----------------------------------------------------------------- --- Generic instances ----------------------------------------------------------------- +-- | Adaptive array of dimension @n@ and containing elements of type +-- @a@. +newtype Vec (n :: Nat) a = Vec { getVecRepr :: VecRepr n a (EltRepr a) } -instance (Arity n, Show a, Unbox n a) => Show (Vec n a) where - show v = "fromList " ++ show (toList v) +type Vec1 = Vec 1 +type Vec2 = Vec 2 +type Vec3 = Vec 3 +type Vec4 = Vec 4 +type Vec5 = Vec 5 -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 = zipWith mappend - {-# INLINE mempty #-} - {-# INLINE mappend #-} +---------------------------------------------------------------- +-- Generic instances +---------------------------------------------------------------- +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 gunfold = C.gunfold @@ -119,269 +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 - overlaps _ _ = False - {-# INLINE overlaps #-} - 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 - overlaps (MV_Bool v) (MV_Bool w) = overlaps v w - {-# INLINE overlaps #-} - new = MV_Bool `liftM` new - {-# INLINE new #-} - copy (MV_Bool v) (MV_Bool w) = copy v w - {-# 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 { \ -; overlaps (con v) (con w) = overlaps v w \ -; new = con `liftM` new \ -; copy (con v) (con w) = copy v w \ -; move (con v) (con w) = move v w \ -; unsafeRead (con v) i = unsafeRead v i \ -; unsafeWrite (con v) i x = unsafeWrite v i x \ -; {-# INLINE overlaps #-} \ -; {-# INLINE new #-} \ -; {-# INLINE move #-} \ -; {-# INLINE copy #-} \ -; {-# 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 #-} \ -} +-- | 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 -#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) +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 -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) +---------------------------------------------------------------- +-- Newtypes +---------------------------------------------------------------- -primWrap(Char, V_Char, MV_Char ) -primWrap(Float, V_Float, MV_Float ) -primWrap(Double, V_Double, MV_Double) +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 ---------------------------------------------------------------- --- 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)) +-- Tuples +---------------------------------------------------------------- -instance (Unbox n a) => Unbox n (Complex a) +-- | Representation for vector of 2-tuple as two vectors. +data T2 n a b x = T2 !(Vec n a) !(Vec n b) -instance (Arity n, MVector (MVec n) a) => MVector (MVec n) (Complex a) where - overlaps (MV_Complex v) (MV_Complex w) = overlaps v w - {-# INLINE overlaps #-} - new = MV_Complex `liftM` new - {-# INLINE new #-} - copy (MV_Complex v) (MV_Complex w) = copy v w - {-# 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 #-} +type instance Dim (T2 n a b) = Peano n +type instance Dim (T2 n a b x) = Peano n -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 #-} +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) +data T_pair a b x y n = T_pair (Fun n a x) (Fun n b y) ----------------------------------------------------------------- --- 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) +-- | 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) -instance (Arity n, MVector (MVec n) a, MVector (MVec n) b) => MVector (MVec n) (a,b) where - overlaps (MV_2 va vb) (MV_2 wa wb) = overlaps va wa || overlaps vb wb - {-# INLINE overlaps #-} - new = do as <- new - bs <- new - return $ MV_2 as bs - {-# 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 #-} +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 #-} -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 #-} +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) -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 - overlaps (MV_3 va vb vc) (MV_3 wa wb wc) - = overlaps va wa || overlaps vb wb || overlaps vc wc - {-# INLINE overlaps #-} - new = do as <- new - bs <- new - cs <- new - 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 (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 -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 #-} +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,96 +1,179 @@ +Cabal-Version: 3.0 +Build-Type: Simple + Name: fixed-vector -Version: 0.8.1.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. - . - * Data.Vector.Fixed.Monomorphic - Wrappers for monomorphic vectors -Cabal-Version: >= 1.8 -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: - ChangeLog +extra-doc-files: + ChangeLog.md -source-repository head - type: hg - location: http://bitbucket.org/Shimuuar/fixed-vector +tested-with: + 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 +common language + Ghc-options: -Wall -Wno-incomplete-uni-patterns + Default-Language: Haskell2010 + 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 - Ghc-options: -Wall - Build-Depends: - base >=3 && <5, - deepseq, - primitive + 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.Monomorphic + 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 doctests +Test-Suite fixed-vector-doctests + Default-Language: Haskell2010 + if impl(ghc < 9.2) + buildable: False Type: exitcode-stdio-1.0 Hs-source-dirs: test Main-is: Doctests.hs - Build-Depends: - base >=3 && <5, - primitive, - -- Additional test dependencies. - doctest >= 0.9, - filemanip == 0.3.6.* + Build-Depends: base >=4.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) + ] + ]