hvect (empty) → 0.1.0.0
raw patch · 6 files changed
+258/−0 lines, 6 filesdep +HTFdep +basedep +hvectsetup-changed
Dependencies added: HTF, base, hvect
Files
- LICENSE +21/−0
- Setup.hs +2/−0
- hvect.cabal +34/−0
- src/Data/HVect.hs +137/−0
- test/Data/HVectTest.hs +56/−0
- test/Test.hs +8/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hvect.cabal view
@@ -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
+ src/Data/HVect.hs view
@@ -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
+ test/Data/HVectTest.hs view
@@ -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!"
+ test/Test.hs view
@@ -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