fixed-vector-hetero (empty) → 0.1.0.0
raw patch · 9 files changed
+2038/−0 lines, 9 filesdep +basedep +deepseqdep +fixed-vectorsetup-changed
Dependencies added: base, deepseq, fixed-vector, ghc-prim, primitive, transformers
Files
- Data/Vector/HFixed.hs +361/−0
- Data/Vector/HFixed/Class.hs +800/−0
- Data/Vector/HFixed/Cont.hs +498/−0
- Data/Vector/HFixed/Functor/HVecF.hs +53/−0
- Data/Vector/HFixed/HVec.hs +185/−0
- Data/Vector/HFixed/TypeFuns.hs +71/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- fixed-vector-hetero.cabal +38/−0
+ Data/Vector/HFixed.hs view
@@ -0,0 +1,361 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ConstraintKinds #-}+-- |+-- Heterogeneous vectors.+module Data.Vector.HFixed (+ -- * HVector type classes+ Arity+ , ArityC+ , HVector(..)+ , HVectorF(..)+ , Wrap+ , Proxy(..)+ -- * Position based functions+ , convert+ , head+ , tail+ , cons+ , concat+ -- ** Indexing+ , ValueAt+ , Index+ , index+ , set+ , element+#if __GLASGOW_HASKELL__ >= 708+ , elementTy+#endif+ -- * Generic constructors+ , mk0+ , mk1+ , mk2+ , mk3+ , mk4+ , mk5+ -- * Folds and unfolds+ , fold+ , foldr+ , foldl+ , mapM_+ , unfoldr+ -- * Polymorphic values+ , replicate+ , replicateM+ , zipMono+ , zipFold+ , monomorphize+ -- * Vector parametrized with type constructor+ , mapFunctor+ , sequence+ , sequenceA+ , sequenceF+ , sequenceAF+ , wrap+ , unwrap+ , distribute+ , distributeF+ -- * Specialized operations+ , eq+ , compare+ , rnf+ ) where++import Control.Monad (liftM)+import Control.Applicative (Applicative,(<$>))+import qualified Control.DeepSeq as NF+ +import Data.Functor.Compose (Compose)+import Data.Monoid (Monoid,All(..))+import Prelude hiding+ (head,tail,concat,sequence,map,zipWith,replicate,foldr,foldl,mapM_,compare)+import qualified Prelude++import Data.Vector.HFixed.Class hiding (cons,consF)+import qualified Data.Vector.Fixed as F+import qualified Data.Vector.HFixed.Cont as C+++----------------------------------------------------------------+-- Generic API+----------------------------------------------------------------++-- | We can convert between any two vector which have same+-- structure but different representations.+convert :: (HVector v, HVector w, Elems v ~ Elems w)+ => v -> w+{-# INLINE convert #-}+convert v = inspect v construct++-- | Tail of the vector+--+-- >>> case tail ('a',"aa",()) of x@(_,_) -> x+-- ("aa",())+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)+ => 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))+ => a -> v -> w+{-# INLINE cons #-}+cons a = C.vector . C.cons a . C.cvec++-- | Concatenate two vectors+concat :: ( HVector v, HVector u, HVector w+ , Elems w ~ (Elems v ++ Elems u)+ )+ => v -> u -> w+concat v u = C.vector $ C.concat (C.cvec v) (C.cvec u)+{-# INLINE concat #-}++++----------------------------------------------------------------+-- Indexing+----------------------------------------------------------------++-- | Index heterogeneous vector+index :: (Index n (Elems v), HVector v) => v -> 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+{-# 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)+{-# INLINE element #-}+element n f v = inspect v+ $ lensF 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)+#endif+++----------------------------------------------------------------+-- Folds over vector+----------------------------------------------------------------++-- | Most generic form of fold which doesn't constrain elements id use+-- of 'inspect'. Or in more convenient form below:+--+-- >>> 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)+{-# 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++-- | 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++-- | 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 ()+{-# INLINE mapM_ #-}+mapM_ c f = foldl c (\m a -> m >> f a) (return ())++++----------------------------------------------------------------+-- Constructors+----------------------------------------------------------------++mk0 :: (HVector v, Elems v ~ '[]) => v+mk0 = C.vector C.mk0+{-# INLINE mk0 #-}++mk1 :: (HVector v, Elems v ~ '[a]) => a -> v+mk1 a = C.vector $ C.mk1 a+{-# INLINE mk1 #-}++mk2 :: (HVector v, Elems v ~ '[a,b]) => a -> b -> v+mk2 a b = C.vector $ C.mk2 a b+{-# 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+{-# 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+{-# 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+{-# INLINE mk5 #-}+++----------------------------------------------------------------+-- Collective operations+----------------------------------------------------------------++mapFunctor :: (HVectorF v)+ => (forall a. f a -> g a) -> v f -> v g+{-# INLINE mapFunctor #-}+mapFunctor f = C.vectorF . C.mapFunctor 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)++-- | 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 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)++-- | 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++-- | 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++-- | 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++-- | Analog of /distribute/ from /Distributive/ type class.+distributeF+ :: ( Functor f, HVectorF v)+ => f (v g) -> v (f `Compose` g)+{-# INLINE distributeF #-}+distributeF = C.vectorF . C.distributeF . fmap C.cvecF++++----------------------------------------------------------------+-- Type class based ops+----------------------------------------------------------------++-- | Replicate polymorphic value n times. Concrete instance for every+-- element is determined by their respective types.+--+-- >>> import Data.Vector.HFixed as H+-- >>> H.replicate (Proxy :: Proxy Monoid) mempty :: ((),String)+-- ((),"")+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 monadic action n times.+--+-- >>> import Data.Vector.HFixed as H+-- >>> H.replicateM (Proxy :: Proxy Read) (fmap read getLine) :: IO (Int,Char)+-- > 12+-- > 'a'+-- (12,'a')+replicateM :: (HVector v, Monad m, ArityC c (Elems v))+ => Proxy c -> (forall x. c x => m x) -> m v+{-# INLINE replicateM #-}+replicateM c x = liftM C.vector $ C.replicateM 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++zipMono :: (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)++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)++-- | Convert heterogeneous vector to homogeneous+monomorphize :: (HVector v, ArityC c (Elems v))+ => Proxy c -> (forall a. a -> x)+ -> v -> F.ContVec (Len (Elems v)) x+{-# INLINE monomorphize #-}+monomorphize c f = C.monomorphize c f . C.cvec+++-- | Generic equality for heterogeneous vectors+eq :: (HVector v, ArityC Eq (Elems v)) => v -> v -> Bool+eq v u = getAll $ zipFold (Proxy :: Proxy Eq) (\x y -> All (x == y)) v u+{-# INLINE eq #-}++-- | Generic comparison for heterogeneous vectors+compare :: (HVector v, ArityC Ord (Elems v)) => v -> v -> Ordering+compare = zipFold (Proxy :: Proxy Ord) Prelude.compare+{-# INLINE compare #-}++-- | Reduce vector to normal form+rnf :: (HVector v, ArityC NF.NFData (Elems v)) => v -> ()+rnf = foldl (Proxy :: Proxy NF.NFData) (\r a -> NF.rnf a `seq` r) ()+{-# INLINE rnf #-}
+ Data/Vector/HFixed/Class.hs view
@@ -0,0 +1,800 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE InstanceSigs #-}+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(..)+ , TFun(..)+ , funToTFun+ , tfunToFun+ -- ** Type functions+ , Proxy(..)+ , (++)()+ , Len+ , Wrap+ , HomList+ -- ** Type classes+ , Arity(..)+ , ArityC(..)+ , HVector(..)+ , HVectorF(..)+ -- *** Witnesses+ , WitWrapped(..)+ , WitConcat(..)+ , WitNestedFun(..)+ , WitLenWrap(..)+ , WitWrapIndex(..)+ , WitAllInstances(..)+ -- ** CPS-encoded vector+ , ContVec(..)+ , ContVecF(..)+ , toContVec+ , toContVecF+ , cons+ , consF+ -- ** Interop with homogeneous vectors+ , HomArity(..)+ , homInspect+ , homConstruct+ -- * Operations of Fun+ -- ** Primitives for Fun+ , curryFun+ , uncurryFun+ , uncurryFun2+ , curryMany+ , constFun+ , stepFun+ -- ** Primitives for TFun+ , curryTFun+ , uncurryTFun+ , uncurryTFun2+ , shuffleTF+ -- ** More complicated functions+ , concatF+ , shuffleF+ , lensWorkerF+ , Index(..)+ ) where++import Control.Applicative (Applicative(..),(<$>))+import Data.Complex (Complex(..))++import Data.Vector.Fixed.Cont (S,Z)+#if __GLASGOW_HASKELL__ >= 708+import Data.Vector.Fixed.Cont (ToPeano,ToNat,NatIso)+#endif+import qualified Data.Vector.Fixed as F+import qualified Data.Vector.Fixed.Cont as F (apFun)+import qualified Data.Vector.Fixed.Unboxed as U+import qualified Data.Vector.Fixed.Primitive as P+import qualified Data.Vector.Fixed.Storable as S+import qualified Data.Vector.Fixed.Boxed as B++import GHC.Generics hiding (Arity(..),S)++import Data.Vector.HFixed.TypeFuns++++----------------------------------------------------------------+-- Types+----------------------------------------------------------------++-- | 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 }++-- | 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 #-}++-- | Cast /TFun/ to equivalent /Fun/+tfunToFun :: TFun f xs b -> Fun (Wrap f xs) b+tfunToFun = Fun . unTFun+{-# INLINE tfunToFun #-}++++----------------------------------------------------------------+-- Generic operations+----------------------------------------------------------------++-- | Type class for dealing with N-ary function in generic way. Both+-- 'accum' and 'apply' work with accumulator data types which are+-- polymorphic. So it's only possible to write functions which+-- rearrange elements in vector using plain ADT. It's possible to+-- get around it by using GADT as accumulator (See 'ArityC' and+-- function which use it)+--+-- 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+ -- | 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.+ -> (t '[] -> b)+ -- ^ Extract value from accumulator.+ -> t xs+ -- ^ Initial state.+ -> Fn 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.+ -> 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+ -> Fn (Wrap f xs) b+ -> b++ -- | 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 f xs where+ WitLenWrap :: Len xs ~ Len (Wrap f xs) => WitLenWrap f xs++-- | 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)+++instance Arity '[] where+ accum _ f t = f t+ apply _ _ = ContVec unFun+ applyM _ _ = return (ContVec unFun)+ accumTy _ f t = f t+ applyTy _ _ b = b+ {-# INLINE accum #-}+ {-# INLINE apply #-}+ {-# INLINE applyM #-}+ {-# INLINE accumTy #-}+ {-# INLINE applyTy #-}+ 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 h = case f t of (a,u) -> applyTy f u (h a)+ {-# INLINE accum #-}+ {-# INLINE apply #-}+ {-# INLINE applyM #-}+ {-# INLINE accumTy #-}+ {-# INLINE applyTy #-}+ 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+++-- | Type class for heterogeneous vectors. Instance should specify way+-- to construct and deconstruct itself+--+-- Note that this type class is extremely generic. Almost any single+-- constructor data type could be made instance. It could be+-- monomorphic, it could be polymorphic in some or all fields it+-- doesn't matter. Only law instance should obey is:+--+-- > inspect v construct = v+--+-- Default implementation which uses 'Generic' is provided.+class Arity (Elems v) => HVector v where+ type Elems v :: [*]+ type Elems v = GElems (Rep v)+ -- | Function for constructing vector+ construct :: Fun (Elems v) v+ default construct :: (Generic v, GHVector (Rep v), GElems (Rep v) ~ Elems v, Functor (Fun (Elems v)))+ => Fun (Elems v) v+ construct = fmap to gconstruct+ -- | Function for deconstruction of vector. It applies vector's+ -- elements to N-ary function.+ inspect :: v -> Fun (Elems v) a -> a+ default inspect :: (Generic v, GHVector (Rep v), GElems (Rep v) ~ Elems v)+ => v -> Fun (Elems v) a -> a+ inspect v = ginspect (from v)+ {-# INLINE construct #-}+ {-# INLINE inspect #-}+++-- | Type class for partially homogeneous vector where every element+-- in the vector have same type constructor. Vector itself is+-- parametrized by that constructor+class Arity (ElemsF v) => HVectorF (v :: (* -> *) -> *) where+ -- | Elements of the vector without type constructors+ type ElemsF v :: [*]+ inspectF :: v f -> TFun f (ElemsF v) a -> a+ constructF :: TFun f (ElemsF v) (v f)++++----------------------------------------------------------------+-- Interop with homogeneous vectors+----------------------------------------------------------------++-- | Conversion between homogeneous and heterogeneous N-ary functions.+class (F.Arity 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+ {-# INLINE toHeterogeneous #-}+ {-# INLINE toHomogeneous #-}++instance HomArity n a => HomArity (S n) a where+ toHeterogeneous f+ = Fun $ \a -> unFun $ toHeterogeneous (F.apFun f a)+ toHomogeneous (f :: Fun (a ': HomList n a) r)+ = F.Fun $ \a -> F.unFun (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 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))+{-# INLINE homConstruct #-}++++instance HomArity n a => HVector (B.Vec n a) where+ type Elems (B.Vec n a) = HomList 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+ 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+ 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+ 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 }++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+ {-# INLINE construct #-}+ {-# INLINE inspect #-}++newtype T_mkN all xs = T_mkN (ContVec xs -> ContVec all)+++-- | CPS-encoded partially heterogeneous vector.+newtype ContVecF xs f = ContVecF (forall r. TFun f xs r -> r)++instance Arity xs => HVectorF (ContVecF xs) where+ type ElemsF (ContVecF xs) = xs+ inspectF (ContVecF cont) = cont+ constructF = constructFF+ {-# INLINE constructF #-}+ {-# INLINE inspectF #-}++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)++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+{-# INLINE cons #-}++-- | Cons element to the vector+consF :: f x -> ContVecF xs f -> ContVecF (x ': xs) f+consF x (ContVecF cont) = ContVecF $ \f -> cont $ curryTFun f x+{-# INLINE consF #-}++++----------------------------------------------------------------+-- 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)+ {-# 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+ {-# 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)+ {-# INLINE (<*>) #-}++instance Arity xs => Monad (TFun f xs) where+ return = pure+ f >>= g = shuffleTF g <*> f+ {-# 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)++++----------------------------------------------------------------+-- Operations on Fun+----------------------------------------------------------------++-- | Apply single parameter to function+curryFun :: Fun (x ': xs) r -> x -> Fun xs r+curryFun (Fun f) x = Fun (f x)+{-# INLINE curryFun #-}++-- | Uncurry N-ary function.+uncurryFun :: (x -> Fun xs r) -> Fun (x ': xs) r+uncurryFun = Fun . fmap unFun+{-# 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+{-# 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++-- | Curry first /n/ arguments of N-ary function.+curryMany :: forall xs ys r. Arity xs => Fun (xs ++ ys) r -> Fun xs (Fun ys r)+{-# 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)+++-- | Add one parameter to function which is ignored.+constFun :: Fun xs r -> Fun (x ': xs) r+constFun = uncurryFun . const+{-# INLINE constFun #-}++-- | 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 #-}++-- | Concatenate n-ary functions. This function combine results of+-- both N-ary functions and merge their parameters into single list.+concatF :: (Arity xs, Arity ys)+ => (a -> b -> c) -> Fun xs a -> Fun ys b -> Fun (xs ++ ys) c+{-# INLINE concatF #-}+concatF f funA funB = uncurryMany $ fmap go funA+ 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)+{-# INLINE lensWorkerF #-}+lensWorkerF g f+ = uncurryFun+ $ \x -> (\r -> fmap (r $) (g x)) <$> shuffleF (curryFun f)++++----------------------------------------------------------------+-- Operations on TFun+----------------------------------------------------------------++-- | Apply single parameter to function+curryTFun :: TFun f (x ': xs) r -> f x -> TFun f xs r+curryTFun (TFun f) = TFun . f+{-# INLINE curryTFun #-}++-- | Uncurry single parameter+uncurryTFun :: (f x -> TFun f xs r) -> TFun f (x ': xs) r+uncurryTFun = TFun . fmap unTFun+{-# 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+ (\(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)++data TF_shuffle f x r xs = TF_shuffle (x -> (Fn (Wrap f xs) r))++++----------------------------------------------------------------+-- Indexing+----------------------------------------------------------------++-- | Indexing of vectors+class F.Arity n => Index (n :: *) (xs :: [*]) where+ type ValueAt n xs :: *+ -- | Getter function for vectors+ getF :: 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+ -- | Helper for implementation of lens+ lensF :: (Functor f, v ~ ValueAt n xs)+ => n -> (v -> f v) -> Fun xs 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+++instance Arity xs => Index Z (x ': xs) where+ type ValueAt Z (x ': xs) = x+ getF _ = Fun $ \x -> unFun (pure x :: Fun xs x)+ putF _ x f = constFun $ curryFun f x+ lensF _ = lensWorkerF+ {-# INLINE getF #-}+ {-# INLINE putF #-}+ {-# INLINE lensF #-}+ 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+ getF _ = constFun $ getF (undefined :: n)+ putF _ x = stepFun $ putF (undefined :: n) x+ lensF _ f = stepFun $ lensF (undefined :: n) f+ {-# INLINE getF #-}+ {-# INLINE putF #-}+ {-# INLINE lensF #-}+ witWrapIndex :: forall f. WitWrapIndex f (S n) (x ': xs)+ witWrapIndex = case witWrapIndex :: WitWrapIndex f n xs of+ WitWrapIndex -> WitWrapIndex+ {-# INLINE witWrapIndex #-}++++----------------------------------------------------------------+-- Instances+----------------------------------------------------------------++-- | Unit is empty heterogeneous vector+instance HVector () where+ type Elems () = '[]+ construct = Fun ()+ inspect () (Fun f) = f++instance HVector (Complex a) where+ type Elems (Complex a) = '[a,a]+ construct = Fun (:+)+ inspect (r :+ i) (Fun f) = 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+ {-# 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+ {-# 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+ {-# 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+ {-# 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+ {-# 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+ {-# INLINE construct #-}+ {-# INLINE inspect #-}++++----------------------------------------------------------------+-- Generics+----------------------------------------------------------------++class GHVector (v :: * -> *) where+ type GElems v :: [*]+ gconstruct :: Fun (GElems v) (v p)+ ginspect :: v p -> Fun (GElems v) r -> r+++-- We simply skip metadata+instance (GHVector f, Functor (Fun (GElems f))) => GHVector (M1 i c f) where+ type GElems (M1 i c f) = GElems f+ gconstruct = fmap M1 gconstruct+ ginspect v = ginspect (unM1 v)+ {-# INLINE gconstruct #-}+ {-# INLINE ginspect #-}+++instance ( GHVector f, GHVector g+ , Arity xs, GElems f ~ xs+ , Arity ys, GElems g ~ ys+ ) => GHVector (f :*: g) where+ type GElems (f :*: g) = GElems f ++ GElems g++ gconstruct = concatF (:*:) gconstruct gconstruct+ ginspect (f :*: g) fun+ = ginspect g $ ginspect f $ curryMany fun+ {-# INLINE gconstruct #-}+ {-# INLINE ginspect #-}+++-- 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+ {-# INLINE gconstruct #-}+ {-# INLINE ginspect #-}+++-- Unit types are empty vectors+instance GHVector U1 where+ type GElems U1 = '[]+ gconstruct = Fun U1+ ginspect _ (Fun f) = f+ {-# INLINE gconstruct #-}+ {-# INLINE ginspect #-}
+ Data/Vector/HFixed/Cont.hs view
@@ -0,0 +1,498 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- CPS encoded heterogeneous vectors.+module Data.Vector.HFixed.Cont (+ -- * CPS-encoded vector+ -- ** Type classes+ Fn+ , Fun(..)+ , TFun(..)+ , Arity(..)+ , HVector(..)+ , HVectorF(..)+ , ValueAt+ , Index+ , Wrap+ -- ** CPS-encoded vector+ , ContVec(..)+ , ContVecF(..)+ , toContVec+ , toContVecF+ -- ** Other data types+ , VecList(..)+ , VecListF(..)+ -- * Conversion to/from vector+ , cvec+ , vector+ , cvecF+ , vectorF+ -- * Position based functions+ , head+ , tail+ , cons+ , consF+ , concat+ -- * Indexing+ , index+ , set+ -- * Constructors+ , mk0+ , mk1+ , mk2+ , mk3+ , mk4+ , mk5+ -- * Folds and unfolds+ , foldl+ , foldr+ , unfoldr+ -- * Polymorphic values+ , replicate+ , replicateM+ , zipMono+ , zipFold+ , monomorphize+ , monomorphizeF+ -- * Vector parametrized with type constructor+ , mapFunctor+ , sequence+ , sequenceA+ , sequenceF+ , sequenceAF+ , distribute+ , distributeF+ , wrap+ , unwrap+ ) where++import Control.Applicative (Applicative(..))+import Control.Monad (ap)+import Data.Monoid (Monoid(..),(<>))+import Data.Functor.Compose (Compose(..))+import qualified Data.Vector.Fixed.Cont as F+import Prelude hiding+ (head,tail,concat,sequence,sequence_,map,zipWith,+ replicate,foldr,foldl)++import Data.Vector.HFixed.Class++++----------------------------------------------------------------+-- Conversions between vectors+----------------------------------------------------------------++-- | Convert heterogeneous vector to CPS form+cvec :: (HVector v, Elems v ~ xs) => v -> ContVec xs+cvec v = ContVec (inspect v)+{-# INLINE cvec #-}++-- | Convert CPS-vector to heterogeneous vector+vector :: (HVector v, Elems v ~ xs) => ContVec xs -> v+vector (ContVec cont) = cont construct+{-# INLINE vector #-}++cvecF :: HVectorF v => v f -> ContVecF (ElemsF v) f+cvecF v = ContVecF (inspectF v)+{-# INLINE cvecF #-}++vectorF :: HVectorF v => ContVecF (ElemsF v) f -> v f+vectorF (ContVecF cont) = cont constructF+{-# INLINE vectorF #-}++++----------------------------------------------------------------+-- 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+----------------------------------------------------------------++-- | Head of vector+head :: forall x xs. Arity xs => ContVec (x ': xs) -> x+head = flip inspect $ Fun $ \x -> unFun (pure x :: Fun xs x)+{-# INLINE head #-}++-- | Tail of CPS-encoded vector+tail :: ContVec (x ': xs) -> ContVec xs+tail (ContVec cont) = ContVec $ 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+{-# INLINE concat #-}++-- | Get value at @n@th position.+index :: Index n xs => ContVec xs -> n -> ValueAt n xs+index (ContVec 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+{-# INLINE set #-}+++----------------------------------------------------------------+-- 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 #-}++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+ (\(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)++++-- | 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)+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)+{-# 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)+++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))++++distribute :: forall f xs. (Arity xs, Functor f)+ => f (ContVec xs) -> ContVecF xs f+{-# INLINE distribute #-}+distribute f0+ = ContVecF $ \(TFun fun) -> applyTy step start fun+ 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)+{-# INLINE distributeF #-}+distributeF f0+ = ContVecF $ \(TFun fun) -> applyTy step start fun+ where+ 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+----------------------------------------------------------------++-- | List like heterogeneous vector.+data VecList :: [*] -> * where+ Nil :: VecList '[]+ 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+ where+ step :: VecList (a ': as) -> (a, VecList as)+ step (Cons a xs) = (a, xs)+ {-# INLINE construct #-}+ {-# INLINE inspect #-}++newtype T_List all xs = T_List (VecList xs -> VecList all)+++-- | List-like vector+data VecListF xs f where+ NilF :: VecListF '[] 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 (TFun f) = applyTy step (TF_insp v) f+ where+ 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)++newtype TF_insp f xs = TF_insp (VecListF xs f)+newtype TF_List f all xs = TF_List (VecListF xs f -> VecListF all f)++++----------------------------------------------------------------+-- 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)+++-- | 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) }++-- | 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)++-- | 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)+++-- | 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)++-- | Convert heterogeneous vector to homogeneous+monomorphizeF :: forall c xs a f. (ArityC c xs)+ => Proxy c -> (forall x. c x => f x -> a)+ -> ContVecF xs f -> F.ContVec (Len xs) a+{-# INLINE monomorphizeF #-}+monomorphizeF _ f v+ -- = undefined+ = inspectF v $ TFun $ accumTy step fini start+ 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)++data T_mono c a all xs = T_mono (F.ContVec (Len xs) a -> F.ContVec (Len all) a) (WitAllInstances c xs)+++-- | 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)+++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 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+ 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)++data T_zipFold c m xs = T_zipFold (VecList xs) m (WitAllInstances c xs)++
+ Data/Vector/HFixed/Functor/HVecF.hs view
@@ -0,0 +1,53 @@+{-# 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 #-}
+ Data/Vector/HFixed/HVec.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# 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'+ ) where++import Control.Monad.ST (ST,runST)+import Control.Monad.Primitive (PrimMonad(..))+import Control.DeepSeq (NFData(..))+import Data.Monoid (Monoid(..))+import Data.List (intercalate)+import Data.Primitive.Array (Array,MutableArray,newArray,writeArray,readArray,+ indexArray, unsafeFreezeArray)+import GHC.Prim (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+----------------------------------------------------------------++-- | 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)+++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)++data T_insp (xs :: [*]) = T_insp Int (Array Any)+data T_con (xs :: [*]) = T_con Int (Box Any)++++-- Helper data type+newtype Box a = Box (forall s. MutableArray 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 #-}++runBox :: Int -> Box a -> Array a+{-# INLINE runBox #-}+runBox size (Box f) = runST $ do arr <- newArray size uninitialised+ f arr+ unsafeFreezeArray arr++uninitialised :: a+uninitialised = error "Data.Vector.HFixed: uninitialised element"++++----------------------------------------------------------------+-- Mutable tuples+----------------------------------------------------------------++-- | Generic mutable heterogeneous vector.+newtype MutableHVec s (xs :: [*]) = MutableHVec (MutableArray s Any)++-- | 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)++-- | 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++-- | 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++-- | 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)++-- | 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)++-- | 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
+ Data/Vector/HFixed/TypeFuns.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+-- | Type functions+module Data.Vector.HFixed.TypeFuns (+ -- * Type proxy+ -- $ghc78+ Proxy(..)+ , proxy+ , unproxy+ -- * Type functions+ , (++)()+ , 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++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+++-- | 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+++-- | 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)+++
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) Aleksey Khudyakov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ fixed-vector-hetero.cabal view
@@ -0,0 +1,38 @@+Name: fixed-vector-hetero+Version: 0.1.0.0+Synopsis: Generic heterogeneous vectors+Description:+ Generic heterogeneous vectors++Cabal-Version: >= 1.6+License: BSD3+License-File: LICENSE+Author: Aleksey Khudyakov <alexey.skladnoy@gmail.com>+Maintainer: Aleksey Khudyakov <alexey.skladnoy@gmail.com>+Homepage: http://github.org/Shimuuar/fixed-vector-hetero+Category: Data+Build-Type: Simple++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+ Ghc-options: -Wall+ Build-Depends:+ base >=4.6 && <5,+ deepseq,+ transformers,+ ghc-prim,+ fixed-vector >= 0.6.4,+ primitive+ 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