summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--LICENSE2
-rw-r--r--hvect.cabal15
-rw-r--r--src/Data/HVect.hs45
-rw-r--r--test/Data/HVectSpec.hs126
-rw-r--r--test/Data/HVectTest.hs82
-rw-r--r--test/Test.hs12
6 files changed, 169 insertions, 113 deletions
diff --git a/LICENSE b/LICENSE
index 4cda4d8..b7ce51f 100644
--- a/LICENSE
+++ b/LICENSE
@@ -1,5 +1,5 @@
Copyright (c) 2014 - 2015 Tim Baumann <tim@timbaumann.info>
-Copyright (c) 2014 - 2016 Alexander Thiemann <mail@athiemann.net>
+Copyright (c) 2014 - 2017 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
diff --git a/hvect.cabal b/hvect.cabal
index d0458e9..3b1ca22 100644
--- a/hvect.cabal
+++ b/hvect.cabal
@@ -1,5 +1,5 @@
name: hvect
-version: 0.3.1.0
+version: 0.4.0.0
synopsis: Simple strict heterogeneous lists
description: Small, concise and simple implementation of heterogeneous lists with useful utility functions
homepage: https://github.com/agrafix/hvect
@@ -8,17 +8,17 @@ 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 - 2016 Alexander Thiemann <mail@athiemann.net>, Tim Baumann <tim@timbaumann.info>
+copyright: (c) 2014 - 2017 Alexander Thiemann <mail@athiemann.net>, Tim Baumann <tim@timbaumann.info>
category: Data
build-type: Simple
cabal-version: >=1.10
-tested-with: GHC==7.8.4, GHC==7.10.2
+tested-with: GHC==7.10.2, GHC==8.0.1
extra-source-files:
README.md
library
exposed-modules: Data.HVect
- build-depends: base >=4.7 && <5
+ build-depends: base >= 4.8 && <5
hs-source-dirs: src
default-language: Haskell2010
@@ -26,10 +26,11 @@ 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,
+ default-language: Haskell2010
+ other-modules: Data.HVectSpec
+ build-depends: base >= 4.8 && <5,
hvect,
- HTF >=0.12.2.4
+ hspec >= 2.2
ghc-options: -Wall
source-repository head
diff --git a/src/Data/HVect.hs b/src/Data/HVect.hs
index abbf887..9922e80 100644
--- a/src/Data/HVect.hs
+++ b/src/Data/HVect.hs
@@ -3,6 +3,7 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
@@ -26,12 +27,15 @@ module Data.HVect
, Rep (..), HasRep (..)
, curryExpl, curry
, packExpl, pack
+ -- * type class constraints on list elements
+ , AllHave
-- * type level numeric utilities
, Nat (..), SNat (..), sNatToInt
, intToSNat, AnySNat (..)
, (:<)
) where
+import GHC.Exts
import Prelude hiding (reverse, uncurry, curry, head, null, (!!), length, tail)
-- | Heterogeneous vector
@@ -39,6 +43,8 @@ data HVect (ts :: [*]) where
HNil :: HVect '[]
(:&:) :: !t -> !(HVect ts) -> HVect (t ': ts)
+infixr 5 :&:
+
instance Eq (HVect '[]) where
_ == _ =
True
@@ -79,22 +85,26 @@ type family Append (as :: [*]) (bs :: [*]) :: [*] where
Append (a ': as) bs = a ': (Append as bs)
type family InList (x :: *) (xs :: [*]) :: Nat where
- InList x (x ': ys) = Zero
- InList x (y ': ys) = Succ (InList x ys)
+ InList x (x ': ys) = 'Zero
+ InList x (y ': ys) = 'Succ (InList x ys)
+
+type family AllHave (c :: * -> Constraint) (xs :: [*]) :: Constraint where
+ AllHave c '[] = 'True ~ 'True
+ AllHave c (x ': xs) = (c x, AllHave c xs)
class SNatRep n where
getSNat :: SNat n
-instance SNatRep Zero where
+instance SNatRep 'Zero where
getSNat = SZero
-instance SNatRep n => SNatRep (Succ n) where
+instance SNatRep n => SNatRep ('Succ n) where
getSNat = SSucc getSNat
type family NotInList (x :: *) (xs :: [*]) :: Bool where
- NotInList x (x ': ys) = False
+ NotInList x (x ': ys) = 'False
NotInList x (y ': ys) = NotInList x ys
- NotInList x '[] = True
+ NotInList x '[] = 'True
type ListContains n x ts = (SNatRep n, InList x ts ~ n, HVectIdx n ts ~ x)
@@ -144,35 +154,34 @@ data Nat where
Succ :: Nat -> Nat
data SNat (n :: Nat) where
- SZero :: SNat Zero
- SSucc :: SNat n -> SNat (Succ n)
+ SZero :: SNat 'Zero
+ SSucc :: SNat n -> SNat ('Succ n)
data AnySNat where
AnySNat :: forall n. SNat n -> AnySNat
type family HVectLen (ts :: [*]) :: Nat where
- HVectLen '[] = Zero
- HVectLen (t ': ts) = Succ (HVectLen ts)
+ HVectLen '[] = 'Zero
+ HVectLen (t ': ts) = 'Succ (HVectLen ts)
type family HVectIdx (n :: Nat) (ts :: [*]) :: * where
- HVectIdx Zero (a ': as) = a
- HVectIdx (Succ n) (a ': as) = HVectIdx n as
+ HVectIdx 'Zero (a ': as) = a
+ HVectIdx ('Succ n) (a ': as) = HVectIdx n as
type family (m :: Nat) :< (n :: Nat) :: Bool where
- m :< Zero = False
- Zero :< (Succ n) = True
- (Succ m) :< (Succ n) = m :< n
+ m :< 'Zero = 'False
+ 'Zero :< ('Succ n) = 'True
+ ('Succ m) :< ('Succ n) = m :< n
type family (m :: Nat) :- (n :: Nat) :: Nat where
- n :- Zero = n
- (Succ m) :- (Succ n) = m :- n
+ n :- 'Zero = n
+ ('Succ m) :- ('Succ n) = m :- n
(!!) :: SNat n -> HVect as -> HVectIdx n as
SZero !! (a :&: _) = a
(SSucc s) !! (_ :&: as) = s !! as
_ !! _ = error "HVect !!: This should never happen"
-infixr 5 :&:
infixr 5 <++>
infixl 9 !!
diff --git a/test/Data/HVectSpec.hs b/test/Data/HVectSpec.hs
new file mode 100644
index 0000000..ef7a195
--- /dev/null
+++ b/test/Data/HVectSpec.hs
@@ -0,0 +1,126 @@
+{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-overlapping-patterns #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+module Data.HVectSpec (spec) where
+
+import Data.HVect
+import Test.Hspec
+import qualified Data.HVect as HV
+
+spec :: Spec
+spec =
+ do teqInstance
+ tordInstance
+ treverse
+ thead
+ ttail
+ tnull
+ tconcat
+ tcurryUncurry
+ tlength
+ tidxAccess
+ tgetFirst
+ tallHave
+
+teqInstance :: Spec
+teqInstance =
+ it "eqInstance" $
+ do ("foo" :&: "bar" :&: empty == "foo" :&: "bar" :&: empty) `shouldBe` True
+ ("foo" :&: True :&: empty == "foo" :&: True :&: empty) `shouldBe` True
+ ("foo" :&: False :&: empty /= "foo" :&: True :&: empty) `shouldBe` True
+
+tordInstance :: Spec
+tordInstance =
+ it "ordInstance" $
+ do ((1 :&: 2 :&: 3 :&: empty) `compare` (1 :&: 2 :&: 3 :&: empty))
+ `shouldBe` ([1, 2, 3] `compare` [1, 2, 3])
+ ((3 :&: 2 :&: 3 :&: empty) `compare` (1 :&: 2 :&: 3 :&: empty))
+ `shouldBe` ([3, 2, 3] `compare` [1, 2, 3])
+ ((3 :&: 2 :&: 3 :&: empty) `compare` (1 :&: 1 :&: 3 :&: empty))
+ `shouldBe` ([1, 2, 3] `compare` [1, 1, 3])
+ ((1 :&: 2 :&: 3 :&: empty) <= (1 :&: 2 :&: 3 :&: empty))
+ `shouldBe` ([1, 2, 3] <= [1, 2, 3])
+ ((3 :&: 2 :&: 3 :&: empty) <= (1 :&: 2 :&: 3 :&: empty))
+ `shouldBe` ([3, 2, 3] <= [1, 2, 3])
+ ((3 :&: 2 :&: 3 :&: empty) <= (1 :&: 1 :&: 3 :&: empty))
+ `shouldBe` ([1, 2, 3] <= [1, 1, 3])
+ ((1 :&: 2 :&: True :&: empty) `compare` (1 :&: 2 :&: True :&: empty))
+ `shouldBe` EQ
+ ((1 :&: "foo" :&: True :&: empty) `compare` (1 :&: "bar" :&: True :&: empty))
+ `shouldBe` ("foo" `compare` "bar")
+
+treverse :: Spec
+treverse =
+ it "reverse" $
+ do (HV.reverse empty) `shouldBe` empty
+ (HV.reverse $ 1 :&: 2 :&: empty) `shouldBe` (2 :&: 1 :&: empty)
+ (HV.reverse $ 1 :&: "foo" :&: True :&: empty) `shouldBe` (True :&: "foo" :&: 1 :&: empty)
+
+thead :: Spec
+thead =
+ it "head" $
+ do (HV.head $ 1 :&: empty) `shouldBe` 1
+ (HV.head $ 1 :&: 2 :&: empty) `shouldBe` 1
+
+ttail :: Spec
+ttail =
+ it "tail" $
+ do (HV.tail $ 1 :&: empty) `shouldBe` empty
+ (HV.tail $ 1 :&: 2 :&: empty) `shouldBe` (2 :&: empty)
+
+tnull :: Spec
+tnull =
+ it "null" $
+ do (HV.null empty) `shouldBe` True
+ (not $ HV.null $ 1 :&: empty) `shouldBe` True
+
+tconcat :: Spec
+tconcat =
+ it "concat" $
+ do ((1 :&: 2 :&: empty) <++> ("foo" :&: "bar" :&: empty))
+ `shouldBe` (1 :&: 2 :&: "foo" :&: "bar" :&: empty)
+ ((1 :&: 2 :&: empty) <++> empty)
+ `shouldBe` (1 :&: 2 :&: empty)
+
+tcurryUncurry :: Spec
+tcurryUncurry =
+ it "curry uncurry" $
+ do (fun (1 :&: 2 :&: empty)) `shouldBe` "12"
+ (HV.curry fun 1 2) `shouldBe` "12"
+ (HV.uncurry (HV.curry fun) (1 :&: 2 :&: empty)) `shouldBe` "12"
+ where
+ fun :: HVect [Int, Int] -> String
+ fun (a :&: b :&: HNil) = show a ++ show b
+ fun _ = "OOPS!"
+
+tlength :: Spec
+tlength =
+ it "length" $
+ do (sNatToInt $ HV.length empty) `shouldBe` 0
+ (sNatToInt $ HV.length ("foo" :&: "bar" :&: empty)) `shouldBe` 2
+ (sNatToInt $ HV.length ("aaa" :&: False :&: True :&: "foo" :&: "bar" :&: empty)) `shouldBe` 5
+
+tidxAccess :: Spec
+tidxAccess =
+ it "idxAccess" $
+ do (SZero HV.!! ("foo" :&: "bar" :&: empty)) `shouldBe` "foo"
+ (SSucc SZero HV.!! ("foo" :&: "bar" :&: empty)) `shouldBe` "bar"
+ (SSucc (SSucc SZero) HV.!! (True :&: "foo" :&: "bar" :&: empty)) `shouldBe` "bar"
+
+tgetFirst :: Spec
+tgetFirst =
+ it "getFirst" $
+ do (findFirst (intOne :&: True :&: False :&: "foo" :&: empty)) `shouldBe` True
+ (findFirst (intOne :&: True :&: False :&: "foo" :&: empty) == intOne) `shouldBe` True
+ where
+ intOne :: Int
+ intOne = 1
+
+tallHave :: Spec
+tallHave =
+ it "allHave" $
+ (showLocal $ 1 :&: 2 :&: True :&: empty) `shouldBe` ["1", "2", "True"]
+ where
+ showLocal :: AllHave Show ts => HVect ts -> [String]
+ showLocal HNil = []
+ showLocal (t :&: ts) = (show t : showLocal ts)
diff --git a/test/Data/HVectTest.hs b/test/Data/HVectTest.hs
deleted file mode 100644
index e04c3e2..0000000
--- a/test/Data/HVectTest.hs
+++ /dev/null
@@ -1,82 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-type-defaults -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_tail :: IO ()
-test_tail =
- do assertEqual empty (HV.tail $ 1 :&: empty)
- assertEqual (2 :&: empty) (HV.tail $ 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_length :: IO ()
-test_length =
- do assertEqual 0 (sNatToInt $ HV.length empty)
- assertEqual 2 (sNatToInt $ HV.length ("foo" :&: "bar" :&: empty))
- assertEqual 5 (sNatToInt $ HV.length ("aaa" :&: False :&: True :&: "foo" :&: "bar" :&: empty))
-
-test_idxAccess :: IO ()
-test_idxAccess =
- do assertEqual "foo" (SZero HV.!! ("foo" :&: "bar" :&: empty))
- assertEqual "bar" (SSucc SZero HV.!! ("foo" :&: "bar" :&: empty))
- assertEqual "bar" (SSucc (SSucc SZero) HV.!! (True :&: "foo" :&: "bar" :&: empty))
-
-test_getFirst :: IO ()
-test_getFirst =
- do assertEqual True (findFirst (intOne :&: True :&: False :&: "foo" :&: empty))
- assertEqual intOne (findFirst (intOne :&: True :&: False :&: "foo" :&: empty))
- where
- intOne :: Int
- intOne = 1
diff --git a/test/Test.hs b/test/Test.hs
index ac65c75..1f6f65b 100644
--- a/test/Test.hs
+++ b/test/Test.hs
@@ -1,8 +1,10 @@
-{-# OPTIONS_GHC -F -pgmF htfpp #-}
-module Main where
+module Main where
-import Test.Framework
-import {-@ HTF_TESTS @-} Data.HVectTest
+import qualified Data.HVectSpec
+
+import Test.Hspec
main :: IO ()
-main = htfMain htf_importedTests
+main =
+ hspec $
+ Data.HVectSpec.spec