summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAlexanderThiemann <>2015-05-02 11:04:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-05-02 11:04:00 (GMT)
commit392a26c2e7f6e83e751c97ade950f5c57d48c984 (patch)
treebf0d55df70d055767774a033c37d56903ab43837
version 0.1.0.00.1.0.0
-rw-r--r--LICENSE21
-rw-r--r--Setup.hs2
-rw-r--r--hvect.cabal34
-rw-r--r--src/Data/HVect.hs137
-rw-r--r--test/Data/HVectTest.hs56
-rw-r--r--test/Test.hs8
6 files changed, 258 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..1f5cd8f
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,21 @@
+Copyright (c) 2014 - 2015 Tim Baumann <tim@timbaumann.info>
+Copyright (c) 2014 - 2015 Alexander Thiemann <mail@athiemann.net>
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/hvect.cabal b/hvect.cabal
new file mode 100644
index 0000000..f04a14c
--- /dev/null
+++ b/hvect.cabal
@@ -0,0 +1,34 @@
+name: hvect
+version: 0.1.0.0
+synopsis: Simple heterogeneous lists
+description: Small, concise and simple implementation of heterogeneous lists with useful utility functions
+homepage: https://github.com/agrafix/hvect
+bug-reports: https://github.com/agrafix/hvect/issues
+license: MIT
+license-file: LICENSE
+author: Alexander Thiemann <mail@athiemann.net>, Tim Baumann <tim@timbaumann.info>
+maintainer: Alexander Thiemann <mail@athiemann.net>
+copyright: (c) 2014 - 2015 Alexander Thiemann <mail@athiemann.net>, Tim Baumann <tim@timbaumann.info>
+category: Data
+build-type: Simple
+cabal-version: >=1.10
+
+library
+ exposed-modules: Data.HVect
+ build-depends: base >=4.6 && <5
+ hs-source-dirs: src
+ default-language: Haskell2010
+
+test-suite hvect-test
+ type: exitcode-stdio-1.0
+ hs-source-dirs: test
+ main-is: Test.hs
+ other-modules: Data.HVectTest
+ build-depends: base >=4.6 && <5,
+ hvect,
+ HTF >=0.12.2.4
+ ghc-options: -Wall
+
+source-repository head
+ type: git
+ location: git://github.com/agrafix/hvect.git
diff --git a/src/Data/HVect.hs b/src/Data/HVect.hs
new file mode 100644
index 0000000..441a288
--- /dev/null
+++ b/src/Data/HVect.hs
@@ -0,0 +1,137 @@
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE UndecidableInstances #-} -- for ReverseLoop type family
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Data.HVect
+ ( HVect (..)
+ , empty, null, head
+ , singleton
+ , HVectElim
+ , Append, (<++>)
+ , ReverseLoop, Reverse, reverse
+ , uncurry
+ , Rep (..), HasRep (..)
+ , curryExpl, curry
+ , packExpl, pack
+ ) where
+
+import Prelude hiding (reverse, uncurry, curry, head, null)
+
+-- | Heterogeneous vector
+data HVect (ts :: [*]) where
+ HNil :: HVect '[]
+ (:&:) :: t -> HVect ts -> HVect (t ': ts)
+
+instance Eq (HVect '[]) where
+ _ == _ =
+ True
+
+instance (Eq (HVect ts), Eq t) => Eq (HVect (t ': ts)) where
+ a :&: as == b :&: bs =
+ a == b && as == bs
+
+instance Show (HVect '[]) where
+ showsPrec d HNil =
+ showParen (d > 10) $ showString "[]"
+
+instance (Show (HVect ts), Show t) => Show (HVect (t ': ts)) where
+ showsPrec d (a :&: as) =
+ showParen (d > 5) $
+ showsPrec 6 a .
+ showString " <:> " .
+ showsPrec 6 as
+
+instance Ord (HVect '[]) where
+ _ `compare` _ = EQ
+ _ <= _ = True
+
+instance (Ord (HVect ts), Ord t) => Ord (HVect (t ': ts)) where
+ (a :&: as) `compare` (b :&: bs) =
+ case a `compare` b of
+ EQ -> as `compare` bs
+ o -> o
+ a :&: as <= b :&: bs =
+ a <= b && as <= bs
+
+-- todo: use a closed type family once GHC 7.6 compatibility is dropped
+type family HVectElim (ts :: [*]) (a :: *) :: *
+type instance HVectElim '[] a = a
+type instance HVectElim (t ': ts) a = t -> HVectElim ts a
+
+-- todo: use a closed type family once GHC 7.6 compatibility is dropped
+type family Append (as :: [*]) (bs :: [*]) :: [*]
+type instance Append '[] bs = bs
+type instance Append (a ': as) bs = a ': (Append as bs)
+
+singleton :: a -> HVect '[a]
+singleton el = el :&: HNil
+
+empty :: HVect '[]
+empty = HNil
+
+null :: HVect as -> Bool
+null HNil = True
+null _ = False
+
+head :: HVect (t ': ts) -> t
+head (a :&: as) = a
+
+infixr 5 :&:
+infixr 5 <++>
+
+(<++>) :: HVect as -> HVect bs -> HVect (Append as bs)
+(<++>) HNil bs = bs
+(<++>) (a :&: as) bs = a :&: (as <++> bs)
+
+type family ReverseLoop (as :: [*]) (bs :: [*]) :: [*]
+type instance ReverseLoop '[] bs = bs
+type instance ReverseLoop (a ': as) bs = ReverseLoop as (a ': bs)
+
+type Reverse as = ReverseLoop as '[]
+
+reverse :: HVect as -> HVect (Reverse as)
+reverse vs = go vs HNil
+ where
+ go :: HVect as -> HVect bs -> HVect (ReverseLoop as bs)
+ go HNil bs = bs
+ go (a :&: as) bs = go as (a :&: bs)
+
+uncurry :: HVectElim ts a -> HVect ts -> a
+uncurry f HNil = f
+uncurry f (x :&: xs) = uncurry (f x) xs
+
+data Rep (ts :: [*]) where
+ RNil :: Rep '[]
+ RCons :: Rep ts -> Rep (t ': ts)
+
+class HasRep (ts :: [*]) where
+ hasRep :: Rep ts
+
+instance HasRep '[] where
+ hasRep = RNil
+
+instance HasRep ts => HasRep (t ': ts) where
+ hasRep = RCons hasRep
+
+curryExpl :: Rep ts -> (HVect ts -> a) -> HVectElim ts a
+curryExpl RNil f = f HNil
+curryExpl (RCons r) f = \x -> curryExpl r (f . (:&:) x)
+
+curry :: HasRep ts => (HVect ts -> a) -> HVectElim ts a
+curry = curryExpl hasRep
+
+buildElim :: Rep ts -> (HVect ts -> HVect ss) -> HVectElim ts (HVect ss)
+buildElim RNil f = f HNil
+buildElim (RCons r) f = \x -> buildElim r (f . (:&:) x)
+
+packExpl :: Rep ts -> (forall a. HVectElim ts a -> a) -> HVect ts
+packExpl rep f = f (buildElim rep id)
+
+pack :: HasRep ts => (forall a. HVectElim ts a -> a) -> HVect ts
+pack = packExpl hasRep
diff --git a/test/Data/HVectTest.hs b/test/Data/HVectTest.hs
new file mode 100644
index 0000000..508d6f3
--- /dev/null
+++ b/test/Data/HVectTest.hs
@@ -0,0 +1,56 @@
+{-# OPTIONS_GHC -F -pgmF htfpp #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+module Data.HVectTest (htf_thisModulesTests) where
+
+import Test.Framework
+import Data.HVect
+import qualified Data.HVect as HV
+
+test_eqInstance :: IO ()
+test_eqInstance =
+ do assertBool ("foo" :&: "bar" :&: empty == "foo" :&: "bar" :&: empty)
+ assertBool ("foo" :&: True :&: empty == "foo" :&: True :&: empty)
+ assertBool ("foo" :&: False :&: empty /= "foo" :&: True :&: empty)
+
+test_ordInstance :: IO ()
+test_ordInstance =
+ do assertEqual ([1, 2, 3] `compare` [1, 2, 3]) ((1 :&: 2 :&: 3 :&: empty) `compare` (1 :&: 2 :&: 3 :&: empty))
+ assertEqual ([3, 2, 3] `compare` [1, 2, 3]) ((3 :&: 2 :&: 3 :&: empty) `compare` (1 :&: 2 :&: 3 :&: empty))
+ assertEqual ([1, 2, 3] `compare` [1, 1, 3]) ((3 :&: 2 :&: 3 :&: empty) `compare` (1 :&: 1 :&: 3 :&: empty))
+ assertEqual ([1, 2, 3] <= [1, 2, 3]) ((1 :&: 2 :&: 3 :&: empty) <= (1 :&: 2 :&: 3 :&: empty))
+ assertEqual ([3, 2, 3] <= [1, 2, 3]) ((3 :&: 2 :&: 3 :&: empty) <= (1 :&: 2 :&: 3 :&: empty))
+ assertEqual ([1, 2, 3] <= [1, 1, 3]) ((3 :&: 2 :&: 3 :&: empty) <= (1 :&: 1 :&: 3 :&: empty))
+ assertEqual EQ ((1 :&: 2 :&: True :&: empty) `compare` (1 :&: 2 :&: True :&: empty))
+ assertEqual ("foo" `compare` "bar") ((1 :&: "foo" :&: True :&: empty) `compare` (1 :&: "bar" :&: True :&: empty))
+
+test_reverse :: IO ()
+test_reverse =
+ do assertEqual empty (HV.reverse empty)
+ assertEqual (2 :&: 1 :&: empty) (HV.reverse $ 1 :&: 2 :&: empty)
+ assertEqual (True :&: "foo" :&: 1 :&: empty) (HV.reverse $ 1 :&: "foo" :&: True :&: empty)
+
+test_head :: IO ()
+test_head =
+ do assertEqual 1 (HV.head $ 1 :&: empty)
+ assertEqual 1 (HV.head $ 1 :&: 2 :&: empty)
+
+test_null :: IO ()
+test_null =
+ do assertBool (HV.null empty)
+ assertBool (not $ HV.null $ 1 :&: empty)
+
+test_concat :: IO ()
+test_concat =
+ do assertEqual (1 :&: 2 :&: "foo" :&: "bar" :&: empty) ((1 :&: 2 :&: empty) <++> ("foo" :&: "bar" :&: empty))
+ assertEqual (1 :&: 2 :&: empty) ((1 :&: 2 :&: empty) <++> empty)
+
+test_curryUncurry :: IO ()
+test_curryUncurry =
+ do assertEqual "12" (fun (1 :&: 2 :&: empty))
+ assertEqual "12" (HV.curry fun 1 2)
+ assertEqual "12" (HV.uncurry (HV.curry fun) (1 :&: 2 :&: empty))
+ where
+ fun :: HVect '[Int, Int] -> String
+ fun (a :&: b :&: HNil) = show a ++ show b
+ fun _ = "OOPS!"
diff --git a/test/Test.hs b/test/Test.hs
new file mode 100644
index 0000000..ac65c75
--- /dev/null
+++ b/test/Test.hs
@@ -0,0 +1,8 @@
+{-# OPTIONS_GHC -F -pgmF htfpp #-}
+module Main where
+
+import Test.Framework
+import {-@ HTF_TESTS @-} Data.HVectTest
+
+main :: IO ()
+main = htfMain htf_importedTests