vector-heterogenous (empty) → 0.0.1
raw patch · 5 files changed
+409/−0 lines, 5 filesdep +basedep +vectorsetup-changed
Dependencies added: base, vector
Files
- Setup.hs +2/−0
- src/Data/Vector/Heterogenous.hs +129/−0
- src/Data/Vector/Heterogenous/HList.hs +179/−0
- src/Data/Vector/Heterogenous/Unsafe.hs +70/−0
- vector-heterogenous.cabal +29/−0
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Data/Vector/Heterogenous.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE EmptyDataDecls #-}++-- | Heterogenous vectors. For more info on heterogenous collections, see <http://www.haskell.org/haskellwiki/Heterogenous_collections>+module Data.Vector.Heterogenous+ ( HVector(..)+ , vec+ , module Data.Vector.Heterogenous.HList+ , module Data.Vector.Heterogenous.Unsafe+ )+ where++import Data.Monoid+-- import Data.Semigroup+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as VM+import qualified Data.Vector.Generic as G+import GHC.ST+import GHC.TypeLits++import Data.Vector.Heterogenous.HList+import Data.Vector.Heterogenous.Unsafe+++-------------------------------------------------------------------------------+-- Vector++newtype HVector box (xs::[a]) = HVector { getvec :: V.Vector box }++instance (Show box) => Show (HVector box xs) where+ show (HVector vec) = "vec "++boxname++" $ "++(go $ n-1)++"HNil"+ where+ boxname = "ShowBox"+ n = V.length vec+ go i = if i >= 0+ then show (vec V.! i)++":::"++go (i-1)+ else ""++-- | creates an "HVector" from an "HList". For example:++vec :: (HLength (HList xs), Downcast (HList xs) box) => (a->box) -> HList xs -> HVector box (xs::[*])+vec box xs = HVector $ V.create $ do+ v <- VM.new n+ vecwrite v (n-1) (downcastAs box xs)+ return $ v+ where+ n = hlength xs+ vecwrite v i [] = return ()+ vecwrite v i (x:xs) = (seq x $ VM.write v i x) >> vecwrite v (i-1) xs++data Indexer xs = Indexer !xs !Int++toHList :: HListBuilder (Indexer (HVector box xs)) ys => HVector box xs -> ys+toHList hv = buildHList $ Indexer hv (V.length (getvec hv) -1)++class HListBuilder xs ys | xs -> ys where+ buildHList :: xs -> ys+ +instance HListBuilder (Indexer (HVector box '[])) (HList '[]) where+ buildHList _ = HNil++instance+ ( ConstraintBox box x+ , HListBuilder (Indexer (HVector box xs)) (HList xs)+ ) => HListBuilder (Indexer (HVector box (x ': xs))) (HList (x ': xs)) + where+ buildHList (Indexer (HVector v) i) = + (unsafeUnbox $ v V.! i):::(buildHList (Indexer (HVector v) (i-1) :: Indexer (HVector box xs))) + +{-instance + ( Semigroup (HList xs)+ , Downcast (HList xs) box+ , HLength (HList xs)+ , HListBuilder (Indexer (HVector box xs)) (HList xs)+ ) => Semigroup (HVector box xs) where+ v1 <> v2 = vec (undefined::box) $ (toHList v1)<>(toHList v2)-}+ +instance + ( Monoid (HList xs)+ , Downcast (HList xs) box+ , HLength (HList xs)+ , HListBuilder (Indexer (HVector box xs)) (HList xs)+ ) => Monoid (HVector box xs) where+ mempty = vec (undefined::a->box) $ mempty+ v1 `mappend` v2 = vec (undefined::a->box) $ (toHList v1) `mappend` (toHList v2)++-------------------------------------------------------------------------------+-- Lens++data Empty a++class View vec i ret | vec i -> ret where+ view :: vec -> i -> ret+ +instance (ConstraintBox box x) => View (Indexer (HVector box (x ': xs))) (Empty Zero) x where+ view (Indexer (HVector v) i) _ = unsafeUnbox $ v V.! i+ +instance (ConstraintBox box ret, View (Indexer (HVector box xs)) (Empty n) ret) => View (Indexer (HVector box (x ': xs))) (Empty (Succ n)) ret where+ view (Indexer (HVector v) i) _ = unsafeUnbox $ v V.! i+ +instance + ( View (Indexer (HVector box xs)) (Empty (ToNat1 n)) ret+ , SingI n+ ) => View (HVector box xs) (Sing n) ret where+ view hv _ = Indexer hv (V.length (getvec hv) -n-1) `view` (undefined::Empty (ToNat1 n))+ where+ n = fromIntegral $ fromSing (sing :: Sing n)+ +{-instance View (HVector box (xs)) (Sing n) (xs :! n) where+ view (HVector v) _ = unsafeUnbox $ v V.! n+ where+ n = fromIntegral $ fromSing (sing :: Sing n) :: Int-}+ +-- instance (ConstraintBox box (xs :! n), SingI n) => View (HVector box (xs)) (Sing (n::Nat)) (xs :! n) where+-- view (HVector v) _ = unsafeUnbox $ v V.! n+-- where+-- n = fromIntegral $ fromSing (sing :: Sing n)
+ src/Data/Vector/Heterogenous/HList.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Vector.Heterogenous.HList+ ( + -- * Heterogenous List+ HList (..)+ , HLength (..)+ + -- * Downcasting+ , ConstraintBox (..)+ , Downcast (..)+ + -- * Boxes+ , ShowBox+ , AnyBox+ + -- * Type functions+ , Nat1(..)+ , ToNat1+ , FromNat1+ )+ where++-- import Data.Semigroup+import Data.Monoid+import GHC.TypeLits+import Unsafe.Coerce++-------------------------------------------------------------------------------+-- HList++-- | The heterogenous list+data HList :: [*] -> * where+ HNil :: HList '[]+ (:::) :: t -> HList ts -> HList (t ': ts)+ +infixr 5 :::++instance Show (HList '[]) where+ show _ = "HNil"+instance (Show x, Show (HList xs)) => Show (HList (x ': xs)) where+ show (x:::xs) = show x ++":::"++show xs+ +-- instance Semigroup (HList '[]) where+-- HNil <> HNil = HNil+-- instance (Semigroup x, Semigroup (HList xs)) => Semigroup (HList (x ': xs)) where+-- (x:::xs)<>(y:::ys) = (x<>y):::(xs<>ys)++instance Monoid (HList '[]) where+ mempty = HNil+ HNil `mappend` HNil = HNil+instance (Monoid x, Monoid (HList xs)) => Monoid (HList (x ': xs)) where+ mempty = mempty:::mempty+ (x:::xs) `mappend` (y:::ys) = (x `mappend` y):::(xs `mappend` ys)++-- | Used only for the HList class to determine its length++class HLength xs where+ hlength :: xs -> Int+instance HLength (HList '[]) where+ hlength _ = 0+instance (HLength (HList xs)) => HLength (HList (x ': xs)) where+ hlength (x:::xs) = 1+hlength xs++-------------------------------------------------------------------------------+-- downcasting HList -> []++class ConstraintBox box a where+ box :: a -> box+ unsafeUnbox :: box -> a+ +class Downcast h box where+ downcast :: h -> [box]+ + downcastAs :: (a->box) -> h -> [box]+ downcastAs box = downcast++instance Downcast (HList '[]) a where+ downcast HNil = []++instance (ConstraintBox box x, Downcast (HList xs) box) => Downcast (HList (x ': xs)) box where+ downcast (x:::xs) = (box x):(downcast xs)++-------------------------------------------------------------------------------+-- boxes++-- | Most generic box, can be used on any type.+data AnyBox = forall a. AnyBox !a++-- | Use this box unless you know for certain that your types won't have a show instance.+data ShowBox = forall a. (Show a) => ShowBox !a++instance Show ShowBox where+ show (ShowBox a) = show a++instance (Show a) => ConstraintBox ShowBox a where+ box a = ShowBox a+ unsafeUnbox (ShowBox a) = unsafeCoerce a+++-------------------------------------------------------------------------------+-- type functions++type family Distribute (xs::[a->b]) (t::a) :: [b]+type instance Distribute '[] a = '[]+type instance Distribute (x ': xs) a = (x a) ': (Distribute xs a)++type family Replicate (x::a) (n::Nat) :: [a]+type instance Replicate x n = Replicate1 x (ToNat1 n)+type family Replicate1 (x::a) (n::Nat1) :: [a]+type instance Replicate1 x Zero = '[]+type instance Replicate1 x (Succ n) = x ': (Replicate1 x n)++type family Map (f :: a -> a) (xs::[a]) :: [a]+type instance Map f '[] = '[]+type instance Map f (x ': xs) = (f x) ': (Map f xs)++type family Length (xs::[a]) :: Nat+type instance Length '[] = 0+type instance Length (a ': xs) = 1 + (Length xs)++type family MoveR (xs::[a]) (ys::[a]) :: [a]+type instance MoveR '[] ys = ys+type instance MoveR (x ': xs) ys = MoveR xs (x ': ys)++type family Reverse (xs::[a]) :: [a]+type instance Reverse xs = MoveR xs '[]++type family (xs::[a]) ++ (ys::[a]) :: [a]+type instance xs ++ ys = MoveR (Reverse xs) ys++type family (:!) (xs::[a]) (i::Nat) :: a+type instance (:!) xs n = Index xs (ToNat1 n)++type family Index (xs::[a]) (i::Nat1) :: a+type instance Index (x ': xs) Zero = x+type instance Index (x ': xs) (Succ i) = Index xs i++---------------------------------------++data Nat1 = Zero | Succ Nat1++type family FromNat1 (n :: Nat1) :: Nat+type instance FromNat1 Zero = 0+type instance FromNat1 (Succ n) = 1 + FromNat1 n++type family ToNat1 (n :: Nat) :: Nat1+type instance ToNat1 0 = Zero+type instance ToNat1 1 = Succ (ToNat1 0)+type instance ToNat1 2 = Succ (ToNat1 1)+type instance ToNat1 3 = Succ (ToNat1 2)+type instance ToNat1 4 = Succ (ToNat1 3)+type instance ToNat1 5 = Succ (ToNat1 4)+type instance ToNat1 6 = Succ (ToNat1 5)+type instance ToNat1 7 = Succ (ToNat1 6)+type instance ToNat1 8 = Succ (ToNat1 7)+type instance ToNat1 9 = Succ (ToNat1 8)+type instance ToNat1 10 = Succ (ToNat1 9)+type instance ToNat1 11 = Succ (ToNat1 10)+type instance ToNat1 12 = Succ (ToNat1 11)+type instance ToNat1 13 = Succ (ToNat1 12)+type instance ToNat1 14 = Succ (ToNat1 13)+type instance ToNat1 15 = Succ (ToNat1 14)+type instance ToNat1 16 = Succ (ToNat1 15)+type instance ToNat1 17 = Succ (ToNat1 16)+type instance ToNat1 18 = Succ (ToNat1 17)+type instance ToNat1 19 = Succ (ToNat1 18)+type instance ToNat1 20 = Succ (ToNat1 19)
+ src/Data/Vector/Heterogenous/Unsafe.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Vector.Heterogenous.Unsafe+ ( UnsafeHVector(..)+ , unhvec+ )+ where++import qualified Data.Vector as V+import qualified Data.Vector.Mutable as VM+import qualified Data.Vector.Generic as G+import GHC.ST+import GHC.TypeLits+import Unsafe.Coerce++import Data.Vector.Heterogenous.HList++-------------------------------------------------------------------------------+-- UnsafeVector++data UnsafeBox = UnsafeBox+ deriving (Read,Show)++newtype UnsafeHVector xs = UnsafeHVector (V.Vector UnsafeBox)++unhvec :: (UnsafeHVectorWriter a, HLength a) => a -> UnsafeHVector a+unhvec xs = UnsafeHVector $ V.create $ do+ v <- VM.new n+ vecwrite v (n-1) xs+ return v+ where+ n = hlength xs+ +class UnsafeHVectorWriter t where+ vecwrite :: VM.MVector s UnsafeBox -> Int -> t -> ST s ()++instance (UnsafeHVectorWriter (HList xs)) => UnsafeHVectorWriter (HList (x ': xs)) where+ vecwrite v i (x:::xs) = VM.write v i (unsafeCoerce x) >> vecwrite v (i-1) xs++instance UnsafeHVectorWriter (HList '[]) where+ vecwrite v i b = return ()++data ShowIndex a = ShowIndex Int a++instance (Show (ShowIndex (UnsafeHVector a))) => Show (UnsafeHVector a) where+ show a = "(vec $ "++(show $ ShowIndex (len-1) a)++")"+ where+ len = let (UnsafeHVector vec) = a in V.length vec++instance + ( Show x+ , Show (ShowIndex (UnsafeHVector (HList xs)))+ ) => Show (ShowIndex (UnsafeHVector (HList (x ': xs)))) where+ show (ShowIndex i (UnsafeHVector vec)) = + show (unsafeCoerce (vec V.! i) :: x)++":::"+++ show (ShowIndex (i-1) (UnsafeHVector vec :: UnsafeHVector (HList xs)))+ +instance Show (ShowIndex (UnsafeHVector (HList '[]))) where+ show (ShowIndex i (UnsafeHVector vec)) = "HNil"
+ vector-heterogenous.cabal view
@@ -0,0 +1,29 @@+Name: vector-heterogenous+Version: 0.0.1+Synopsis: A type-safe library for vectors whose elements can be of any type, or any type satisfying some constraints+Description: +Category: Data, Data Structures+License: GPL+--License-file: LICENSE+Author: Mike izbicki+Maintainer: mike@izbicki.me+Build-Type: Simple+Cabal-Version: >=1.8+homepage: http://github.com/mikeizbicki/vector-heterogenous/+bug-reports: http://github.com/mikeizbicki/vector-heterogenous/issues++Library+ Build-Depends: + base >= 3 && < 5,+ vector >= 0.9+ + hs-source-dirs: src+ ghc-options: + -rtsopts + -O2 + -- -fllvm+ Exposed-modules:+ Data.Vector.Heterogenous+ Data.Vector.Heterogenous.HList+ Data.Vector.Heterogenous.Unsafe+