fixed-vector-hetero 0.3.1.2 → 0.4.0.0

raw patch · 9 files changed

+850/−1168 lines, 9 filesdep −ghc-primdep −transformersdep ~basedep ~fixed-vectordep ~primitivePVP ok

version bump matches the API change (PVP)

Dependencies removed: ghc-prim, transformers

Dependency ranges changed: base, fixed-vector, primitive

API changes (from Hackage documentation)

Files

• ChangeLog +0/−33
• ChangeLog.md +48/−0
• Data/Vector/HFixed.hs +198/−134
• Data/Vector/HFixed/Class.hs +330/−438
• Data/Vector/HFixed/Cont.hs +179/−317
• Data/Vector/HFixed/Functor/HVecF.hs +0/−53
• Data/Vector/HFixed/HVec.hs +77/−136
• Data/Vector/HFixed/TypeFuns.hs +11/−43
• fixed-vector-hetero.cabal +7/−14

@@ -1,33 +0,0 @@-Changes in 0.3.1.2--  * Fix build for GHC 8.2--Changes in 0.3.1.0--  * Fix build for GHC 8.0---Changes in 0.3.1.0--  * replicateF added--  * type signature of zipMonoF generalized---Changes in 0.3.0.0--  * HVector instances up to 32-element tuples--  * `asCVec` function added--  * `ContVec` reexported from Data.Vector.HFixed---Changes in 0.2.0.0--  * Type changing lenses added--  * zipMonoF added--  * types of monomorphize and monomorphizeF corrected-

@@ -0,0 +1,48 @@+Changes in 0.4.0.0++  * Major rework of API. `Fun` and `TFun` are unified. `Fun ~ TFun Identity`.+    Type class `ArityC` now contain special variants of `accum` and+    `arity` instead of building data structure containing all necessary dictionaries.++  * `Monad` constraints now relaxed to `Applicative` where appropriate++  * Most functions now have 3 variants: typeclass-based for `HVector`,+    typeclass-based for `HVectorF` and ones that use natural transformations for+    `HVectorF`. Some have been renamed to get consistent naming.++  * Support for GHC 7.10 is dropped++  * `HVecF` definition is moved to `Data.Vector.HFixed.HVec`++Changes in 0.3.1.2++  * Fix build for GHC 8.2++Changes in 0.3.1.0++  * Fix build for GHC 8.0+++Changes in 0.3.1.0++  * replicateF added++  * type signature of zipMonoF generalized+++Changes in 0.3.0.0++  * HVector instances up to 32-element tuples++  * `asCVec` function added++  * `ContVec` reexported from Data.Vector.HFixed+++Changes in 0.2.0.0++  * Type changing lenses added++  * zipMonoF added++  * types of monomorphize and monomorphizeF corrected

@@ -1,15 +1,15 @@-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE Rank2Types            #-} {-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-} {-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE TypeOperators         #-} {-# LANGUAGE UndecidableInstances  #-}-{-# LANGUAGE Rank2Types            #-}-{-# LANGUAGE ConstraintKinds       #-} -- | -- Heterogeneous vectors. module Data.Vector.HFixed (@@ -17,11 +17,14 @@     Arity   , ArityC   , HVector(..)+  , tupleSize   , HVectorF(..)-  , Wrap+  , tupleSizeF   , Proxy(..)   , ContVec+  , ContVecF(..)   , asCVec+  , asCVecF     -- * Position based functions   , convert   , head@@ -35,10 +38,6 @@   , set   , element   , elementCh-#if __GLASGOW_HASKELL__ >= 708-  , elementTy-  , elementChTy-#endif     -- * Generic constructors   , mk0   , mk1@@ -50,23 +49,31 @@   , fold   , foldr   , foldl+  , foldrF+  , foldlF+  , foldrNatF+  , foldlNatF   , mapM_   , unfoldr-    -- * Polymorphic values+  , unfoldrF+    -- ** Replicate variants   , replicate   , replicateM   , replicateF-  , zipMono-  , zipMonoF+  , replicateNatF+    -- ** Zip variants+  , zipWith+  , zipWithF+  , zipWithNatF   , zipFold+  , zipFoldF   , monomorphize   , monomorphizeF-    -- * Vector parametrized with type constructor-  , mapFunctor+    -- ** Tuples parametrized with type constructor+  , mapNat   , sequence-  , sequenceA+  , sequence_   , sequenceF-  , sequenceAF   , wrap   , unwrap   , distribute@@ -77,17 +84,19 @@   , rnf   ) where -import Control.Monad        (liftM)-import Control.Applicative  (Applicative,(<$>))+import Control.Applicative  (Applicative(..),(<$>)) import qualified Control.DeepSeq as NF-                                       -import Data.Functor.Compose (Compose)-import Data.Monoid          (Monoid,All(..))-import Prelude (Functor(..),Monad(..),Eq(..),Ord,Bool,Ordering,-                id,(.),($),undefined,seq)++import Data.Coerce           (coerce)+import Data.Functor.Compose  (Compose(..))+import Data.Functor.Identity (Identity(..))+import Data.Monoid           (Monoid,All(..))+import Prelude ( Functor(..),Eq(..),Ord,Bool,Ordering+               , id,(.),($),seq) import qualified Prelude -import Data.Vector.HFixed.Class hiding (cons,consF)+import           Data.Vector.HFixed.Class hiding (cons,consF)+import           Data.Vector.Fixed.Cont       (Peano) import qualified Data.Vector.Fixed          as F import qualified Data.Vector.HFixed.Cont    as C @@ -111,6 +120,9 @@ asCVec :: ContVec xs -> ContVec xs asCVec = id +asCVecF :: ContVecF f xs -> ContVecF f xs+asCVecF = id+ -- | We can convert between any two vector which have same --   structure but different representations. convert :: (HVector v, HVector w, Elems v ~ Elems w)@@ -122,21 +134,21 @@ -- -- >>> case tail ('a',"aa",()) of x@(_,_) -> x -- ("aa",())-tail :: (HVector v, HVector w, (a ': Elems w) ~ Elems v)+tail :: (HVector v, HVector w, (a : Elems w) ~ Elems v)      => v -> w {-# INLINE tail #-} tail = C.vector . C.tail . C.cvec   -- | Head of the vector-head :: (HVector v, Elems v ~ (a ': as), Arity as)+head :: (HVector v, Elems v ~ (a : as), Arity as)      => v -> a {-# INLINE head #-} head = C.head . C.cvec  -- | Prepend element to the list. Note that it changes type of vector --   so it either must be known from context of specified explicitly-cons :: (HVector v, HVector w, Elems w ~ (a ': Elems v))+cons :: (HVector v, HVector w, Elems w ~ (a : Elems v))      => a -> v -> w {-# INLINE cons #-} cons a = C.vector . C.cons a . C.cvec@@ -156,63 +168,46 @@ ----------------------------------------------------------------  -- | Index heterogeneous vector-index :: (Index n (Elems v), HVector v) => v -> n -> ValueAt n (Elems v)+index :: (Index n (Elems v), HVector v) => v -> proxy n -> ValueAt n (Elems v) {-# INLINE index #-} index = C.index . C.cvec  -- | Set element in the vector set :: (Index n (Elems v), HVector v)-       => n -> ValueAt n (Elems v) -> v -> v+       => proxy n -> ValueAt n (Elems v) -> v -> v {-# INLINE set #-} set n x = C.vector         . C.set n x         . C.cvec  -- | Twan van Laarhoven's lens for i'th element.-element :: (Index n (Elems v), ValueAt n (Elems v) ~ a, HVector v, Functor f)-        => n -> (a -> f a) -> (v -> f v)+element :: forall n v a f proxy.+           ( Index   (Peano n) (Elems v)+           , ValueAt (Peano n) (Elems v) ~ a+           , HVector v+           , Functor f+           )+        => proxy n -> (a -> f a) -> (v -> f v) {-# INLINE element #-}-element n f v = inspect v-              $ lensF n f construct+element _ f v = inspect v+              $ lensF (Proxy @ (Peano n)) f construct  -- | Type changing Twan van Laarhoven's lens for i'th element.-elementCh :: ( Index n (Elems v)-             , a ~ ValueAt n (Elems v)+elementCh :: forall n v w a b f proxy.+             ( Index   (Peano n) (Elems v)+             , ValueAt (Peano n) (Elems v) ~ a              , HVector v              , HVector w-             , Elems w ~ NewElems n (Elems v) b-             , Functor f)-          => n -> (a -> f b) -> (v -> f w)+             , Elems w ~ NewElems (Peano n) (Elems v) b+             , Functor f+             )+          => proxy n -> (a -> f b) -> (v -> f w) {-# INLINE elementCh #-}-elementCh n f v = inspect v-                $ lensChF n f construct+elementCh _ f v = inspect v+                $ lensChF (Proxy @ (Peano n)) f construct -#if __GLASGOW_HASKELL__ >= 708--- | Twan van Laarhoven's lens for i'th element. GHC >= 7.8-elementTy :: forall n a f v proxy.-             ( Index   (ToPeano n) (Elems v)-             , ValueAt (ToPeano n) (Elems v) ~ a-             , NatIso  (ToPeano n) n-             , HVector v-             , Functor f)-          => proxy n -> (a -> f a) -> (v -> f v)-{-# INLINE elementTy #-}-elementTy _ = element (undefined :: ToPeano n) --- | Type changing Twan van Laarhoven's lens for i'th element.-elementChTy :: forall a b f n v w proxy.-               ( Index (ToPeano n) (Elems v)-               , a ~ ValueAt (ToPeano n) (Elems v)-               , HVector v-               , HVector w-               , Elems w ~ NewElems (ToPeano n) (Elems v) b-               , Functor f)-            => proxy n -> (a -> f b) -> (v -> f w)-{-# INLINE elementChTy #-}-elementChTy _ = elementCh (undefined :: ToPeano n)-#endif - ---------------------------------------------------------------- -- Folds over vector ----------------------------------------------------------------@@ -222,112 +217,155 @@ -- -- >>> fold (12::Int,"Str") (\a s -> show a ++ s) -- "12Str"-fold :: HVector v => v -> Fn (Elems v) r -> r-fold v f = inspect v (Fun f)+fold :: HVector v => v -> Fn Identity (Elems v) r -> r+-- FIXME: Not really useable+fold v f = inspect v (TFun f) {-# INLINE fold #-}  -- | Right fold over heterogeneous vector foldr :: (HVector v, ArityC c (Elems v))       => Proxy c -> (forall a. c a => a -> b -> b) -> b -> v -> b {-# INLINE foldr #-}-foldr c f b0 = C.foldr c f b0 . C.cvec+foldr c f b0 = C.foldrF c (\(Identity a) b -> f a b) b0 . C.cvec  -- | Left fold over heterogeneous vector foldl :: (HVector v, ArityC c (Elems v))       => Proxy c -> (forall a. c a => b -> a -> b) -> b -> v -> b {-# INLINE foldl #-}-foldl c f b0 = C.foldl c f b0 . C.cvec+foldl c f b0 = C.foldlF c (\b (Identity a) -> f b a) b0 . C.cvec +-- | Right fold over heterogeneous vector+foldrF :: (HVectorF v, ArityC c (ElemsF v))+       => Proxy c -> (forall a. c a => f a -> b -> b) -> b -> v f -> b+{-# INLINE foldrF #-}+foldrF c f b0 = C.foldrF c f b0 . C.cvecF++-- | Left fold over heterogeneous vector+foldlF :: (HVectorF v, ArityC c (ElemsF v))+       => Proxy c -> (forall a. c a => b -> f a -> b) -> b -> v f -> b+{-# INLINE foldlF #-}+foldlF c f b0 = C.foldlF c f b0 . C.cvecF++-- | Right fold over heterogeneous vector+foldrNatF :: (HVectorF v)+          => (forall a. f a -> b -> b) -> b -> v f -> b+{-# INLINE foldrNatF #-}+foldrNatF f b0 = C.foldrNatF f b0 . C.cvecF++-- | Left fold over heterogeneous vector+foldlNatF :: (HVectorF v)+          => (forall a. b -> f a -> b) -> b -> v f -> b+{-# INLINE foldlNatF #-}+foldlNatF f b0 = C.foldlNatF f b0 . C.cvecF+ -- | Apply monadic action to every element in the vector-mapM_ :: (HVector v, ArityC c (Elems v), Monad m)-      => Proxy c -> (forall a. c a => a -> m ()) -> v -> m ()+mapM_ :: (HVector v, ArityC c (Elems v), Applicative f)+      => Proxy c -> (forall a. c a => a -> f ()) -> v -> f () {-# INLINE mapM_ #-}-mapM_ c f = foldl c (\m a -> m >> f a) (return ())+mapM_ c f = foldl c (\m a -> m *> f a) (pure ()) +-- | Unfold vector.+unfoldr :: (HVector v, ArityC c (Elems v))+        => Proxy c -> (forall a. c a => b -> (a,b)) -> b -> v+{-# INLINE unfoldr #-}+unfoldr c f = C.vector . C.unfoldrF c (\b -> let (a,b') = f b in (Identity a, b')) +-- | Unfold vector.+unfoldrF :: (HVectorF v, ArityC c (ElemsF v))+        => Proxy c -> (forall a. c a => b -> (f a,b)) -> b -> v f+{-# INLINE unfoldrF #-}+unfoldrF c f = C.vectorF . C.unfoldrF c f ++ ---------------------------------------------------------------- -- Constructors ---------------------------------------------------------------- -mk0 :: (HVector v, Elems v ~ '[]) => v-mk0 = C.vector C.mk0+mk0 :: forall v. (HVector v, Elems v ~ '[]) => v+mk0 = coerce (construct :: Fun '[] v) {-# INLINE mk0 #-} -mk1 :: (HVector v, Elems v ~ '[a]) => a -> v-mk1 a = C.vector $ C.mk1 a+mk1 :: forall v a. (HVector v, Elems v ~ '[a])+    => a -> v+mk1 = coerce (construct :: Fun '[a] v) {-# INLINE mk1 #-} -mk2 :: (HVector v, Elems v ~ '[a,b]) => a -> b -> v-mk2 a b = C.vector $ C.mk2 a b+mk2 :: forall v a b. (HVector v, Elems v ~ '[a,b])+    => a -> b -> v+mk2 = coerce (construct :: Fun '[a,b] v) {-# INLINE mk2 #-} -mk3 :: (HVector v, Elems v ~ '[a,b,c]) => a -> b -> c -> v-mk3 a b c = C.vector $ C.mk3 a b c+mk3 :: forall v a b c. (HVector v, Elems v ~ '[a,b,c])+    => a -> b -> c -> v+mk3 = coerce (construct :: Fun '[a,b,c] v) {-# INLINE mk3 #-} -mk4 :: (HVector v, Elems v ~ '[a,b,c,d]) => a -> b -> c -> d -> v-mk4 a b c d = C.vector $ C.mk4 a b c d+mk4 :: forall v a b c d. (HVector v, Elems v ~ '[a,b,c,d])+    => a -> b -> c -> d -> v+mk4 = coerce (construct :: Fun '[a,b,c,d] v) {-# INLINE mk4 #-} -mk5 :: (HVector v, Elems v ~ '[a,b,c,d,e]) => a -> b -> c -> d -> e -> v-mk5 a b c d e = C.vector $ C.mk5 a b c d e+mk5 :: forall v a b c d e. (HVector v, Elems v ~ '[a,b,c,d,e])+    => a -> b -> c -> d -> e -> v+mk5 = coerce (construct :: Fun '[a,b,c,d,e] v) {-# INLINE mk5 #-}  + ---------------------------------------------------------------- -- Collective operations ---------------------------------------------------------------- -mapFunctor :: (HVectorF v)+-- | Apply natural transformation to every element of the tuple.+mapNat :: (HVectorF v)            => (forall a. f a -> g a) -> v f -> v g-{-# INLINE mapFunctor #-}-mapFunctor f = C.vectorF . C.mapFunctor f . C.cvecF+{-# INLINE mapNat #-}+mapNat f = C.vectorF . C.mapNat f . C.cvecF  -- | Sequence effects for every element in the vector sequence-  :: ( Monad m, HVectorF v, HVector w, ElemsF v ~ Elems w )-  => v m -> m w-{-# INLINE sequence #-}-sequence v = do w <- C.sequence $ C.cvecF v-                return $ C.vector w---- | Sequence effects for every element in the vector-sequenceA   :: ( Applicative f, HVectorF v, HVector w, ElemsF v ~ Elems w )   => v f -> f w-{-# INLINE sequenceA #-}-sequenceA v = C.vector <$> C.sequenceA (C.cvecF v)+{-# INLINE sequence #-}+sequence+  = fmap C.vector+  . C.sequenceF+  . C.mapNat (Compose . fmap Identity)+  . C.cvecF  -- | Sequence effects for every element in the vector-sequenceF :: ( Monad m, HVectorF v) => v (m `Compose` f) -> m (v f)-{-# INLINE sequenceF #-}-sequenceF v = do w <- C.sequenceF $ C.cvecF v-                 return $ C.vectorF w+sequence_ :: (Applicative f, HVectorF v) => v f -> f ()+{-# INLINE sequence_ #-}+sequence_ = foldlNatF (\m a -> m <* a) (pure ())  -- | Sequence effects for every element in the vector-sequenceAF :: ( Applicative f, HVectorF v) => v (f `Compose` g) -> f (v g)-{-# INLINE sequenceAF #-}-sequenceAF v = C.vectorF <$> C.sequenceAF (C.cvecF v)+sequenceF :: ( Applicative f, HVectorF v) => v (f `Compose` g) -> f (v g)+{-# INLINE sequenceF #-}+sequenceF v = C.vectorF <$> C.sequenceF (C.cvecF v)  -- | Wrap every value in the vector into type constructor. wrap :: ( HVector v, HVectorF w, Elems v ~ ElemsF w )      => (forall a. a -> f a) -> v -> w f {-# INLINE wrap #-}-wrap f = C.vectorF . C.wrap f . C.cvec+wrap f = C.vectorF . C.mapNat (f . runIdentity) . C.cvec  -- | Unwrap every value in the vector from the type constructor. unwrap :: ( HVectorF v, HVector w, ElemsF v ~ Elems w )        => (forall a. f a -> a) -> v f -> w {-# INLINE unwrap #-}-unwrap  f = C.vector . C.unwrap f . C.cvecF+unwrap  f = C.vector . C.mapNat (Identity . f) . C.cvecF  -- | Analog of /distribute/ from /Distributive/ type class. distribute   :: ( Functor f, HVector v, HVectorF w,  Elems v ~ ElemsF w )   => f v -> w f {-# INLINE distribute #-}-distribute = C.vectorF . C.distribute . fmap C.cvec+distribute+  = C.vectorF+  . mapNat (fmap runIdentity . getCompose)+  . C.distributeF+  . fmap C.cvec  -- | Analog of /distribute/ from /Distributive/ type class. distributeF@@ -351,7 +389,7 @@ replicate :: (HVector v, ArityC c (Elems v))           => Proxy c -> (forall x. c x => x) -> v {-# INLINE replicate #-}-replicate c x = C.vector $ C.replicate c x+replicate c x = C.vector $ C.replicateF c (Identity x)  -- | Replicate monadic action n times. --@@ -360,54 +398,80 @@ -- > 12 -- > 'a' -- (12,'a')-replicateM :: (HVector v, Monad m, ArityC c (Elems v))-           => Proxy c -> (forall x. c x => m x) -> m v+replicateM :: (HVector v, Applicative f, ArityC c (Elems v))+           => Proxy c -> (forall a. c a => f a) -> f v {-# INLINE replicateM #-}-replicateM c x = liftM C.vector $ C.replicateM c x+replicateM c x+  = fmap C.vector+  $ C.sequenceF+  $ C.replicateF c (Compose $ fmap Identity x) -replicateF :: (HVectorF v, Arity (ElemsF v))+replicateNatF :: (HVectorF v, Arity (ElemsF v))            => (forall a. f a) -> v f+{-# INLINE replicateNatF #-}+replicateNatF x = C.vectorF $ C.replicateNatF x++replicateF :: (HVectorF v, ArityC c (ElemsF v))+            => Proxy c -> (forall a. c a => f a) -> v f {-# INLINE replicateF #-}-replicateF x = C.vectorF $ C.replicateF x+replicateF c x = C.vectorF $ C.replicateF c x  --- | Unfold vector.-unfoldr :: (HVector v, ArityC c (Elems v))-        => Proxy c -> (forall a. c a => b -> (a,b)) -> b -> v-{-# INLINE unfoldr #-}-unfoldr c f b0 = C.vector $ C.unfoldr c f b0 +----------------------------------------------------------------+-- Zipping of vectors+----------------------------------------------------------------+ -- | Zip two heterogeneous vectors-zipMono :: (HVector v, ArityC c (Elems v))+zipWith :: (HVector v, ArityC c (Elems v))         => Proxy c -> (forall a. c a => a -> a -> a) -> v -> v -> v-{-# INLINE zipMono #-}-zipMono c f v u-  = C.vector $ C.zipMono c f (C.cvec v) (C.cvec u)+{-# INLINE zipWith #-}+zipWith c f v u+  = C.vector+  $ C.zipWithF c (\(Identity a) (Identity b) -> Identity (f a b)) (C.cvec v) (C.cvec u)  -- | Zip two heterogeneous vectors-zipMonoF :: (HVectorF v, ArityC c (ElemsF v))+zipWithF :: (HVectorF v, ArityC c (ElemsF v))          => Proxy c -> (forall a. c a => f a -> g a -> h a) -> v f -> v g -> v h-{-# INLINE zipMonoF #-}-zipMonoF c f v u-  = C.vectorF $ C.zipMonoF c f (C.cvecF v) (C.cvecF u)+{-# INLINE zipWithF #-}+zipWithF c f v u+  = C.vectorF $ C.zipWithF c f (C.cvecF v) (C.cvecF u) +-- | Zip two heterogeneous vectors+zipWithNatF :: (HVectorF v)+        => (forall a. f a -> g a -> h a) -> v f -> v g -> v h+{-# INLINE zipWithNatF #-}+zipWithNatF f v u+  = C.vectorF $ C.zipWithNatF f (C.cvecF v) (C.cvecF u)+ zipFold :: (HVector v, ArityC c (Elems v), Monoid m)         => Proxy c -> (forall a. c a => a -> a -> m) -> v -> v -> m {-# INLINE zipFold #-} zipFold c f v u-  = C.zipFold c f (C.cvec v) (C.cvec u)+  = C.zipFoldF c (\(Identity a) (Identity b) -> f a b) (C.cvec v) (C.cvec u) +zipFoldF :: (HVectorF v, ArityC c (ElemsF v), Monoid m)+        => Proxy c -> (forall a. c a => f a -> f a -> m) -> v f -> v f -> m+{-# INLINE zipFoldF #-}+zipFoldF c f v u+  = C.zipFoldF c f (C.cvecF v) (C.cvecF u)+ -- | Convert heterogeneous vector to homogeneous-monomorphize :: (HVector v, ArityC c (Elems v))+monomorphize :: ( HVector v+                , Peano n ~ Len (Elems v)+                , ArityC c (Elems v))              => Proxy c -> (forall a. c a => a -> x)-             -> v -> F.ContVec (Len (Elems v)) x+             -> v -> F.ContVec n x {-# INLINE monomorphize #-}-monomorphize c f = C.monomorphize c f . C.cvec+monomorphize c f = C.monomorphizeF c (f . runIdentity) . C.cvec  -- | Convert heterogeneous vector to homogeneous-monomorphizeF :: (HVectorF v, ArityC c (ElemsF v))+monomorphizeF :: ( HVectorF v+                 , Peano n ~ Len (ElemsF v)+                 , ArityC c (ElemsF v)+                 )              => Proxy c -> (forall a. c a => f a -> x)-             -> v f -> F.ContVec (Len (ElemsF v)) x+             -> v f -> F.ContVec n x {-# INLINE monomorphizeF #-} monomorphizeF c f = C.monomorphizeF c f . C.cvecF 

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP                   #-} {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE DataKinds             #-} {-# LANGUAGE DefaultSignatures     #-}@@ -12,49 +11,31 @@ {-# LANGUAGE PolyKinds             #-} {-# LANGUAGE RankNTypes            #-} {-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-} {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE TypeOperators         #-} {-# LANGUAGE UndecidableInstances  #-} module Data.Vector.HFixed.Class (     -- * Types and type classes-    -- ** Peano numbers-    S-  , Z-#if __GLASGOW_HASKELL__ >= 708-    -- * Isomorphism between Peano numbers and Nats-  , NatIso-  , ToPeano-  , ToNat-#endif     -- ** N-ary functions-  , Fn-  , Fun(..)+    Fn+  , Fun   , TFun(..)-  , funToTFun-  , tfunToFun     -- ** Type functions   , Proxy(..)-  , type (++)()+  , type (++)   , Len-  , Wrap   , HomList     -- ** Type classes   , Arity(..)   , ArityC(..)   , HVector(..)+  , tupleSize   , HVectorF(..)-    -- *** Witnesses-  , WitWrapped(..)-  , WitConcat(..)-  , WitNestedFun(..)-  , WitLenWrap(..)-  , WitWrapIndex(..)-  , WitAllInstances(..)+  , tupleSizeF     -- ** CPS-encoded vector-  , ContVec(..)+  , ContVec   , ContVecF(..)-  , toContVec-  , toContVecF   , cons   , consF     -- ** Interop with homogeneous vectors@@ -65,29 +46,29 @@     -- ** Primitives for Fun   , curryFun   , uncurryFun-  , uncurryFun2+  , uncurryMany   , curryMany   , constFun-  , stepFun     -- ** Primitives for TFun+  , constTFun   , curryTFun   , uncurryTFun-  , uncurryTFun2   , shuffleTF+  , stepTFun     -- ** More complicated functions   , concatF-  , shuffleF   , lensWorkerF+  , lensWorkerTF   , Index(..)   ) where -import Control.Applicative (Applicative(..),(<$>))-import Data.Complex        (Complex(..))+import Control.Applicative   (Applicative(..),(<$>))+import Data.Coerce+import Data.Complex          (Complex(..))+import Data.Typeable         (Proxy(..))+import Data.Functor.Identity (Identity(..)) -import           Data.Vector.Fixed.Cont   (S,Z)-#if __GLASGOW_HASKELL__ >= 708-import           Data.Vector.Fixed.Cont   (ToPeano,ToNat,NatIso)-#endif+import           Data.Vector.Fixed.Cont   (Peano,PeanoNum(..),ArityPeano) import qualified Data.Vector.Fixed                as F import qualified Data.Vector.Fixed.Cont           as F (curryFirst) import qualified Data.Vector.Fixed.Unboxed        as U@@ -95,7 +76,9 @@ import qualified Data.Vector.Fixed.Storable       as S import qualified Data.Vector.Fixed.Boxed          as B -import GHC.Generics hiding (Arity(..),S)+import Unsafe.Coerce (unsafeCoerce)+import GHC.TypeLits+import GHC.Generics hiding (S)  import Data.Vector.HFixed.TypeFuns @@ -107,28 +90,18 @@  -- | Type family for N-ary function. Types of function parameters are --   encoded as the list of types.-type family   Fn (as :: [*]) b-type instance Fn '[]       b = b-type instance Fn (a ': as) b = a -> Fn as b---- | Newtype wrapper to work around of type families' lack of---   injectivity.-newtype Fun (as :: [*]) b = Fun { unFun :: Fn as b }+type family Fn (f :: * -> *) (as :: [*]) b where+  Fn f '[]      b = b+  Fn f (a : as) b = f a -> Fn f as b  -- | Newtype wrapper for function where all type parameters have same --   type constructor. This type is required for writing function --   which works with monads, appicatives etc.-newtype TFun f as b = TFun { unTFun :: Fn (Wrap f as) b }---- | Cast /Fun/ to equivalent /TFun/-funToTFun  :: Fun (Wrap f xs) b -> TFun f xs b-funToTFun = TFun . unFun-{-# INLINE funToTFun #-}+newtype TFun f as b = TFun { unTFun :: Fn f as b } --- | Cast /TFun/ to equivalent /Fun/-tfunToFun :: TFun f xs b -> Fun (Wrap f xs) b-tfunToFun = Fun . unTFun-{-# INLINE tfunToFun #-}+-- | Newtype wrapper to work around of type families' lack of+--   injectivity.+type Fun = TFun Identity   @@ -146,143 +119,78 @@ --   This is also somewhat a kitchen sink module. It contains --   witnesses which could be used to prove type equalities or to --   bring instance in scope.-class F.Arity (Len xs) => Arity (xs :: [*]) where+class Arity (xs :: [*]) where   -- | Fold over /N/ elements exposed as N-ary function.-  accum :: (forall a as. t (a ': as) -> a -> t as)-           -- ^ Step function. Applies element to accumulator.+  accum :: (forall a as. t (a : as) -> f a -> t as)+        -- ^ Step function. Applies element to accumulator.         -> (t '[] -> b)-           -- ^ Extract value from accumulator.+        -- ^ Extract value from accumulator.         -> t xs-           -- ^ Initial state.-        -> Fn xs b+        -- ^ Initial state.+        -> TFun f xs b    -- | Apply values to N-ary function-  apply :: (forall a as. t (a ': as) -> (a, t as))-           -- ^ Extract value to be applied to function.+  apply :: (forall a as. t (a : as) -> (f a, t as))+        -- ^ Extract value to be applied to function.         -> t xs-           -- ^ Initial state.-        -> ContVec xs-  -- | Apply value to N-ary function using monadic actions-  applyM :: Monad m-         => (forall a as. t (a ': as) -> m (a, t as))-            -- ^ Extract value to be applied to function-         -> t xs-            -- ^ Initial state-         -> m (ContVec xs)--  -- | Analog of accum-  accumTy :: (forall a as. t (a ': as) -> f a -> t as)-          -> (t '[] -> b)-          -> t xs-          -> Fn (Wrap f xs) b--  -- | Analog of 'apply' which allows to works with vectors which-  --   elements are wrapped in the newtype constructor.-  applyTy :: (forall a as. t (a ': as) -> (f a, t as))-          -> t xs-          -> ContVecF xs f+        -- ^ Initial state.+        -> ContVecF xs f    -- | Size of type list as integer.   arity :: p xs -> Int -  witWrapped   :: WitWrapped f xs-  witConcat    :: Arity ys => WitConcat xs ys-  witNestedFun :: WitNestedFun xs ys r-  witLenWrap   :: WitLenWrap f xs ---- | Declares that every type in list satisfy constraint @c@-class Arity xs => ArityC c xs where-  witAllInstances :: WitAllInstances c xs--instance ArityC c '[] where-  witAllInstances = WitAllInstancesNil-  {-# INLINE witAllInstances #-}-instance (c x, ArityC c xs) => ArityC c (x ': xs) where-  witAllInstances = WitAllInstancesCons (witAllInstances :: WitAllInstances c xs)-  {-# INLINE witAllInstances #-}----- | Witness that observe fact that if we have instance @Arity xs@---   than we have instance @Arity (Wrap f xs)@.-data WitWrapped f xs where-  WitWrapped :: Arity (Wrap f xs) => WitWrapped f xs---- | Witness that observe fact that @(Arity xs, Arity ys)@ implies---   @Arity (xs++ys)@-data WitConcat xs ys where-  WitConcat :: (Arity (xs++ys)) => WitConcat xs ys---- | Observes fact that @Fn (xs++ys) r ~ Fn xs (Fn ys r)@-data WitNestedFun xs ys r where-  WitNestedFun :: (Fn (xs++ys) r ~ Fn xs (Fn ys r)) => WitNestedFun xs ys r---- | Observe fact than @Len xs ~ Len (Wrap f xs)@-data WitLenWrap :: (* -> *) -> [*] -> * where-  WitLenWrap :: Len xs ~ Len (Wrap f xs) => WitLenWrap f xs+class (Arity xs) => ArityC c xs where+  accumC :: proxy c+         -- ^+         -> (forall a as. (c a) => t (a : as) -> f a -> t as)+         -- ^ Step function. Applies element to accumulator.+         -> (t '[] -> b)+         -- ^ Extract value from accumulator.+         -> t xs+         -- ^ Initial state.+         -> TFun f xs b --- | Witness that all elements of type list satisfy predicate @c@.-data WitAllInstances c xs where-  WitAllInstancesNil  :: WitAllInstances c '[]-  WitAllInstancesCons :: c x => WitAllInstances c xs -> WitAllInstances c (x ': xs)+  -- | Apply values to N-ary function+  applyC :: proxy c+         --+         -> (forall a as. (c a) => t (a : as) -> (f a, t as))+         -- ^ Extract value to be applied to function.+         -> t xs+         -- ^ Initial state.+         -> ContVecF xs f   instance Arity '[] where-  accum   _ f t = f t-  apply   _ _   = ContVec unFun-  applyM  _ _   = return (ContVec unFun)-  accumTy _ f t = f t-  applyTy _ _   = ContVecF unTFun-  {-# INLINE accum   #-}-  {-# INLINE apply   #-}-  {-# INLINE applyM  #-}-  {-# INLINE accumTy #-}-  {-# INLINE applyTy #-}+  accum _ f t = TFun (f t)+  apply _ _   = ContVecF unTFun+  {-# INLINE accum #-}+  {-# INLINE apply #-}   arity _     = 0   {-# INLINE arity #-} -  witWrapped   = WitWrapped-  witConcat    = WitConcat-  witNestedFun = WitNestedFun-  witLenWrap   = WitLenWrap-  {-# INLINE witWrapped #-}-  {-# INLINE witConcat #-}-  {-# INLINE witNestedFun #-}-  {-# INLINE witLenWrap #-}--instance Arity xs => Arity (x ': xs) where-  accum   f g t = \a -> accum f g (f t a)-  apply   f t   = case f t of (a,u) -> cons a (apply f u)-  applyM  f t   = do (a,t') <- f t-                     vec    <- applyM f t'-                     return $ cons a vec-  accumTy f g t = \a -> accumTy f g (f t a)-  applyTy f t   = case f t of (a,u) -> consF a (applyTy f u)-  {-# INLINE accum   #-}-  {-# INLINE apply   #-}-  {-# INLINE applyM  #-}-  {-# INLINE accumTy #-}-  {-# INLINE applyTy #-}+instance Arity xs => Arity (x : xs) where+  accum f g t = uncurryTFun (\a -> accum f g (f t a))+  apply f t   = case f t of (a,u) -> consF a (apply f u)+  {-# INLINE accum #-}+  {-# INLINE apply #-}   arity _     = 1 + arity (Proxy :: Proxy xs)   {-# INLINE arity        #-} -  witWrapped :: forall f. WitWrapped f (x ': xs)-  witWrapped = case witWrapped :: WitWrapped f xs of-                 WitWrapped -> WitWrapped-  {-# INLINE witWrapped #-}-  witConcat :: forall ys. Arity ys => WitConcat (x ': xs) ys-  witConcat = case witConcat :: WitConcat xs ys of-                WitConcat -> WitConcat-  {-# INLINE witConcat  #-}-  witNestedFun :: forall ys r. WitNestedFun (x ': xs) ys r-  witNestedFun = case witNestedFun :: WitNestedFun xs ys r of-                   WitNestedFun -> WitNestedFun-  {-# INLINE witNestedFun #-}-  witLenWrap :: forall f. WitLenWrap f (x ': xs)-  witLenWrap = case witLenWrap :: WitLenWrap f xs of-                 WitLenWrap -> WitLenWrap+instance ArityC c '[] where+  accumC _ _ f t = TFun (f t)+  applyC _ _ _   = ContVecF unTFun+  {-# INLINE accumC #-}+  {-# INLINE applyC #-} +instance (c x, ArityC c xs) => ArityC c (x : xs) where+  accumC w f g t = uncurryTFun (\a -> accumC w f g (f t a))+  applyC w f t   = case f t of (a,u) -> consF a (applyC w f u)+  {-# INLINE accumC #-}+  {-# INLINE applyC #-} ++ -- | Type class for heterogeneous vectors. Instance should specify way -- to construct and deconstruct itself --@@ -311,6 +219,9 @@   {-# INLINE construct #-}   {-# INLINE inspect   #-} +-- | Number of elements in tuple+tupleSize :: forall v proxy. HVector v => proxy v -> Int+tupleSize _ = arity (Proxy :: Proxy (Elems v))  -- | Type class for partially homogeneous vector where every element --   in the vector have same type constructor. Vector itself is@@ -321,6 +232,9 @@   inspectF   :: v f -> TFun f (ElemsF v) a -> a   constructF :: TFun f (ElemsF v) (v f) +-- | Number of elements in tuple+tupleSizeF :: forall v f proxy. HVectorF v => proxy (v f) -> Int+tupleSizeF _a = arity (Proxy :: Proxy (ElemsF v))   ----------------------------------------------------------------@@ -328,93 +242,111 @@ ----------------------------------------------------------------  -- | Conversion between homogeneous and heterogeneous N-ary functions.-class (F.Arity n, Arity (HomList n a)) => HomArity n a where+class (ArityPeano n, Arity (HomList n a)) => HomArity n a where   -- | Convert n-ary homogeneous function to heterogeneous.   toHeterogeneous :: F.Fun n a r -> Fun (HomList n a) r   -- | Convert heterogeneous n-ary function to homogeneous.   toHomogeneous   :: Fun (HomList n a) r -> F.Fun n a r  -instance HomArity Z a where-  toHeterogeneous = Fun   . F.unFun-  toHomogeneous   = F.Fun . unFun+instance HomArity 'Z a where+  toHeterogeneous = coerce+  toHomogeneous   = coerce   {-# INLINE toHeterogeneous #-}   {-# INLINE toHomogeneous   #-} -instance HomArity n a => HomArity (S n) a where+instance HomArity n a => HomArity ('S n) a where   toHeterogeneous f-    = Fun $ \a -> unFun $ toHeterogeneous (F.curryFirst f a)-  toHomogeneous (f :: Fun (a ': HomList n a) r)-    = F.Fun $ \a -> F.unFun (toHomogeneous $ curryFun f a :: F.Fun n a r)+    = coerce $ \a -> unTFun $ toHeterogeneous (F.curryFirst f a)+  toHomogeneous (f :: Fun (a : HomList n a) r)+    = coerce $ \a -> (toHomogeneous $ curryFun f a :: F.Fun n a r)   {-# INLINE toHeterogeneous #-}   {-# INLINE toHomogeneous   #-}  -- | Default implementation of 'inspect' for homogeneous vector.-homInspect :: (F.Vector v a, HomArity (F.Dim v) a)-           => v a -> Fun (HomList (F.Dim v) a) r -> r+homInspect :: (F.Vector v a, HomArity (Peano (F.Dim v)) a)+           => v a -> Fun (HomList (Peano (F.Dim v)) a) r -> r homInspect v f = F.inspect v (toHomogeneous f) {-# INLINE homInspect #-}  -- | Default implementation of 'construct' for homogeneous vector. homConstruct :: forall v a.-                (F.Vector v a, HomArity (F.Dim v) a)-             => Fun (HomList (F.Dim v) a) (v a)-homConstruct = toHeterogeneous (F.construct :: F.Fun (F.Dim v) a (v a))+                (F.Vector v a, HomArity (Peano (F.Dim v)) a)+             => Fun (HomList (Peano (F.Dim v)) a) (v a)+homConstruct = toHeterogeneous (F.construct :: F.Fun (Peano (F.Dim v)) a (v a)) {-# INLINE homConstruct #-}   -instance HomArity n a => HVector (B.Vec n a) where-  type Elems (B.Vec n a) = HomList n a+instance ( HomArity (Peano n) a+         , KnownNat n+         , Peano (n + 1) ~ 'S (Peano n)+         ) => HVector (B.Vec n a) where+  type Elems (B.Vec n a) = HomList (Peano n) a   inspect   = homInspect   construct = homConstruct   {-# INLINE inspect   #-}   {-# INLINE construct #-} -instance (U.Unbox n a, HomArity n a) => HVector (U.Vec n a) where-  type Elems (U.Vec n a) = HomList n a+instance ( U.Unbox n a+         , HomArity (Peano n) a+         , KnownNat n+         , Peano (n + 1) ~ 'S (Peano n)+         ) => HVector (U.Vec n a) where+  type Elems (U.Vec n a) = HomList (Peano n) a   inspect   = homInspect   construct = homConstruct   {-# INLINE inspect   #-}   {-# INLINE construct #-} -instance (S.Storable a, HomArity n a) => HVector (S.Vec n a) where-  type Elems (S.Vec n a) = HomList n a+instance ( S.Storable a+         , HomArity (Peano n) a+         , KnownNat n+         , Peano (n + 1) ~ 'S (Peano n)+         ) => HVector (S.Vec n a) where+  type Elems (S.Vec n a) = HomList (Peano n) a   inspect   = homInspect   construct = homConstruct   {-# INLINE inspect   #-}   {-# INLINE construct #-} -instance (P.Prim a, HomArity n a) => HVector (P.Vec n a) where-  type Elems (P.Vec n a) = HomList n a+instance ( P.Prim a+         , HomArity (Peano n) a+         , KnownNat n+         , Peano (n + 1) ~ 'S (Peano n)+         ) => HVector (P.Vec n a) where+  type Elems (P.Vec n a) = HomList (Peano n) a   inspect   = homInspect   construct = homConstruct   {-# INLINE inspect   #-}   {-# INLINE construct #-}  + ---------------------------------------------------------------- -- CPS-encoded vectors ---------------------------------------------------------------- --- | CPS-encoded heterogeneous vector.-newtype ContVec xs = ContVec { runContVec :: forall r. Fun xs r -> r }+--+-- newtype ContVec xs = ContVec { runContVec :: forall r. Fun xs r -> r } -instance Arity xs => HVector (ContVec xs) where-  type Elems (ContVec xs) = xs-  construct = Fun $-    accum (\(T_mkN f) x -> T_mkN (f . cons x))-          (\(T_mkN f)   -> f (ContVec unFun))-          (T_mkN id :: T_mkN xs xs)-  inspect (ContVec cont) f = cont f+instance Arity xs => HVector (ContVecF xs Identity) where+  type Elems (ContVecF xs Identity) = xs+  construct = accum+    (\(T_mkN f) (Identity x) -> T_mkN (f . cons x))+    (\(T_mkN f)              -> f (ContVecF unTFun))+    (T_mkN id)+  inspect (ContVecF cont) f = cont f   {-# INLINE construct #-}   {-# INLINE inspect   #-}  newtype T_mkN all xs = T_mkN (ContVec xs -> ContVec all) +-- | CPS-encoded heterogeneous vector.+type ContVec xs = ContVecF xs Identity  -- | CPS-encoded partially heterogeneous vector.-newtype ContVecF xs f = ContVecF (forall r. TFun f xs r -> r)+newtype ContVecF xs f = ContVecF { runContVecF :: forall r. TFun f xs r -> r }  instance Arity xs => HVectorF (ContVecF xs) where   type ElemsF (ContVecF xs) = xs@@ -425,29 +357,20 @@  constructFF :: forall f xs. (Arity xs) => TFun f xs (ContVecF xs f) {-# INLINE constructFF #-}-constructFF = TFun $ accumTy (\(TF_mkN f) x -> TF_mkN (f . consF x))-                             (\(TF_mkN f)   -> f $ ContVecF unTFun)-                             (TF_mkN id :: TF_mkN f xs xs)+constructFF = accum (\(TF_mkN f) x -> TF_mkN (f . consF x))+                    (\(TF_mkN f)   -> f $ ContVecF unTFun)+                    (TF_mkN id)  newtype TF_mkN f all xs = TF_mkN (ContVecF xs f -> ContVecF all f)  --toContVec :: ContVecF xs f -> ContVec (Wrap f xs)-toContVec (ContVecF cont) = ContVec $ cont . TFun . unFun-{-# INLINE toContVec #-}--toContVecF :: ContVec (Wrap f xs) -> ContVecF xs f-toContVecF (ContVec cont) = ContVecF $ cont . Fun . unTFun-{-# INLINE toContVecF #-}- -- | Cons element to the vector-cons :: x -> ContVec xs -> ContVec (x ': xs)-cons x (ContVec cont) = ContVec $ \f -> cont $ curryFun f x+cons :: x -> ContVec xs -> ContVec (x : xs)+cons x (ContVecF cont) = ContVecF $ \f -> cont $ curryFun f x {-# INLINE cons #-}  -- | Cons element to the vector-consF :: f x -> ContVecF xs f -> ContVecF (x ': xs) f+consF :: f x -> ContVecF xs f -> ContVecF (x : xs) f consF x (ContVecF cont) = ContVecF $ \f -> cont $ curryTFun f x {-# INLINE consF #-} @@ -457,54 +380,22 @@ -- Instances of Fun ---------------------------------------------------------------- -instance (Arity xs) => Functor (Fun xs) where-  fmap (f :: a -> b) (Fun g0 :: Fun xs a)-    = Fun $ accum (\(T_fmap g) a -> T_fmap (g a))-                  (\(T_fmap r)   -> f r)-                  (T_fmap g0 :: T_fmap a xs)-  {-# INLINE fmap #-}--instance Arity xs => Applicative (Fun xs) where-  pure r = Fun $ accum (\T_pure _ -> T_pure)-                       (\T_pure   -> r)-                       (T_pure :: T_pure xs)-  (Fun f0 :: Fun xs (a -> b)) <*> (Fun g0 :: Fun xs a)-    = Fun $ accum (\(T_ap f g) a -> T_ap (f a) (g a))-                  (\(T_ap f g)   -> f g)-                  ( T_ap f0 g0 :: T_ap (a -> b) a xs)-  {-# INLINE pure  #-}-  {-# INLINE (<*>) #-}--instance Arity xs => Monad (Fun xs) where-  return  = pure-  f >>= g = shuffleF g <*> f-  {-# INLINE return #-}-  {-# INLINE (>>=)  #-}--newtype T_fmap a   xs = T_fmap (Fn xs a)-data    T_pure     xs = T_pure-data    T_ap   a b xs = T_ap (Fn xs a) (Fn xs b)-- instance (Arity xs) => Functor (TFun f xs) where-  fmap (f :: a -> b) (TFun g0 :: TFun f xs a)-    = TFun $ accumTy (\(TF_fmap g) a -> TF_fmap (g a))-                     (\(TF_fmap r)   -> f r)-                     (TF_fmap g0 :: TF_fmap f a xs)+  fmap f (TFun g0)+    = accum (\(TF_fmap g) a -> TF_fmap (g a))+            (\(TF_fmap r)   -> f r)+            (TF_fmap g0)   {-# INLINE fmap #-}  instance (Arity xs) => Applicative (TFun f xs) where-  pure r = TFun $ accumTy step-                          (\TF_pure   -> r)-                          (TF_pure :: TF_pure f xs)-    where-      step :: forall a as. TF_pure f (a ': as) -> f a -> TF_pure f as-      step _ _ = TF_pure+  pure r = accum (\Proxy _ -> Proxy)+                 (\Proxy   -> r)+                 (Proxy)   {-# INLINE pure  #-}   (TFun f0 :: TFun f xs (a -> b)) <*> (TFun g0 :: TFun f xs a)-    = TFun $ accumTy (\(TF_ap f g) a -> TF_ap (f a) (g a))-                  (\(TF_ap f g)   -> f g)-                  ( TF_ap f0 g0 :: TF_ap f (a -> b) a xs)+    = accum (\(TF_ap f g) a -> TF_ap (f a) (g a))+            (\(TF_ap f g)   -> f g)+            ( TF_ap f0 g0 :: TF_ap f (a -> b) a xs)   {-# INLINE (<*>) #-}  instance Arity xs => Monad (TFun f xs) where@@ -513,9 +404,8 @@   {-# INLINE return #-}   {-# INLINE (>>=)  #-} -newtype TF_fmap f a   xs = TF_fmap (Fn (Wrap f xs) a)-data    TF_pure f     xs = TF_pure-data    TF_ap   f a b xs = TF_ap (Fn (Wrap f xs) a) (Fn (Wrap f xs) b)+newtype TF_fmap f a   xs = TF_fmap (Fn f xs a)+data    TF_ap   f a b xs = TF_ap   (Fn f xs a) (Fn f xs b)   @@ -524,50 +414,49 @@ ----------------------------------------------------------------  -- | Apply single parameter to function-curryFun :: Fun (x ': xs) r -> x -> Fun xs r-curryFun (Fun f) x = Fun (f x)+curryFun :: Fun (x : xs) r -> x -> Fun xs r+curryFun = coerce {-# INLINE curryFun #-}  -- | Uncurry N-ary function.-uncurryFun :: (x -> Fun xs r) -> Fun (x ': xs) r-uncurryFun = Fun . fmap unFun+uncurryFun :: (x -> Fun xs r) -> Fun (x : xs) r+uncurryFun = coerce {-# INLINE uncurryFun #-} -uncurryFun2 :: (Arity xs)-            => (x -> y -> Fun xs (Fun ys r))-            -> Fun (x ': xs) (Fun (y ': ys) r)-uncurryFun2 = uncurryFun . fmap (fmap uncurryFun . shuffleF)-{-# INLINE uncurryFun2 #-}- -- | Conversion function uncurryMany :: forall xs ys r. Arity xs => Fun xs (Fun ys r) -> Fun (xs ++ ys) r+-- NOTE: GHC is not smart enough to figure out that:+--+--       > Fn xs (Fn ys) r ~ Fn (xs ++ ys) r+--+--       It's possible to construct type safe definition but it's+--       quite complicated and increase compile time and may hurrt+--       performance {-# INLINE uncurryMany #-}-uncurryMany f =-  case witNestedFun :: WitNestedFun xs ys r of-    WitNestedFun ->-      case fmap unFun f :: Fun xs (Fn ys r) of-        Fun g -> Fun g+uncurryMany = unsafeCoerce  -- | Curry first /n/ arguments of N-ary function. curryMany :: forall xs ys r. Arity xs => Fun (xs ++ ys) r -> Fun xs (Fun ys r)+-- NOTE: See uncurryMany {-# INLINE curryMany #-}-curryMany (Fun f0)-  = Fun $ accum (\(T_curry f) a -> T_curry (f a))-                (\(T_curry f)   -> Fun f :: Fun ys r)-                (T_curry f0 :: T_curry r ys xs)--newtype T_curry r ys xs = T_curry (Fn (xs ++ ys) r)+curryMany = unsafeCoerce   -- | Add one parameter to function which is ignored.-constFun :: Fun xs r -> Fun (x ': xs) r+constFun :: Fun xs r -> Fun (x : xs) r constFun = uncurryFun . const {-# INLINE constFun #-} +-- | Add one parameter to function which is ignored.+constTFun :: TFun f xs r -> TFun f (x : xs) r+constTFun = uncurryTFun . const+{-# INLINE constTFun #-}+ -- | Transform function but leave outermost parameter untouched.-stepFun :: (Fun xs a -> Fun ys b) -> Fun (x ': xs) a -> Fun (x ': ys) b-stepFun g = uncurryFun . fmap g . curryFun-{-# INLINE stepFun #-}+stepTFun :: (TFun f xs a       -> TFun f ys b)+         -> (TFun f (x : xs) a -> TFun f (x : ys) b)+stepTFun g = uncurryTFun . fmap g . curryTFun+{-# INLINE stepTFun #-}  -- | Concatenate n-ary functions. This function combine results of --   both N-ary functions and merge their parameters into single list.@@ -578,25 +467,23 @@   where     go a = fmap (\b -> f a b) funB --- | Move first argument of function to its result. This function is---   useful for implementation of lens.-shuffleF :: forall x xs r. Arity xs => (x -> Fun xs r) -> Fun xs (x -> r)-{-# INLINE shuffleF #-}-shuffleF fun = Fun $ accum-  (\(T_shuffle f) a -> T_shuffle (\x -> f x a))-  (\(T_shuffle f)   -> f)-  (T_shuffle (fmap unFun fun) :: T_shuffle x r xs)--data T_shuffle x r xs = T_shuffle (Fn (x ': xs) r)- -- | Helper for lens implementation. lensWorkerF :: forall f r x y xs. (Functor f, Arity xs)-            => (x -> f y) -> Fun (y ': xs) r -> Fun (x ': xs) (f r)+            => (x -> f y) -> Fun (y : xs) r -> Fun (x : xs) (f r) {-# INLINE lensWorkerF #-} lensWorkerF g f   = uncurryFun-  $ \x -> (\r -> fmap (r $) (g x)) <$> shuffleF (curryFun f)+  $ \x -> (\r -> fmap (r $) (g x)) <$> shuffleTF (curryFun f) +-- | Helper for lens implementation.+lensWorkerTF :: forall f g r x y xs. (Functor f, Arity xs)+             => (g x -> f (g y))+             -> TFun g (y : xs) r+             -> TFun g (x : xs) (f r)+{-# INLINE lensWorkerTF #-}+lensWorkerTF g f+  = uncurryTFun+  $ \x -> (\r -> fmap (r $) (g x)) <$> shuffleTF (curryTFun f)   ----------------------------------------------------------------@@ -604,34 +491,26 @@ ----------------------------------------------------------------  -- | Apply single parameter to function-curryTFun :: TFun f (x ': xs) r -> f x -> TFun f xs r-curryTFun (TFun f) = TFun . f+curryTFun :: TFun f (x : xs) r -> f x -> TFun f xs r+curryTFun = coerce {-# INLINE curryTFun #-}  -- | Uncurry single parameter-uncurryTFun :: (f x -> TFun f xs r) -> TFun f (x ': xs) r-uncurryTFun = TFun . fmap unTFun+uncurryTFun :: (f x -> TFun f xs r) -> TFun f (x : xs) r+uncurryTFun = coerce {-# INLINE uncurryTFun #-} --- | Uncurry two parameters for nested TFun.-uncurryTFun2 :: (Arity xs, Arity ys)-             => (f x -> f y -> TFun f xs (TFun f ys r))-             -> TFun f (x ': xs) (TFun f (y ': ys) r)-uncurryTFun2 = uncurryTFun . fmap (fmap uncurryTFun . shuffleTF)-{-# INLINE uncurryTFun2 #-}-- -- | Move first argument of function to its result. This function is --   useful for implementation of lens. shuffleTF :: forall f x xs r. Arity xs           => (x -> TFun f xs r) -> TFun f xs (x -> r) {-# INLINE shuffleTF #-}-shuffleTF fun0 = TFun $ accumTy+shuffleTF fun0 = accum   (\(TF_shuffle f) a -> TF_shuffle (\x -> f x a))   (\(TF_shuffle f)   -> f)-  (TF_shuffle (fmap unTFun fun0) :: TF_shuffle f x r xs)+  (TF_shuffle (fmap unTFun fun0)) -data TF_shuffle f x r xs = TF_shuffle (x -> (Fn (Wrap f xs) r))+data TF_shuffle f x r xs = TF_shuffle (x -> Fn f xs r)   @@ -640,37 +519,27 @@ ----------------------------------------------------------------  -- | Indexing of vectors-class F.Arity n => Index (n :: *) (xs :: [*]) where+class ArityPeano n => Index (n :: PeanoNum) (xs :: [*]) where   -- | Type at position n   type ValueAt n xs :: *   -- | List of types with n'th element replaced by /a/.   type NewElems n xs a :: [*]   -- | Getter function for vectors-  getF :: n -> Fun xs (ValueAt n xs)+  getF :: proxy n -> Fun xs (ValueAt n xs)   -- | Putter function. It applies value @x@ to @n@th parameter of   --   function.-  putF :: n -> ValueAt n xs -> Fun xs r -> Fun xs r+  putF :: proxy n -> ValueAt n xs -> Fun xs r -> Fun xs r   -- | Helper for implementation of lens-  lensF :: (Functor f, v ~ ValueAt n xs)-        => n -> (v -> f v) -> Fun xs r -> Fun xs (f r)+  lensF   :: (Functor f, v ~ ValueAt n xs)+          => proxy n -> (v -> f v) -> Fun xs r -> Fun xs (f r)   -- | Helper for type-changing lens   lensChF :: (Functor f)-          => n -> (ValueAt n xs -> f a) -> Fun (NewElems n xs a) r -> Fun xs (f r)-  witWrapIndex :: WitWrapIndex f n xs----- | Proofs for the indexing of wrapped type lists.-data WitWrapIndex f n xs where-  WitWrapIndex :: ( ValueAt n (Wrap f xs) ~ f (ValueAt n xs)-                  , Index n (Wrap f xs)-                  , Arity (Wrap f xs)-                  ) => WitWrapIndex f n xs-+          => proxy n -> (ValueAt n xs -> f a) -> Fun (NewElems n xs a) r -> Fun xs (f r) -instance Arity xs => Index Z (x ': xs) where-  type ValueAt  Z (x ': xs)   = x-  type NewElems Z (x ': xs) a = a ': xs-  getF  _     = Fun $ \x -> unFun (pure x :: Fun xs x)+instance Arity xs => Index 'Z (x : xs) where+  type ValueAt  'Z (x : xs)   = x+  type NewElems 'Z (x : xs) a = a : xs+  getF  _     = TFun $ \(Identity x) -> unTFun (pure x :: Fun xs x)   putF  _ x f = constFun $ curryFun f x   lensF   _     = lensWorkerF   lensChF _     = lensWorkerF@@ -678,26 +547,18 @@   {-# INLINE putF    #-}   {-# INLINE lensF   #-}   {-# INLINE lensChF #-}-  witWrapIndex :: forall f. WitWrapIndex f Z (x ': xs)-  witWrapIndex = case witWrapped :: WitWrapped f xs of-                   WitWrapped -> WitWrapIndex-  {-# INLINE witWrapIndex #-} -instance Index n xs => Index (S n) (x ': xs) where-  type ValueAt  (S n) (x ': xs)   = ValueAt n xs-  type NewElems (S n) (x ': xs) a = x ': NewElems n xs a-  getF    _   = constFun $ getF    (undefined :: n)-  putF    _ x = stepFun  $ putF    (undefined :: n) x-  lensF   _ f = stepFun  $ lensF   (undefined :: n) f-  lensChF _ f = stepFun  $ lensChF (undefined :: n) f+instance Index n xs => Index ('S n) (x : xs) where+  type ValueAt  ('S n) (x : xs)   = ValueAt n xs+  type NewElems ('S n) (x : xs) a = x : NewElems n xs a+  getF    _   = constFun $ getF    (Proxy @ n)+  putF    _ x = stepTFun $ putF    (Proxy @ n) x+  lensF   _ f = stepTFun $ lensF   (Proxy @ n) f+  lensChF _ f = stepTFun $ lensChF (Proxy @ n) f   {-# INLINE getF    #-}   {-# INLINE putF    #-}   {-# INLINE lensF   #-}   {-# INLINE lensChF #-}-  witWrapIndex :: forall f. WitWrapIndex f (S n) (x ': xs)-  witWrapIndex = case witWrapIndex :: WitWrapIndex f n xs of-                   WitWrapIndex -> WitWrapIndex-  {-# INLINE witWrapIndex #-}   @@ -708,266 +569,297 @@ -- | Unit is empty heterogeneous vector instance HVector () where   type Elems () = '[]-  construct = Fun ()-  inspect () (Fun f) = f+  construct = TFun ()+  inspect () (TFun f) = f  instance HVector (Complex a) where   type Elems (Complex a) = '[a,a]-  construct = Fun (:+)-  inspect (r :+ i) (Fun f) = f r i+  construct = TFun $ \(Identity r) (Identity i) -> (:+) r i+  inspect (r :+ i) f = coerce f r i   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b) where   type Elems (a,b) = '[a,b]-  construct = Fun (,)-  inspect (a,b) (Fun f) = f a b+  construct = coerce ((,) :: a->b -> (a,b))+  inspect (a,b) f = coerce f a b   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c) where   type Elems (a,b,c) = '[a,b,c]-  construct = Fun (,,)-  inspect (a,b,c) (Fun f) = f a b c+  construct = coerce ((,,) :: a->b->c -> (a,b,c))+  inspect (a,b,c) f = coerce f a b c   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d) where   type Elems (a,b,c,d) = '[a,b,c,d]-  construct = Fun (,,,)-  inspect (a,b,c,d) (Fun f) = f a b c d+  construct = coerce ((,,,) :: a->b->c->d -> (a,b,c,d))+  inspect (a,b,c,d) f = coerce f a b c d   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e) where   type Elems (a,b,c,d,e) = '[a,b,c,d,e]-  construct = Fun (,,,,)-  inspect (a,b,c,d,e) (Fun f) = f a b c d e+  construct = coerce ((,,,,) :: a->b->c->d->e -> (a,b,c,d,e))+  inspect (a,b,c,d,e) f = coerce f a b c d e   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f) where   type Elems (a,b,c,d,e,f) = '[a,b,c,d,e,f]-  construct = Fun (,,,,,)-  inspect (a,b,c,d,e,f) (Fun fun) = fun a b c d e f+  construct = coerce ((,,,,,) :: a->b->c->d->e->f+                              -> (a,b,c,d,e,f))+  inspect (a,b,c,d,e,f) fun = coerce fun a b c d e f   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g) where   type Elems (a,b,c,d,e,f,g) = '[a,b,c,d,e,f,g]-  construct = Fun (,,,,,,)-  inspect (a,b,c,d,e,f,g) (Fun fun) = fun a b c d e f g+  construct = coerce ((,,,,,,) :: a->b->c->d->e->f->g+                               -> (a,b,c,d,e,f,g))+  inspect (a,b,c,d,e,f,g) fun = coerce fun a b c d e f g   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g,h) where   type Elems (a,b,c,d,e,f,g,h) = '[a,b,c,d,e,f,g,h]-  construct = Fun (,,,,,,,)-  inspect (a,b,c,d,e,f,g,h) (Fun fun) = fun a b c d e f g h+  construct = coerce ((,,,,,,,) :: a->b->c->d->e->f->g->h+                                -> (a,b,c,d,e,f,g,h))+  inspect (a,b,c,d,e,f,g,h) fun = coerce fun a b c d e f g h   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g,h,i) where   type Elems (a,b,c,d,e,f,g,h,i) = '[a,b,c,d,e,f,g,h,i]-  construct = Fun (,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i) (Fun fun) = fun a b c d e f g h i+  construct = coerce ((,,,,,,,,) :: a->b->c->d->e->f->g->h->i+                                 -> (a,b,c,d,e,f,g,h,i))+  inspect (a,b,c,d,e,f,g,h,i) fun = coerce fun a b c d e f g h i   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g,h,i,j) where   type Elems (a,b,c,d,e,f,g,h,i,j) = '[a,b,c,d,e,f,g,h,i,j]-  construct = Fun (,,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i,j) (Fun fun) = fun a b c d e f g h i j+  construct = coerce ((,,,,,,,,,) :: a->b->c->d->e->f->g->h->i->j+                                  -> (a,b,c,d,e,f,g,h,i,j))+  inspect (a,b,c,d,e,f,g,h,i,j) fun = coerce fun a b c d e f g h i j   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g,h,i,j,k) where   type Elems (a,b,c,d,e,f,g,h,i,j,k) = '[a,b,c,d,e,f,g,h,i,j,k]-  construct = Fun (,,,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i,j,k) (Fun fun) = fun a b c d e f g h i j k+  construct = coerce ((,,,,,,,,,,) :: a->b->c->d->e->f->g->h->i->j->k+                                   -> (a,b,c,d,e,f,g,h,i,j,k))+  inspect (a,b,c,d,e,f,g,h,i,j,k) fun = coerce fun a b c d e f g h i j k   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g,h,i,j,k,l) where   type Elems (a,b,c,d,e,f,g,h,i,j,k,l) = '[a,b,c,d,e,f,g,h,i,j,k,l]-  construct = Fun (,,,,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i,j,k,l) (Fun fun) = fun a b c d e f g h i j k l+  construct = coerce ((,,,,,,,,,,,) :: a->b->c->d->e->f->g->h->i->j->k->l+                                    -> (a,b,c,d,e,f,g,h,i,j,k,l))+  inspect (a,b,c,d,e,f,g,h,i,j,k,l) fun = coerce fun a b c d e f g h i j k l   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g,h,i,j,k,l,m) where   type Elems (a,b,c,d,e,f,g,h,i,j,k,l,m) = '[a,b,c,d,e,f,g,h,i,j,k,l,m]-  construct = Fun (,,,,,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m) (Fun fun) = fun a b c d e f g h i j k l m+  construct = coerce ((,,,,,,,,,,,,) :: a->b->c->d->e->f->g->h->i->j->k->l->m+                                     -> (a,b,c,d,e,f,g,h,i,j,k,l,m))+  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m) fun = coerce fun a b c d e f g h i j k l m   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where   type Elems (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n]-  construct = Fun (,,,,,,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n) (Fun fun) =-    fun a b c d e f g h i j k l m n+  construct = coerce ((,,,,,,,,,,,,,) :: a->b->c->d->e->f->g->h->i->j->k->l->m->n+                                      -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n))+  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n) fun+    = coerce fun a b c d e f g h i j k l m n   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where   type Elems (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o]-  construct = Fun (,,,,,,,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) (Fun fun) =-    fun a b c d e f g h i j k l m n o+  construct = coerce ((,,,,,,,,,,,,,,) :: a->b->c->d->e->f->g->h->i->j->k->l->m->n->o+                                       -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o))+  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) fun+    = coerce fun a b c d e f g h i j k l m n o   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where   type Elems (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) =     '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p]-  construct = Fun (,,,,,,,,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) (Fun fun) =-    fun a b c d e f g h i j k l m n o p+  construct = coerce ((,,,,,,,,,,,,,,,) :: a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p+                                        -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p))+  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) fun+    = coerce fun a b c d e f g h i j k l m n o p   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) where   type Elems (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) =     '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q]-  construct = Fun (,,,,,,,,,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) (Fun fun) =-    fun a b c d e f g h i j k l m n o p q+  construct = coerce ((,,,,,,,,,,,,,,,,) :: a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q+                                         -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q))+  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) fun+    = coerce fun a b c d e f g h i j k l m n o p q   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) where   type Elems (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) =     '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r]-  construct = Fun (,,,,,,,,,,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) (Fun fun) =-    fun a b c d e f g h i j k l m n o p q r+  construct = coerce ((,,,,,,,,,,,,,,,,,) :: a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r+                                          -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r))+  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) fun+    = coerce fun a b c d e f g h i j k l m n o p q r   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) where   type Elems (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) =     '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s]-  construct = Fun (,,,,,,,,,,,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) (Fun fun) =-    fun a b c d e f g h i j k l m n o p q r s+  construct = coerce ((,,,,,,,,,,,,,,,,,,) :: a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r->s+                                           -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s))+  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) fun+    = coerce fun a b c d e f g h i j k l m n o p q r s   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) where   type Elems (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) =     '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t]-  construct = Fun (,,,,,,,,,,,,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) (Fun fun) =-    fun a b c d e f g h i j k l m n o p q r s t+  construct = coerce ((,,,,,,,,,,,,,,,,,,,) :: a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r->s->t+                                            -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t))+  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) fun+    = coerce fun a b c d e f g h i j k l m n o p q r s t   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u) where   type Elems (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u) =     '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u]-  construct = Fun (,,,,,,,,,,,,,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u) (Fun fun) =-    fun a b c d e f g h i j k l m n o p q r s t u+  construct = coerce ((,,,,,,,,,,,,,,,,,,,,) :: a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r->s->t->u+                                             -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u))+  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u) fun+    = coerce fun a b c d e f g h i j k l m n o p q r s t u   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v) where   type Elems (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v) =     '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v]-  construct = Fun (,,,,,,,,,,,,,,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v) (Fun fun) =-    fun a b c d e f g h i j k l m n o p q r s t u v+  construct = coerce ((,,,,,,,,,,,,,,,,,,,,,) :: a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r->s->t->u->v+                                              -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v))+  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v) fun+    = coerce fun a b c d e f g h i j k l m n o p q r s t u v   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w) where   type Elems (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w) =     '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w]-  construct = Fun (,,,,,,,,,,,,,,,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w) (Fun fun) =-    fun a b c d e f g h i j k l m n o p q r s t u v w+  construct = coerce ((,,,,,,,,,,,,,,,,,,,,,,) :: a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r->s->t->u->v->w+                                               -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w))+  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w) fun+    = coerce fun a b c d e f g h i j k l m n o p q r s t u v w   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x) where   type Elems (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x) =     '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x]-  construct = Fun (,,,,,,,,,,,,,,,,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x) (Fun fun) =-    fun a b c d e f g h i j k l m n o p q r s t u v w x+  construct = coerce ((,,,,,,,,,,,,,,,,,,,,,,,) :: a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r->s->t->u->v->w->x+                                                -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x))+  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x) fun+    = coerce fun a b c d e f g h i j k l m n o p q r s t u v w x   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y) where   type Elems (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y) =     '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y]-  construct = Fun (,,,,,,,,,,,,,,,,,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y) (Fun fun) =-    fun a b c d e f g h i j k l m n o p q r s t u v w x y+  construct = coerce ((,,,,,,,,,,,,,,,,,,,,,,,,) :: a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r->s->t->u->v->w->x->y+                                                 -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y))+  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y) fun+    = coerce fun a b c d e f g h i j k l m n o p q r s t u v w x y   {-# INLINE construct #-}   {-# INLINE inspect   #-} - instance HVector (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z) where   type Elems (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z) =     '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z]-  construct = Fun (,,,,,,,,,,,,,,,,,,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z) (Fun fun) =-    fun a b c d e f g h i j k l m n o p q r s t u v w x y z+  construct = coerce ((,,,,,,,,,,,,,,,,,,,,,,,,,) :: a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r->s->t->u->v->w->x->y->z+                                                  -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z))+  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z) fun+    = coerce fun a b c d e f g h i j k l m n o p q r s t u v w x y z   {-# INLINE construct #-}   {-# INLINE inspect   #-} - instance HVector (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a') where   type Elems (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a') =     '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a']-  construct = Fun (,,,,,,,,,,,,,,,,,,,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a') (Fun fun) =-    fun a b c d e f g h i j k l m n o p q r s t u v w x y z a'+  construct = coerce ((,,,,,,,,,,,,,,,,,,,,,,,,,,) :: a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r->s->t->u->v->w->x->y->z->a'+                                                   -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a'))+  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a') fun+    = coerce fun a b c d e f g h i j k l m n o p q r s t u v w x y z a'   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b') where   type Elems (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b') =     '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b']-  construct = Fun (,,,,,,,,,,,,,,,,,,,,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b') (Fun fun) = fun a b c d e f g h i j k l m n o p q r s t u v w x y z a' b'+  construct = coerce ((,,,,,,,,,,,,,,,,,,,,,,,,,,,) :: a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r->s->t->u->v->w->x->y->z->a'->b'+                                                    -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b'))+  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b') fun+    = coerce fun a b c d e f g h i j k l m n o p q r s t u v w x y z a' b'   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c') where   type Elems (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c') =     '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c']-  construct = Fun (,,,,,,,,,,,,,,,,,,,,,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c') (Fun fun) = fun a b c d e f g h i j k l m n o p q r s t u v w x y z a' b' c'+  construct = coerce ((,,,,,,,,,,,,,,,,,,,,,,,,,,,,) :: a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r->s->t->u->v->w->x->y->z->a'->b'->c'+                                                     -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c'))+  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c') fun+    = coerce fun a b c d e f g h i j k l m n o p q r s t u v w x y z a' b' c'   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c',d') where   type Elems (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c',d') =     '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c',d']-  construct = Fun (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c',d') (Fun fun) = fun a b c d e f g h i j k l m n o p q r s t u v w x y z a' b' c' d'+  construct = coerce ((,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) :: a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r->s->t->u->v->w->x->y->z->a'->b'->c'->d'+                                                      -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c',d'))+  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c',d') fun+    = coerce fun a b c d e f g h i j k l m n o p q r s t u v w x y z a' b' c' d'   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c',d',e') where-  type Elems (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c',d',e') = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c',d',e']-  construct = Fun (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c',d',e') (Fun fun) =-    fun a b c d e f g h i j k l m n o p q r s t u v w x y z a' b' c' d' e'+  type Elems (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c',d',e')+    = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c',d',e']+  construct = coerce ((,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) :: a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r->s->t->u->v->w->x->y->z->a'->b'->c'->d'->e'+                                                       -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c',d',e'))+  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c',d',e') fun+    = coerce fun a b c d e f g h i j k l m n o p q r s t u v w x y z a' b' c' d' e'   {-# INLINE construct #-}   {-# INLINE inspect   #-}  instance HVector (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c',d',e',f') where-  type Elems (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c',d',e',f') = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c',d',e',f']-  construct = Fun (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)-  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c',d',e',f') (Fun fun) =-    fun a b c d e f g h i j k l m n o p q r s t u v w x y z a' b' c' d' e' f'+  type Elems (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c',d',e',f')+    = '[a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c',d',e',f']+  construct = coerce ((,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) :: a->b->c->d->e->f->g->h->i->j->k->l->m->n->o->p->q->r->s->t->u->v->w->x->y->z->a'->b'->c'->d'->e'->f'+                                                        -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c',d',e',f'))+  inspect (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a',b',c',d',e',f') fun+    = coerce fun a b c d e f g h i j k l m n o p q r s t u v w x y z a' b' c' d' e' f'   {-# INLINE construct #-}   {-# INLINE inspect   #-} + ---------------------------------------------------------------- -- Generics ----------------------------------------------------------------@@ -1001,16 +893,16 @@ -- Recursion is terminated by simple field instance GHVector (K1 R x) where   type GElems (K1 R x) = '[x]-  gconstruct = Fun K1-  ginspect (K1 x) (Fun f) = f x+  gconstruct               = TFun (K1 . runIdentity)+  ginspect (K1 x) (TFun f) = f (Identity x) -- f (Identity x)   {-# INLINE gconstruct #-}   {-# INLINE ginspect   #-}   -- Unit types are empty vectors instance GHVector U1 where-  type GElems U1 = '[]-  gconstruct         = Fun U1-  ginspect _ (Fun f) = f+  type GElems U1      = '[]+  gconstruct          = coerce U1+  ginspect _ (TFun f) = f   {-# INLINE gconstruct #-}   {-# INLINE ginspect   #-}

@@ -1,13 +1,14 @@-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE DataKinds             #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE PolyKinds             #-} {-# LANGUAGE Rank2Types            #-}-{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-} {-# LANGUAGE UndecidableInstances  #-} -- | -- CPS encoded heterogeneous vectors.@@ -15,19 +16,18 @@     -- * CPS-encoded vector     -- ** Type classes     Fn-  , Fun(..)+  , Fun   , TFun(..)   , Arity(..)   , HVector(..)+  , tupleSize   , HVectorF(..)+  , tupleSizeF   , ValueAt   , Index-  , Wrap     -- ** CPS-encoded vector-  , ContVec(..)+  , ContVec   , ContVecF(..)-  , toContVec-  , toContVecF     -- ** Other data types   , VecList(..)   , VecListF(..)@@ -36,53 +36,44 @@   , vector   , cvecF   , vectorF-    -- * Position based functions+    -- * Generic API for tuples+    -- ** Position based functions   , head   , tail   , cons   , consF   , concat-    -- * Indexing+    -- ** Indexing   , index   , set-    -- * Constructors-  , mk0-  , mk1-  , mk2-  , mk3-  , mk4-  , mk5-    -- * Folds and unfolds-  , foldl-  , foldr-  , unfoldr-    -- * Polymorphic values-  , replicate-  , replicateM+    -- ** Folds and unfolds+  , foldlF+  , foldrF+  , foldlNatF+  , foldrNatF+  , unfoldrF+    -- ** Replicate variants   , replicateF-  , zipMono-  , zipMonoF-  , zipFold-  , monomorphize+  , replicateNatF+    -- ** Zip variants+  , zipWithF+  , zipWithNatF+  , zipFoldF+    -- ** Monomorphization of vectors   , monomorphizeF-    -- * Vector parametrized with type constructor-  , mapFunctor-  , sequence-  , sequenceA+    -- ** Manipulation with type constructor+  , mapNat   , sequenceF-  , sequenceAF-  , distribute   , distributeF-  , wrap-  , unwrap   ) where -import Control.Applicative   (Applicative(..))-import Control.Monad         (ap)+import Control.Applicative   (Applicative(..),Const(..)) import Data.Monoid           (Monoid(..),(<>)) import Data.Functor.Compose  (Compose(..))+import Data.Functor.Identity (Identity(..))+import Data.Typeable         (Proxy(..)) import qualified Data.Vector.Fixed.Cont as F-import Prelude (Functor(..),Monad(..),id,(.),($),flip)+import Prelude               (Functor(..),id,(.),($))  import Data.Vector.HFixed.Class @@ -94,12 +85,12 @@  -- | Convert heterogeneous vector to CPS form cvec :: (HVector v, Elems v ~ xs) => v -> ContVec xs-cvec v = ContVec (inspect v)+cvec v = ContVecF (inspect v) {-# INLINE cvec #-}  -- | Convert CPS-vector to heterogeneous vector vector :: (HVector v, Elems v ~ xs) => ContVec xs -> v-vector (ContVec cont) = cont construct+vector (ContVecF cont) = cont construct {-# INLINE vector #-}  cvecF :: HVectorF v => v f -> ContVecF (ElemsF v) f@@ -113,62 +104,32 @@   ------------------------------------------------------------------- Constructors-------------------------------------------------------------------mk0 :: ContVec '[]-mk0 = ContVec $ \(Fun r) -> r-{-# INLINE mk0 #-}--mk1 :: a -> ContVec '[a]-mk1 a1 = ContVec $ \(Fun f) -> f a1-{-# INLINE mk1 #-}--mk2 :: a -> b -> ContVec '[a,b]-mk2 a1 a2 = ContVec $ \(Fun f) -> f a1 a2-{-# INLINE mk2 #-}--mk3 :: a -> b -> c -> ContVec '[a,b,c]-mk3 a1 a2 a3 = ContVec $ \(Fun f) -> f a1 a2 a3-{-# INLINE mk3 #-}--mk4 :: a -> b -> c -> d -> ContVec '[a,b,c,d]-mk4 a1 a2 a3 a4 = ContVec $ \(Fun f) -> f a1 a2 a3 a4-{-# INLINE mk4 #-}--mk5 :: a -> b -> c -> d -> e -> ContVec '[a,b,c,d,e]-mk5 a1 a2 a3 a4 a5 = ContVec $ \(Fun f) -> f a1 a2 a3 a4 a5-{-# INLINE mk5 #-}----------------------------------------------------------------------- Transformation+-- Position based functions ----------------------------------------------------------------  -- | Head of vector-head :: forall x xs. Arity xs => ContVec (x ': xs) -> x-head = flip inspect $ Fun $ \x -> unFun (pure x :: Fun xs x)+head :: Arity xs => ContVec (x : xs) -> x+head v = inspect v (uncurryFun pure) {-# INLINE head #-}  -- | Tail of CPS-encoded vector-tail :: ContVec (x ': xs) -> ContVec xs-tail (ContVec cont) = ContVec $ cont . constFun+tail :: ContVec (x : xs) -> ContVec xs+tail (ContVecF cont) = ContVecF $ cont . constFun {-# INLINE tail #-}  -- | Concatenate two vectors concat :: Arity xs => ContVec xs -> ContVec ys -> ContVec (xs ++ ys)-concat (ContVec contX) (ContVec contY) = ContVec $ contY . contX . curryMany+concat (ContVecF contX) (ContVecF contY) = ContVecF $ contY . contX . curryMany {-# INLINE concat #-}  -- | Get value at @n@th position.-index :: Index n xs => ContVec xs -> n -> ValueAt n xs-index (ContVec cont) = cont . getF+index :: Index n xs => ContVec xs -> proxy n -> ValueAt n xs+index (ContVecF cont) = cont . getF {-# INLINE index #-}  -- | Set value on nth position.-set :: Index n xs => n -> ValueAt n xs -> ContVec xs -> ContVec xs-set n x (ContVec cont) = ContVec $ cont . putF n x+set :: Index n xs => proxy n -> ValueAt n xs -> ContVec xs -> ContVec xs+set n x (ContVecF cont) = ContVecF $ cont . putF n x {-# INLINE set #-}  @@ -176,156 +137,62 @@ -- Monadic/applicative API ---------------------------------------------------------------- --- | Map functor.-mapFunctor :: (Arity xs)-     => (forall a. f a -> g a) -> ContVecF xs f -> ContVecF xs g-mapFunctor f (ContVecF cont) = ContVecF $ cont . mapFF f-{-# INLINE mapFunctor #-}+-- | Apply natural transformation to every element of the tuple.+mapNat :: (Arity xs)+       => (forall a. f a -> g a)+       -> ContVecF xs f+       -> ContVecF xs g+mapNat f (ContVecF cont) = ContVecF $ cont . mapFF f+{-# INLINE mapNat #-}  mapFF :: forall r f g xs. (Arity xs)       => (forall a. f a -> g a) -> TFun g xs r -> TFun f xs r {-# INLINE mapFF #-}-mapFF g (TFun f0) = TFun $ accumTy+mapFF g (TFun f0) = accum   (\(TF_map f) a -> TF_map $ f (g a))   (\(TF_map r)   -> r)-  (TF_map f0 :: TF_map r g xs)--newtype TF_map r g xs = TF_map (Fn (Wrap g xs) r)+  (TF_map f0) +newtype TF_map r g xs = TF_map (Fn g xs r)  --- | Sequence vector's elements-sequence :: (Arity xs, Monad m)-          => ContVecF xs m -> m (ContVec xs)-sequence (ContVecF cont)-  = cont $ sequence_F construct-{-# INLINE sequence #-}---- | Sequence vector's elements-sequenceA :: (Arity xs, Applicative f)-          => ContVecF xs f -> f (ContVec xs)-sequenceA (ContVecF cont)-  = cont $ sequenceA_F construct-{-# INLINE sequenceA #-}---- | Sequence vector's elements-sequenceF :: (Arity xs, Monad m)-          => ContVecF xs (m `Compose` f) -> m (ContVecF xs f)+-- | Apply sequence to outer level of parametrized tuple elements.+sequenceF :: (Arity xs, Applicative f)+          => ContVecF xs (f `Compose` g) -> f (ContVecF xs g) sequenceF (ContVecF cont)   = cont $ sequenceF_F constructF {-# INLINE sequenceF #-} --- | Sequence vector's elements-sequenceAF :: (Arity xs, Applicative f)-           => ContVecF xs (f `Compose` g) -> f (ContVecF xs g)-sequenceAF (ContVecF cont)-  = cont $ sequenceAF_F constructF-{-# INLINE sequenceAF #-}---sequence_F :: forall m xs r. (Monad m, Arity xs)-          => Fun xs r -> TFun m xs (m r)-{-# INLINE sequence_F #-}-sequence_F (Fun f) = TFun $-  accumTy (\(T_seq m) a -> T_seq $ m `ap` a)-          (\(T_seq m)             -> m)-          (T_seq (return f) :: T_seq m r xs)--sequenceA_F :: forall f xs r. (Applicative f, Arity xs)-          => Fun xs r -> TFun f xs (f r)-{-# INLINE sequenceA_F #-}-sequenceA_F (Fun f) = TFun $-  accumTy (\(T_seq m) a -> T_seq $ m <*> a)-          (\(T_seq m)             -> m)-          (T_seq (pure f) :: T_seq f r xs)--sequenceAF_F :: forall f g xs r. (Applicative f, Arity xs)-          => TFun g xs r -> TFun (f `Compose` g) xs (f r)-{-# INLINE sequenceAF_F #-}-sequenceAF_F (TFun f) = TFun $-  accumTy (\(T_seq2 m) (Compose a) -> T_seq2 $ m <*> a)-          (\(T_seq2 m)             -> m)-           (T_seq2 (pure f) :: T_seq2 f g r xs)--sequenceF_F :: forall m f xs r. (Monad m, Arity xs)-          => TFun f xs r -> TFun (m `Compose` f) xs (m r)+sequenceF_F :: forall f g xs r. (Applicative f, Arity xs)+            => TFun g xs r -> TFun (f `Compose` g) xs (f r) {-# INLINE sequenceF_F #-}-sequenceF_F (TFun f) = TFun $-  accumTy (\(T_seq2 m) (Compose a) -> T_seq2 $ m `ap` a)-          (\(T_seq2 m)             -> m)-          (T_seq2 (return f) :: T_seq2 m f r xs)-+sequenceF_F (TFun f) =+  accum (\(T_seq2 m) (Compose a) -> T_seq2 $ m <*> a)+        (\(T_seq2 m)             -> m)+        (T_seq2 (pure f)) -newtype T_seq    f r xs = T_seq  (f (Fn xs r))-newtype T_seq2 f g r xs = T_seq2 (f (Fn (Wrap g xs) r))+newtype T_seq2 f g r xs = T_seq2 (f (Fn g xs r))   -distribute :: forall f xs. (Arity xs, Functor f)-            => f (ContVec xs) -> ContVecF xs f-{-# INLINE distribute #-}-distribute f0-  = applyTy step start-  where-    step :: forall a as. T_distribute f (a ': as) -> (f a, T_distribute f as)-    step (T_distribute v) = ( fmap (\(Cons x _) -> x) v-                            , T_distribute $ fmap (\(Cons _ x) -> x) v-                            )-    start :: T_distribute f xs-    start = T_distribute $ fmap vector f0- distributeF :: forall f g xs. (Arity xs, Functor f)-            => f (ContVecF xs g) -> ContVecF xs (f `Compose` g)+            => f (ContVecF xs g)+            -> ContVecF xs (f `Compose` g) {-# INLINE distributeF #-} distributeF f0-  = applyTy step start+  = apply step start   where-    step :: forall a as. T_distributeF f g (a ': as) -> ((Compose f g) a, T_distributeF f g as)+    step :: forall a as. T_distributeF f g (a : as) -> ((Compose f g) a, T_distributeF f g as)     step (T_distributeF v) = ( Compose $ fmap (\(ConsF x _) -> x) v                              , T_distributeF $ fmap (\(ConsF _ x) -> x) v                              )     start :: T_distributeF f g xs     start = T_distributeF $ fmap vectorF f0 -newtype T_distribute    f xs = T_distribute  (f (VecList  xs)) newtype T_distributeF f g xs = T_distributeF (f (VecListF xs g))   --- | Wrap every value in the vector into type constructor.-wrap :: Arity xs => (forall a. a -> f a) -> ContVec xs -> ContVecF xs f-{-# INLINE wrap #-}-wrap f (ContVec cont)-  = ContVecF $ \fun -> cont $ wrapF f fun--wrapF :: forall f xs r. (Arity xs)-       => (forall a. a -> f a) -> TFun f xs r -> Fun xs r-{-# INLINE wrapF #-}-wrapF g (TFun f0) = Fun $ accum (\(T_wrap f) x -> T_wrap $ f (g x))-                                (\(T_wrap r)   -> r)-                                (T_wrap f0 :: T_wrap f r xs)--newtype T_wrap f r xs = T_wrap (Fn (Wrap f xs) r)------ | Unwrap every value in the vector from the type constructor.-unwrap :: Arity xs => (forall a. f a -> a) -> ContVecF xs f -> ContVec xs-{-# INLINE unwrap #-}-unwrap f (ContVecF cont)-  = ContVec $ \fun -> cont $ unwrapF f fun--unwrapF :: forall f xs r. (Arity xs)-         => (forall a. f a -> a) -> Fun xs r -> TFun f xs r-{-# INLINE unwrapF #-}-unwrapF g (Fun f0) = TFun $ accumTy (\(T_unwrap f) x -> T_unwrap $ f (g x))-                                    (\(T_unwrap r)   -> r)-                                    (T_unwrap f0 :: T_unwrap r xs)--newtype T_unwrap r xs = T_unwrap (Fn xs r)--- ---------------------------------------------------------------- -- Other vectors ----------------------------------------------------------------@@ -333,18 +200,18 @@ -- | List like heterogeneous vector. data VecList :: [*] -> * where   Nil  :: VecList '[]-  Cons :: x -> VecList xs -> VecList (x ': xs)+  Cons :: x -> VecList xs -> VecList (x : xs)  instance Arity xs => HVector (VecList xs) where   type Elems (VecList xs) = xs-  construct = Fun $ accum-    (\(T_List f) a -> T_List (f . Cons a))-    (\(T_List f)   -> f Nil)-    (T_List id :: T_List xs xs)-  inspect = runContVec . apply step+  construct = accum+    (\(T_List f) (Identity a) -> T_List (f . Cons a))+    (\(T_List f)              -> f Nil)+    (T_List id)+  inspect = runContVecF . apply step     where-      step :: VecList (a ': as) -> (a, VecList as)-      step (Cons a xs) = (a, xs)+      step :: VecList (a : as) -> (Identity a, VecList as)+      step (Cons a xs) = (Identity a, xs)   {-# INLINE construct #-}   {-# INLINE inspect   #-} @@ -354,22 +221,23 @@ -- | List-like vector data VecListF xs f where   NilF  :: VecListF '[] f-  ConsF :: f x -> VecListF xs f -> VecListF (x ': xs) f+  ConsF :: f x -> VecListF xs f -> VecListF (x : xs) f  instance Arity xs => HVectorF (VecListF xs) where   type ElemsF (VecListF xs) = xs   constructF   = conVecF-  inspectF   v = inspectF (applyTy step (TF_insp v))+  inspectF   v = inspectF (apply step (TF_insp v))     where-      step :: TF_insp f (a ': as) -> (f a, TF_insp f as)+      step :: TF_insp f (a : as) -> (f a, TF_insp f as)       step (TF_insp (ConsF a xs)) = (a, TF_insp xs)   {-# INLINE constructF #-}   {-# INLINE inspectF   #-}  conVecF :: forall f xs. (Arity xs) => TFun f xs (VecListF xs f)-conVecF = TFun $ accumTy (\(TF_List f) a -> TF_List (f . ConsF a))-                         (\(TF_List f)   -> f NilF)-                         (TF_List id :: TF_List f xs xs)+{-# INLINE conVecF #-}+conVecF = accum (\(TF_List f) a -> TF_List (f . ConsF a))+                (\(TF_List f)   -> f NilF)+                (TF_List id)  newtype TF_insp f     xs = TF_insp (VecListF xs f) newtype TF_List f all xs = TF_List (VecListF xs f -> VecListF all f)@@ -380,142 +248,136 @@ -- More combinators ---------------------------------------------------------------- --- | Replicate polymorphic value n times. Concrete instance for every---   element is determined by their respective types.-replicate :: forall xs c. (ArityC c xs)-          => Proxy c -> (forall x. c x => x) -> ContVec xs-{-# INLINE replicate #-}-replicate _ x-  = apply step (witAllInstances :: WitAllInstances c xs)-  where-    step :: forall a as. WitAllInstances c (a ': as) -> (a, WitAllInstances c as)-    step (WitAllInstancesCons d) = (x,d)+replicateNatF :: forall f xs. Arity xs => (forall a. f a) -> ContVecF xs f+{-# INLINE replicateNatF #-}+replicateNatF f = apply (\Proxy -> (f, Proxy)) (Proxy) +replicateF :: forall f c xs. ArityC c xs => Proxy c -> (forall a. c a => f a) -> ContVecF xs f+{-# INLINE replicateF #-}+replicateF cls f = applyC cls (\Proxy -> (f,Proxy)) Proxy --- | Replicate monadic action n times.-replicateM :: forall xs c m. (ArityC c xs, Monad m)-           => Proxy c -> (forall x. c x => m x) -> m (ContVec xs)-{-# INLINE replicateM #-}-replicateM _ act-  = applyM step (witAllInstances :: WitAllInstances c xs)-  where-    step :: forall a as. WitAllInstances c (a ': as) -> m (a, WitAllInstances c as)-    step (WitAllInstancesCons d) = do { x <- act; return (x,d) } -replicateF :: forall f xs. Arity xs => (forall a. f a) -> ContVecF xs f-replicateF f = applyTy-  (\T_replicateF -> (f, T_replicateF))-  (T_replicateF :: T_replicateF xs) -data T_replicateF (xs :: [*]) = T_replicateF-+----------------------------------------------------------------+-- Folds+----------------------------------------------------------------  -- | Right fold over vector-foldr :: forall xs c b. (ArityC c xs)-      => Proxy c -> (forall a. c a => a -> b -> b) -> b -> ContVec xs -> b-{-# INLINE foldr #-}-foldr _ f b0 v-  = inspect v $ Fun-  $ accum (\(T_foldr b (WitAllInstancesCons d)) a -> T_foldr (b . f a) d)-          (\(T_foldr b  _                     )   -> b b0)-          (T_foldr id witAllInstances :: T_foldr c b xs)+foldrF :: (ArityC c xs)+       => Proxy c -> (forall a. c a => f a -> b -> b) -> b -> ContVecF xs f -> b+{-# INLINE foldrF #-}+foldrF cls f b0 v+  = inspectF v+  $ accumC cls (\(Const b) a -> Const (b . f a))+               (\(Const b)   -> b b0)+               (Const id)  -- | Left fold over vector-foldl :: forall xs c b. (ArityC c xs)-      => Proxy c -> (forall a. c a => b -> a -> b) -> b -> ContVec xs -> b-{-# INLINE foldl #-}-foldl _ f b0 v-  = inspect v $ Fun-  $ accum (\(T_foldl b (WitAllInstancesCons d)) a -> T_foldl (f b a) d)-          (\(T_foldl b  _                     )   -> b)-          (T_foldl b0 witAllInstances :: T_foldl c b xs)--data T_foldr c b xs = T_foldr (b -> b) (WitAllInstances c xs)-data T_foldl c b xs = T_foldl  b       (WitAllInstances c xs)+foldlF :: (ArityC c xs)+       => Proxy c -> (forall a. c a => b -> f a -> b) -> b -> ContVecF xs f -> b+{-# INLINE foldlF #-}+foldlF cls f b0 v+  = inspectF v+  $ accumC cls (\(Const b) a -> Const (f b a))+               (\(Const b)   -> b)+               (Const b0) +-- | Right fold over vector+foldrNatF :: (Arity xs)+       => (forall a. f a -> b -> b) -> b -> ContVecF xs f -> b+{-# INLINE foldrNatF #-}+foldrNatF f b0 v+  = inspectF v+  $ accum (\(Const b) a -> Const (b . f a))+          (\(Const b)   -> b b0)+          (Const id) --- | Convert heterogeneous vector to homogeneous-monomorphize :: forall c xs a. (ArityC c xs)-             => Proxy c -> (forall x. c x => x -> a)-             -> ContVec xs -> F.ContVec (Len xs) a-{-# INLINE monomorphize #-}-monomorphize _ f v-  = inspect v $ Fun $ accum-      (\(T_mono cont (WitAllInstancesCons d)) a -> T_mono (cont . F.cons (f a)) d)-      (\(T_mono cont _)                         -> cont F.empty)-      (T_mono id witAllInstances :: T_mono c a xs xs)+-- | Left fold over vector+foldlNatF :: (Arity xs)+          => (forall a. b -> f a -> b) -> b -> ContVecF xs f -> b+{-# INLINE foldlNatF #-}+foldlNatF f b0 v+  = inspectF v+  $ accum (\(Const b) a -> Const (f b a))+          (\(Const b)   -> b)+          (Const b0)  -- | Convert heterogeneous vector to homogeneous-monomorphizeF :: forall c xs a f. (ArityC c xs)+monomorphizeF :: forall c xs a f n. ( ArityC c xs+                                    , F.Peano n ~ Len xs+                                    )               => Proxy c -> (forall x. c x => f x -> a)-              -> ContVecF xs f -> F.ContVec (Len xs) a+              -> ContVecF xs f -> F.ContVec n a {-# INLINE monomorphizeF #-}-monomorphizeF _ f v-  -- = undefined-  = inspectF v $ TFun $ accumTy step fini start+monomorphizeF cls f v+  = inspectF v+  $ accumC cls (\(T_mono cont) a -> T_mono (cont . F.consPeano (f a)))+               (\(T_mono cont)   -> fini (cont (F.CVecPeano F.unFun)))+               (T_mono id :: T_mono a xs xs)   where-    step :: forall z zs. T_mono c a xs (z ': zs) -> f z -> T_mono c a xs zs-    step (T_mono cont (WitAllInstancesCons d)) a = T_mono (cont . F.cons (f a)) d-    ---    fini (T_mono cont _) = cont F.empty-    start = (T_mono id witAllInstances :: T_mono c a xs xs)+    fini (F.CVecPeano cont) = F.ContVec cont -data T_mono c a all xs = T_mono (F.ContVec (Len xs) a -> F.ContVec (Len all) a) (WitAllInstances c xs)+data T_mono a all xs = T_mono (F.CVecPeano (Len xs) a -> F.CVecPeano (Len all) a)   -- | Unfold vector.-unfoldr :: forall xs c b. (ArityC c xs)-        => Proxy c -> (forall a. c a => b -> (a,b)) -> b -> ContVec xs-{-# INLINE unfoldr #-}-unfoldr _ f b0 = apply-  (\(T_unfoldr b (WitAllInstancesCons d)) -> let (a,b') = f b-                                             in  (a,T_unfoldr b' d))-  (T_unfoldr b0 witAllInstances :: T_unfoldr c b xs)+unfoldrF :: (ArityC c xs)+         => Proxy c+         -> (forall a. c a => b -> (f a, b))+         -> b+         -> ContVecF xs f+{-# INLINE unfoldrF #-}+unfoldrF cls f b0 = applyC cls+  (\(Const b) -> let (a,b') = f b in (a, Const b'))+  (Const b0)  -data T_unfoldr c b xs = T_unfoldr b (WitAllInstances c xs) ---- | Zip two heterogeneous vectors-zipMono :: forall xs c. (ArityC c xs)-        => Proxy c -> (forall a. c a => a -> a -> a) -> ContVec xs -> ContVec xs -> ContVec xs-{-# INLINE zipMono #-}-zipMono _ f cvecA cvecB-  = apply (\(T_zipMono (Cons a va) (Cons b vb) (WitAllInstancesCons w)) ->-              (f a b, T_zipMono va vb w))-          (T_zipMono (vector cvecA) (vector cvecB) witAllInstances :: T_zipMono c xs)--data T_zipMono c xs = T_zipMono (VecList xs) (VecList xs) (WitAllInstances c xs)+----------------------------------------------------------------+-- Zip variants+----------------------------------------------------------------  -- | Zip two heterogeneous vectors-zipMonoF :: forall xs f g h c. (ArityC c xs)+zipWithF :: forall xs f g h c. (ArityC c xs)          => Proxy c          -> (forall a. c a => f a -> g a -> h a)          -> ContVecF xs f          -> ContVecF xs g          -> ContVecF xs h-{-# INLINE zipMonoF #-}-zipMonoF _ f cvecA cvecB-  = applyTy (\(T_zipMonoF (ConsF a va) (ConsF b vb) (WitAllInstancesCons w)) ->-                  (f a b, T_zipMonoF va vb w))-              (T_zipMonoF (vectorF cvecA) (vectorF cvecB) witAllInstances :: T_zipMonoF c f g xs)+{-# INLINE zipWithF #-}+zipWithF cls f cvecA cvecB = applyC cls+  (\(T_zipWithF (ConsF a va) (ConsF b vb)) ->+      (f a b, T_zipWithF va vb))+  (T_zipWithF (vectorF cvecA) (vectorF cvecB) :: T_zipWithF f g xs) -data T_zipMonoF c f g xs = T_zipMonoF (VecListF xs f) (VecListF xs g) (WitAllInstances c xs)+data T_zipWithF f g xs = T_zipWithF (VecListF xs f) (VecListF xs g)   -- | Zip vector and fold result using monoid-zipFold :: forall xs c m. (ArityC c xs, Monoid m)-        => Proxy c -> (forall a. c a => a -> a -> m) -> ContVec xs -> ContVec xs -> m-{-# INLINE zipFold #-}-zipFold _ f cvecA cvecB-  = inspect cvecB zipF+zipFoldF :: forall xs c m f. (ArityC c xs, Monoid m)+        => Proxy c -> (forall a. c a => f a -> f a -> m) -> ContVecF xs f -> ContVecF xs f -> m+{-# INLINE zipFoldF #-}+zipFoldF cls f cvecA cvecB+  = inspectF cvecB zipF   where-    zipF :: Fun xs m-    zipF = Fun $ accum (\(T_zipFold (Cons a va) m (WitAllInstancesCons w)) b ->-                           T_zipFold va (m <> f a b) w)-                       (\(T_zipFold _ m _) -> m)-                       (T_zipFold (vector cvecA) mempty witAllInstances :: T_zipFold c m xs)+    zipF :: TFun f xs m+    zipF = accumC cls+      (\(T_zipFoldF (ConsF a va) m) b -> T_zipFoldF va (m <> f a b))+      (\(T_zipFoldF _            m)   -> m)+      (T_zipFoldF (vectorF cvecA) mempty :: T_zipFoldF m f xs) -data T_zipFold c m xs = T_zipFold (VecList xs) m (WitAllInstances c xs)+data T_zipFoldF m f xs = T_zipFoldF (VecListF xs f) m  +-- | Zip two heterogeneous vectors+zipWithNatF :: forall xs f g h. (Arity xs)+            => (forall a. f a -> g a -> h a)+            -> ContVecF xs f+            -> ContVecF xs g+            -> ContVecF xs h+{-# INLINE zipWithNatF #-}+zipWithNatF f cvecA cvecB+  = apply (\(T_zipNatF (ConsF a va) (ConsF b vb)) -> (f a b, T_zipNatF va vb))+          (T_zipNatF (vectorF cvecA) (vectorF cvecB) :: T_zipNatF f g xs)++data T_zipNatF f g xs = T_zipNatF (VecListF xs f) (VecListF xs g)

@@ -1,53 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE InstanceSigs         #-}--- |-module Data.Vector.HFixed.Functor.HVecF (-    HVecF(..)-  ) where--import Control.DeepSeq-import Data.Vector.HFixed.Cont-import Data.Vector.HFixed.Class-import Data.Vector.HFixed.HVec (HVec)-import qualified Data.Vector.HFixed as H---- | Partially heterogeneous vector which can hold elements of any---   type.-newtype HVecF xs f = HVecF { getHVecF :: HVec (Wrap f xs) }---- | It's not possible to remove constrain @Arity (Wrap f xs)@ because---   it's required by superclass and we cannot prove it for all---   /f/. 'witWrapped' allow to generate proofs for terms-instance (Arity (Wrap f xs), Arity xs) => HVector (HVecF xs f) where-  type Elems (HVecF xs f) = Wrap f xs-  inspect v f = inspectF v (funToTFun f)-  construct   = tfunToFun constructF-  {-# INLINE inspect   #-}-  {-# INLINE construct #-}--instance Arity xs => HVectorF (HVecF xs) where-  type ElemsF (HVecF xs) = xs-  inspectF (HVecF v) (f :: TFun f xs a) =-    case witWrapped :: WitWrapped f xs of-      WitWrapped -> inspect v (tfunToFun f)-  {-# INLINE inspectF   #-}-  constructF :: forall f. TFun f (ElemsF (HVecF xs)) (HVecF xs f)-  constructF =-    case witWrapped :: WitWrapped f xs of-      WitWrapped -> funToTFun $ fmap HVecF construct-  {-# INLINE constructF #-}--instance (Arity xs, ArityC Eq (Wrap f xs)) => Eq (HVecF xs f) where-  (==) = H.eq-  {-# INLINE (==) #-}--instance (Arity xs, ArityC Eq (Wrap f xs), ArityC Ord (Wrap f xs)) => Ord (HVecF xs f) where-  compare = H.compare-  {-# INLINE compare #-}--instance (Arity xs, ArityC NFData (Wrap f xs)) => NFData (HVecF xs f) where-  rnf = H.rnf-  {-# INLINE rnf #-}

@@ -1,185 +1,126 @@-{-# LANGUAGE GADTs                #-} {-# LANGUAGE DataKinds            #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE GADTs                #-} {-# LANGUAGE Rank2Types           #-}-{-# LANGUAGE TypeFamilies         #-} {-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeFamilies         #-} {-# LANGUAGE UndecidableInstances #-} -- | -- Heterogeneous vector parametric in its elements module Data.Vector.HFixed.HVec (     -- * Generic heterogeneous vector     HVec-    -- * Mutable heterogeneous vector-  , MutableHVec-  , newMutableHVec-  , unsafeFreezeHVec-    -- ** Indices-  , readMutableHVec-  , writeMutableHVec-  , modifyMutableHVec-  , modifyMutableHVec'+  , HVecF   ) where  import Control.Monad.ST        (ST,runST)-import Control.Monad.Primitive (PrimMonad(..))+import Data.Functor.Identity   (Identity(..))+import Data.Functor.Classes import Control.DeepSeq         (NFData(..))-import Data.Monoid             (Monoid(..))-import Data.List               (intercalate)-import Data.Primitive.Array    (Array,MutableArray,newArray,writeArray,readArray,-                                indexArray, unsafeFreezeArray)+import Data.Monoid             (Monoid(..),All(..))+import Data.List               (intersperse,intercalate)+import Data.Primitive.SmallArray ( SmallArray, SmallMutableArray, newSmallArray+                                 , writeSmallArray, indexSmallArray+                                 , unsafeFreezeSmallArray)+import Text.Show               (showChar) import GHC.Exts                (Any) import Unsafe.Coerce           (unsafeCoerce) -import qualified Data.Vector.Fixed.Cont as F (Arity(..)) import qualified Data.Vector.HFixed     as H import Data.Vector.HFixed.Class    ------------------------------------------------------------------- Generic HVec+-- HVecF ---------------------------------------------------------------- --- | Generic heterogeneous vector-newtype HVec (xs :: [*]) = HVec (Array Any)--instance (ArityC Show xs) => Show (HVec xs) where-  show v-    = "[" ++ intercalate ", " (H.foldr (Proxy :: Proxy Show) (\x xs -> show x : xs) [] v) ++ "]"--instance (ArityC Eq xs) => Eq (HVec xs) where-  (==) = H.eq-  {-# INLINE (==) #-}---- NOTE: We need to add `Eq (HVec xs)' since GHC cannot deduce that---       `ArityC Ord xs => ArityC Eq xs' for all xs-instance (ArityC Ord xs, Eq (HVec xs)) => Ord (HVec xs) where-  compare = H.compare-  {-# INLINE compare #-}--instance (ArityC Monoid xs) => Monoid (HVec xs) where-  mempty  = H.replicate (Proxy :: Proxy Monoid) mempty-  mappend = H.zipMono (Proxy :: Proxy Monoid) mappend-  {-# INLINE mempty  #-}-  {-# INLINE mappend #-}--instance (ArityC NFData xs) => NFData (HVec xs) where-  rnf = H.rnf-  {-# INLINE rnf #-}--instance Arity xs => HVector (HVec xs) where-  type Elems (HVec xs) = xs-  inspect   (HVec arr) = inspectFF arr-  construct = constructFF-  {-# INLINE inspect #-}-  {-# INLINE construct #-}---inspectFF :: forall xs r. Arity xs => Array Any -> Fun xs r -> r-{-# INLINE inspectFF #-}-inspectFF arr-  = runContVec-  $ apply (\(T_insp i a) -> ( unsafeCoerce $ indexArray a i-                            , T_insp (i+1) a))-          (T_insp 0 arr :: T_insp xs)-+-- | Heterogeneous vector parametrized by common type constructor.+newtype HVecF (xs :: [*]) (f :: * -> *) = HVecF (SmallArray Any) -constructFF :: forall xs. Arity xs => Fun xs (HVec xs)-{-# INLINE constructFF #-}-constructFF-  = Fun $ accum (\(T_con i box) a -> T_con (i+1) (writeToBox (unsafeCoerce a) i box))-                (\(T_con _ box)   -> HVec $ runBox len box :: HVec xs)-                (T_con 0 (Box $ \_ -> return ()) :: T_con xs)-  where-    len = arity (Proxy :: Proxy xs)+instance Arity xs => HVectorF (HVecF xs) where+  type ElemsF (HVecF xs) = xs+  inspectF (HVecF arr)+    = runContVecF+    $ apply (\(T_insp i a) -> ( unsafeCoerce $ indexSmallArray a i+                              , T_insp (i+1) a))+            (T_insp 0 arr)+  {-# INLINE inspectF #-}+  constructF = accum+    (\(T_con i box) a -> T_con (i+1) (writeToBox (unsafeCoerce a) i box))+    (\(T_con _ box)   -> HVecF $ runBox len box)+    (T_con 0 (Box $ \_ -> return ()))+    where+    len = arity (Proxy @ xs)+  {-# INLINE constructF #-} -data T_insp (xs :: [*]) = T_insp Int (Array Any)+data T_insp (xs :: [*]) = T_insp Int (SmallArray Any) data T_con  (xs :: [*]) = T_con  Int (Box Any) ----- Helper data type-newtype Box a = Box (forall s. MutableArray s a -> ST s ())+-- Helper data type for creating of array+newtype Box a = Box (forall s. SmallMutableArray s a -> ST s ())  writeToBox :: a -> Int -> Box a -> Box a-writeToBox a i (Box f) = Box $ \arr -> f arr >> (writeArray arr i $! a) {-# INLINE writeToBox #-}+writeToBox a i (Box f) = Box $ \arr -> f arr >> (writeSmallArray arr i $! a) -runBox :: Int -> Box a -> Array a+runBox :: Int -> Box a -> SmallArray a {-# INLINE runBox #-}-runBox size (Box f) = runST $ do arr <- newArray size uninitialised+runBox size (Box f) = runST $ do arr <- newSmallArray size uninitialised                                  f arr-                                 unsafeFreezeArray arr+                                 unsafeFreezeSmallArray arr  uninitialised :: a uninitialised = error "Data.Vector.HFixed: uninitialised element"  +instance (Show1 f, ArityC Show xs) => Show (HVecF xs f) where+  showsPrec _ v = showChar '['+                . ( foldr (.) id+                  $ intersperse (showChar ',')+                  $ H.foldrF (Proxy @ Show) (\x xs -> showsPrec1 0 x : xs) [] v+                  )+                . showChar ']'+instance (Eq1 f, ArityC Eq xs) => Eq (HVecF xs f) where+  v == u = getAll $ H.zipFoldF (Proxy @ Eq) (\x y -> All (eq1 x y)) v u+instance (Ord1 f, ArityC Eq xs, ArityC Ord xs) => Ord (HVecF xs f) where+  compare = H.zipFoldF (Proxy :: Proxy Ord) compare1  ------------------------------------------------------------------- Mutable tuples+-- HVec ---------------------------------------------------------------- --- | Generic mutable heterogeneous vector.-newtype MutableHVec s (xs :: [*]) = MutableHVec (MutableArray s Any)+-- | Generic heterogeneous vector+newtype HVec (xs :: [*]) = HVec (HVecF xs Identity) --- | Create new uninitialized heterogeneous vector.-newMutableHVec :: forall m xs. (PrimMonad m, Arity xs)-               => m (MutableHVec (PrimState m) xs)-{-# INLINE newMutableHVec #-}-newMutableHVec = do-  arr <- newArray n uninitialised-  return $ MutableHVec arr-  where-    n = arity (Proxy :: Proxy xs)+instance Arity xs => HVector (HVec xs) where+  type Elems (HVec xs) = xs+  inspect (HVec v) = inspectF v+  construct = HVec <$> constructF+  {-# INLINE inspect   #-}+  {-# INLINE construct #-} --- | Convert mutable vector to immutable one. Mutable vector must not---   be modified after that.-unsafeFreezeHVec :: (PrimMonad m) => MutableHVec (PrimState m) xs -> m (HVec xs)-{-# INLINE unsafeFreezeHVec #-}-unsafeFreezeHVec (MutableHVec marr) = do-  arr <- unsafeFreezeArray marr-  return $ HVec arr+instance (ArityC Show xs) => Show (HVec xs) where+  show v+    = "[" ++ intercalate ", " (H.foldr (Proxy :: Proxy Show) (\x xs -> show x : xs) [] v) ++ "]" --- | Read value at statically known index.-readMutableHVec :: (PrimMonad m, Index n xs, Arity xs)-                => MutableHVec (PrimState m) xs-                -> n-                -> m (ValueAt n xs)-{-# INLINE readMutableHVec #-}-readMutableHVec (MutableHVec arr) n = do-  a <- readArray arr $ F.arity n-  return $ unsafeCoerce a+instance (ArityC Eq xs) => Eq (HVec xs) where+  (==) = H.eq+  {-# INLINE (==) #-} --- | Write value at statically known index-writeMutableHVec :: (PrimMonad m, Index n xs, Arity xs)-                 => MutableHVec (PrimState m) xs-                 -> n-                 -> ValueAt n xs-                 -> m ()-{-# INLINE writeMutableHVec #-}-writeMutableHVec (MutableHVec arr) n a = do-  writeArray arr (F.arity n) (unsafeCoerce a)+-- NOTE: We need to add `Eq (HVec xs)' since GHC cannot deduce that+--       `ArityC Ord xs => ArityC Eq xs' for all xs+instance (ArityC Ord xs, ArityC Eq xs) => Ord (HVec xs) where+  compare = H.compare+  {-# INLINE compare #-} --- | Apply function to value at statically known index.-modifyMutableHVec :: (PrimMonad m, Index n xs, Arity xs)-                  => MutableHVec (PrimState m) xs-                  -> n-                  -> (ValueAt n xs -> ValueAt n xs)-                  -> m ()-{-# INLINE modifyMutableHVec #-}-modifyMutableHVec hvec n f = do-  a <- readMutableHVec hvec n-  writeMutableHVec hvec n (f a)+instance (ArityC Monoid xs) => Monoid (HVec xs) where+  mempty  = H.replicate (Proxy @ Monoid) mempty+  mappend = H.zipWith   (Proxy @ Monoid) mappend+  {-# INLINE mempty  #-}+  {-# INLINE mappend #-} --- | Strictly apply function to value at statically known index.-modifyMutableHVec' :: (PrimMonad m, Index n xs, Arity xs)-                   => MutableHVec (PrimState m) xs-                   -> n-                   -> (ValueAt n xs -> ValueAt n xs)-                   -> m ()-{-# INLINE modifyMutableHVec' #-}-modifyMutableHVec' hvec n f = do-  a <- readMutableHVec hvec n-  writeMutableHVec hvec n $! f a+instance (ArityC NFData xs) => NFData (HVec xs) where+  rnf = H.rnf+  {-# INLINE rnf #-}

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP                #-} {-# LANGUAGE DataKinds          #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE PolyKinds          #-}@@ -7,66 +6,35 @@ -- | Type functions module Data.Vector.HFixed.TypeFuns (     -- * Type proxy-    -- $ghc78     Proxy(..)   , proxy-  , unproxy     -- * Type functions-  , type (++)()+  , type (++)   , Len-  , Head   , HomList-  , Wrap   ) where -#if __GLASGOW_HASKELL__ >= 708 import Data.Typeable          (Proxy(..))-#endif-import Data.Vector.Fixed.Cont (S,Z)---- $ghc78------ Starting from version 7.8 GHC provides kind-polymorphic proxy data--- type. In those versions /Data.Typeable.Proxy/ is reexported. For--- GHC 7.6 we have to define our own Proxy data type.-#if __GLASGOW_HASKELL__ < 708-data Proxy a = Proxy-#endif+import Data.Vector.Fixed.Cont (PeanoNum(..))  proxy :: t -> Proxy t proxy _ = Proxy -unproxy :: Proxy t -> t-unproxy _ = error "Data.Vector.HFixed.Class: unproxied value" - -- | Concaternation of type level lists.-type family   (++) (xs :: [α]) (ys :: [α]) :: [α]-type instance (++) '[]       ys = ys-type instance (++) (x ': xs) ys = x ': xs ++ ys+type family   (++) (xs :: [α]) (ys :: [α]) :: [α] where+  (++) '[]      ys = ys+  (++) (x : xs) ys = x : xs ++ ys   -- | Length of type list expressed as type level naturals from --   @fixed-vector@.-type family   Len (xs :: [α]) :: *-type instance Len '[]       = Z-type instance Len (x ': xs) = S (Len xs)---- | Head of type list-type family   Head (xs :: [α]) :: α-type instance Head (x ': xs) = x-+type family Len (xs :: [α]) :: PeanoNum where+  Len '[]      = 'Z+  Len (x : xs) = 'S (Len xs)  -- | Homogeneous type list with length /n/ and element of type /a/. It --   uses type level natural defined in @fixed-vector@.-type family   HomList n (a :: α) :: [α]-type instance HomList  Z    a = '[]-type instance HomList (S n) a = a ': HomList n a---- | Wrap every element of list into type constructor-type family   Wrap (f :: α -> β) (a :: [α]) :: [β]-type instance Wrap f  '[]      = '[]-type instance Wrap f (x ': xs) = (f x) ': (Wrap f xs)---+type family HomList (n :: PeanoNum) (a :: α) :: [α] where+  HomList  'Z    a = '[]+  HomList ('S n) a = a : HomList n a

@@ -1,5 +1,5 @@ Name:           fixed-vector-hetero-Version:        0.3.1.2+Version:        0.4.0.0 Synopsis:       Generic heterogeneous vectors Description:   Generic heterogeneous vectors@@ -13,30 +13,23 @@ Category:       Data Build-Type:     Simple extra-source-files:-  ChangeLog+  ChangeLog.md  source-repository head-  type:     git-  location: http://github.com/Shimuuar/fixed-vector-source-repository head   type:     hg   location: http://bitbucket.org/Shimuuar/fixed-vector-hetero  Library   -- Bigger context stack needed for HVector instances for large   -- tuples-  Ghc-options:          -Wall -fcontext-stack=50-  Build-Depends:-    base          >=4.7 && <5,-    deepseq,-    transformers,-    ghc-prim,-    fixed-vector  >= 0.7.0.3,-    primitive+  Ghc-options:          -Wall -freduction-depth=50+  Build-Depends: base          >=4.9 && <5+               , deepseq+               , fixed-vector  >= 1.0.0.0+               , primitive     >= 0.6.2   Exposed-modules:           Data.Vector.HFixed     Data.Vector.HFixed.Class     Data.Vector.HFixed.Cont     Data.Vector.HFixed.HVec-    Data.Vector.HFixed.Functor.HVecF     Data.Vector.HFixed.TypeFuns