fixed-vector 1.2.3.0 → 2.0.0.0

raw patch · 15 files changed

+1776/−1405 lines, 15 filesdep +fixed-vectordep +tastydep +tasty-inspection-testingdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: fixed-vector, tasty, tasty-inspection-testing, template-haskell

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• ChangeLog.md +164/−164
• Data/Vector/Fixed.hs +255/−166
• Data/Vector/Fixed/Boxed.hs +63/−105
• Data/Vector/Fixed/Cont.hs +457/−278
• Data/Vector/Fixed/Generic.hs +0/−1
• Data/Vector/Fixed/Internal.hs +69/−59
• Data/Vector/Fixed/Mutable.hs +89/−77
• Data/Vector/Fixed/Primitive.hs +34/−75
• Data/Vector/Fixed/Storable.hs +62/−83
• Data/Vector/Fixed/Strict.hs +124/−0
• Data/Vector/Fixed/Unboxed.hs +207/−382
• fixed-vector.cabal +84/−14
• test/Doctests.hs +57/−1
• test/Inspect/Obligations.hs +20/−0
• test/inspect.hs +91/−0

@@ -1,235 +1,235 @@-Changes in 1.2.3.0+2.0.0.0 [2025.07.10]+------------------+* Type family `Dim` returns Peano numbers instead of standard type level+  naturals. -  * Pattern `V1` added+  - `Index` type class restored and all indexing operation are performed in+  - `Arity` simplified+  - `CVecPeano` dropped and `ContVec` is parameterized using Peano numbers. -  * `COMPLETE` pragmas added for patterns `V1`,`V2`,`V3`,`V4`+* 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. -Changes in 1.2.2.1+* `Data.Vector.Fixed.Cont.arity` dropped. -  * Newtype `StorableViaFixed` for deriving `Storable` instances added.+* Type of `D.V.F.Cont.withFun` generalized. +* Type class `VectorN` dropped. Use `QuantifiedConstraints` instead. -Changes in 1.2.1.1+* Show instance now has form `[...]` instead of `fromList [...]`. -  * Fixed bug in `any` (#18)+* `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. -Changes in 1.2.1.0+* `Data.Vector.Fixed.sequenceA` is deprecated in favor of `sequence`. -  * Support for GHC7.10 dropped.+* `foldl'` and `ifoldl'` functions added. -  * Pattern synonyms `V2`,`V3`,`V4` added.+* Implement `sum` as in terms of `foldl'`. -  * `replicate{,M}` and `generate{,M}` added. -  * Functions `mk6`, `mk7`, `mk8` added.+1.2.3.0 [2023-10-31]+--------------------+* Pattern `V1` added+* `COMPLETE` pragmas added for patterns `V1`,`V2`,`V3`,`V4`  -Changes in 1.2.0.0+1.2.2.1 [2022-12-29]+--------------------+* Newtype `StorableViaFixed` for deriving `Storable` instances added. -  * `Show` instance for data type now respect precedence. -Changes in 1.1.0.0+1.2.1.1 [2022-12-26]+--------------------+* Fixed bug in `any` (#18) -  * GHC8.4 compatibility release. Semigroup instances added and-    semigroup dependency added for GHC7.10 -Changes in 1.0.0.0+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. -  * Vector length now expressed as GHC's type level literals. Underlying-    implementation still uses Peano numbers to perform induction. This doesn't-    change user facing API much. Notably `FlexibleInstances` and-    `GADTs`/`TypeFamiles` are now required to write `Arity` constraint. -  * `Monad` constraint is relaxed to `Applicative` where applicable. Duplicate-    functions are removed (`sequence` & `sequenceA` → `sequence`, etc)+1.2.0.0 [2018-09-02]+--------------------+* `Show` instance for data type now respect precedence. -  * Module `Data.Vector.Fixed.Monomorphic` is dropped. -  * Construction of N-ary vectors reworked. `Make` type class is gone.+1.1.0.0 [2018-03-11]+--------------------+* GHC8.4 compatibility release. Semigroup instances added and+  semigroup dependency added for GHC7.10 -  * Boxed arrays now use SmallArrays internally. -  * `overlaps` is removed from API for mutable vectors.--  * `Data.Vector.Fixed.defaultRnf` is added.--  * `Data.Vector.Fixed.Mutable.lengthI` is dropped.--Changes in 0.9.0.0--  * Simplification of `Arity` type class. This change shouldn't affect client-    code.--  * Support for GHC < 7.8 is droppped.--  * Fixed bug in `any`.+1.0.0.0 [2017-11-06]+--------------------+* Vector length now expressed as GHC's type level literals. Underlying+  implementation still uses Peano numbers to perform induction. This doesn't+  change user facing API much. Notably `FlexibleInstances` and+  `GADTs`/`TypeFamiles` are now required to write `Arity` constraint.+* `Monad` constraint is relaxed to `Applicative` where applicable. Duplicate+  functions are removed (`sequence` & `sequenceA` → `sequence`, etc)+* Module `Data.Vector.Fixed.Monomorphic` is dropped.+* Construction of N-ary vectors reworked. `Make` type class is gone.+* Boxed arrays now use SmallArrays internally.+* `overlaps` is removed from API for mutable vectors.+* `Data.Vector.Fixed.defaultRnf` is added.+* `Data.Vector.Fixed.Mutable.lengthI` is dropped.  -Changes in 0.8.1.0--  * `find` function added.+0.9.0.0 [2016-09-14]+--------------------+* Simplification of `Arity` type class. This change shouldn't affect client+  code.+* Support for GHC < 7.8 is droppped.+* Fixed bug in `any`.  -Changes in 0.8.0.0--  * NFData instances for all data type.--  * Storable instances for all data types and default implementation of-    Storable's methods added.--  * {i,}zipWith3 and {i,}zipWithM_ added.+0.8.1.0 [2015-08-27]+--------------------+* `find` function added.  -Changes in 0.7.0.3--  * GHC 7.10 support+0.8.0.0 [2015-04-06]+--------------------+* NFData instances for all data type.+* Storable instances for all data types and default implementation of+  Storable's methods added.+* {i,}zipWith3 and {i,}zipWithM_ added.  -Changes in 0.7.0.0--  * Type level addition for unary numbers added--  * `concat` function added--  * More consistent naming for functions for working with `Fun`+0.7.0.3 [2015-01-03]+--------------------+* GHC 7.10 support  -Changes in 0.6.4.0--  * Isomorphism between Peano numbers and Nat added. (GHC >= 7.8)+0.7.0.0 [2014-08-15]+--------------------+* Type level addition for unary numbers added+* `concat` function added+* More consistent naming for functions for working with `Fun`  -Changes in 0.6.3.1--  * Documentation fixes.+0.6.4.0 [2014-04-15]+--------------------+* Isomorphism between Peano numbers and Nat added. (GHC >= 7.8)  -Changes in 0.6.3.0--  * Left scans added.+0.6.3.1 [2014-03-12]+--------------------+* Documentation fixes.  -Changes in 0.6.2.0--  * `Vec1` type synonym for boxed/unboxed/etc. vectors added.--  * Vector instance for Data.Typeable.Proxy (GHC >= 7.8)+0.6.3.0 [2014-02-22]+--------------------+* Left scans added.  -Changes in 0.6.1.1--  * GHC 7.8 support+0.6.2.0 [2014-02-07]+--------------------+* `Vec1` type synonym for boxed/unboxed/etc. vectors added.+* Vector instance for Data.Typeable.Proxy (GHC >= 7.8)  -Changes in 0.6.1.0--  * `distribute` `collect` and their monadic variants added.+0.6.1.1 [2014-02-04]+--------------------+* GHC 7.8 support  -Changes in 0.6.0.0--  * Data instance for all array-based vectors added.--  * Storable instance added for `Storable.Vec`.--  * Monoid instances added for all vectors.+0.6.1.0 [2014-01-24]+--------------------+* `distribute` `collect` and their monadic variants added.  -Changes in 0.5.1.0+0.6.0.0 [2013-11-17]+--------------------+* Data instance for all array-based vectors added.+* Storable instance added for `Storable.Vec`.+* Monoid instances added for all vectors. -  * Zero-element vector `Empty'`is added.+0.5.1.0 [2013-08-06]+--------------------+* Zero-element vector `Empty'`is added.  -Changes in 0.5.0.0--  * `ContVec` now behaves like normal vector. `Arity` type class is-    reworked. `Id' data type is removed.--  * Construction of vector reworked.--  * `reverse`, `snoc`, `consV`, `fold` and `foldMap` are added.--  * Type changing maps and zips are added.--  * Vector indexing with type level numbers is added.--  * Twan van Laarhoven's lens added. (`element` and `elementTy`)--  * Ord instances added to vector data types defined in the library.+0.5.0.0 [2013-08-02]+--------------------+* `ContVec` now behaves like normal vector. `Arity` type class is+  reworked. `Id` data type is removed.+* Construction of vector reworked.+* `reverse`, `snoc`, `consV`, `fold` and `foldMap` are added.+* Type changing maps and zips are added.+* Vector indexing with type level numbers is added.+* Twan van Laarhoven's lens added. (`element` and `elementTy`)+* Ord instances added to vector data types defined in the library.  -Changes in 0.4.4.0--  * Functor and Applicative instances are added to Id.+0.4.4.0 [2013-06-13]+--------------------+* Functor and Applicative instances are added to Id.  -Changes in 0.4.3.0--  * Typeable instance for S and Z added.+0.4.3.0 [2013-05-18]+--------------------+* Typeable instance for S and Z added.  -Changes in 0.4.2.0--  * 1-tuple `Only` added.--  * `fromList'` and fromListM added.--  * apply functions from Arity type class generalized.+0.4.2.0 [2013-05-01]+--------------------+* 1-tuple `Only` added.+* `fromList'` and fromListM added.+* apply functions from Arity type class generalized.  -Changes in 0.4.1.0--  * `cons` function added.--  * Getter for `Fun` data type added.+0.4.1.0 [2013-04-29]+--------------------+* `cons` function added.+* Getter for `Fun` data type added.  -Changes in 0.4.0.0--  * Wrapper for monomorphics vectors is added.--  * `VecList` is reimplemented as GADT and constructors are exported.--  * Constructor of `ContVecT` is exported--  * Empty `ContVecT` is implemented as `empty`.--  * Typeable, Foldable and Traversable instances are added where-    appropriate+0.4.0.0 [2013-04-04]+--------------------+* Wrapper for monomorphics vectors is added.+* `VecList` is reimplemented as GADT and constructors are exported.+* Constructor of `ContVecT` is exported+* Empty `ContVecT` is implemented as `empty`.+* Typeable, Foldable and Traversable instances are added where+  appropriate  -Changes in 0.3.0.0--  * Vector type class definition is moved to the D.V.F.Cont module.--  * Indexing function restored.--  * `unfoldr` added.+0.3.0.0 [2013-03-06]+--------------------+* Vector type class definition is moved to the D.V.F.Cont module.+* Indexing function restored.+* `unfoldr` added.  -Changes in 0.2.0.0--  * Continuation-based vector added.--  * Right fold added.--  * tailWith, convertContinuation, and ! from-    Data.Vector.Fixed removed.--  * Vector instance for tuples added.+0.2.0.0 [2013-02-10]+--------------------+* Continuation-based vector added.+* Right fold added.+* tailWith, convertContinuation, and ! from+  Data.Vector.Fixed removed.+* Vector instance for tuples added.  -Changes in 0.1.2--  * imap, imapM, ifoldl, ifoldM, zipWithM, izipWithM-    functions are added.--  * VectorN type class added.+0.1.2 [2013-01-26]+------------------+* imap, imapM, ifoldl, ifoldM, zipWithM, izipWithM+  functions are added.+* VectorN type class added.  -Changes in 0.1.1--  * foldM and tailWith added. Type synonyms for numbers up to 6 are-    added. Fun is reexported from Data.Vector.Fixed.+0.1.1 [2012-11-29]+------------------+* foldM and tailWith added. Type synonyms for numbers up to 6 are+  added. Fun is reexported from Data.Vector.Fixed.

@@ -1,37 +1,44 @@ {-# LANGUAGE CPP                   #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE DeriveDataTypeable    #-}-{-# LANGUAGE DeriveFoldable        #-}-{-# LANGUAGE DeriveFunctor         #-}-{-# LANGUAGE DeriveTraversable     #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternSynonyms       #-} {-# LANGUAGE PolyKinds             #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE StandaloneDeriving    #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE UndecidableInstances  #-}-{-# LANGUAGE ViewPatterns          #-} -- |--- Generic API for vectors with fixed length.+-- @fixed-vector@ library provides general API for working with short+-- N-element arrays. Functions in this module work on data types which+-- are instances of 'Vector' type class. We provide instances for data+-- types from @base@: tuples, 'Data.Complex.Complex', and few others.+-- There are several length polymorphic arrays: ----- For encoding of vector size library uses Peano naturals defined in--- the library. At come point in the future it would make sense to--- switch to new GHC type level numerals.+--  * Lazy boxed arrays "Data.Vector.Fixed.Boxed". ----- [@Common pitfalls@]+--  * Strict boxed arrays "Data.Vector.Fixed.Strict". ----- Library provide instances for tuples. But there's a catch. Tuples--- are monomorphic in element type. Let consider 2-tuple @(Int,Int)@.--- Vector type @v@ is @(,) Int@ and only allowed element type is--- @Int@.  Because of that we cannot change element type and following--- code will fail:+--  * Arrays backed by single @ByteArray@: "Data.Vector.Fixed.Primitive". --+--  * Arrays backed by pinned memory: "Data.Vector.Fixed.Storable".+--+--  * Arrays which infer array representation from element data type:+--    "Data.Vector.Fixed.Unboxed"+--+--  * Continuation based 'Data.Vector.Fixed.Cont.ContVec' which used+--    by library internally.+--+-- Type level naturals don't have support for induction so all type+-- level computation with length and indices are done using Peano+-- numerals ('PeanoNum'). Type level naturals are only used as type+-- parameters for defining length of arrays.+--+-- [@Instances for tuples@]+--+-- Library provides instances for tuples. They however come with caveat.+-- Let look at 'Vector' instance for 2-tuple:+--+-- > instance b ~ a => Vector ((,) b) a+--+-- Tuple could only be @Vector@ instance if all elements have same+-- type.  so first element fixes type of second one. Thus functions+-- which change element type like 'map' won't work:+-- -- > >>> map (== 1) ((1,2) :: (Int,Int)) -- > -- > <interactive>:3:1:@@ -39,25 +46,29 @@ -- >     In the expression: F.map (== 1) ((1, 2) :: (Int, Int)) -- >     In an equation for `it': it = map (== 1) ((1, 2) :: (Int, Int)) ----- To make it work we need to change vector type as well. Functions--- from module "Data.Vector.Fixed.Generic" provide this functionality.+-- This could be solved either by switching to @ContVec@ manually: ----- > >>> map (== 1) ((1,2) :: (Int,Int)) :: (Bool,Bool)--- > (True,False)+-- >>> (vector . map (==1) . cvec) ((1, 2) :: Tuple2 Int) :: Tuple2 Bool+-- (True,False)+--+-- or by using functions genereic in vector type from module+-- "Data.Vector.Fixed.Generic". module Data.Vector.Fixed (     -- * Vector type class-    -- ** Vector size-    Dim-    -- ** Type class-  , Vector(..)-  , VectorN+    Vector(..)+  , Dim   , Arity+  , ArityPeano   , Fun(..)   , length-    -- * Constructors+    -- ** Peano numbers+  , PeanoNum(..)+  , C.Peano+  , C.N1, C.N2, C.N3, C.N4, C.N5, C.N6, C.N7, C.N8+    -- * Construction and destructions     -- $construction-    -- ** Small dimensions-    -- $smallDim++    -- ** Constructors   , mk0   , mk1   , mk2@@ -68,24 +79,19 @@   , mk7   , mk8   , mkN-    -- ** Pattern for low-dimension vectors+    -- ** Pattern synonyms   , pattern V1   , pattern V2   , pattern V3   , pattern V4-    -- ** Continuation-based vectors-  , ContVec-  , empty-  , vector-  , C.cvec-    -- ** Functions+    -- * Functions+    -- ** Creation   , replicate   , replicateM   , generate   , generateM   , unfoldr   , basis-    -- * Modifying vectors     -- ** Transformations   , head   , tail@@ -94,15 +100,12 @@   , concat   , reverse     -- ** Indexing & lenses-  -- , C.Index+  , C.Index   , (!)   , index   , set   , element   , elementTy-    -- ** Comparison-  , eq-  , ord     -- ** Maps   , map   , mapM@@ -114,12 +117,12 @@   , scanl1   , sequence   , sequence_-  , sequenceA   , traverse   , distribute   , collect-    -- * Folding+    -- ** Folds   , foldl+  , foldl'   , foldr   , foldl1   , fold@@ -128,7 +131,7 @@   , ifoldr   , foldM   , ifoldM-    -- ** Special folds+    -- *** Special folds   , sum   , maximum   , minimum@@ -137,7 +140,7 @@   , all   , any   , find-    -- * Zips+    -- ** Zips   , zipWith   , zipWith3   , zipWithM@@ -146,16 +149,10 @@   , izipWith3   , izipWithM   , izipWithM_-    -- * Storable methods-    -- $storable-  , StorableViaFixed(..)-  , defaultAlignemnt-  , defaultSizeOf-  , defaultPeek-  , defaultPoke-    -- * NFData-  , defaultRnf-    -- * Conversion+    -- *** Special zips+  , eq+  , ord+    -- ** Conversion   , convert   , toList   , fromList@@ -172,26 +169,42 @@   , 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.Applicative (Applicative(..)) import Control.DeepSeq     (NFData(..)) import Data.Coerce-import Data.Data           (Typeable,Data)+import Data.Data           (Data) import Data.Monoid         (Monoid(..)) import Data.Semigroup      (Semigroup(..))-import qualified Data.Foldable    as F-import qualified Data.Traversable as T-import Foreign.Storable (Storable(..))-import Foreign.Ptr      (castPtr)+import Data.Foldable       qualified as F+import Data.Traversable    qualified as T+import Foreign.Storable    (Storable(..)) import GHC.TypeLits -import Data.Vector.Fixed.Cont     (Vector(..),VectorN,Dim,length,ContVec,PeanoNum(..),-                                   vector,empty,Arity,Fun(..),accum,apply,vector)-import qualified Data.Vector.Fixed.Cont as C-import Data.Vector.Fixed.Internal+import Data.Vector.Fixed.Cont     (Vector(..),Dim,length,ContVec,PeanoNum(..),+                                   vector,cvec,empty,Arity,ArityPeano,Fun(..),accum,apply)+import Data.Vector.Fixed.Cont     qualified as C+import Data.Vector.Fixed.Internal as I -import Prelude (Show(..),Eq(..),Ord(..),Functor(..),id,(.),($),undefined)+import Prelude (Show(..),Eq(..),Ord(..),Num(..),Functor(..),id,(.),($),(<$>))   -- $construction@@ -203,28 +216,26 @@ -- >>> mk3 'a' 'b' 'c' :: (Char,Char,Char) -- ('a','b','c') ----- Alternatively one could use 'mkN'. See its documentation for--- examples.+-- Another way is to use pattern synonyms for construction and+-- inspection of vectors: ----- Another option is to create tuple and 'convert' it to desired--- vector type. For example:+-- >>> V2 'a' 'b' :: (Char,Char)+-- ('a','b') ----- > v = convert (x,y,z)+-- >>> case ('a','b') of V2 a b -> [a,b]+-- "ab" ----- It will work on if type of @v@ is know from elsewhere. Same trick--- could be used to pattern match on the vector with opaque--- representation using view patterns+-- Last option is to use 'convert' to convert between different vector+-- types of same length. For example ----- > function :: Vec N3 Double -> ...--- > function (convert -> (x,y,z)) = ...+-- > v = convert (x,y,z) ----- For small vectors pattern synonyms @V2@, @V3$, @V4@ are provided--- that use same trick internally.----- $smallDim+-- This could be used in view patterns as well: ----- Constructors for vectors with small dimensions.+-- > foo :: Vec3 Double -> Foo+-- > foo (convert -> (x,y,z)) = ...+--+-- Pattern synonyms use this trick internally.   -- $storable@@ -233,7 +244,6 @@ -- that individual elements of vector are stored as N-element array.  - -- | Type-based vector with statically known length parametrized by --   GHC's type naturals newtype VecList (n :: Nat) a = VecList (VecPeano (C.Peano n) a)@@ -243,88 +253,85 @@ data VecPeano (n :: PeanoNum) a where   Nil  :: VecPeano 'Z a   Cons :: a -> VecPeano n a -> VecPeano ('S n) a-  deriving (Typeable) -instance (Arity n, NFData a) => NFData (VecList n a) where-  rnf = defaultRnf-  {-# INLINE rnf #-}--type instance Dim (VecList n) = n+type instance Dim (VecList  n) = C.Peano n+type instance Dim (VecPeano n) = n  instance Arity n => Vector (VecList n) a where-  construct = fmap VecList $ accum+  construct = VecList <$> construct @(VecPeano (C.Peano n)) @a+  inspect (VecList v) = inspect v+  {-# INLINE construct #-}+  {-# INLINE inspect   #-}++instance C.ArityPeano n => Vector (VecPeano n) a where+  construct = accum     (\(T_List f) a -> T_List (f . Cons a))     (\(T_List f)   -> f Nil)-    (T_List id :: T_List a (C.Peano n) (C.Peano n))-  inspect (VecList v)+    (T_List id :: T_List a n n)+  inspect v     = inspect (apply step (Flip v) :: C.ContVec n a)     where       step :: Flip VecPeano a ('S k)  -> (a, Flip VecPeano a k)       step (Flip (Cons a xs)) = (a, Flip xs)   {-# INLINE construct #-}   {-# INLINE inspect   #-}-instance Arity n => VectorN VecList n a  newtype Flip f a n = Flip (f n a) newtype T_List a n k = T_List (VecPeano k a -> VecPeano n a)  --- Standard instances-instance (Show a, Arity n) => Show (VecList n a) where-  show = show . foldr (:) []-instance (Eq a, Arity n) => Eq (VecList n a) where-  (==) = eq-instance (Ord a, Arity n) => Ord (VecList n a) where-  compare = ord-instance Arity n => Functor (VecList n) where-  fmap = map-instance Arity n => Applicative (VecList n) where-  pure  = replicate-  (<*>) = zipWith ($)-instance Arity n => F.Foldable (VecList n) where-  foldr = foldr++deriving via ViaFixed (VecList n) instance (Arity n) => Functor     (VecList n)+deriving via ViaFixed (VecList n) instance (Arity n) => Applicative (VecList n)+deriving via ViaFixed (VecList n) instance (Arity n) => F.Foldable  (VecList n)+ instance Arity n => T.Traversable (VecList n) where-  sequenceA = sequenceA-  traverse  = traverse-instance (Arity n, Monoid a) => Monoid (VecList n a) where-  mempty  = replicate mempty-  mappend = (<>)-  {-# INLINE mempty  #-}-  {-# INLINE mappend #-}+  sequence  = sequence+  sequenceA = sequence+  traverse  = mapM+  mapM      = mapM+  {-# INLINE sequence  #-}+  {-# INLINE sequenceA #-}+  {-# INLINE mapM      #-}+  {-# INLINE traverse  #-} -instance (Arity n, Semigroup a) => Semigroup (VecList n a) where-  (<>) = zipWith (<>)-  {-# INLINE (<>) #-}+deriving via ViaFixed (VecList n) a instance (Arity n, Show      a) => Show      (VecList n a)+deriving via ViaFixed (VecList n) a instance (Arity n, Eq        a) => Eq        (VecList n a)+deriving via ViaFixed (VecList n) a instance (Arity n, Ord       a) => Ord       (VecList n a)+deriving via ViaFixed (VecList n) a instance (Arity n, NFData    a) => NFData    (VecList n a)+deriving via ViaFixed (VecList n) a instance (Arity n, Semigroup a) => Semigroup (VecList n a)+deriving via ViaFixed (VecList n) a instance (Arity n, Monoid    a) => Monoid    (VecList n a)+deriving via ViaFixed (VecList n) a instance (Arity n, Storable  a) => Storable  (VecList n a)  -instance (Storable a, Arity n) => Storable (VecList n a) where-  alignment = defaultAlignemnt-  sizeOf    = defaultSizeOf-  peek      = defaultPeek-  poke      = defaultPoke-  {-# INLINE alignment #-}-  {-# INLINE sizeOf    #-}-  {-# INLINE peek      #-}-  {-# INLINE poke      #-} --- | Newtype for deriving 'Storable' instance for data types which has---   instance of 'Vector'-newtype StorableViaFixed v a = StorableViaFixed (v a)+deriving via ViaFixed (VecPeano n) instance (ArityPeano n) => Functor     (VecPeano n)+deriving via ViaFixed (VecPeano n) instance (ArityPeano n) => Applicative (VecPeano n)+deriving via ViaFixed (VecPeano n) instance (ArityPeano n) => F.Foldable  (VecPeano n) -instance (Vector v a, Storable a) => Storable (StorableViaFixed v a) where-  alignment = coerce (defaultAlignemnt @a @v)-  sizeOf    = coerce (defaultSizeOf    @a @v)-  peek      = coerce (defaultPeek      @a @v)-  poke      = coerce (defaultPoke      @a @v)-  {-# INLINE alignment #-}-  {-# INLINE sizeOf    #-}-  {-# INLINE peek      #-}-  {-# INLINE poke      #-}+instance ArityPeano n => T.Traversable (VecPeano n) where+  sequence  = sequence+  sequenceA = sequence+  traverse  = mapM+  mapM      = mapM+  {-# INLINE sequence  #-}+  {-# INLINE sequenceA #-}+  {-# INLINE mapM      #-}+  {-# INLINE traverse  #-} +deriving via ViaFixed (VecPeano n) a instance (ArityPeano n, Show      a) => Show      (VecPeano n a)+deriving via ViaFixed (VecPeano n) a instance (ArityPeano n, Eq        a) => Eq        (VecPeano n a)+deriving via ViaFixed (VecPeano n) a instance (ArityPeano n, Ord       a) => Ord       (VecPeano n a)+deriving via ViaFixed (VecPeano n) a instance (ArityPeano n, NFData    a) => NFData    (VecPeano n a)+deriving via ViaFixed (VecPeano n) a instance (ArityPeano n, Semigroup a) => Semigroup (VecPeano n a)+deriving via ViaFixed (VecPeano n) a instance (ArityPeano n, Monoid    a) => Monoid    (VecPeano n a)+deriving via ViaFixed (VecPeano n) a instance (ArityPeano n, Storable  a) => Storable  (VecPeano n a) ++ -- | Single-element tuple. newtype Only a = Only a-                 deriving (Show,Eq,Ord,Typeable,Data,Functor,F.Foldable,T.Traversable)+                 deriving (Show,Eq,Ord,Data,Functor,F.Foldable,T.Traversable)  instance Monoid a => Monoid (Only a) where   mempty  = Only mempty@@ -337,7 +344,7 @@ instance NFData a => NFData (Only a) where   rnf (Only a) = rnf a -type instance Dim Only = 1+type instance Dim Only = C.N1  instance Vector Only a where   construct = Fun Only@@ -346,24 +353,20 @@   {-# INLINE inspect   #-}  instance (Storable a) => Storable (Only a) where-  alignment _ = alignment (undefined :: a)-  sizeOf    _ = sizeOf    (undefined :: a)-  peek p          = Only <$> peek (castPtr p)-  poke p (Only a) = poke (castPtr p) a-  {-# INLINE alignment #-}-  {-# INLINE sizeOf    #-}-  {-# INLINE peek      #-}-  {-# INLINE poke      #-}+  alignment = coerce (alignment @a)+  sizeOf    = coerce (sizeOf    @a)+  peek      = coerce (peek      @a)+  poke      = coerce (poke      @a)   -- | Empty tuple. data Empty a = Empty-  deriving (Show,Eq,Ord,Typeable,Data,Functor,F.Foldable,T.Traversable)+  deriving (Show,Eq,Ord,Data,Functor,F.Foldable,T.Traversable)  instance NFData (Empty a) where   rnf Empty = () -type instance Dim Empty = 0+type instance Dim Empty = 'Z  instance Vector Empty a where   construct = Fun Empty@@ -378,10 +381,98 @@   ----------------------------------------------------------------+-- 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++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, 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      #-}++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+  {-# INLINE foldMap' #-}+  {-# INLINE foldr    #-}+  {-# INLINE foldl    #-}+  {-# INLINE foldl'   #-}+  {-# INLINE toList   #-}+  {-# INLINE sum      #-}+  {-# INLINE product  #-}+-- GHC<9.2 fails to compile this+#if MIN_VERSION_base(4,16,0)+  length = length+  {-# INLINE length #-}+#endif+++---------------------------------------------------------------- -- Patterns ---------------------------------------------------------------- -pattern V1 :: (Vector v a, Dim v ~ 1) => a -> v a+pattern V1 :: (Vector v a, Dim v ~ C.N1) => a -> v a pattern V1 x <- (convert -> (Only x)) where   V1 x = mk1 x #if MIN_VERSION_base(4,16,0)@@ -389,7 +480,7 @@ {-# COMPLETE V1 #-} #endif -pattern V2 :: (Vector v a, Dim v ~ 2) => a -> a -> v a+pattern V2 :: (Vector v a, Dim v ~ C.N2) => a -> a -> v a pattern V2 x y <- (convert -> (x,y)) where   V2 x y = mk2 x y #if MIN_VERSION_base(4,16,0)@@ -397,7 +488,7 @@ {-# COMPLETE V2 #-} #endif -pattern V3 :: (Vector v a, Dim v ~ 3) => a -> a -> a -> v a+pattern V3 :: (Vector v a, Dim v ~ C.N3) => a -> a -> a -> v a pattern V3 x y z <- (convert -> (x,y,z)) where   V3 x y z = mk3 x y z #if MIN_VERSION_base(4,16,0)@@ -405,7 +496,7 @@ {-# COMPLETE V3 #-} #endif -pattern V4 :: (Vector v a, Dim v ~ 4) => a -> a -> a -> a -> v a+pattern V4 :: (Vector v a, Dim v ~ C.N4) => a -> a -> a -> a -> v a pattern V4 t x y z <- (convert -> (t,x,y,z)) where   V4 t x y z = mk4 t x y z #if MIN_VERSION_base(4,16,0)@@ -413,9 +504,7 @@ {-# COMPLETE V4 #-} #endif --- -- $setup -- -- >>> import Data.Char+-- >>> import Prelude (Int,Bool(..))

@@ -1,14 +1,8 @@-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE DeriveDataTypeable    #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE StandaloneDeriving    #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE MagicHash            #-}+{-# 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@@ -31,100 +25,90 @@ 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,seq)+               , ($!),error,(<$>))  import Data.Vector.Fixed hiding (index)-import Data.Vector.Fixed.Mutable (Mutable, MVector(..), IVector(..), DimM, constructVec, inspectVec, arity, index)+import Data.Vector.Fixed.Mutable (Mutable, MVector(..), IVector(..), DimM, constructVec, inspectVec, index) import qualified Data.Vector.Fixed.Cont     as C-import qualified Data.Vector.Fixed.Internal as I-+import           Data.Vector.Fixed.Cont     (ArityPeano(..))   ---------------------------------------------------------------- -- Data type ---------------------------------------------------------------- --- | Vector with fixed length which can hold any value.+-- | Vector with fixed length which can hold any value. It's lazy and+--   doesn't evaluate elements. newtype Vec (n :: Nat) a = Vec (SmallArray a)  -- | Mutable unboxed vector with fixed length newtype MVec (n :: Nat) s a = MVec (SmallMutableArray s a) -deriving instance Typeable Vec-deriving instance Typeable MVec- type Vec1 = Vec 1 type Vec2 = Vec 2 type Vec3 = Vec 3 type Vec4 = Vec 4 type Vec5 = Vec 5 --instance (Typeable n, Arity n, Data a) => Data (Vec n a) where-  gfoldl       = C.gfoldl-  gunfold      = C.gunfold-  toConstr   _ = con_Vec-  dataTypeOf _ = ty_Vec--ty_Vec :: DataType-ty_Vec  = mkDataType "Data.Vector.Fixed.Boxed.Vec" [con_Vec]--con_Vec :: Constr-con_Vec = mkConstr ty_Vec "Vec" [] Prefix--instance (Storable a, Arity n) => Storable (Vec n a) where-  alignment = defaultAlignemnt-  sizeOf    = defaultSizeOf-  peek      = defaultPeek-  poke      = defaultPoke-  {-# INLINE alignment #-}-  {-# INLINE sizeOf    #-}-  {-# INLINE peek      #-}-  {-# INLINE poke      #-}--+type instance Mutable (Vec  n) = MVec n+type instance Dim     (Vec  n) = Peano n+type instance DimM    (MVec n) = Peano n   ---------------------------------------------------------------- -- Instances ---------------------------------------------------------------- -instance (Arity n, Show a) => Show (Vec n a) where-  showsPrec = I.showsPrec+deriving via ViaFixed (Vec n) instance Arity n => Functor    (Vec n)+deriving via ViaFixed (Vec n) instance Arity n => Applicative (Vec n)+deriving via ViaFixed (Vec n) instance Arity n => F.Foldable  (Vec n) -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)  instance (Arity n) => MVector (MVec n) a where-  new = do-    v <- newSmallArray (arity (Proxy :: Proxy n)) uninitialised-    return $ MVec v-  {-# INLINE new         #-}-  copy = move-  {-# INLINE copy        #-}-  move (MVec dst) (MVec src) = copySmallMutableArray dst 0 src 0 (arity (Proxy :: Proxy n))-  {-# INLINE move        #-}-  unsafeRead  (MVec v) i   = readSmallArray  v i-  {-# INLINE unsafeRead  #-}-  unsafeWrite (MVec v) i x = writeSmallArray v i x-  {-# INLINE unsafeWrite #-}+  basicNew =+    MVec <$> newSmallArray (peanoToInt (proxy# @(Peano n))) uninitialised+  basicReplicate a =+    MVec <$> newSmallArray (peanoToInt (proxy# @(Peano n))) a+  basicCopy (MVec dst) (MVec src) =+    copySmallMutableArray dst 0 src 0 (peanoToInt (proxy# @(Peano n)))+  basicClone (MVec src) =+    MVec <$> cloneSmallMutableArray src 0 (peanoToInt (proxy# @(Peano n)))+  basicUnsafeRead  (MVec v) i   = readSmallArray  v i+  basicUnsafeWrite (MVec v) i x = writeSmallArray v i x+  {-# INLINE basicNew         #-}+  {-# INLINE basicReplicate   #-}+  {-# INLINE basicCopy        #-}+  {-# INLINE basicClone       #-}+  {-# INLINE basicUnsafeRead  #-}+  {-# INLINE basicUnsafeWrite #-}  instance (Arity n) => IVector (Vec n) a where-  unsafeFreeze (MVec v)   = do { a <- unsafeFreezeSmallArray v; return $! Vec  a }-  unsafeThaw   (Vec  v)   = do { a <- unsafeThawSmallArray   v; return $! MVec a }+  basicUnsafeFreeze (MVec v) = do { a <- unsafeFreezeSmallArray v; return $! Vec  a }+  basicThaw         (Vec  v) =+    MVec <$> thawSmallArray v 0 (peanoToInt (proxy# @(Peano n)))   unsafeIndex  (Vec  v) i = indexSmallArray v i-  {-# INLINE unsafeFreeze #-}-  {-# INLINE unsafeThaw   #-}-  {-# INLINE unsafeIndex  #-}----type instance Dim  (Vec  n) = n-type instance DimM (MVec n) = n+  {-# INLINE basicUnsafeFreeze #-}+  {-# INLINE basicThaw         #-}+  {-# INLINE unsafeIndex       #-}  instance (Arity n) => Vector (Vec n) a where   construct  = constructVec@@ -133,44 +117,18 @@   {-# INLINE construct  #-}   {-# INLINE inspect    #-}   {-# INLINE basicIndex #-}-instance (Arity n) => VectorN Vec n a -instance (Arity n, Eq a) => Eq (Vec n a) where-  (==) = eq-  {-# INLINE (==) #-}-instance (Arity n, Ord a) => Ord (Vec n a) where-  compare = ord-  {-# INLINE compare #-}--instance (Arity n, Monoid a) => Monoid (Vec n a) where-  mempty  = replicate mempty-  mappend = (<>)-  {-# INLINE mempty  #-}-  {-# INLINE mappend #-}--instance (Arity n, Semigroup a) => Semigroup (Vec n a) where-  (<>) = zipWith (<>)-  {-# INLINE (<>) #-}--instance Arity n => Functor (Vec n) where-  {-# INLINE fmap #-}-  fmap = map--instance Arity n => 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"

@@ -1,18 +1,7 @@-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE DeriveDataTypeable    #-}-{-# LANGUAGE EmptyDataDecls        #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE InstanceSigs          #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds             #-}-{-# LANGUAGE Rank2Types            #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE MagicHash            #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE UndecidableInstances #-} -- | -- API for Church-encoded vectors. Implementation of function from -- "Data.Vector.Fixed" module uses these function internally in order@@ -20,6 +9,7 @@ module Data.Vector.Fixed.Cont (     -- * Type-level numbers     PeanoNum(..)+  , N1,N2,N3,N4,N5,N6,N7,N8   , Peano   , Add     -- * N-ary functions@@ -27,9 +17,9 @@   , Fun(..)   , Arity   , ArityPeano(..)-  , arity   , apply   , applyM+  , Index(..)     -- ** Combinators   , constFun   , curryFirst@@ -39,16 +29,14 @@   , apLast   , shuffleFun   , withFun+  , dimapFun     -- * Vector type class   , Dim   , Vector(..)-  , VectorN   , length     -- * Vector as continuation   , ContVec(..)-  , CVecPeano(..)   , consPeano-  , toContVec   , runContVec     -- * Construction of ContVec   , cvec@@ -108,9 +96,12 @@   , vector     -- ** Folds   , foldl+  , foldl'   , foldl1+  , foldl1'   , foldr   , ifoldl+  , ifoldl'   , ifoldr   , foldM   , ifoldM@@ -136,13 +127,14 @@ import Data.Functor.Identity (Identity(..)) import Data.Typeable         (Proxy(..)) import qualified Data.Foldable    as F-import qualified Data.Traversable as F+import qualified Data.Traversable as T import Unsafe.Coerce       (unsafeCoerce) import GHC.TypeLits--import Prelude hiding ( replicate,map,zipWith,zipWith3,maximum,minimum,and,or,any,all-                      , foldl,foldr,foldl1,length,sum,reverse,scanl,scanl1-                      , head,tail,mapM,mapM_,sequence,sequence_,concat+import GHC.Exts       (Proxy#, proxy#)+import Prelude        ( Bool(..), Int, Maybe(..), Either(..)+                      , Eq(..), Ord(..), Num(..), Functor(..), Applicative(..), Monad(..)+                      , Semigroup(..), Monoid(..)+                      , (.), ($), (&&), (||), (<$>), id, error, otherwise, fst                       )  @@ -156,6 +148,16 @@ data PeanoNum = Z               | S PeanoNum +type N1 = S Z+type N2 = S N1+type N3 = S N2+type N4 = S N3+type N5 = S N4+type N6 = S N5+type N7 = S N6+type N8 = S N7++ -- | Convert type level natural to Peano representation type family Peano (n :: Nat) :: PeanoNum where   Peano 0 = 'Z@@ -177,8 +179,9 @@   Fn 'Z     a b = b   Fn ('S n) a b = a -> Fn n a b --- | Newtype wrapper which is used to make 'Fn' injective. It's also a---   reader monad.+-- | Newtype wrapper which is used to make 'Fn' injective. It's a+--   function which takes @n@ parameters of type @a@ and returns value+--   of type @b@. newtype Fun n a b = Fun { unFun :: Fn n a b }  @@ -200,12 +203,14 @@   {-# INLINE pure  #-}   {-# INLINE (<*>) #-} +-- | Reader instance ArityPeano n => Monad (Fun n a) where   return  = pure   f >>= g = shuffleFun g <*> f   {-# INLINE return #-}   {-# INLINE (>>=)  #-} +newtype T_Flip a b n = T_Flip (Fun n a b) data T_ap a b c n = T_ap (Fn n a b) (Fn n a c)  @@ -214,14 +219,10 @@ -- Generic operations of N-ary functions ---------------------------------------------------------------- --- | Type class for type level number for which we can defined---   operations over N-ary functions.-type Arity n = ( ArityPeano (Peano n)-               , KnownNat n-               , Peano (n+1) ~ 'S (Peano n)-               )+-- | Synonym for writing constrains using type level naturals.+type Arity n = ArityPeano (Peano n) --- | Type class for handling /n/-ary functions.+-- | Type class for defining and applying /n/-ary functions. class ArityPeano n where   -- | Left fold over /n/ elements exposed as n-ary function. These   --   elements are supplied as arguments to the function.@@ -230,12 +231,20 @@         -> t n                              -- ^ Initial value         -> Fun n a b                        -- ^ Reduction function +  -- | Same as @accum@ but allow use @ArityPeano@ at each step Note+  --   that in general case this will lead to /O(n²)/ compilation time.+  accumPeano+    :: (forall k. ArityPeano k => t ('S k) -> a -> t k) -- ^ Fold function+    -> (t 'Z -> b)                                      -- ^ Extract result of fold+    -> t n                                              -- ^ Initial value+    -> Fun n a b                                        -- ^ Reduction function+   -- | Apply all parameters to the function.   applyFun :: (forall k. t ('S k) -> (a, t k))               -- ^ Get value to apply to function            -> t n               -- ^ Initial value-           -> (CVecPeano n a, t 'Z)+           -> (ContVec n a, t 'Z)    -- | Apply all parameters to the function using monadic   --   actions. Note that for identity monad it's same as@@ -245,80 +254,107 @@   applyFunM :: Applicative f             => (forall k. t ('S k) -> (f a, t k)) -- ^ Get value to apply to function             -> t n                                -- ^ Initial value-            -> (f (CVecPeano n a), t 'Z)+            -> (f (ContVec n a), t 'Z) -  -- | Reverse order of parameters. It's implemented directly in type-  --   class since expressing it in terms of @accum@ will require-  --   putting ArityPeano constraint on step funcion-  reverseF :: Fun n a b -> Fun n a b -  -- | Worker function for 'gunfold'-  gunfoldF :: (Data a)-           => (forall b x. Data b => c (b -> x) -> c x)-           -> T_gunfold c r a n -> c r+  -- | Perform N reduction steps. This function doesn't involve N-ary+  --   function directly.+  reducePeano :: (forall k. t ('S k) -> t k) -- ^ Reduction step+              -> t n+              -> t 'Z -newtype T_gunfold c r a n = T_gunfold (c (Fn n a r))+  -- | Conver peano number to int+  peanoToInt :: Proxy# n -> Int +  -- | Provide @ArityPeano@ dictionary for previous Peano number. GHC+  --   cannot infer that when @ArityPeano n@ and @n ~ S k@ we have+  --   instance for @k@ as well. So we have to provide such dictionary+  --   manually.+  --+  --   It's not possible to have non-⊥ implementation for @Z@ but+  --   neither it's possible to call it.+  dictionaryPred :: (n ~ S k) => Proxy# n -> (ArityPeano k => r) -> r +newtype T_gunfold c r a n = T_gunfold (c (Fn n a r)) + -- | Apply all parameters to the function.-apply :: Arity n+apply :: ArityPeano n       => (forall k. t ('S k) -> (a, t k)) -- ^ Get value to apply to function-      -> t (Peano n)                      -- ^ Initial value+      -> t n                              -- ^ Initial value       -> ContVec n a                      -- ^ N-ary function {-# INLINE apply #-}-apply step z = toContVec $ fst (applyFun step z)+apply step z = fst (applyFun step z)  -- | Apply all parameters to the function using applicative actions.-applyM :: (Applicative f, Arity n)+applyM :: (Applicative f, ArityPeano n)        => (forall k. t ('S k) -> (f a, t k)) -- ^ Get value to apply to function-       -> t (Peano n)                        -- ^ Initial value+       -> t n                                -- ^ Initial value        -> f (ContVec n a) {-# INLINE applyM #-}-applyM f t = fmap toContVec $ fst $ applyFunM f t+applyM f t = fst $ applyFunM f t --- | Arity of function.-arity :: KnownNat n => proxy n -> Int-{-# INLINE arity #-}-arity = fromIntegral . natVal +-- | Type class for indexing of vector of length @n@ with statically+--   known index @k@+class Index (k :: PeanoNum) (n :: PeanoNum) where+  getF  :: Proxy# k -> Fun n a a+  putF  :: Proxy# k -> a -> Fun n a r -> Fun n a r+  lensF :: Functor f => Proxy# k -> (a -> f a) -> Fun n a r -> Fun n a (f r)+++ instance ArityPeano 'Z where-  accum     _ g t = Fun $ g t-  applyFun  _ t   = (CVecPeano unFun, t)-  applyFunM _ t   = (pure (CVecPeano unFun), t)-  {-# INLINE accum     #-}-  {-# INLINE applyFun  #-}-  {-# INLINE applyFunM #-}-  reverseF = id-  gunfoldF _ (T_gunfold c) = c-  {-# INLINE reverseF    #-}-  {-# INLINE gunfoldF    #-}+  accum       _ g t = Fun $ g t+  accumPeano  _ g t = Fun $ g t+  applyFun    _ t   = (ContVec unFun, t)+  applyFunM   _ t   = (pure (ContVec unFun), t)+  reducePeano _     = id+  peanoToInt _      = 0+  {-# INLINE accum       #-}+  {-# INLINE accumPeano  #-}+  {-# INLINE applyFun    #-}+  {-# INLINE applyFunM   #-}+  {-# INLINE reducePeano #-}+  {-# INLINE peanoToInt #-}+  dictionaryPred _ _ = error "dictionaryPred: IMPOSSIBLE"  instance ArityPeano n => ArityPeano ('S n) where-  accum     f g t = Fun $ \a -> unFun $ accum f g (f t a)-  applyFun  f t   = let (a,t') = f t-                        (v,tZ) = applyFun f t'-                    in  (consPeano a v, tZ)-  applyFunM f t   = let (a,t')   = f t-                        (vec,t0) = applyFunM f t'-                    in  (consPeano <$> a <*> vec, t0)-  {-# INLINE accum     #-}-  {-# INLINE applyFun  #-}-  {-# INLINE applyFunM #-}-  reverseF f   = Fun $ \a -> unFun (reverseF $ apLast f a)-  gunfoldF f c = gunfoldF f (apGunfold f c)-  {-# INLINE reverseF    #-}-  {-# INLINE gunfoldF    #-}+  accum       f g t = Fun $ \a -> unFun $ accum      f g (f t a)+  accumPeano  f g t = Fun $ \a -> unFun $ accumPeano f g (f t a)+  applyFun    f t   = let (a,t') = f t+                          (v,tZ) = applyFun f t'+                      in  (consPeano a v, tZ)+  applyFunM   f t   = let (a,t')   = f t+                          (vec,t0) = applyFunM f t'+                      in  (consPeano <$> a <*> vec, t0)+  reducePeano f t   = reducePeano f (f t)+  peanoToInt  _     = 1 + peanoToInt (proxy# @n)+  {-# INLINE accum      #-}+  {-# INLINE applyFun   #-}+  {-# INLINE applyFunM  #-}+  {-# INLINE peanoToInt #-}+  {-# INLINE reducePeano #-}+  dictionaryPred _ r = r+  {-# INLINE dictionaryPred #-} -apGunfold :: Data a-          => (forall b x. Data b => c (b -> x) -> c x)-          -> T_gunfold c r a ('S n)-          -> T_gunfold c r a n-apGunfold f (T_gunfold c) = T_gunfold $ f c-{-# INLINE apGunfold #-} +instance ArityPeano n => Index 'Z ('S n) where+  getF  _       = uncurryFirst pure+  putF  _ a f   = Fun $ \_ -> unFun f a+  lensF _ f fun = Fun $ \a -> unFun $+    (\g -> g <$> f a) <$> shuffleFun (curryFirst fun)+  {-# INLINE getF  #-}+  {-# INLINE putF  #-}+  {-# INLINE lensF #-} -newtype T_Flip a b n = T_Flip (Fun n a b)+instance Index k n => Index (S k) (S n) where+  getF  _       = uncurryFirst $ \_ -> getF (proxy# @k)+  putF  _ a     = withFun (putF  (proxy# @k) a)+  lensF _ f fun = withFun (lensF (proxy# @k) f) fun+  {-# INLINE getF  #-}+  {-# INLINE putF  #-}+  {-# INLINE lensF #-}   @@ -367,7 +403,7 @@ {-# INLINE apLast #-}  -- | Recursive step for the function-withFun :: (Fun n a b -> Fun n a b) -> Fun ('S n) a b -> Fun ('S n) a b+withFun :: (Fun n a b -> Fun n a c) -> Fun ('S n) a b -> Fun ('S n) a c withFun f fun = Fun $ \a -> unFun $ f $ curryFirst fun a {-# INLINE withFun #-} @@ -382,18 +418,27 @@  newtype T_shuffle x a r n = T_shuffle (x -> Fn n a r) +-- | Apply function to parameters and result of @Fun@ simultaneously.+dimapFun :: ArityPeano n => (a -> b) -> (c -> d) -> Fun n b c -> Fun n a d+{-# INLINE dimapFun #-}+dimapFun fA fR fun+  = accum (\(T_Flip g) a -> T_Flip (curryFirst g (fA a)))+          (\(T_Flip x)   -> fR (unFun x))+          (T_Flip fun)  ++ ---------------------------------------------------------------- -- Type class for fixed vectors ---------------------------------------------------------------- --- | Size of vector expressed as type-level natural.-type family Dim (v :: Type -> Type) :: Nat+-- | Size of vector expressed as Peano natural.+type family Dim (v :: Type -> Type) :: PeanoNum  -- | Type class for vectors with fixed length. Instance should provide---   two functions: one to create vector and another for vector---   deconstruction. They must obey following law:+--   two functions: one to create vector from @N@ elements and another+--   for vector deconstruction. They must obey following law: -- --   > inspect v construct = v --@@ -405,28 +450,23 @@ --   > instance Vector V2 a where --   >   construct                = Fun V2 --   >   inspect (V2 a b) (Fun f) = f a b-class Arity (Dim v) => Vector v a where-  -- | N-ary function for creation of vectors.-  construct :: Fun (Peano (Dim v)) a (v a)-  -- | Deconstruction of vector.-  inspect   :: v a -> Fun (Peano (Dim v)) a b -> b+class ArityPeano (Dim v) => Vector v a where+  -- | N-ary function for creation of vectors. It takes @N@ elements+  --   of array as parameters and return vector.+  construct :: Fun (Dim v) a (v a)+  -- | Deconstruction of vector. It takes N-ary function as parameters+  --   and applies vector's elements to it.+  inspect   :: v a -> Fun (Dim v) a b -> b   -- | Optional more efficient implementation of indexing. Shouldn't   --   be used directly, use 'Data.Vector.Fixed.!' instead.   basicIndex :: v a -> Int -> a   basicIndex v i = index i (cvec v)   {-# INLINE basicIndex #-} --- | Vector parametrized by length. In ideal world it should be:------ > forall n. (Arity n, Vector (v n) a, Dim (v n) ~ n) => VectorN v a------ Alas polymorphic constraints aren't allowed in haskell.-class (Vector (v n) a, Dim (v n) ~ n) => VectorN v n a- -- | Length of vector. Function doesn't evaluate its argument.-length :: forall v a. KnownNat (Dim v) => v a -> Int+length :: forall v a. ArityPeano (Dim v) => v a -> Int {-# INLINE length #-}-length _ = arity (Proxy :: Proxy (Dim v))+length _ = peanoToInt (proxy# @(Dim v))   ----------------------------------------------------------------@@ -435,62 +475,85 @@  -- | Vector represented as continuation. Alternative wording: it's --   Church encoded N-element vector.-newtype ContVec n a = ContVec (forall r. Fun (Peano n) a r -> r)+newtype ContVec n a = ContVec (forall r. Fun n a r -> r)  type instance Dim (ContVec n) = n --- | Same as 'ContVec' but its length is expressed as Peano number.-newtype CVecPeano n a = CVecPeano (forall r. Fun n a r -> r)---- | Cons values to the @CVecPeano@.-consPeano :: a -> CVecPeano n a -> CVecPeano ('S n) a-consPeano a (CVecPeano cont) = CVecPeano $ \f -> cont $ curryFirst f a+-- | Cons values to the @ContVec@.+consPeano :: a -> ContVec n a -> ContVec ('S n) a+consPeano a (ContVec cont) = ContVec $ \f -> cont $ curryFirst f a {-# INLINE consPeano #-} -toContVec :: CVecPeano (Peano n) a -> ContVec n a-toContVec = coerce--instance Arity n => Vector (ContVec n) a where+instance ArityPeano n => Vector (ContVec n) a where   construct = accum     (\(T_mkN f) a -> T_mkN (f . consPeano a))-    (\(T_mkN f)   -> toContVec $ f (CVecPeano unFun))+    (\(T_mkN f)   -> f (ContVec unFun))     (T_mkN id)   inspect (ContVec c) f = c f   {-# INLINE construct #-}   {-# INLINE inspect   #-} -newtype T_mkN n_tot a n = T_mkN (CVecPeano n a -> CVecPeano n_tot a)+newtype T_mkN n_tot a n = T_mkN (ContVec n a -> ContVec n_tot a) -instance Arity n => VectorN ContVec n a  -instance (Arity n) => Functor (ContVec n) where+instance (Eq a, ArityPeano n) => Eq (ContVec n a) where+  a == b = and $ zipWith (==) a b+  {-# INLINE (==) #-}++instance (Ord a, ArityPeano n) => Ord (ContVec n a) where+  compare a b = foldl mappend mempty $ zipWith compare a b+  {-# INLINE compare #-}++instance (ArityPeano n, Monoid a) => Monoid (ContVec n a) where+  mempty = replicate mempty+  {-# INLINE mempty  #-}++instance (ArityPeano n, Semigroup a) => Semigroup (ContVec n a) where+  (<>) = zipWith (<>)+  {-# INLINE (<>) #-}+++instance (ArityPeano n) => Functor (ContVec n) where   fmap = map   {-# INLINE fmap #-} -instance (Arity n) => Applicative (ContVec n) where+instance (ArityPeano n) => Applicative (ContVec n) where   pure  = replicate   (<*>) = zipWith ($)   {-# INLINE pure  #-}   {-# INLINE (<*>) #-} -instance (Arity n) => F.Foldable (ContVec n) where-  foldr = foldr-  {-# INLINE foldr #-}+instance (ArityPeano n) => F.Foldable (ContVec n) where+  foldMap' f = foldl' (\ acc a -> acc <> f a) mempty+  foldr      = foldr+  foldl      = foldl+  foldl'     = foldl'+  toList     = toList+  sum        = sum+  product    = foldl' (*) 0+  {-# INLINE foldMap' #-}+  {-# INLINE foldr    #-}+  {-# INLINE foldl    #-}+  {-# INLINE foldl'   #-}+  {-# INLINE toList   #-}+  {-# INLINE sum      #-}+  {-# INLINE product  #-}+-- GHC<9.2 fails to compile this+#if MIN_VERSION_base(4,16,0)+  length = length+  {-# INLINE length #-}+#endif -instance (Arity n) => F.Traversable (ContVec n) where-  sequenceA v = inspect v $ sequenceAF construct+instance (ArityPeano n) => T.Traversable (ContVec n) where+  sequence  = sequence+  sequenceA = sequence+  traverse  = mapM+  mapM      = mapM+  {-# INLINE sequence  #-}   {-# INLINE sequenceA #-}--sequenceAF :: forall f n a b. (Applicative f, ArityPeano n)-     => Fun n a b -> Fun n (f a) (f b)-{-# INLINE sequenceAF #-}-sequenceAF (Fun f0)-  = accum (\(T_sequenceA f) a -> T_sequenceA (f <*> a))-          (\(T_sequenceA f)   -> f)-          (T_sequenceA (pure f0) :: T_sequenceA f a b n)--newtype T_sequenceA f a b n = T_sequenceA (f (Fn n a b))+  {-# INLINE mapM      #-}+  {-# INLINE traverse  #-}   @@ -499,19 +562,19 @@ ----------------------------------------------------------------  -- | Convert regular vector to continuation based one.-cvec :: (Vector v a, Dim v ~ n) => v a -> ContVec n a+cvec :: (Vector v a) => v a -> ContVec (Dim v) a cvec v = ContVec (inspect v) {-# INLINE[0] cvec #-}  -- | Create empty vector.-empty :: ContVec 0 a+empty :: ContVec 'Z a {-# INLINE empty #-} empty = ContVec (\(Fun r) -> r)   -- | Convert list to continuation-based vector. Will throw error if --   list is shorter than resulting vector.-fromList :: Arity n => [a] -> ContVec n a+fromList :: ArityPeano n => [a] -> ContVec n a {-# INLINE fromList #-} fromList xs =   apply step (Const xs)@@ -521,22 +584,22 @@  -- | Same as 'fromList' bu throws error is list doesn't have same --   length as vector.-fromList' :: forall n a. Arity n => [a] -> ContVec n a+fromList' :: forall n a. ArityPeano n => [a] -> ContVec n a {-# INLINE fromList' #-} fromList' xs =   let step (Const []    ) = error "Data.Vector.Fixed.Cont.fromList': too few elements"       step (Const (a:as)) = (a, Const as)-  in case applyFun step (Const xs :: Const [a] (Peano n)) of-    (v,Const []) -> toContVec v+  in case applyFun step (Const xs :: Const [a] n) of+    (v,Const []) -> v     _            -> error "Data.Vector.Fixed.Cont.fromList': too many elements"   -- | Convert list to continuation-based vector. Will fail with --   'Nothing' if list doesn't have right length.-fromListM :: forall n a. Arity n => [a] -> Maybe (ContVec n a)+fromListM :: forall n a. ArityPeano n => [a] -> Maybe (ContVec n a) {-# INLINE fromListM #-}-fromListM xs = case applyFunM step (Const xs :: Const [a] (Peano n)) of-  (Just v, Const []) -> Just (toContVec v)+fromListM xs = case applyFunM step (Const xs :: Const [a] n) of+  (Just v, Const []) -> Just v   _                  -> Nothing   where     step (Const []    ) = (Nothing, Const [])@@ -544,46 +607,46 @@   -- | Convert vector to the list-toList :: (Arity n) => ContVec n a -> [a]+toList :: (ArityPeano n) => ContVec n a -> [a] toList = foldr (:) [] {-# INLINE toList #-}   -- | Execute monadic action for every element of vector. Synonym for 'pure'.-replicate :: (Arity n) => a -> ContVec n a+replicate :: (ArityPeano n) => a -> ContVec n a {-# INLINE replicate #-} replicate a = apply (\Proxy -> (a, Proxy)) Proxy  -- | Execute monadic action for every element of vector.-replicateM :: (Arity n, Applicative f) => f a -> f (ContVec n a)+replicateM :: (ArityPeano n, Applicative f) => f a -> f (ContVec n a) {-# INLINE replicateM #-} replicateM act   = applyM (\Proxy -> (act, Proxy)) Proxy   -- | Generate vector from function which maps element's index to its value.-generate :: (Arity n) => (Int -> a) -> ContVec n a+generate :: (ArityPeano n) => (Int -> a) -> ContVec n a {-# INLINE generate #-} generate f =   apply (\(Const n) -> (f n, Const (n + 1))) (Const 0)  -- | Generate vector from monadic function which maps element's index --   to its value.-generateM :: (Applicative f, Arity n) => (Int -> f a) -> f (ContVec n a)+generateM :: (Applicative f, ArityPeano n) => (Int -> f a) -> f (ContVec n a) {-# INLINE generateM #-} generateM f =   applyM (\(Const n) -> (f n, Const (n + 1))) (Const 0)   -- | Unfold vector.-unfoldr :: Arity n => (b -> (a,b)) -> b -> ContVec n a+unfoldr :: ArityPeano n => (b -> (a,b)) -> b -> ContVec n a {-# INLINE unfoldr #-} unfoldr f b0 =   apply (\(Const b) -> let (a,b') = f b in (a, Const b'))         (Const b0)  -- | Unit vector along Nth axis.-basis :: (Num a, Arity n) => Int -> ContVec n a+basis :: (Num a, ArityPeano n) => Int -> ContVec n a {-# INLINE basis #-} basis n0 =   apply (\(Const n) -> (if n == 0 then 1 else 0, Const (n - 1)))@@ -591,35 +654,35 @@   -mk1 :: a -> ContVec 1 a+mk1 :: a -> ContVec N1 a mk1 a1 = ContVec $ \(Fun f) -> f a1 {-# INLINE mk1 #-} -mk2 :: a -> a -> ContVec 2 a+mk2 :: a -> a -> ContVec N2 a mk2 a1 a2 = ContVec $ \(Fun f) -> f a1 a2 {-# INLINE mk2 #-} -mk3 :: a -> a -> a -> ContVec 3 a+mk3 :: a -> a -> a -> ContVec N3 a mk3 a1 a2 a3 = ContVec $ \(Fun f) -> f a1 a2 a3 {-# INLINE mk3 #-} -mk4 :: a -> a -> a -> a -> ContVec 4 a+mk4 :: a -> a -> a -> a -> ContVec N4 a mk4 a1 a2 a3 a4 = ContVec $ \(Fun f) -> f a1 a2 a3 a4 {-# INLINE mk4 #-} -mk5 :: a -> a -> a -> a -> a -> ContVec 5 a+mk5 :: a -> a -> a -> a -> a -> ContVec N5 a mk5 a1 a2 a3 a4 a5 = ContVec $ \(Fun f) -> f a1 a2 a3 a4 a5 {-# INLINE mk5 #-} -mk6 :: a -> a -> a -> a -> a -> a -> ContVec 6 a+mk6 :: a -> a -> a -> a -> a -> a -> ContVec N6 a mk6 a1 a2 a3 a4 a5 a6 = ContVec $ \(Fun f) -> f a1 a2 a3 a4 a5 a6 {-# INLINE mk6 #-} -mk7 :: a -> a -> a -> a -> a -> a -> a -> ContVec 7 a+mk7 :: a -> a -> a -> a -> a -> a -> a -> ContVec N7 a mk7 a1 a2 a3 a4 a5 a6 a7 = ContVec $ \(Fun f) -> f a1 a2 a3 a4 a5 a6 a7 {-# INLINE mk7 #-} -mk8 :: a -> a -> a -> a -> a -> a -> a -> a -> ContVec 8 a+mk8 :: a -> a -> a -> a -> a -> a -> a -> a -> ContVec N8 a mk8 a1 a2 a3 a4 a5 a6 a7 a8 = ContVec $ \(Fun f) -> f a1 a2 a3 a4 a5 a6 a7 a8 {-# INLINE mk8 #-} @@ -629,23 +692,26 @@ ----------------------------------------------------------------  -- | Map over vector. Synonym for 'fmap'-map :: (Arity n) => (a -> b) -> ContVec n a -> ContVec n b+map :: (ArityPeano n) => (a -> b) -> ContVec n a -> ContVec n b {-# INLINE map #-}-map = imap . const+map f (ContVec contA) = ContVec $+  contA . mapF f  -- | Apply function to every element of the vector and its index.-imap :: (Arity n) => (Int -> a -> b) -> ContVec n a -> ContVec n b+imap :: (ArityPeano n) => (Int -> a -> b) -> ContVec n a -> ContVec n b {-# INLINE imap #-} imap f (ContVec contA) = ContVec $   contA . imapF f  -- | Effectful map over vector.-mapM :: (Arity n, Applicative f) => (a -> f b) -> ContVec n a -> f (ContVec n b)+mapM :: (ArityPeano n, Applicative f) => (a -> f b) -> ContVec n a -> f (ContVec n b) {-# INLINE mapM #-}-mapM = imapM . const+mapM f v+ = inspect v+ $ mapMF f construct  -- | Apply monadic function to every element of the vector and its index.-imapM :: (Arity n, Applicative f)+imapM :: (ArityPeano n, Applicative f)       => (Int -> a -> f b) -> ContVec n a -> f (ContVec n b) {-# INLINE imapM #-} imapM f v@@ -653,45 +719,65 @@   $ imapMF f construct  -- | Apply monadic action to each element of vector and ignore result.-mapM_ :: (Arity n, Applicative f) => (a -> f b) -> ContVec n a -> f ()+mapM_ :: (ArityPeano n, Applicative f) => (a -> f b) -> ContVec n a -> f () {-# INLINE mapM_ #-} mapM_ f = foldl (\m a -> m *> f a *> pure ()) (pure ())  -- | Apply monadic action to each element of vector and its index and --   ignore result.-imapM_ :: (Arity n, Applicative f) => (Int -> a -> f b) -> ContVec n a -> f ()+imapM_ :: (ArityPeano n, Applicative f) => (Int -> a -> f b) -> ContVec n a -> f () {-# INLINE imapM_ #-} imapM_ f = ifoldl (\m i a -> m *> f i a *> pure ()) (pure ())  ++mapMF :: (ArityPeano n, Applicative f)+      => (a -> f b) -> Fun n b r -> Fun n a (f r)+{-# INLINE mapMF #-}+mapMF f (Fun funB) =+  accum (\(T_mapM m) a -> T_mapM (($) <$> m <*> f a))+        (\(T_mapM m) -> m)+        (T_mapM (pure funB))+ imapMF :: (ArityPeano n, Applicative f)        => (Int -> a -> f b) -> Fun n b r -> Fun n a (f r) {-# INLINE imapMF #-} imapMF f (Fun funB) =-  accum (\(T_mapM i m) a -> T_mapM (i+1) $ ($) <$> m <*> f i a)-        (\(T_mapM _ m) -> m)-        (T_mapM 0 (pure funB))+  accum (\(T_imapM i m) a -> T_imapM (i+1) $ ($) <$> m <*> f i a)+        (\(T_imapM _ m) -> m)+        (T_imapM 0 (pure funB)) -data T_mapM a m r n = T_mapM Int (m (Fn n a r))+newtype T_mapM  a m r n = T_mapM      (m (Fn n a r))+data    T_imapM a m r n = T_imapM Int (m (Fn n a r)) ++mapF :: ArityPeano n+     => (a -> b) -> Fun n b r -> Fun n a r+{-# INLINE mapF #-}+mapF f (Fun funB) =+  accum (\(T_map g) b -> T_map (g (f b)))+        (\(T_map r)   -> r)+        (  T_map funB)+ imapF :: ArityPeano n       => (Int -> a -> b) -> Fun n b r -> Fun n a r {-# INLINE imapF #-} imapF f (Fun funB) =-  accum (\(T_map i g) b -> T_map (i+1) (g (f i b)))-        (\(T_map _ r)   -> r)-        (  T_map 0 funB)+  accum (\(T_imap i g) b -> T_imap (i+1) (g (f i b)))+        (\(T_imap _ r)   -> r)+        (  T_imap 0 funB) -data T_map a r n = T_map Int (Fn n a r)+newtype T_map  a r n = T_map      (Fn n a r)+data    T_imap a r n = T_imap Int (Fn n a r)  -- | Left scan over vector-scanl :: (Arity n) => (b -> a -> b) -> b -> ContVec n a -> ContVec (n+1) b+scanl :: (ArityPeano n) => (b -> a -> b) -> b -> ContVec n a -> ContVec ('S n) b {-# INLINE scanl #-} scanl f b0 (ContVec cont) = ContVec $   cont . scanlF f b0  -- | Left scan over vector-scanl1 :: (Arity n) => (a -> a -> a) -> ContVec n a -> ContVec n a+scanl1 :: (ArityPeano n) => (a -> a -> a) -> ContVec n a -> ContVec n a {-# INLINE scanl1 #-} scanl1 f (ContVec cont) = ContVec $   cont . scanl1F f@@ -719,17 +805,17 @@   -- | Evaluate every action in the vector from left to right.-sequence :: (Arity n, Applicative f) => ContVec n (f a) -> f (ContVec n a)+sequence :: (ArityPeano n, Applicative f) => ContVec n (f a) -> f (ContVec n a) sequence = mapM id {-# INLINE sequence #-}  -- | Evaluate every action in the vector from left to right and ignore result.-sequence_ :: (Arity n, Applicative f) => ContVec n (f a) -> f ()+sequence_ :: (ArityPeano n, Applicative f) => ContVec n (f a) -> f () sequence_ = mapM_ id {-# INLINE sequence_ #-}  -- | The dual of sequenceA-distribute :: (Functor f, Arity n) => f (ContVec n a) -> ContVec n (f a)+distribute :: (Functor f, ArityPeano n) => f (ContVec n a) -> ContVec n (f a) {-# INLINE distribute #-} distribute f0   = apply step start@@ -740,64 +826,77 @@                      , Const $ fmap (\(_:x) -> x) f)     start = Const (fmap toList f0) -collect :: (Functor f, Arity n) => (a -> ContVec n b) -> f a -> ContVec n (f b)+collect :: (Functor f, ArityPeano n) => (a -> ContVec n b) -> f a -> ContVec n (f b) collect f = distribute . fmap f {-# INLINE collect #-}  -- | /O(1)/ Tail of vector.-tail :: {-FIXME-} Arity n => ContVec (n+1) a -> ContVec n a+tail :: ContVec (S n) a -> ContVec n a tail (ContVec cont) = ContVec $ \f -> cont $ constFun f {-# INLINE tail #-}  -- | /O(1)/ Prepend element to vector-cons :: {-FIXME-} Arity n => a -> ContVec n a -> ContVec (n+1) a+cons :: a -> ContVec n a -> ContVec ('S n) a cons a (ContVec cont) = ContVec $ \f -> cont $ curryFirst f a {-# INLINE cons #-}  -- | Prepend single element vector to another vector.-consV :: {-FIXME-} Arity n => ContVec 1 a -> ContVec n a -> ContVec (n+1) a+consV :: ArityPeano n => ContVec N1 a -> ContVec n a -> ContVec ('S n) a {-# INLINE consV #-} consV (ContVec cont1) (ContVec cont)   = ContVec $ \f -> cont $ curryFirst f $ cont1 $ Fun id  -- | /O(1)/ Append element to vector-snoc :: Arity n => a -> ContVec n a -> ContVec (n+1) a+snoc :: ArityPeano n => a -> ContVec n a -> ContVec ('S n) a snoc a (ContVec cont) = ContVec $ \f -> cont $ apLast f a {-# INLINE snoc #-} + -- | Concatenate vector-concat :: ( Arity n-          , Arity k-          , Arity (n + k)-          -- Tautology-          , Peano (n + k) ~ Add (Peano n) (Peano k)+concat :: ( ArityPeano n+          , ArityPeano k+          , ArityPeano (n `Add` k)           )-       => ContVec n a -> ContVec k a -> ContVec (n + k) a+       => ContVec n a -> ContVec k a -> ContVec (Add n k) a {-# INLINE concat #-} concat v u = inspect u            $ inspect v            $ curryMany construct  -- | Reverse order of elements in the vector-reverse :: Arity n => ContVec n a -> ContVec n a+reverse :: ArityPeano n => ContVec n a -> ContVec n a reverse (ContVec cont) = ContVec $ cont . reverseF {-# INLINE reverse #-} +reverseF :: forall n a b. ArityPeano n => Fun n a b -> Fun n a b+reverseF (Fun fun0) = accumPeano+  step+  (\(T_map b) -> b)+  (T_map fun0 :: T_map a b n)+  where+    step :: forall k. ArityPeano k => T_map a b (S k) -> a -> T_map a b k+    step (T_map f) a = T_map $ unFun $ apLast (Fun f :: Fun (S k) a b) a++ -- | Zip two vector together using function.-zipWith :: (Arity n) => (a -> b -> c)+zipWith :: (ArityPeano n) => (a -> b -> c)         -> ContVec n a -> ContVec n b -> ContVec n c {-# INLINE zipWith #-}-zipWith = izipWith . const+zipWith f vecA vecB = ContVec $ \funC ->+    inspect vecB+  $ inspect vecA+  $ zipWithF f funC  -- | Zip three vectors together-zipWith3 :: (Arity n) => (a -> b -> c -> d)+zipWith3 :: (ArityPeano n) => (a -> b -> c -> d)          -> ContVec n a -> ContVec n b -> ContVec n c -> ContVec n d {-# INLINE zipWith3 #-}-zipWith3 f v1 v2 v3 = zipWith (\a (b, c) -> f a b c) v1 (zipWith (,) v2 v3)+zipWith3 f v1 v2 v3+  = zipWith ($) (zipWith f v1 v2) v3  -- | Zip two vector together using function which takes element index --   as well.-izipWith :: (Arity n) => (Int -> a -> b -> c)+izipWith :: (ArityPeano n) => (Int -> a -> b -> c)          -> ContVec n a -> ContVec n b -> ContVec n c {-# INLINE izipWith #-} izipWith f vecA vecB = ContVec $ \funC ->@@ -806,53 +905,86 @@   $ izipWithF f funC  -- | Zip three vectors together-izipWith3 :: (Arity n) => (Int -> a -> b -> c -> d)+izipWith3 :: (ArityPeano n) => (Int -> a -> b -> c -> d)           -> ContVec n a -> ContVec n b -> ContVec n c -> ContVec n d {-# INLINE izipWith3 #-} izipWith3 f v1 v2 v3 = izipWith (\i a (b, c) -> f i a b c) v1 (zipWith (,) v2 v3)  -- | Zip two vector together using monadic function.-zipWithM :: (Arity n, Applicative f) => (a -> b -> f c)+zipWithM :: (ArityPeano n, Applicative f) => (a -> b -> f c)          -> ContVec n a -> ContVec n b -> f (ContVec n c) {-# INLINE zipWithM #-} zipWithM f v w = sequence $ zipWith f v w -zipWithM_ :: (Arity n, Applicative f)+zipWithM_ :: (ArityPeano n, Applicative f)           => (a -> b -> f c) -> ContVec n a -> ContVec n b -> f () {-# INLINE zipWithM_ #-} zipWithM_ f xs ys = sequence_ (zipWith f xs ys)  -- | Zip two vector together using monadic function which takes element --   index as well..-izipWithM :: (Arity n, Applicative f) => (Int -> a -> b -> f c)+izipWithM :: (ArityPeano n, Applicative f) => (Int -> a -> b -> f c)           -> ContVec n a -> ContVec n b -> f (ContVec n c) {-# INLINE izipWithM #-} izipWithM f v w = sequence $ izipWith f v w -izipWithM_ :: (Arity n, Applicative f)+izipWithM_ :: (ArityPeano n, Applicative f)            => (Int -> a -> b -> f c) -> ContVec n a -> ContVec n b -> f () {-# INLINE izipWithM_ #-} izipWithM_ f xs ys = sequence_ (izipWith f xs ys) +-- NOTE: [zipWith]+-- ~~~~~~~~~~~~~~~+--+-- It turns out it's very difficult to implement zipWith using+-- accum/apply. Key problem is we need to implement:+--+-- > zipF :: Fun n (a,b) r → Fun n a (Fun b r)+--+-- Induction step would be implementing+--+-- > ((a,b) → Fun n (a,b) r) → (a → Fun n a (b → Fun b r))+--+-- in terms of zipF above. It will give us `Fun n a (Fun b r)` but+-- we'll need to move parameter `b` _inside_ `Fun n a`. This requires+-- `ArityPeano` constraint while accum's parameter has note. Even+-- worse this implementation has quadratic complexity.+--+-- It's possible to make zipF method of ArityPeano but quadratic+-- complexity won't go away and starts cause slowdown even for modest+-- values of `n`: 5-6. For n above 10 compilation starts to fail with+-- "simplifier ticks exhausted error".+--+-- It turns out easiest way is materialize list and then deconstruct.+-- GHC is able to eliminate it and it's very hard to beat this approach++zipWithF :: (ArityPeano n)+          => (a -> b -> c) -> Fun n c r -> Fun n a (Fun n b r)+{-# INLINE zipWithF #-}+zipWithF f (Fun g0)+  = makeList+  $ \v -> accum (\(T_zip (a:as) g) b -> T_zip as (g $ f a b))+                (\(T_zip _      x)   -> x)+                (T_zip v g0)+ izipWithF :: (ArityPeano n)           => (Int -> a -> b -> c) -> Fun n c r -> Fun n a (Fun n b r) {-# INLINE izipWithF #-}-izipWithF f (Fun g0) =-  fmap (\v -> accum-              (\(T_izip i (a:as) g) b -> T_izip (i+1) as (g $ f i a b))-              (\(T_izip _ _      x)   -> x)-              (T_izip 0 v g0)-       ) makeList-+izipWithF f (Fun g0)+  = makeList+  $ \v -> accum (\(T_izip i (a:as) g) b -> T_izip (i+1) as (g $ f i a b))+                (\(T_izip _ _      x)   -> x)+                (T_izip 0 v g0) -makeList :: ArityPeano n => Fun n a [a]+makeList :: ArityPeano n => ([a] -> b) -> Fun n a b {-# INLINE makeList #-}-makeList = accum+makeList cont = accum     (\(Const xs) x -> Const (xs . (x:)))-    (\(Const xs) -> xs [])+    (\(Const xs) -> cont (xs []))     (Const id)  data T_izip a c r n = T_izip Int [a] (Fn n c r)+data T_zip  a c r n = T_zip      [a] (Fn n c r)   @@ -862,29 +994,28 @@  -- | Run continuation vector. It's same as 'inspect' but with --   arguments flipped.-runContVec :: Fun (Peano n) a r+runContVec :: Fun n a r            -> ContVec n a            -> r runContVec f (ContVec c) = c f {-# INLINE runContVec #-}  -- | Convert continuation to the vector.-vector :: (Vector v a, Dim v ~ n) => ContVec n a -> v a+vector :: (Vector v a) => ContVec (Dim v) a -> v a vector = runContVec construct {-# INLINE[1] vector #-}  -- | Finalizer function for getting head of the vector.-head :: (Arity n, 1<=n) => ContVec n a -> a+head :: forall n k a. (ArityPeano n, n ~ 'S k) => ContVec n a -> a {-# INLINE head #-} head-  = runContVec-  $ accum (\(Const m) a -> Const $ case m of { Nothing -> Just a; x -> x })-          (\(Const (Just x)) -> x)-          (Const Nothing)+  = dictionaryPred (proxy# @n)+  $ runContVec+  $ uncurryFirst pure   -- | /O(n)/ Get value at specified index.-index :: Arity n => Int -> ContVec n a -> a+index :: ArityPeano n => Int -> ContVec n a -> a {-# INLINE index #-} index n   | n < 0     = error "Data.Vector.Fixed.Cont.index: index out of range"@@ -902,7 +1033,7 @@   -- | Twan van Laarhoven lens for continuation based vector-element :: (Arity n, Functor f)+element :: (ArityPeano n, Functor f)         => Int -> (a -> f a) -> ContVec n a -> f (ContVec n a) {-# INLINE element #-} element i f v = inspect v@@ -931,107 +1062,153 @@   -- | Left fold over continuation vector.-foldl :: Arity n => (b -> a -> b) -> b -> ContVec n a -> b+foldl :: ArityPeano n => (b -> a -> b) -> b -> ContVec n a -> b {-# INLINE foldl #-}-foldl f = ifoldl (\b _ a -> f b a)+foldl f b0 = runContVec (foldlF f b0) +-- | Strict left fold over continuation vector.+foldl' :: ArityPeano n => (b -> a -> b) -> b -> ContVec n a -> b+{-# INLINE foldl' #-}+foldl' f b0 = runContVec (foldlF' f b0)+ -- | Left fold over continuation vector.-ifoldl :: Arity n => (b -> Int -> a -> b) -> b -> ContVec n a -> b+ifoldl :: ArityPeano n => (b -> Int -> a -> b) -> b -> ContVec n a -> b {-# INLINE ifoldl #-} ifoldl f b v   = inspect v   $ accum (\(T_ifoldl i r) a -> T_ifoldl (i+1) (f r i a))-          (\(T_ifoldl _ r) -> r)+          (\(T_ifoldl _ r)   -> r)           (T_ifoldl 0 b) +-- | Strict left fold over continuation vector.+ifoldl' :: ArityPeano n => (b -> Int -> a -> b) -> b -> ContVec n a -> b+{-# INLINE ifoldl' #-}+ifoldl' f b v+  = inspect v+  $ accum (\(T_ifoldl i !r) a -> T_ifoldl (i+1) (f r i a))+          (\(T_ifoldl _ r)    -> r)+          (T_ifoldl 0 b)+ -- | Monadic left fold over continuation vector.-foldM :: (Arity n, Monad m)+foldM :: (ArityPeano n, Monad m)       => (b -> a -> m b) -> b -> ContVec n a -> m b {-# INLINE foldM #-} foldM f x   = foldl (\m a -> do{ b <- m; f b a}) (return x)  -- | Monadic left fold over continuation vector.-ifoldM :: (Arity n, Monad m)+ifoldM :: (ArityPeano n, Monad m)        => (b -> Int -> a -> m b) -> b -> ContVec n a -> m b {-# INLINE ifoldM #-} ifoldM f x   = ifoldl (\m i a -> do{ b <- m; f b i a}) (return x) -data T_ifoldl b n = T_ifoldl !Int b --- Implementation of foldl1 is quite ugly. It could be expressed in--- terms of foldlF (worker function for foldl)------ > foldl1F f = Fun $ \a -> case foldlF f a :: Fun n a a of Fun g -> g------ But it require constraint `Arity n` whereas `Vector v a` gives--- `Arity (S n)`.  Latter imply former but GHC cannot infer it.---- | Left fold.-foldl1 :: (Arity n, 1 <= n) => (a -> a -> a) -> ContVec n a -> a+-- | Left fold without base case. It's total because it requires vector to be nonempty+foldl1 :: forall n k a. (ArityPeano n, n ~ 'S k)+       => (a -> a -> a) -> ContVec n a -> a {-# INLINE foldl1 #-} foldl1 f-  = runContVec-  $ accum (\(Const r       ) a -> Const $ Just $ maybe a (flip f a) r)-          (\(Const (Just x))   -> x)-          (Const Nothing)+  = dictionaryPred (proxy# @n)+  $ runContVec+  $ uncurryFirst (foldlF f) +-- | Left fold without base case. It's total because it requires vector to be nonempty+foldl1' :: forall n k a. (ArityPeano n, n ~ 'S k)+       => (a -> a -> a) -> ContVec n a -> a+{-# INLINE foldl1' #-}+foldl1' f+  = dictionaryPred (proxy# @n)+  $ runContVec+  $ uncurryFirst (foldlF' f)+++foldlF :: ArityPeano n => (b -> a -> b) -> b -> Fun n a b+{-# INLINE foldlF #-}+foldlF f b0+  = accum (\(T_foldl b) a -> T_foldl (f b a))+          (\(T_foldl b)   -> b)+          (T_foldl b0)++foldlF' :: ArityPeano n => (b -> a -> b) -> b -> Fun n a b+{-# INLINE foldlF' #-}+foldlF' f b0+  = accum (\(T_foldl !b) a -> T_foldl (f b a))+          (\(T_foldl  b)   -> b)+          (T_foldl b0)++newtype T_foldl  b n = T_foldl       b+data    T_ifoldl b n = T_ifoldl !Int b++ -- | Right fold over continuation vector-foldr :: Arity n => (a -> b -> b) -> b -> ContVec n a -> b+foldr :: ArityPeano n => (a -> b -> b) -> b -> ContVec n a -> b {-# INLINE foldr #-}-foldr = ifoldr . const+foldr f b0 = runContVec $ foldrF f b0  -- | Right fold over continuation vector-ifoldr :: Arity n => (Int -> a -> b -> b) -> b -> ContVec n a -> b+ifoldr :: ArityPeano n => (Int -> a -> b -> b) -> b -> ContVec n a -> b {-# INLINE ifoldr #-}-ifoldr f z-  = runContVec-  $ accum (\(T_ifoldr i g) a -> T_ifoldr (i+1) (g . f i a))-          (\(T_ifoldr _ g)   -> g z)-          (T_ifoldr 0 id)+ifoldr f b0 = runContVec $ ifoldrF f b0 ++foldrF :: ArityPeano n => (a -> b -> b) -> b -> Fun n a b+{-# INLINE foldrF #-}+foldrF f b0 = accum+  (\(T_foldr g) a -> T_foldr (g . f a))+  (\(T_foldr g)   -> g b0)+  (T_foldr id)++ifoldrF :: ArityPeano n => (Int -> a -> b -> b) -> b -> Fun n a b+{-# INLINE ifoldrF #-}+ifoldrF f b0 = accum+  (\(T_ifoldr i g) a -> T_ifoldr (i+1) (g . f i a))+  (\(T_ifoldr _ g)   -> g b0)+  (T_ifoldr 0 id)++data T_foldr  b n = T_foldr      (b -> b) data T_ifoldr b n = T_ifoldr Int (b -> b) + -- | Sum all elements in the vector.-sum :: (Num a, Arity n) => ContVec n a -> a-sum = foldl (+) 0+sum :: (Num a, ArityPeano n) => ContVec n a -> a+sum = foldl' (+) 0 {-# INLINE sum #-}  -- | Minimal element of vector.-minimum :: (Ord a, Arity n, 1<=n) => ContVec n a -> a+minimum :: (Ord a, ArityPeano n, n ~ 'S k) => ContVec n a -> a minimum = foldl1 min {-# INLINE minimum #-}  -- | Maximal element of vector.-maximum :: (Ord a, Arity n, 1<=n) => ContVec n a -> a+maximum :: (Ord a, ArityPeano n, n ~ 'S k) => ContVec n a -> a maximum = foldl1 max {-# INLINE maximum #-}  -- | Conjunction of elements of a vector.-and :: Arity n => ContVec n Bool -> Bool+and :: ArityPeano n => ContVec n Bool -> Bool and = foldr (&&) True {-# INLINE and #-}  -- | Disjunction of all elements of a vector.-or :: Arity n => ContVec n Bool -> Bool+or :: ArityPeano n => ContVec n Bool -> Bool or = foldr (||) False {-# INLINE or #-}  -- | Determines whether all elements of vector satisfy predicate.-all :: Arity n => (a -> Bool) -> ContVec n a -> Bool+all :: ArityPeano n => (a -> Bool) -> ContVec n a -> Bool all f = foldr (\x b -> f x && b) True {-# INLINE all #-}  -- | Determines whether any of element of vector satisfy predicate.-any :: Arity n => (a -> Bool) -> ContVec n a -> Bool+any :: ArityPeano n => (a -> Bool) -> ContVec n a -> Bool any f = foldr (\x b -> f x || b) False {-# INLINE any #-}  -- | The 'find' function takes a predicate and a vector and returns --   the leftmost element of the vector matching the predicate, --   or 'Nothing' if there is no such element.-find :: Arity n => (a -> Bool) -> ContVec n a -> Maybe a+find :: ArityPeano n => (a -> Bool) -> ContVec n a -> Maybe a find f = foldl (\r x -> r <|> if f x then Just x else Nothing) Nothing {-# INLINE find #-} @@ -1042,7 +1219,7 @@        -> v a -> c (v a) gfoldl f inj v   = inspect v-  $ gfoldlF f (inj $ unFun (construct :: Fun (Peano (Dim v)) a (v a)))+  $ gfoldlF f (inj $ unFun (construct :: Fun (Dim v) a (v a)))  -- | Generic 'Data.Data.gunfoldl' which could work with any --   vector. Since vector can only have one constructor argument for@@ -1051,22 +1228,24 @@         => (forall b r. Data b => c (b -> r) -> c r)         -> (forall r. r -> c r)         -> con -> c (v a)-gunfold f inj _-  = gunfoldF f gun+gunfold f inj _ =+  case reducePeano step gun of+    T_gunfold c -> c   where-    con = construct                   :: Fun (Peano (Dim v)) a (v a)-    gun = T_gunfold (inj $ unFun con) :: T_gunfold c (v a) a (Peano (Dim v))-+    con = construct @v @a+    gun = T_gunfold (inj $ unFun con) :: T_gunfold c (v a) a (Dim v)+    --+    step :: forall k r. T_gunfold c r a ('S k) -> T_gunfold c r a k+    step (T_gunfold c) = T_gunfold (f c)  gfoldlF :: (ArityPeano n, Data a)         => (forall x y. Data x => c (x -> y) -> x -> c y)         -> c (Fn n a r) -> Fun n a (c r) gfoldlF f c0 = accum-  (\(T_gfoldl c) x -> T_gfoldl (f c x))-  (\(T_gfoldl c)   -> c)-  (T_gfoldl   c0)+  (\(T_mapM c) x -> T_mapM (f c x))+  (\(T_mapM c)   -> c)+  (T_mapM   c0) -newtype T_gfoldl c r a n = T_gfoldl (c (Fn n a r))   ----------------------------------------------------------------@@ -1105,7 +1284,7 @@ -- Instances ---------------------------------------------------------------- -type instance Dim Complex = 2+type instance Dim Complex = N2  instance Vector Complex a where   construct = Fun (:+)@@ -1114,7 +1293,7 @@   {-# INLINE inspect #-}  -type instance Dim Identity = 1+type instance Dim Identity = N1  instance Vector Identity a where   construct = Fun Identity@@ -1123,7 +1302,7 @@   {-# INLINE inspect #-}  -type instance Dim ((,) a) = 2+type instance Dim ((,) a) = N2  -- | Note this instance (and other instances for tuples) is --   essentially monomorphic in element type. Vector type /v/ of 2@@ -1136,7 +1315,7 @@   {-# INLINE inspect #-}  -type instance Dim ((,,) a b) = 3+type instance Dim ((,,) a b) = N3  instance (b~a, c~a) => Vector ((,,) b c) a where   construct = Fun (,,)@@ -1145,7 +1324,7 @@   {-# INLINE inspect #-}  -type instance Dim ((,,,) a b c) = 4+type instance Dim ((,,,) a b c) = N4  instance (b~a, c~a, d~a) => Vector ((,,,) b c d) a where   construct = Fun (,,,)@@ -1154,7 +1333,7 @@   {-# INLINE inspect #-}  -type instance Dim ((,,,,) a b c d) = 5+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 (,,,,)@@ -1163,7 +1342,7 @@   {-# INLINE inspect #-}  -type instance Dim ((,,,,,) a b c d e) = 6+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 (,,,,,)@@ -1172,7 +1351,7 @@   {-# INLINE inspect #-}  -type instance Dim ((,,,,,,) a b c d e f) = 7+type instance Dim ((,,,,,,) a b c d e f) = N7  instance (b~a, c~a, d~a, e~a, f~a, g~a) => Vector ((,,,,,,) b c d e f g) a where   construct = Fun (,,,,,,)@@ -1180,7 +1359,7 @@   {-# INLINE construct #-}   {-# INLINE inspect #-} -type instance Dim Proxy = 0+type instance Dim Proxy = Z  instance Vector Proxy a where   construct = Fun Proxy

@@ -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

@@ -1,26 +1,18 @@-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds             #-}-{-# LANGUAGE Rank2Types            #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PolyKinds #-} -- | -- Implementation of fixed-vectors module Data.Vector.Fixed.Internal where  import Control.DeepSeq       (NFData(..))-import Data.Typeable         (Proxy(..))-import Data.Functor.Identity (Identity(..)) import qualified Data.Foldable    as T import qualified Data.Traversable as T import Foreign.Storable (Storable(..)) import Foreign.Ptr      (Ptr,castPtr)-import GHC.TypeLits+import GHC.Exts         (proxy#) -import           Data.Vector.Fixed.Cont     (Vector(..),Dim,Arity,vector,Add)+import           Data.Vector.Fixed.Cont (Vector(..),Dim,vector,Add,PeanoNum(..),+                                         Peano,Index,ArityPeano) import qualified Data.Vector.Fixed.Cont as C  import Prelude hiding ( replicate,map,zipWith,maximum,minimum,and,or,all,any@@ -33,39 +25,39 @@ -- Constructors ---------------------------------------------------------------- -mk0 :: (Vector v a, Dim v ~ 0) => v a+mk0 :: (Vector v a, Dim v ~ 'Z) => v a mk0 = vector C.empty {-# INLINE mk0 #-} -mk1 :: (Vector v a, Dim v ~ 1) => a -> v a+mk1 :: (Vector v a, Dim v ~ C.N1) => a -> v a mk1 a1 = vector $ C.mk1 a1 {-# INLINE mk1 #-} -mk2 :: (Vector v a, Dim v ~ 2) => a -> a -> v a+mk2 :: (Vector v a, Dim v ~ C.N2) => a -> a -> v a mk2 a1 a2 = vector $ C.mk2 a1 a2 {-# INLINE mk2 #-} -mk3 :: (Vector v a, Dim v ~ 3) => a -> a -> a -> v a+mk3 :: (Vector v a, Dim v ~ C.N3) => a -> a -> a -> v a mk3 a1 a2 a3 = vector $ C.mk3 a1 a2 a3 {-# INLINE mk3 #-} -mk4 :: (Vector v a, Dim v ~ 4) => a -> a -> a -> a -> v a+mk4 :: (Vector v a, Dim v ~ C.N4) => a -> a -> a -> a -> v a mk4 a1 a2 a3 a4 = vector $ C.mk4 a1 a2 a3 a4 {-# INLINE mk4 #-} -mk5 :: (Vector v a, Dim v ~ 5) => a -> a -> a -> a -> a -> v a+mk5 :: (Vector v a, Dim v ~ C.N5) => a -> a -> a -> a -> a -> v a mk5 a1 a2 a3 a4 a5 = vector $ C.mk5 a1 a2 a3 a4 a5 {-# INLINE mk5 #-} -mk6 :: (Vector v a, Dim v ~ 6) => a -> a -> a -> a -> a -> a -> v a+mk6 :: (Vector v a, Dim v ~ C.N6) => a -> a -> a -> a -> a -> a -> v a mk6 a1 a2 a3 a4 a5 a6 = vector $ C.mk6 a1 a2 a3 a4 a5 a6 {-# INLINE mk6 #-} -mk7 :: (Vector v a, Dim v ~ 7) => a -> a -> a -> a -> a -> a -> a -> v a+mk7 :: (Vector v a, Dim v ~ C.N7) => a -> a -> a -> a -> a -> a -> a -> v a mk7 a1 a2 a3 a4 a5 a6 a7 = vector $ C.mk7 a1 a2 a3 a4 a5 a6 a7 {-# INLINE mk7 #-} -mk8 :: (Vector v a, Dim v ~ 8) => a -> a -> a -> a -> a -> a -> a -> a -> v a+mk8 :: (Vector v a, Dim v ~ C.N8) => a -> a -> a -> a -> a -> a -> a -> a -> v a mk8 a1 a2 a3 a4 a5 a6 a7 a8 = vector $ C.mk8 a1 a2 a3 a4 a5 a6 a7 a8 {-# INLINE mk8 #-} @@ -77,14 +69,14 @@ -- --   or using @TypeApplications@ syntax: -----   > v = mkN (Proxy @ (Int,Int,Int)) 1 2 3+--   > v = mkN (Proxy @(Int,Int,Int)) 1 2 3 -- --   or if type of @v@ is fixed elsewhere -- --   > v = mkN [v] 1 2 3 mkN :: forall proxy v a. (Vector v a)-    => proxy (v a) -> C.Fn (C.Peano (Dim v)) a (v a)-mkN _ = C.unFun (construct :: C.Fun (C.Peano (Dim v)) a (v a))+    => proxy (v a) -> C.Fn (Dim v) a (v a)+mkN _ = C.unFun (construct :: C.Fun (Dim v) a (v a))  ---------------------------------------------------------------- -- Generic functions@@ -96,14 +88,14 @@ -- --   >>> import Data.Vector.Fixed.Boxed (Vec2) --   >>> replicate 1 :: Vec2 Int---   fromList [1,1]+--   [1,1] -- --   >>> replicate 2 :: (Double,Double,Double) --   (2.0,2.0,2.0) -- --   >>> import Data.Vector.Fixed.Boxed (Vec4) --   >>> replicate "foo" :: Vec4 String---   fromList ["foo","foo","foo","foo"]+--   ["foo","foo","foo","foo"] replicate :: Vector v a => a -> v a {-# INLINE replicate #-} replicate@@ -116,11 +108,11 @@ -- --   >>> import Data.Vector.Fixed.Boxed (Vec2,Vec3) --   >>> replicateM (Just 3) :: Maybe (Vec3 Int)---   Just (fromList [3,3,3])+--   Just [3,3,3] --   >>> replicateM (putStrLn "Hi!") :: IO (Vec2 ()) --   Hi! --   Hi!---   fromList [(),()]+--   [(),()] replicateM :: (Vector v a, Applicative f) => f a -> f (v a) {-# INLINE replicateM #-} replicateM@@ -134,11 +126,11 @@ -- --   >>> import Data.Vector.Fixed.Boxed (Vec3) --   >>> basis 0 :: Vec3 Int---   fromList [1,0,0]+--   [1,0,0] --   >>> basis 1 :: Vec3 Int---   fromList [0,1,0]+--   [0,1,0] --   >>> basis 3 :: Vec3 Int---   fromList [0,0,0]+--   [0,0,0] basis :: (Vector v a, Num a) => Int -> v a {-# INLINE basis #-} basis = vector . C.basis@@ -157,7 +149,7 @@ -- --   >>> import Data.Vector.Fixed.Unboxed (Vec4) --   >>> generate (^2) :: Vec4 Int---   fromList [0,1,4,9]+--   [0,1,4,9] generate :: (Vector v a) => (Int -> a) -> v a {-# INLINE generate #-} generate = vector . C.generate@@ -181,7 +173,7 @@ --   >>> let x = mk3 1 2 3 :: Vec3 Int --   >>> head x --   1-head :: (Vector v a, 1 <= Dim v) => v a -> a+head :: (Vector v a, Dim v ~ 'S k) => v a -> a {-# INLINE head #-} head = C.head . C.cvec @@ -193,27 +185,25 @@ --   >>> import Data.Complex --   >>> tail (1,2,3) :: Complex Double --   2.0 :+ 3.0-tail :: (Vector v a, Vector w a, Dim v ~ (Dim w + 1))+tail :: (Vector v a, Vector w a, Dim v ~ 'S (Dim w))      => v a -> w a {-# INLINE tail #-} tail = vector . C.tail . C.cvec  -- | Cons element to the vector-cons :: (Vector v a, Vector w a, Dim w ~ (Dim v + 1))+cons :: (Vector v a, Vector w a, Dim w ~ 'S (Dim v))      => a -> v a -> w a {-# INLINE cons #-} cons a = vector . C.cons a . C.cvec  -- | Append element to the vector-snoc :: (Vector v a, Vector w a, Dim w ~ (Dim v + 1))+snoc :: (Vector v a, Vector w a, Dim w ~ 'S (Dim v))      => a -> v a -> w a {-# INLINE snoc #-} snoc a = vector . C.snoc a . C.cvec  concat :: ( Vector v a, Vector u a, Vector w a-          , (Dim v + Dim u) ~ Dim w-            -- Tautology-          , C.Peano (Dim v + Dim u) ~ Add (C.Peano (Dim v)) (C.Peano (Dim u))+          , (Dim v `Add` Dim u) ~ Dim w           )        => v a -> u a -> w a {-# INLINE concat #-}@@ -228,10 +218,10 @@ --   /O(n)/ but more efficient one is used when possible. (!) :: (Vector v a) => v a -> Int -> a {-# INLINE (!) #-}-v ! n = runIndex n (C.cvec v)+(!) v n = runIndex n (C.cvec v)  -- Used in rewriting of index function.-runIndex :: Arity n => Int -> C.ContVec n r -> r+runIndex :: ArityPeano n => Int -> C.ContVec n r -> r runIndex = C.index {-# INLINE[0] runIndex #-} @@ -259,16 +249,18 @@   -- | Get element from vector at statically known index-index :: (Vector v a, KnownNat k, k + 1 <= Dim v)+index :: forall k v a proxy. (Vector v a, Index (Peano k) (Dim v))       => v a -> proxy k -> a {-# INLINE index #-}-index v k = v ! fromIntegral (natVal k)+index v _ = inspect v (C.getF (proxy# @(Peano k)))  -- | Set n'th element in the vector-set :: (Vector v a, KnownNat k, k + 1 <= Dim v) => proxy k -> a -> v a -> v a+set :: forall k v a proxy. (Vector v a, Index (Peano k) (Dim v))+    => proxy k -> a -> v a -> v a {-# INLINE set #-}-set k a = runIdentity . element (fromIntegral (natVal k))-                                (const (Identity a))+set _ a v+  = inspect v+  $ C.putF (proxy# @(Peano k)) a construct  -- | Twan van Laarhoven's lens for element of vector element :: (Vector v a, Functor f) => Int -> (a -> f a) -> (v a -> f (v a))@@ -277,10 +269,13 @@  -- | Twan van Laarhoven's lens for element of vector with statically --   known index.-elementTy :: (Vector v a, KnownNat k, k + 1 <= Dim v, Functor f)+elementTy :: forall k v a f proxy. (Vector v a, Index (Peano k) (Dim v), Functor f)           => proxy k -> (a -> f a) -> (v a -> f (v a)) {-# INLINE elementTy #-}-elementTy k = element (fromIntegral (natVal k))+elementTy _ f v+  = fmap vector+  $ inspect (C.cvec v) +    (C.lensF (proxy# @(Peano k)) f construct)  -- | Left fold over vector foldl :: Vector v a => (b -> a -> b) -> b -> v a -> b@@ -288,6 +283,12 @@ foldl f x = C.foldl f x           . C.cvec +-- | Strict left fold over vector+foldl' :: Vector v a => (b -> a -> b) -> b -> v a -> b+{-# INLINE foldl' #-}+foldl' f x = C.foldl' f x+           . C.cvec+ -- | Right fold over vector foldr :: Vector v a => (a -> b -> b) -> b -> v a -> b {-# INLINE foldr #-}@@ -296,7 +297,7 @@   -- | Left fold over vector-foldl1 :: (Vector v a, 1 <= Dim v) => (a -> a -> a) -> v a -> a+foldl1 :: (Vector v a, Dim v ~ 'S k) => (a -> a -> a) -> v a -> a {-# INLINE foldl1 #-} foldl1 f = C.foldl1 f          . C.cvec@@ -328,6 +329,13 @@ ifoldl f z = C.ifoldl f z            . C.cvec +-- | Strict left fold over vector. Function is applied to each element+--   and its index.+ifoldl' :: Vector v a => (b -> Int -> a -> b) -> b -> v a -> b+{-# INLINE ifoldl' #-}+ifoldl' f z = C.ifoldl' f z+            . C.cvec+ -- | Monadic fold over vector. foldM :: (Vector v a, Monad m) => (b -> a -> m b) -> b -> v a -> m b {-# INLINE foldM #-}@@ -356,7 +364,7 @@ --   >>> let x = mk3 1 2 3 :: Vec3 Int --   >>> maximum x --   3-maximum :: (Vector v a, 1 <= Dim v, Ord a) => v a -> a+maximum :: (Vector v a, Dim v ~ S k, Ord a) => v a -> a maximum = C.maximum . C.cvec {-# INLINE maximum #-} @@ -368,7 +376,7 @@ --   >>> let x = mk3 1 2 3 :: Vec3 Int --   >>> minimum x --   1-minimum :: (Vector v a, 1 <= Dim v, Ord a) => v a -> a+minimum :: (Vector v a, Dim v ~ S k, Ord a) => v a -> a minimum = C.minimum . C.cvec {-# INLINE minimum #-} @@ -484,7 +492,7 @@          . C.cvec  -- | Left scan over vector-scanl :: (Vector v a, Vector w b, Dim w ~ (Dim v + 1))+scanl :: (Vector v a, Vector w b, Dim w ~ 'S (Dim v))       => (b -> a -> b) -> b -> v a -> w b {-# INLINE scanl #-} scanl f x0 = vector . C.scanl f x0 . C.cvec@@ -499,7 +507,8 @@ sequenceA :: (Vector v a, Vector v (f a), Applicative f)           => v (f a) -> f (v a) {-# INLINE sequenceA #-}-sequenceA = fmap vector . T.sequenceA . C.cvec+sequenceA = sequence+{-# DEPRECATED sequenceA "Use sequence instead" #-}  -- | Analog of 'T.traverse' from 'T.Traversable'. traverse :: (Vector v a, Vector v b, Applicative f)@@ -531,11 +540,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 #-}@@ -612,12 +621,13 @@ defaultAlignemnt _ = alignment (undefined :: a) {-# INLINE defaultAlignemnt #-} + -- | Default implementation of 'sizeOf` for 'Storable' type class for --   fixed vectors defaultSizeOf   :: forall a v. (Storable a, Vector v a)   => v a -> Int-defaultSizeOf _ = sizeOf (undefined :: a) * C.arity (Proxy :: Proxy (Dim v))+defaultSizeOf _ = sizeOf (undefined :: a) * C.peanoToInt (proxy# @(Dim v)) {-# INLINE defaultSizeOf #-}  -- | Default implementation of 'peek' for 'Storable' type class for@@ -676,5 +686,5 @@  -- | Generic definition of 'Prelude.showsPrec' showsPrec :: (Vector v a, Show a) => Int -> v a -> ShowS-showsPrec d v = showParen (d > 10) $ showString "fromList " . Prelude.showsPrec 11 (toList v)+showsPrec _ = shows . toList {-# INLINE showsPrec #-}

@@ -1,10 +1,5 @@-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds             #-}-{-# LANGUAGE Rank2Types            #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PolyKinds #-} -- | -- Type classes for vectors which are implemented on top of the arrays -- and support in-place mutation. API is similar to one used in the@@ -12,14 +7,17 @@ module Data.Vector.Fixed.Mutable (     -- * Mutable vectors     Arity-  , arity   , Mutable   , DimM   , MVector(..)   , lengthM+  , new+  , clone+  , copy   , read   , write-  , clone+  , unsafeRead+  , unsafeWrite     -- * Creation   , replicate   , replicateM@@ -32,6 +30,7 @@   , index   , freeze   , thaw+  , unsafeFreeze     -- * Vector API   , constructVec   , inspectVec@@ -40,13 +39,14 @@ import Control.Applicative  (Const(..)) import Control.Monad.ST import Control.Monad.Primitive-import Data.Typeable  (Proxy(..)) import Data.Kind      (Type)-import GHC.TypeLits-import Data.Vector.Fixed.Cont (Dim,PeanoNum(..),Peano,Arity,Fun(..),Vector(..),ContVec,arity,apply,accum,length) import Prelude hiding (read,length,replicate)+import GHC.Exts (proxy#) +import Data.Vector.Fixed.Cont (Dim,PeanoNum(..),Arity,ArityPeano(..),Fun(..),Vector(..),+                               ContVec,apply,accum,length) + ---------------------------------------------------------------- -- Type classes ----------------------------------------------------------------@@ -55,34 +55,60 @@ type family Mutable (v :: Type -> Type) :: Type -> Type -> Type  -- | Dimension for mutable vector.-type family DimM (v :: Type -> Type -> Type) :: Nat+type family DimM (v :: Type -> Type -> Type) :: PeanoNum  -- | Type class for mutable vectors.-class (Arity (DimM v)) => MVector v a where-  -- | Copy vector. The two vectors may not overlap. Since vectors'-  --   length is encoded in the type there is no need in runtime checks.-  copy :: PrimMonad m-       => v (PrimState m) a    -- ^ Target-       -> v (PrimState m) a    -- ^ Source-       -> m ()-  -- | Copy vector. The two vectors may overlap. Since vectors' length-  --   is encoded in the type there is no need in runtime checks.-  move :: PrimMonad m-       => v (PrimState m) a    -- ^ Target-       -> v (PrimState m) a    -- ^ Source-       -> m ()-  -- | Allocate new vector-  new   :: PrimMonad m => m (v (PrimState m) a)-  -- | Read value at index without bound checks.-  unsafeRead  :: PrimMonad m => v (PrimState m) a -> Int -> m a-  -- | Write value at index without bound checks.-  unsafeWrite :: PrimMonad m => v (PrimState m) a -> Int -> a -> m ()-+class (ArityPeano (DimM v)) => MVector v a where+  -- | Copy vector. The two vectors may not overlap. Shouldn't be used+  --   directly, use 'copy' instead.+  basicCopy :: v s a    -- ^ Target+            -> v s a    -- ^ Source+            -> ST s ()+  -- | Allocate new uninitialized vector. Shouldn't be used+  --   directly, use 'new' instead.+  basicNew :: ST s (v s a)+  -- | Allocate new vector initialized with given element. Shouldn't be used+  --   directly, use 'replicate' instead.+  basicReplicate :: a -> ST s (v s a)+  {-# INLINE basicReplicate #-}+  basicReplicate a = do+    v <- basicNew+    forI v $ \i -> basicUnsafeWrite v i a+    pure v+  -- | Create copy of existing vector. Shouldn't be used+  --   directly, use 'clone' instead.+  basicClone :: v s a -> ST s (v s a)+  {-# INLINE basicClone #-}+  basicClone src = do+    dst <- basicNew+    basicCopy dst src+    pure src+  -- | Read value at index without bound checks. Shouldn't be used+  --   directly, use 'unsafeRead' instead.+  basicUnsafeRead  :: v s a -> Int -> ST s a+  -- | Write value at index without bound checks. Shouldn't be used+  --   directly, use 'unsafeWrite' instead.+  basicUnsafeWrite :: v s a -> Int -> a -> ST s ()  -- | Length of mutable vector. Function doesn't evaluate its argument.-lengthM :: forall v s a. (Arity (DimM v)) => v s a -> Int-lengthM _ = arity (Proxy :: Proxy (DimM v))+lengthM :: forall v s a. (ArityPeano (DimM v)) => v s a -> Int+lengthM _ = peanoToInt (proxy# @(DimM v)) +-- | Create new uninitialized  mutable vector.+new :: (MVector v a, PrimMonad m) => m (v (PrimState m) a)+new = stToPrim basicNew+{-# INLINE new #-}++-- | Copy vector. The two vectors may not overlap. Since vectors'+--   length is encoded in the type there is no need in runtime+--   checks of length.+copy :: (MVector v a, PrimMonad m)+     => v (PrimState m) a    -- ^ Target+     -> v (PrimState m) a    -- ^ Source+     -> m ()+{-# INLINE copy #-}+copy tgt src = stToPrim $ basicCopy tgt src+ -- | Create copy of vector. -- --   Examples:@@ -93,14 +119,21 @@ --   >>> import qualified Data.Vector.Fixed.Mutable as M --   >>> let x = runST (do { v <- M.replicate 100; v' <- clone v; M.write v' 0 2; M.unsafeFreeze v' }) :: Vec3 Int --   >>> x---   fromList [2,100,100]+--   [2,100,100] clone :: (PrimMonad m, MVector v a) => v (PrimState m) a -> m (v (PrimState m) a) {-# INLINE clone #-}-clone v = do-  u <- new-  move u v-  return u+clone = stToPrim . basicClone +-- | Read value at index without bound checks.+unsafeRead  :: (MVector v a, PrimMonad m) => v (PrimState m) a -> Int -> m a+{-# INLINE unsafeRead #-}+unsafeRead v i = stToPrim $ basicUnsafeRead v i++-- | Write value at index without bound checks.+unsafeWrite :: (MVector v a, PrimMonad m) => v (PrimState m) a -> Int -> a -> m ()+{-# INLINE unsafeWrite #-}+unsafeWrite v i a = stToPrim $ basicUnsafeWrite v i a+ -- | Read value at index with bound checks. read  :: (PrimMonad m, MVector v a) => v (PrimState m) a -> Int -> m a {-# INLINE read #-}@@ -119,10 +152,7 @@ -- | Create new vector with all elements set to given value. replicate :: (PrimMonad m, MVector v a) => a -> m (v (PrimState m) a) {-# INLINE replicate #-}-replicate a = do-  v <- new-  forI v $ \i -> unsafeWrite v i a-  pure v+replicate = stToPrim . basicReplicate  -- | Create new vector with all elements are generated by provided --   monadic action.@@ -167,37 +197,19 @@ class (Dim v ~ DimM (Mutable v), MVector (Mutable v) a) => IVector v a where   -- | Convert vector to immutable state. Mutable vector must not be   --   modified afterwards.-  unsafeFreeze :: PrimMonad m => Mutable v (PrimState m) a -> m (v a)-  -- | /O(1)/ Unsafely convert immutable vector to mutable without-  --   copying.  Note that this is a very dangerous function and-  --   generally it's only safe to read from the resulting vector. In-  --   this case, the immutable vector could be used safely as well.-  ---  -- Problems with mutation happen because GHC has a lot of freedom to-  -- introduce sharing. As a result mutable vectors produced by-  -- @unsafeThaw@ may or may not share the same underlying buffer. For-  -- example:-  ---  -- > foo = do-  -- >   let vec = F.generate 10 id-  -- >   mvec <- M.unsafeThaw vec-  -- >   do_something mvec-  ---  -- Here GHC could lift @vec@ outside of foo which means that all calls to-  -- @do_something@ will use same buffer with possibly disastrous-  -- results. Whether such aliasing happens or not depends on the program in-  -- question, optimization levels, and GHC flags.-  ---  -- All in all, attempts to modify a vector produced by @unsafeThaw@-  -- fall out of domain of software engineering and into realm of-  -- black magic, dark rituals, and unspeakable horrors. The only-  -- advice that could be given is: "Don't attempt to mutate a vector-  -- produced by @unsafeThaw@ unless you know how to prevent GHC from-  -- aliasing buffers accidentally. We don't."-  unsafeThaw   :: PrimMonad m => v a -> m (Mutable v (PrimState m) a)+  basicUnsafeFreeze :: Mutable v s a -> ST s (v a)+  -- | Convert immutable vector to mutable by copying it.+  basicThaw :: v a -> ST s (Mutable v s a)   -- | Get element at specified index without bounds check.   unsafeIndex :: v a -> Int -> a ++-- | Convert vector to immutable state. Mutable vector must not be+--   modified afterwards.+unsafeFreeze :: (IVector v a, PrimMonad m) => Mutable v (PrimState m) a -> m (v a)+{-# INLINE unsafeFreeze #-}+unsafeFreeze = stToPrim . basicUnsafeFreeze+ index :: IVector v a => v a -> Int -> a {-# INLINE index #-} index v i | i < 0 || i >= length v = error "Data.Vector.Fixed.Mutable.!: index out of bounds"@@ -212,7 +224,7 @@ -- | Safely convert immutable vector to mutable. thaw :: (PrimMonad m, IVector v a) => v a -> m (Mutable v (PrimState m) a) {-# INLINE thaw #-}-thaw v = clone =<< unsafeThaw v+thaw = stToPrim . basicThaw   @@ -221,22 +233,22 @@ ----------------------------------------------------------------  -- | Generic inspect implementation for array-based vectors.-inspectVec :: forall v a b. (Arity (Dim v), IVector v a) => v a -> Fun (Peano (Dim v)) a b -> b+inspectVec :: forall v a b. (ArityPeano (Dim v), IVector v a) => v a -> Fun (Dim v) a b -> b {-# INLINE inspectVec #-} inspectVec v   = inspect cv   where     cv :: ContVec (Dim v) a     cv = apply (\(Const i) -> (unsafeIndex v i, Const (i+1)))-               (Const 0 :: Const Int (Peano (Dim v)))+               (Const 0 :: Const Int (Dim v))  -- | Generic construct implementation for array-based vectors.-constructVec :: forall v a. (Arity (Dim v), IVector v a) => Fun (Peano (Dim v)) a (v a)+constructVec :: forall v a. (ArityPeano (Dim v), IVector v a) => Fun (Dim v) a (v a) {-# INLINE constructVec #-} constructVec =   accum step         (\(T_new _ st) -> runST $ unsafeFreeze =<< st :: v a)-        (T_new 0 new :: T_new v a (Peano (Dim v)))+        (T_new 0 new :: T_new v a (Dim v))  data T_new v a n = T_new Int (forall s. ST s (Mutable v s a)) 

@@ -1,12 +1,5 @@-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE DeriveDataTypeable    #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE StandaloneDeriving    #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE MagicHash            #-}+{-# LANGUAGE UndecidableInstances #-} -- | -- Unboxed vectors with fixed length. Vectors from -- "Data.Vector.Fixed.Unboxed" provide more flexibility at no@@ -32,17 +25,18 @@ import Data.Semigroup           (Semigroup(..)) import Data.Primitive.ByteArray import Data.Primitive-import qualified Foreign.Storable as Foreign (Storable(..))+import Data.Kind                (Type)+import Foreign.Storable         (Storable) import GHC.TypeLits+import GHC.Exts (proxy#) import Prelude (Show(..),Eq(..),Ord(..),Num(..))-import Prelude (($),($!),undefined,seq)+import Prelude (($),($!),undefined,seq,(<$>))   import Data.Vector.Fixed hiding (index)-import Data.Vector.Fixed.Mutable (Mutable, MVector(..), IVector(..), DimM, constructVec, inspectVec, arity, index)+import Data.Vector.Fixed.Mutable (Mutable, MVector(..), IVector(..), DimM, constructVec, inspectVec, index) import qualified Data.Vector.Fixed.Cont     as C-import qualified Data.Vector.Fixed.Internal as I-+import           Data.Vector.Fixed.Cont     (ArityPeano(..))   ----------------------------------------------------------------@@ -50,62 +44,56 @@ ----------------------------------------------------------------  -- | Unboxed vector with fixed length-newtype Vec (n :: Nat) a = Vec ByteArray+newtype Vec (n :: Nat) (a :: Type) = Vec ByteArray  -- | Mutable unboxed vector with fixed length newtype MVec (n :: Nat) s a = MVec (MutableByteArray s) -deriving instance Typeable Vec-deriving instance Typeable MVec- type Vec1 = Vec 1 type Vec2 = Vec 2 type Vec3 = Vec 3 type Vec4 = Vec 4 type Vec5 = Vec 5 +type instance Mutable (Vec  n) = MVec n+type instance Dim     (Vec  n) = Peano n+type instance DimM    (MVec n) = Peano n   ---------------------------------------------------------------- -- Instances ---------------------------------------------------------------- -instance (Arity n, Prim a, Show a) => Show (Vec n a) where-  showsPrec = I.showsPrec- instance (Arity n, Prim a, NFData a) => NFData (Vec n a) where-  rnf = foldl (\r a -> r `seq` rnf a) ()-  {-# INLINE rnf #-}+  rnf x = seq x () -type instance Mutable (Vec n) = MVec n+deriving via ViaFixed (Vec n) a instance (Arity n, Prim a, Show      a) => Show      (Vec n a)+deriving via ViaFixed (Vec n) a instance (Arity n, Prim a, Eq        a) => Eq        (Vec n a)+deriving via ViaFixed (Vec n) a instance (Arity n, Prim a, Ord       a) => Ord       (Vec n a)+deriving via ViaFixed (Vec n) a instance (Arity n, Prim a, Semigroup a) => Semigroup (Vec n a)+deriving via ViaFixed (Vec n) a instance (Arity n, Prim a, Monoid    a) => Monoid    (Vec n a)+deriving via ViaFixed (Vec n) a instance (Arity n, Prim a, Storable  a) => Storable  (Vec n a)  instance (Arity n, Prim a) => MVector (MVec n) a where-  new = do-    v <- newByteArray $! arity (Proxy :: Proxy n)+  basicNew = do+    v <- newByteArray $! peanoToInt (proxy# @(Peano n))                        * sizeOf (undefined :: a)     return $ MVec v-  {-# INLINE new         #-}-  copy                       = move-  {-# INLINE copy        #-}-  move (MVec dst) (MVec src) = copyMutableByteArray dst 0 src 0 (arity (Proxy :: Proxy n))-  {-# INLINE move        #-}-  unsafeRead  (MVec v) i   = readByteArray  v i-  {-# INLINE unsafeRead  #-}-  unsafeWrite (MVec v) i x = writeByteArray v i x-  {-# INLINE unsafeWrite #-}+  {-# INLINE basicNew         #-}+  basicCopy (MVec dst) (MVec src) = copyMutableByteArray dst 0 src 0 (peanoToInt (proxy# @(Peano n)))+  {-# INLINE basicCopy        #-}+  basicUnsafeRead  (MVec v) i   = readByteArray  v i+  {-# INLINE basicUnsafeRead  #-}+  basicUnsafeWrite (MVec v) i x = writeByteArray v i x+  {-# INLINE basicUnsafeWrite #-}  instance (Arity n, Prim a) => IVector (Vec n) a where-  unsafeFreeze (MVec v)   = do { a <- unsafeFreezeByteArray v; return $! Vec  a }-  unsafeThaw   (Vec  v)   = do { a <- unsafeThawByteArray   v; return $! MVec a }-  unsafeIndex  (Vec  v) i = indexByteArray v i-  {-# INLINE unsafeFreeze #-}-  {-# INLINE unsafeThaw   #-}-  {-# INLINE unsafeIndex  #-}----type instance Dim  (Vec  n) = n-type instance DimM (MVec n) = n+  basicUnsafeFreeze (MVec v) = do { a <- unsafeFreezeByteArray v; return $! Vec  a }+  basicThaw         (Vec  v) = MVec <$> thawByteArray v 0 (peanoToInt (proxy# @(Peano n)))+  unsafeIndex       (Vec  v) i = indexByteArray v i+  {-# INLINE basicUnsafeFreeze #-}+  {-# INLINE basicThaw         #-}+  {-# INLINE unsafeIndex       #-}  instance (Arity n, Prim a) => Vector (Vec n) a where   construct  = constructVec@@ -114,26 +102,7 @@   {-# INLINE construct  #-}   {-# INLINE inspect    #-}   {-# INLINE basicIndex #-}-instance (Arity n, Prim a) => VectorN Vec n a -instance (Arity n, Prim a, Eq a) => Eq (Vec n a) where-  (==) = eq-  {-# INLINE (==) #-}-instance (Arity n, Prim a, Ord a) => Ord (Vec n a) where-  compare = ord-  {-# INLINE compare #-}--instance (Arity n, Prim a, Monoid a) => Monoid (Vec n a) where-  mempty  = replicate mempty-  mappend = (<>)-  {-# INLINE mempty  #-}-  {-# INLINE mappend #-}--instance (Arity n, Prim a, Semigroup a) => Semigroup (Vec n a) where-  (<>) = zipWith (<>)-  {-# INLINE (<>) #-}-- instance (Typeable n, Arity n, Prim a, Data a) => Data (Vec n a) where   gfoldl       = C.gfoldl   gunfold      = C.gunfold@@ -145,13 +114,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      #-}

@@ -1,12 +1,6 @@-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE DeriveDataTypeable    #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE StandaloneDeriving    #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE MagicHash            #-}+{-# LANGUAGE UndecidableInstances #-} -- | -- Storable-based unboxed vectors. module Data.Vector.Fixed.Storable (@@ -34,18 +28,22 @@ import Data.Data import Foreign.Ptr           (castPtr) import Foreign.Storable-import Foreign.ForeignPtr import Foreign.Marshal.Array ( copyArray, moveArray )-import GHC.ForeignPtr        ( ForeignPtr(..), mallocPlainForeignPtrBytes )+import GHC.ForeignPtr        ( mallocPlainForeignPtrBytes ) import GHC.Ptr               ( Ptr(..) )+import GHC.Exts              ( proxy# ) import GHC.TypeLits+#if MIN_VERSION_base(4,15,0)+import GHC.ForeignPtr       ( unsafeWithForeignPtr )+#endif+import Foreign.ForeignPtr   ( ForeignPtr, withForeignPtr ) import Prelude ( Show(..),Eq(..),Ord(..),Num(..),Monad(..),IO,Int-               , ($),undefined,seq)+               , ($),undefined,seq,pure)  import Data.Vector.Fixed hiding (index)-import Data.Vector.Fixed.Mutable (Mutable, MVector(..), IVector(..), DimM, constructVec, inspectVec, arity, index)+import Data.Vector.Fixed.Mutable (Mutable, MVector(..), IVector(..), DimM, constructVec, inspectVec, index, new,unsafeFreeze) import qualified Data.Vector.Fixed.Cont     as C-import qualified Data.Vector.Fixed.Internal as I+import           Data.Vector.Fixed.Cont     (ArityPeano(..))   @@ -59,15 +57,15 @@ -- | Storable-based mutable vector with fixed length newtype MVec (n :: Nat) s a = MVec (ForeignPtr a) -deriving instance Typeable Vec-deriving instance Typeable MVec- type Vec1 = Vec 1 type Vec2 = Vec 2 type Vec3 = Vec 3 type Vec4 = Vec 4 type Vec5 = Vec 5 +type instance Mutable (Vec  n) = MVec n+type instance Dim     (Vec  n) = Peano n+type instance DimM    (MVec n) = Peano n   ----------------------------------------------------------------@@ -84,9 +82,11 @@ {-# INLINE unsafeFromForeignPtr #-} unsafeFromForeignPtr = Vec +-- | Pass pointer to the vector's data to the IO action. The data may+--   not be modified through the 'Ptr. unsafeWith :: (Ptr a -> IO b) -> Vec n a -> IO b {-# INLINE unsafeWith #-}-unsafeWith f (Vec fp) = f (getPtr fp)+unsafeWith f (Vec fp) = withForeignPtr fp f   @@ -94,55 +94,47 @@ -- Instances ---------------------------------------------------------------- -instance (Arity n, Storable a, Show a) => Show (Vec n a) where-  showsPrec = I.showsPrec- instance (Arity n, Storable a, NFData a) => NFData (Vec n a) where-  rnf = foldl (\r a -> r `seq` rnf a) ()-  {-# INLINE rnf #-}+  rnf x = seq x () -type instance Mutable (Vec n) = MVec n+deriving via ViaFixed (Vec n) a instance (Arity n, Storable a, Show      a) => Show      (Vec n a)+deriving via ViaFixed (Vec n) a instance (Arity n, Storable a, Eq        a) => Eq        (Vec n a)+deriving via ViaFixed (Vec n) a instance (Arity n, Storable a, Ord       a) => Ord       (Vec n a)+deriving via ViaFixed (Vec n) a instance (Arity n, Storable a, Semigroup a) => Semigroup (Vec n a)+deriving via ViaFixed (Vec n) a instance (Arity n, Storable a, Monoid    a) => Monoid    (Vec n a)  instance (Arity n, Storable a) => MVector (MVec n) a where-  new = unsafePrimToPrim $ do-    fp <- mallocVector $ arity (Proxy :: Proxy n)+  basicNew = unsafePrimToPrim $ do+    fp <- mallocVector (peanoToInt (proxy# @(Peano n)))     return $ MVec fp-  {-# INLINE new         #-}-  copy (MVec fp) (MVec fq)-    = unsafePrimToPrim-    $ withForeignPtr fp $ \p ->-      withForeignPtr fq $ \q ->-      copyArray p q (arity (Proxy :: Proxy n))-  {-# INLINE copy        #-}-  move (MVec fp) (MVec fq)+  {-# INLINE basicNew         #-}+  basicCopy (MVec fp) (MVec fq)     = unsafePrimToPrim-    $ withForeignPtr fp $ \p ->-      withForeignPtr fq $ \q ->-      moveArray p q (arity (Proxy :: Proxy n))-  {-# INLINE move        #-}-  unsafeRead (MVec fp) i+    $ unsafeWithForeignPtr fp $ \p ->+      unsafeWithForeignPtr fq $ \q ->+      copyArray p q (peanoToInt (proxy# @(Peano n)))+  {-# INLINE basicCopy        #-}+  basicUnsafeRead (MVec fp) i     = unsafePrimToPrim-    $ withForeignPtr fp (`peekElemOff` i)-  {-# INLINE unsafeRead  #-}-  unsafeWrite (MVec fp) i x+    $ unsafeWithForeignPtr fp (`peekElemOff` i)+  {-# INLINE basicUnsafeRead  #-}+  basicUnsafeWrite (MVec fp) i x     = unsafePrimToPrim-    $ withForeignPtr fp $ \p -> pokeElemOff p i x-  {-# INLINE unsafeWrite #-}-+    $ unsafeWithForeignPtr fp $ \p -> pokeElemOff p i x+  {-# INLINE basicUnsafeWrite #-}  instance (Arity n, Storable a) => IVector (Vec n) a where-  unsafeFreeze (MVec fp)   = return $ Vec  fp-  unsafeThaw   (Vec  fp)   = return $ MVec fp+  basicUnsafeFreeze (MVec fp) = return $ Vec  fp+  basicThaw         (Vec  fp) = do+    mv <- basicNew+    basicCopy mv (MVec fp)+    pure mv   unsafeIndex  (Vec  fp) i     = unsafeInlineIO-    $ withForeignPtr fp (`peekElemOff` i)-  {-# INLINE unsafeFreeze #-}-  {-# INLINE unsafeThaw   #-}-  {-# INLINE unsafeIndex  #-}---type instance Dim  (Vec  n) = n-type instance DimM (MVec n) = n+    $ unsafeWithForeignPtr fp (`peekElemOff` i)+  {-# INLINE basicUnsafeFreeze #-}+  {-# INLINE basicThaw         #-}+  {-# INLINE unsafeIndex       #-}  instance (Arity n, Storable a) => Vector (Vec n) a where   construct  = constructVec@@ -151,37 +143,18 @@   {-# INLINE construct  #-}   {-# INLINE inspect    #-}   {-# INLINE basicIndex #-}-instance (Arity n, Storable a) => VectorN Vec n a -instance (Arity n, Storable a, Eq a) => Eq (Vec n a) where-  (==) = eq-  {-# INLINE (==) #-}-instance (Arity n, Storable a, Ord a) => Ord (Vec n a) where-  compare = ord-  {-# INLINE compare #-}--instance (Arity n, Storable a, Monoid a) => Monoid (Vec n a) where-  mempty  = replicate mempty-  mappend = (<>)-  {-# INLINE mempty  #-}-  {-# INLINE mappend #-}--instance (Arity n, Storable a, Semigroup a) => Semigroup (Vec n a) where-  (<>) = zipWith (<>)-  {-# INLINE (<>) #-}- instance (Arity n, Storable a) => Storable (Vec n a) where-  sizeOf    _ = arity  (Proxy :: Proxy n)-              * sizeOf (undefined :: a)-  alignment _ = alignment (undefined :: a)+  sizeOf    = defaultSizeOf+  alignment = defaultAlignemnt   peek ptr = do     arr@(MVec fp) <- new-    withForeignPtr fp $ \p ->-      moveArray p (castPtr ptr) (arity (Proxy :: Proxy n))+    unsafeWithForeignPtr fp $ \p ->+      moveArray p (castPtr ptr) (peanoToInt (proxy# @(Peano n)))     unsafeFreeze arr   poke ptr (Vec fp)-    = withForeignPtr fp $ \p ->-      moveArray (castPtr ptr) p (arity (Proxy :: Proxy n))+    = unsafeWithForeignPtr fp $ \p ->+      moveArray (castPtr ptr) p (peanoToInt (proxy# @(Peano n)))  instance (Typeable n, Arity n, Storable a, Data a) => Data (Vec n a) where   gfoldl       = C.gfoldl@@ -209,6 +182,12 @@ mallocVector size   = mallocPlainForeignPtrBytes (size * sizeOf (undefined :: a)) -getPtr :: ForeignPtr a -> Ptr a-{-# INLINE getPtr #-}-getPtr (ForeignPtr addr _) = Ptr addr+#if !MIN_VERSION_base(4,15,0)+-- | A compatibility wrapper for 'GHC.ForeignPtr.unsafeWithForeignPtr' provided+-- by GHC 9.0.1 and later.+--+-- Only to be used when the continuation is known not to+-- unconditionally diverge lest unsoundness can result.+unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b+unsafeWithForeignPtr = withForeignPtr+#endif

@@ -0,0 +1,124 @@+{-# LANGUAGE MagicHash            #-}+{-# 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 qualified Data.Foldable    as F+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.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 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)++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)++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 (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"

@@ -1,35 +1,37 @@-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE DeriveDataTypeable    #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds             #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE StandaloneDeriving    #-}-{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MagicHash             #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE UnboxedTuples         #-} {-# LANGUAGE UndecidableInstances  #-} -- |--- Unboxed vectors with fixed length.+-- Adaptive array type which picks vector representation from type of+-- element of array. For example arrays of @Double@ are backed by+-- @ByteArray@, arrays of @Bool@ are represented as bit-vector, arrays+-- of tuples are products of arrays. 'Unbox' type class is used to+-- describe representation of an array. module Data.Vector.Fixed.Unboxed(-    -- * Immutable-    Vec+    -- * Data type+    Vec(..)   , Vec1   , Vec2   , Vec3   , Vec4   , Vec5-    -- * Mutable-  , MVec-    -- * Type classes+    -- * Type classes & derivation   , Unbox+  , UnboxViaPrim+    -- * Concrete representations+  , BitVec+  , T2(..)+  , T3(..)   ) where  import Control.Applicative   (Const(..))-import Control.Monad import Control.DeepSeq       (NFData(..))+import Data.Bits import Data.Complex+import Data.Coerce import Data.Data+import Data.Kind import Data.Functor.Identity (Identity(..)) import Data.Int              (Int8, Int16, Int32, Int64 ) import Data.Monoid           (Monoid(..),Dual(..),Sum(..),Product(..),All(..),Any(..))@@ -38,16 +40,15 @@ import Data.Word             (Word,Word8,Word16,Word32,Word64) import Foreign.Storable      (Storable(..)) import GHC.TypeLits-import Prelude               ( Show(..),Eq(..),Ord(..),Int,Double,Float,Char,Bool(..)-                             , ($),(.),seq)+import GHC.Exts              (Proxy#, proxy#)+import Prelude               ( Show(..),Eq(..),Ord(..),Num(..),Applicative(..)+                             , Int,Double,Float,Char,Bool(..),($),id) -import Data.Vector.Fixed (Dim,Vector(..),VectorN,eq,ord,replicate,zipWith,foldl,-                          defaultSizeOf,defaultAlignemnt,defaultPeek,defaultPoke-                         )-import Data.Vector.Fixed.Mutable (Mutable, MVector(..), IVector(..), DimM, constructVec, inspectVec, Arity, index)-import qualified Data.Vector.Fixed.Cont      as C-import qualified Data.Vector.Fixed.Primitive as P-import qualified Data.Vector.Fixed.Internal  as I+import Data.Vector.Fixed           (Dim,Vector(..),ViaFixed(..))+import Data.Vector.Fixed           qualified as F+import Data.Vector.Fixed.Cont      qualified as C+import Data.Vector.Fixed.Cont      (Peano,Arity,ArityPeano,Fun(..),curryFirst)+import Data.Vector.Fixed.Primitive qualified as P   @@ -55,11 +56,9 @@ -- Data type ---------------------------------------------------------------- -data family Vec  (n :: Nat) a-data family MVec (n :: Nat) s a--deriving instance Typeable Vec-deriving instance Typeable MVec+-- | Adaptive array of dimension @n@ and containing elements of type+--   @a@.+newtype Vec (n :: Nat) a = Vec { getVecRepr :: VecRepr n a (EltRepr a) }  type Vec1 = Vec 1 type Vec2 = Vec 2@@ -67,52 +66,50 @@ type Vec4 = Vec 4 type Vec5 = Vec 5 -class (Arity n, IVector (Vec n) a, MVector (MVec n) a) => Unbox n a+-- | 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 Dim (Vec n) = Peano n -------------------------------------------------------------------- Generic instances-----------------------------------------------------------------+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 (Arity n, Show a, Unbox n a) => Show (Vec n a) where-  showsPrec = I.showsPrec -instance (Arity n, Unbox n a, NFData a) => NFData (Vec n a) where-  rnf = foldl (\r a -> r `seq` rnf a) ()-  {-# INLINE rnf #-} -type instance Mutable (Vec n) = MVec n--type instance Dim  (Vec  n) = n-type instance DimM (MVec n) = n--instance (Unbox n a) => Vector (Vec n) a where-  construct  = constructVec-  inspect    = inspectVec-  basicIndex = index-  {-# INLINE construct  #-}-  {-# INLINE inspect    #-}-  {-# INLINE basicIndex #-}---instance (Unbox n a) => VectorN Vec n a--instance (Unbox n a, Eq a) => Eq (Vec n a) where-  (==) = eq-  {-# INLINE (==) #-}-instance (Unbox n a, Ord a) => Ord (Vec n a) where-  compare = ord-  {-# INLINE compare #-}--instance (Unbox n a, Monoid a) => Monoid (Vec n a) where-  mempty  = replicate mempty-  mappend = (<>)-  {-# INLINE mempty  #-}-  {-# INLINE mappend #-}+----------------------------------------------------------------+-- Generic instances+---------------------------------------------------------------- -instance (Unbox n a, Semigroup a) => Semigroup (Vec n a) where-  (<>) = zipWith (<>)-  {-# INLINE (<>) #-}+deriving via ViaFixed (Vec n) a instance (Unbox n a, Show      a) => Show      (Vec n a)+deriving via ViaFixed (Vec n) a instance (Unbox n a, Eq        a) => Eq        (Vec n a)+deriving via ViaFixed (Vec n) a instance (Unbox n a, Ord       a) => Ord       (Vec n a)+deriving via ViaFixed (Vec n) a instance (Unbox n a, NFData    a) => NFData    (Vec n a)+deriving via ViaFixed (Vec n) a instance (Unbox n a, Semigroup a) => Semigroup (Vec n a)+deriving via ViaFixed (Vec n) a instance (Unbox n a, Monoid    a) => Monoid    (Vec n a)+deriving via ViaFixed (Vec n) a instance (Unbox n a, Storable  a) => Storable  (Vec n a)  instance (Typeable n, Unbox n a, Data a) => Data (Vec n a) where   gfoldl       = C.gfoldl@@ -126,364 +123,192 @@ con_Vec :: Constr con_Vec = mkConstr ty_Vec "Vec" [] Prefix -instance (Storable a, Unbox n a) => Storable (Vec n a) where-  alignment = defaultAlignemnt-  sizeOf    = defaultSizeOf-  peek      = defaultPeek-  poke      = defaultPoke-  {-# INLINE alignment #-}-  {-# INLINE sizeOf    #-}-  {-# INLINE peek      #-}-  {-# INLINE poke      #-} -- ---------------------------------------------------------------- -- Data instances ---------------------------------------------------------------- --- Unit type-data instance MVec n s () = MV_Unit-data instance Vec  n   () = V_Unit+instance F.Arity n => Unbox n () where+  type VecRepr n () = VecUnit n+  type EltRepr   () = ()+  toEltRepr   _ = id+  fromEltRepr _ = id+  {-# INLINE toEltRepr   #-}+  {-# INLINE fromEltRepr #-} -instance Arity n => Unbox n ()+data VecUnit (n :: Nat) a = VecUnit -instance Arity n => MVector (MVec n) () where-  new          = return MV_Unit-  {-# INLINE new         #-}-  copy _ _     = return ()-  {-# INLINE move        #-}-  move _ _     = return ()-  {-# INLINE copy        #-}-  unsafeRead  _ _   = return ()-  {-# INLINE unsafeRead  #-}-  unsafeWrite _ _ _ = return ()-  {-# INLINE unsafeWrite #-}+type instance Dim (VecUnit n) = Peano n -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 -instance Arity n => MVector (MVec n) Bool where-  new          = MV_Bool `liftM` new-  {-# INLINE new         #-}-  copy (MV_Bool v) (MV_Bool w) = copy v w-  {-# INLINE copy        #-}-  move (MV_Bool v) (MV_Bool w) = move v w-  {-# INLINE move        #-}-  unsafeRead  (MV_Bool v) i   = toBool `liftM` unsafeRead v i-  {-# INLINE unsafeRead  #-}-  unsafeWrite (MV_Bool v) i b = unsafeWrite v i (fromBool b)-  {-# INLINE unsafeWrite #-}+instance (n <= 64, Arity n, a ~ Bool) => Vector (BitVec n) a where+  inspect (BitVec w) = inspect (C.generate (testBit w))+  construct = C.accum+    (\(Const (i,w)) -> \case+          True  -> Const (i+1, setBit w i)+          False -> Const (i+1, w))+    (\(Const (_,w)) -> BitVec w)+    (Const (0,0)) -instance Arity n => IVector (Vec n) Bool where-  unsafeFreeze (MV_Bool v) = V_Bool  `liftM` unsafeFreeze v-  unsafeThaw   (V_Bool  v) = MV_Bool `liftM` unsafeThaw   v-  unsafeIndex  (V_Bool  v) = toBool . unsafeIndex v-  {-# INLINE unsafeFreeze #-}-  {-# INLINE unsafeThaw   #-}-  {-# INLINE unsafeIndex  #-}+instance (n <= 64, Arity n) => Unbox n Bool where+  type VecRepr n Bool = BitVec n+  type EltRepr   Bool = Bool+  toEltRepr   _ = id+  fromEltRepr _ = id+  {-# INLINE toEltRepr   #-}+  {-# INLINE fromEltRepr #-}  -fromBool :: Bool -> Word8-{-# INLINE fromBool #-}-fromBool True = 1-fromBool False = 0 -toBool :: Word8 -> Bool-{-# INLINE toBool #-}-toBool 0 = False-toBool _ = True-- ---------------------------------------------------------------- -- Primitive wrappers-#define primMV(ty,con)                              \-instance Arity n => MVector (MVec n) ty where {     \-; new = con `liftM` new                             \-; copy (con v) (con w) = copy v w                   \-; move (con v) (con w) = move v w                   \-; unsafeRead  (con v) i = unsafeRead v i            \-; unsafeWrite (con v) i x = unsafeWrite v i x       \-; {-# INLINE new         #-}                        \-; {-# INLINE move        #-}                        \-; {-# INLINE copy        #-}                        \-; {-# INLINE unsafeRead  #-}                        \-; {-# INLINE unsafeWrite #-}                        \-}--#define primIV(ty,con,mcon)                             \-instance Arity n => IVector (Vec n) ty where {          \-; unsafeFreeze (mcon v)   = con  `liftM` unsafeFreeze v \-; unsafeThaw   (con  v)   = mcon `liftM` unsafeThaw   v \-; unsafeIndex  (con  v) i = unsafeIndex v i             \-; {-# INLINE unsafeFreeze #-}                           \-; {-# INLINE unsafeThaw   #-}                           \-; {-# INLINE unsafeIndex  #-}                           \-}--#define primWrap(ty,con,mcon) \-newtype instance MVec n s ty = mcon (P.MVec n s ty) ; \-newtype instance Vec  n   ty = con  (P.Vec  n   ty) ; \-instance Arity n => Unbox n ty ; \-primMV(ty, mcon     )          ; \-primIV(ty, con, mcon)----primWrap(Int,   V_Int,   MV_Int  )-primWrap(Int8,  V_Int8,  MV_Int8 )-primWrap(Int16, V_Int16, MV_Int16)-primWrap(Int32, V_Int32, MV_Int32)-primWrap(Int64, V_Int64, MV_Int64)+---------------------------------------------------------------- -primWrap(Word,   V_Word,   MV_Word  )-primWrap(Word8,  V_Word8,  MV_Word8 )-primWrap(Word16, V_Word16, MV_Word16)-primWrap(Word32, V_Word32, MV_Word32)-primWrap(Word64, V_Word64, MV_Word64)+-- | Wrapper for deriving 'Unbox' for data types which are instances+--   of 'P.Prim' type class:+--+-- > deriving via UnboxViaPrim Word instance (C.Arity n) => Unbox n Word+newtype UnboxViaPrim a = UnboxViaPrim a+  deriving newtype P.Prim -primWrap(Char,   V_Char,   MV_Char  )-primWrap(Float,  V_Float,  MV_Float )-primWrap(Double, V_Double, MV_Double)+instance (C.Arity n, P.Prim a) => Unbox n (UnboxViaPrim a) where+  type VecRepr n (UnboxViaPrim a) = P.Vec n+  type EltRepr   (UnboxViaPrim a) = a+  toEltRepr   _ = coerce+  fromEltRepr _ = coerce+  +deriving via UnboxViaPrim Int    instance (C.Arity n) => Unbox n Int +deriving via UnboxViaPrim Int8   instance (C.Arity n) => Unbox n Int8+deriving via UnboxViaPrim Int16  instance (C.Arity n) => Unbox n Int16+deriving via UnboxViaPrim Int32  instance (C.Arity n) => Unbox n Int32+deriving via UnboxViaPrim Int64  instance (C.Arity n) => Unbox n Int64+deriving via UnboxViaPrim Word   instance (C.Arity n) => Unbox n Word +deriving via UnboxViaPrim Word8  instance (C.Arity n) => Unbox n Word8+deriving via UnboxViaPrim Word16 instance (C.Arity n) => Unbox n Word16+deriving via UnboxViaPrim Word32 instance (C.Arity n) => Unbox n Word32+deriving via UnboxViaPrim Word64 instance (C.Arity n) => Unbox n Word64 +deriving via UnboxViaPrim Char   instance (C.Arity n) => Unbox n Char+deriving via UnboxViaPrim Float  instance (C.Arity n) => Unbox n Float+deriving via UnboxViaPrim Double instance (C.Arity n) => Unbox n Double   ------------------------------------------------------------------- Complex-newtype instance MVec n s (Complex a) = MV_Complex (MVec n s (a,a))-newtype instance Vec  n   (Complex a) = V_Complex  (Vec  n   (a,a))--instance (Unbox n a) => Unbox n (Complex a)--instance (Arity n, MVector (MVec n) a) => MVector (MVec n) (Complex a) where-  new = MV_Complex `liftM` new-  {-# INLINE new #-}-  copy (MV_Complex v) (MV_Complex w) = copy v w-  {-# INLINE copy        #-}-  move (MV_Complex v) (MV_Complex w) = move v w-  {-# INLINE move        #-}-  unsafeRead (MV_Complex v) i = do (a,b) <- unsafeRead v i-                                   return (a :+ b)-  {-# INLINE unsafeRead  #-}-  unsafeWrite (MV_Complex v) i (a :+ b) = unsafeWrite v i (a,b)-  {-# INLINE unsafeWrite #-}+-- Newtypes+---------------------------------------------------------------- -instance (Arity n, IVector (Vec n) a) => IVector (Vec n) (Complex a) where-  unsafeFreeze (MV_Complex v) = V_Complex `liftM` unsafeFreeze v-  {-# INLINE unsafeFreeze #-}-  unsafeThaw   (V_Complex  v) = MV_Complex `liftM` unsafeThaw v-  {-# INLINE unsafeThaw   #-}-  unsafeIndex (V_Complex v) i =-    case unsafeIndex v i of (a,b) -> a :+ b-  {-# INLINE unsafeIndex  #-}+deriving newtype instance (Unbox n a) => Unbox n (Const a b)+deriving newtype instance (Unbox n a) => Unbox n (Identity a)+deriving newtype instance (Unbox n a) => Unbox n (Down a)+deriving newtype instance (Unbox n a) => Unbox n (Dual a)+deriving newtype instance (Unbox n a) => Unbox n (Sum  a)+deriving newtype instance (Unbox n a) => Unbox n (Product a) +deriving newtype instance (n <= 64, Arity n) => Unbox n All+deriving newtype instance (n <= 64, Arity n) => Unbox n Any   ---------------------------------------------------------------- -- Tuples-data instance MVec n s (a,b) = MV_2 !(MVec n s a) !(MVec n s b)-data instance Vec  n   (a,b) = V_2  !(Vec  n   a) !(Vec  n   b)--instance (Unbox n a, Unbox n b) => Unbox n (a,b)--instance (Arity n, MVector (MVec n) a, MVector (MVec n) b) => MVector (MVec n) (a,b) where-  new = do as <- new-           bs <- new-           return $ MV_2 as bs-  {-# INLINE new #-}-  copy (MV_2 va vb) (MV_2 wa wb) = copy va wa >> copy vb wb-  {-# INLINE copy        #-}-  move (MV_2 va vb) (MV_2 wa wb) = move va wa >> move vb wb-  {-# INLINE move        #-}-  unsafeRead  (MV_2 v w) i = do a <- unsafeRead v i-                                b <- unsafeRead w i-                                return (a,b)-  {-# INLINE unsafeRead  #-}-  unsafeWrite (MV_2 v w) i (a,b) = unsafeWrite v i a >> unsafeWrite w i b-  {-# INLINE unsafeWrite #-}---instance ( Arity n-         , IVector (Vec n) a, IVector (Vec n) b-         ) => IVector (Vec n) (a,b) where-  unsafeFreeze (MV_2 v w)   = do as <- unsafeFreeze v-                                 bs <- unsafeFreeze w-                                 return $ V_2 as bs-  {-# INLINE unsafeFreeze #-}-  unsafeThaw   (V_2  v w)   = do as <- unsafeThaw v-                                 bs <- unsafeThaw w-                                 return $ MV_2 as bs-  {-# INLINE unsafeThaw   #-}-  unsafeIndex  (V_2  v w) i = (unsafeIndex v i, unsafeIndex w i)-  {-# INLINE unsafeIndex  #-}-----data instance MVec n s (a,b,c) = MV_3 !(MVec n s a) !(MVec n s b) !(MVec n s c)-data instance Vec  n   (a,b,c) = V_3  !(Vec  n   a) !(Vec  n   b) !(Vec  n   c)--instance (Unbox n a, Unbox n b, Unbox n c) => Unbox n (a,b,c)--instance (Arity n, MVector (MVec n) a, MVector (MVec n) b, MVector (MVec n) c-         ) => MVector (MVec n) (a,b,c) where-  new = do as <- new-           bs <- new-           cs <- new-           return $ MV_3 as bs cs-  {-# INLINE new #-}-  copy (MV_3 va vb vc) (MV_3 wa wb wc)-    = copy va wa >> copy vb wb >> copy vc wc-  {-# INLINE copy        #-}-  move (MV_3 va vb vc) (MV_3 wa wb wc)-    = move va wa >> move vb wb >> move vc wc-  {-# INLINE move        #-}-  unsafeRead  (MV_3 v w u) i = do a <- unsafeRead v i-                                  b <- unsafeRead w i-                                  c <- unsafeRead u i-                                  return (a,b,c)-  {-# INLINE unsafeRead  #-}-  unsafeWrite (MV_3 v w u) i (a,b,c)-    = unsafeWrite v i a >> unsafeWrite w i b >> unsafeWrite u i c-  {-# INLINE unsafeWrite #-}--instance ( Arity n-         , Vector  (Vec n) a, Vector  (Vec n) b, Vector  (Vec n) c-         , IVector (Vec n) a, IVector (Vec n) b, IVector (Vec n) c-         ) => IVector (Vec n) (a,b,c) where-  unsafeFreeze (MV_3 v w u) = do as <- unsafeFreeze v-                                 bs <- unsafeFreeze w-                                 cs <- unsafeFreeze u-                                 return $ V_3 as bs cs-  {-# INLINE unsafeFreeze #-}-  unsafeThaw   (V_3  v w u) = do as <- unsafeThaw v-                                 bs <- unsafeThaw w-                                 cs <- unsafeThaw u-                                 return $ MV_3 as bs cs-  {-# INLINE unsafeThaw   #-}-  unsafeIndex  (V_3 v w u) i-    = (unsafeIndex v i, unsafeIndex w i, unsafeIndex u i)-  {-# INLINE unsafeIndex  #-}-- ------------------------------------------------------------------- Newtype wrappers -newtype instance MVec n s (Const a b) = MV_Const (MVec n s a)-newtype instance Vec  n   (Const a b) = V_Const  (Vec  n   a)-instance Unbox n a => Unbox n (Const a b)+-- | Representation for vector of 2-tuple as two vectors.+data T2 n a b x = T2 !(Vec n a) !(Vec n b) -instance (Unbox n a) => MVector (MVec n) (Const a b) where-  new                                  = MV_Const `liftM` new-  copy (MV_Const v) (MV_Const w)       = copy v w-  move (MV_Const v) (MV_Const w)       = move v w-  unsafeRead  (MV_Const v) i           = Const `liftM` unsafeRead v i-  unsafeWrite (MV_Const v) i (Const x) = unsafeWrite v i x-  {-# INLINE new         #-}-  {-# INLINE move        #-}-  {-# INLINE copy        #-}-  {-# INLINE unsafeRead  #-}-  {-# INLINE unsafeWrite #-}+type instance Dim (T2 n a b) = Peano n -instance (Unbox n a) => IVector (Vec n) (Const a b) where-  unsafeFreeze (MV_Const v)   = V_Const  `liftM` unsafeFreeze v-  unsafeThaw   (V_Const  v)   = MV_Const `liftM` unsafeThaw   v-  unsafeIndex  (V_Const  v) i = Const (unsafeIndex v i)-  {-# INLINE unsafeFreeze #-}-  {-# INLINE unsafeThaw   #-}-  {-# INLINE unsafeIndex  #-}+instance (Arity n, Unbox n a, Unbox n b) => Vector (T2 n a b) (a,b) where+  inspect (T2 vA vB)+    = inspect (C.zipWith (,) cvA cvB)+    where+      cvA = C.ContVec $ inspect vA+      cvB = C.ContVec $ inspect vB+  construct = pairF T2 construct construct+  {-# INLINE construct #-}+  {-# INLINE inspect   #-} +pairF+  :: ArityPeano n+  => (x -> y -> z)+  -> Fun n a x+  -> Fun n b y+  -> Fun n (a,b) z+{-# INLINE pairF #-}+pairF g funA funB = C.accum+  (\(T_pair fA fB) (a,b) -> T_pair (curryFirst fA a) (curryFirst fB b))+  (\(T_pair (Fun x) (Fun y)) -> g x y)+  (T_pair funA funB) -------------------------------------------------------------------- Newtype wrappers with kind * -> *+data T_pair a b x y n = T_pair (Fun n a x) (Fun n b y) -#define primNewMV(ty,con)                         \-instance Unbox n a => MVector (MVec n) (ty a) where {     \-; new = con `liftM` new                             \-; copy (con v) (con w) = copy v w                   \-; move (con v) (con w) = move v w                   \-; unsafeRead  (con v) i = ty `liftM` unsafeRead v i            \-; unsafeWrite (con v) i (ty x) = unsafeWrite v i x       \-; {-# INLINE new         #-}                        \-; {-# INLINE move        #-}                        \-; {-# INLINE copy        #-}                        \-; {-# INLINE unsafeRead  #-}                        \-; {-# INLINE unsafeWrite #-}                        \-} -#define primNewIV(ty,con,mcon)                             \-instance Unbox n a => IVector (Vec n) (ty a)  where {          \-; unsafeFreeze (mcon v)   = con  `liftM` unsafeFreeze v \-; unsafeThaw   (con  v)   = mcon `liftM` unsafeThaw   v \-; unsafeIndex  (con  v) i = ty (unsafeIndex v i)             \-; {-# INLINE unsafeFreeze #-}                           \-; {-# INLINE unsafeThaw   #-}                           \-; {-# INLINE unsafeIndex  #-}                           \-}+-- | Representation for vector of 2-tuple as two vectors.+data T3 n a b c x = T3 !(Vec n a) !(Vec n b) !(Vec n c) -#define primNewWrap(ty,con,mcon) \-newtype instance MVec n s (ty a) = mcon (MVec n s a) ; \-newtype instance Vec  n   (ty a) = con  (Vec  n   a) ; \-instance Unbox n a => Unbox n (ty a) ; \-primNewMV(ty, mcon     )          ; \-primNewIV(ty, con, mcon)+type instance Dim (T3 n a b c) = Peano n +instance (Arity n, Unbox n a, Unbox n b, Unbox n c) => Vector (T3 n a b c) (a,b,c) where+  inspect (T3 vA vB vC)+    = inspect (C.zipWith3 (,,) cvA cvB cvC)+    where+      cvA = C.ContVec $ inspect vA+      cvB = C.ContVec $ inspect vB+      cvC = C.ContVec $ inspect vC+  construct = pair3F T3 construct construct construct+  {-# INLINE construct #-}+  {-# INLINE inspect   #-} -primNewWrap(Identity, V_Identity, MV_Identity)-primNewWrap(Down, V_Down, MV_Down)-primNewWrap(Dual, V_Dual, MV_Dual)-primNewWrap(Sum, V_Sum, MV_Sum)-primNewWrap(Product, V_Product, MV_Product)+pair3F+  :: ArityPeano n+  => (x -> y -> z -> r)+  -> Fun n a x+  -> Fun n b y+  -> Fun n c z+  -> Fun n (a,b,c) r+{-# INLINE pair3F #-}+pair3F g funA funB funC = C.accum+  (\(T_pair3 fA fB fC) (a,b,c) -> T_pair3 (curryFirst fA a)+                                          (curryFirst fB b)+                                          (curryFirst fC c))+  (\(T_pair3 (Fun x) (Fun y) (Fun z)) -> g x y z)+  (T_pair3 funA funB funC) +data T_pair3 a b c x y z n = T_pair3 (Fun n a x) (Fun n b y) (Fun n c z) -------------------------------------------------------------------- Monomorphic newtype wrappers -#define primNewMonoMV(ty,con)                         \-instance Arity n => MVector (MVec n) ty where {     \-; new = con `liftM` new                             \-; copy (con v) (con w) = copy v w                   \-; move (con v) (con w) = move v w                   \-; unsafeRead  (con v) i = ty `liftM` unsafeRead v i            \-; unsafeWrite (con v) i (ty x) = unsafeWrite v i x       \-; {-# INLINE new         #-}                        \-; {-# INLINE move        #-}                        \-; {-# INLINE copy        #-}                        \-; {-# INLINE unsafeRead  #-}                        \-; {-# INLINE unsafeWrite #-}                        \-} -#define primNewMonoIV(ty,con,mcon)                             \-instance Arity n => IVector (Vec n) ty where {          \-; unsafeFreeze (mcon v)   = con  `liftM` unsafeFreeze v \-; unsafeThaw   (con  v)   = mcon `liftM` unsafeThaw   v \-; unsafeIndex  (con  v) i = ty (unsafeIndex v i)             \-; {-# INLINE unsafeFreeze #-}                           \-; {-# INLINE unsafeThaw   #-}                           \-; {-# INLINE unsafeIndex  #-}                           \-}--#define primNewMonoWrap(ty,repr,con,mcon) \-newtype instance MVec n s ty = mcon (MVec n s repr) ; \-newtype instance Vec  n   ty = con  (Vec  n   repr) ; \-instance Arity n => Unbox n ty ; \-primNewMonoMV(ty, mcon     )          ; \-primNewMonoIV(ty, con, mcon)+instance (Unbox n a, Unbox n b) => Unbox n (a,b) where+  type VecRepr n (a,b) = T2 n a b+  type EltRepr   (a,b) = (a,b)+  toEltRepr   _ = id+  fromEltRepr _ = id -primNewMonoWrap(Any, Bool, V_Any, MV_Any)-primNewMonoWrap(All, Bool, V_All, MV_All)+instance (Unbox n a) => Unbox n (Complex a) where+  -- NOTE: It would be nice to have ability to use single buffer say+  --       for `Complex Double`. But buffers seems to be opaque+  type VecRepr n (Complex a) = T2 n a a+  type EltRepr   (Complex a) = (a,a)+  toEltRepr   _ (r :+ i) = (r,i)+  fromEltRepr _ (r,i)    = r :+ i+  {-# INLINE toEltRepr   #-}+  {-# INLINE fromEltRepr #-}

@@ -1,5 +1,8 @@+Cabal-Version:  3.0+Build-Type:     Simple+ Name:           fixed-vector-Version:        1.2.3.0+Version:        2.0.0.0 Synopsis:       Generic vectors with statically known size. Description:   Generic library for vectors with statically known@@ -42,35 +45,89 @@   * Data.Vector.Fixed.Primitive   Unboxed vectors based on pritimive package. -Cabal-Version:  >= 1.10-License:        BSD3+License:        BSD-3-Clause License-File:   LICENSE Author:         Aleksey Khudyakov <alexey.skladnoy@gmail.com> Maintainer:     Aleksey Khudyakov <alexey.skladnoy@gmail.com> Bug-reports:    https://github.com/Shimuuar/fixed-vector/issues Category:       Data-Build-Type:     Simple-extra-source-files:+extra-doc-files:   ChangeLog.md  tested-with:-    GHC ==8.4.4-     || ==8.6.5-     || ==8.8.4-     || ==8.10.7+    GHC ==8.10.7      || ==9.0.1      || ==9.2.8      || ==9.4.7-     || ==9.6.3+     || ==9.6.6+     || ==9.8.2+     || ==9.10.1  source-repository head   type:     git   location: http://github.com/Shimuuar/fixed-vector -Library+common language   Ghc-options:          -Wall -Wno-incomplete-uni-patterns   Default-Language:     Haskell2010-  Build-Depends: base      >=4.11 && <5+  Default-Extensions:+    -- GHC2021 sans PolyKinds+    BangPatterns+    ConstraintKinds+    DataKinds+    DeriveDataTypeable+    DeriveFoldable+    DeriveFunctor+    DeriveGeneric+    DeriveLift+    DeriveTraversable+    DerivingStrategies+    DisambiguateRecordFields+    DoAndIfThenElse+    EmptyCase+    EmptyDataDecls+    EmptyDataDeriving+    ExistentialQuantification+    ExplicitNamespaces+    FlexibleContexts+    FlexibleInstances+    ForeignFunctionInterface+    GADTs+    GADTSyntax+    GeneralisedNewtypeDeriving+    ImplicitPrelude+    ImportQualifiedPost+    InstanceSigs+    KindSignatures+    LambdaCase+    MonoLocalBinds+    MonomorphismRestriction+    MultiParamTypeClasses+    NamedFieldPuns+    NamedWildCards+    NumericUnderscores+    PatternGuards+    PostfixOperators+    RankNTypes+    RelaxedPolyRec+    RoleAnnotations+    ScopedTypeVariables+    StandaloneDeriving+    StandaloneKindSignatures+    TupleSections+    TypeApplications+    TypeOperators+    TypeSynonymInstances+    --+    DerivingVia+    PatternSynonyms+    ViewPatterns+    TypeFamilies+++Library+  import:        language+  Build-Depends: base      >=4.14 && <5                , primitive >=0.6.2                , deepseq   Exposed-modules:@@ -81,6 +138,7 @@     -- 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@@ -89,13 +147,25 @@  Test-Suite fixed-vector-doctests   Default-Language: Haskell2010-  if impl(ghc < 8.0.1 )+  if impl(ghc < 9.2)     buildable: False   Type:           exitcode-stdio-1.0   Hs-source-dirs: test   Main-is:        Doctests.hs-  Build-Depends: base >=4.8 && <5+  Build-Depends: base      >=4.14 && <5                , primitive >=0.6.2                  -- Additional test dependencies.                , doctest   >= 0.18                , filemanip == 0.3.6.*++Test-Suite fixed-vector-inspect+  import:         language+  Type:           exitcode-stdio-1.0+  Hs-source-dirs: test+  Main-is:        inspect.hs+  Other-modules:  Inspect.Obligations+  Build-Depends:  base         >=4.8 && <5+                , template-haskell+                , fixed-vector+                , tasty        >= 1.2+                , tasty-inspection-testing >= 0.1

@@ -10,4 +10,60 @@ 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"+  ]

@@ -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

@@ -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)+    ]+  ]