diff --git a/ChangeLog b/ChangeLog deleted file mode 100644 --- a/ChangeLog +++ /dev/null @@ -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 - diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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 diff --git a/Data/Vector/HFixed.hs b/Data/Vector/HFixed.hs --- a/Data/Vector/HFixed.hs +++ b/Data/Vector/HFixed.hs @@ -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 diff --git a/Data/Vector/HFixed/Class.hs b/Data/Vector/HFixed/Class.hs --- a/Data/Vector/HFixed/Class.hs +++ b/Data/Vector/HFixed/Class.hs @@ -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 #-} diff --git a/Data/Vector/HFixed/Cont.hs b/Data/Vector/HFixed/Cont.hs --- a/Data/Vector/HFixed/Cont.hs +++ b/Data/Vector/HFixed/Cont.hs @@ -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) diff --git a/Data/Vector/HFixed/Functor/HVecF.hs b/Data/Vector/HFixed/Functor/HVecF.hs deleted file mode 100644 --- a/Data/Vector/HFixed/Functor/HVecF.hs +++ /dev/null @@ -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 #-} diff --git a/Data/Vector/HFixed/HVec.hs b/Data/Vector/HFixed/HVec.hs --- a/Data/Vector/HFixed/HVec.hs +++ b/Data/Vector/HFixed/HVec.hs @@ -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 #-} diff --git a/Data/Vector/HFixed/TypeFuns.hs b/Data/Vector/HFixed/TypeFuns.hs --- a/Data/Vector/HFixed/TypeFuns.hs +++ b/Data/Vector/HFixed/TypeFuns.hs @@ -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 diff --git a/fixed-vector-hetero.cabal b/fixed-vector-hetero.cabal --- a/fixed-vector-hetero.cabal +++ b/fixed-vector-hetero.cabal @@ -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