diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,5 @@ Copyright (c) 2014 - 2015 Tim Baumann -Copyright (c) 2014 - 2016 Alexander Thiemann +Copyright (c) 2014 - 2017 Alexander Thiemann 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 --- 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-file: LICENSE author: Alexander Thiemann , Tim Baumann maintainer: Alexander Thiemann -copyright: (c) 2014 - 2016 Alexander Thiemann , Tim Baumann +copyright: (c) 2014 - 2017 Alexander Thiemann , Tim Baumann 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 @@ 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 --- 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 @@ , 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 @@ HNil :: HVect '[] (:&:) :: !t -> !(HVect ts) -> HVect (t ': ts) +infixr 5 :&: + instance Eq (HVect '[]) where _ == _ = True @@ -79,22 +85,26 @@ 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 @@ 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 --- /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 --- 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 --- 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