diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +Copyright (c) 2014 - 2015 Tim Baumann +Copyright (c) 2014 - 2015 Alexander Thiemann + +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 --- /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 --- /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 , Tim Baumann +maintainer: Alexander Thiemann +copyright: (c) 2014 - 2015 Alexander Thiemann , Tim Baumann +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 --- /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 --- /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 --- /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