diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,13 @@ +# 0.2.0.0 + +- Made NMap and NSum polymorphic over the kind of the key. (Perhaps + 'Natural' keys would be useful as well.) This is a breaking API + change, because the qualifier for the kind of the key must go before + the qualifier for the typelevel lists, potentially breaking + TypeApplication uses. +- Add Eq and Ord instances for NMap and NSum +- Add a testsuite + # 0.1.0.1 Quickfix for an oversight in the `uninsertSum` function that broke diff --git a/named-sop.cabal b/named-sop.cabal --- a/named-sop.cabal +++ b/named-sop.cabal @@ -1,5 +1,5 @@ name: named-sop -version: 0.1.0.1 +version: 0.2.0.0 category: Data homepage: https://github.com/sjsch/named-sop @@ -47,3 +47,14 @@ hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall -Werror=incomplete-patterns + +test-suite named-sop-spec + type: exitcode-stdio-1.0 + main-is: Tests.hs + hs-source-dirs: test + build-depends: base + , named-sop + , tasty + , tasty-hunit + default-language: Haskell2010 + ghc-options: -Wall -Werror=incomplete-patterns diff --git a/src/Data/NamedSOP/Generic.hs b/src/Data/NamedSOP/Generic.hs --- a/src/Data/NamedSOP/Generic.hs +++ b/src/Data/NamedSOP/Generic.hs @@ -48,6 +48,11 @@ genProduct' = genProduct' . unM1 specProduct' = M1 . specProduct' +instance GenProduct U1 where + type GProduct U1 = '[] + genProduct' U1 = NMapEmpty + specProduct' NMapEmpty = U1 + instance GenProduct (S1 ('MetaSel ('Just n) _a _b _c) (Rec0 t)) where type GProduct (S1 ( 'MetaSel ( 'Just n) _a _b _c) (Rec0 t)) = '[n ':-> t] genProduct' (M1 (K1 c)) = NMapExt c NMapEmpty @@ -73,6 +78,14 @@ genProductN' :: Sing n -> f a -> NMap (GProductN n f) specProductN' :: Sing n -> NMap (GProductN n f) -> f a +instance GenProductN U1 where + type GProductN n U1 = '[] + type GProductS U1 = 0 + sGProductS = SNat + sGProductN _ = SNil + genProductN' _ U1 = NMapEmpty + specProductN' _ NMapEmpty = U1 + instance GenProductN (S1 ('MetaSel 'Nothing _a _b _c) (Rec0 t)) where type GProductN n (S1 ( 'MetaSel 'Nothing _a _b _c) (Rec0 t)) = '[Mappend "_" (Show_ n) ':-> t] type GProductS (S1 ( 'MetaSel 'Nothing _a _b _c) (Rec0 t)) = 1 @@ -97,7 +110,7 @@ (x, y) = withSingI sm1 $ withSingI sm2 - $ ununionMap @(GProductN n f) @(GProductN (n + GProductS f) g) m + $ ununionMap @_ @(GProductN n f) @(GProductN (n + GProductS f) g) m in specProductN' sn x :*: specProductN' (sn %+ sGProductS @f) y class GenSum (f :: * -> *) where @@ -110,6 +123,11 @@ genSum' = genSum' . unM1 specSum' = M1 . specSum' +instance GenSum V1 where + type GSum V1 = '[] + genSum' _ = error "unreachable" + specSum' _ = error "unreachable" + instance GenProduct f => GenSum (C1 ('MetaCons n _a 'True) f) where type GSum (C1 ( 'MetaCons n _a 'True) f) = '[Mappend "_" n ':-> NMap (GProduct f)] genSum' (M1 x) = NSumThis (genProduct' x) @@ -125,9 +143,9 @@ instance ( SingI (GSum f), SingI (GSum g) , GenSum f, GenSum g) => GenSum (f :+: g) where type GSum (f :+: g) = Union (GSum f) (GSum g) - genSum' (L1 x) = unionSum @(GSum f) @(GSum g) (Left (genSum' x)) - genSum' (R1 x) = unionSum @(GSum f) @(GSum g) (Right (genSum' x)) - specSum' m = case ununionSum @(GSum f) @(GSum g) m of + genSum' (L1 x) = unionSum @_ @(GSum f) @(GSum g) (Left (genSum' x)) + genSum' (R1 x) = unionSum @_ @(GSum f) @(GSum g) (Right (genSum' x)) + specSum' m = case ununionSum @_ @(GSum f) @(GSum g) m of Left x -> L1 (specSum' x) Right y -> R1 (specSum' y) @@ -154,11 +172,13 @@ -- constructors into an 'NSum' of 'NMap's. All constructor names will -- be prefixed with @_@ to allow for the use of @-XOverloadedLabels@. -- --- >>> data A = C { a :: Int, b :: Bool } | D Int Bool deriving (Generic) +-- >>> data A = C { a :: Int, b :: Bool } | D Int Bool | E String +-- >>> deriving (Generic) -- >>> :t genSum (C 3 True) -- NSum -- '[ "_C" ':-> NMap '[ "a" ':-> Int, "b" ':-> Bool], --- "_D" ':-> NMap '[ "_1" ':-> Int, "_2" ':-> Bool]] +-- "_D" ':-> NMap '[ "_1" ':-> Int, "_2" ':-> Bool], +-- "_E" ':-> NMap '[ "_1" ':-> String ]] genSum :: (Generic a, GenSum (Rep a)) => a -> NSum (GSum (Rep a)) genSum = genSum' . from diff --git a/src/Data/NamedSOP/Map.hs b/src/Data/NamedSOP/Map.hs --- a/src/Data/NamedSOP/Map.hs +++ b/src/Data/NamedSOP/Map.hs @@ -1,7 +1,8 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -31,7 +32,7 @@ -- -- > type A = NMap '[ "a" ':-> Int, "b" ':-> Bool ] -- > data A = A { a :: Int, b :: Bool } -data NMap :: [Mapping Symbol Type] -> Type where +data NMap :: [Mapping s Type] -> Type where NMapEmpty :: NMap '[] NMapExt :: forall k v xs. v -> NMap xs -> NMap ((k ':-> v) : xs) @@ -56,12 +57,26 @@ instance ShowMap xs => Show (NMap xs) where show xs = "{ " ++ showMap xs ++ " }" +instance Eq (NMap '[]) where + NMapEmpty == NMapEmpty = True + +instance (Eq v, Eq (NMap xs)) => Eq (NMap ((k ':-> v) ': xs)) where + (NMapExt x xs) == (NMapExt y ys) = x == y && xs == ys + +instance Ord (NMap '[]) where + compare NMapEmpty NMapEmpty = EQ + +instance (Ord v, Ord (NMap xs)) => Ord (NMap ((k ':-> v) ': xs)) where + compare (NMapExt x xs) (NMapExt y ys) = case compare x y of + EQ -> compare xs ys + o -> o + appendMap :: NMap xs -> NMap ys -> NMap (xs ++ ys) appendMap NMapEmpty ys = ys appendMap (NMapExt x xs) ys = NMapExt x (appendMap xs ys) -insertMap :: - Sing (k ':-> v) -> Sing xs -> v -> NMap xs -> NMap (Insert (k ':-> v) xs) +insertMap :: forall s k v (xs :: [Mapping s *]). SOrd s + => Sing (k ':-> v) -> Sing xs -> v -> NMap xs -> NMap (Insert (k ':-> v) xs) insertMap _ _ x NMapEmpty = NMapExt x NMapEmpty insertMap sxk (SCons syk sys) x ys@(NMapExt y ys') = case sCompare sxk syk of @@ -69,7 +84,8 @@ SEQ -> NMapExt x ys SGT -> NMapExt y (insertMap sxk sys x ys') -sortMap :: Sing xs -> NMap xs -> NMap (Sort xs) +sortMap :: forall s (xs :: [Mapping s *]). SOrd s + => Sing xs -> NMap xs -> NMap (Sort xs) sortMap _ NMapEmpty = NMapEmpty sortMap (SCons sx sxs) (NMapExt x xs) = insertMap sx (sSort sxs) x (sortMap sxs xs) @@ -85,7 +101,7 @@ -- This function takes a tuple as an argument so that it is symmetric -- with `ununionMap`. unionMap :: - forall xs ys. (SingI xs, SingI ys) + forall s (xs :: [Mapping s *]) (ys :: [Mapping s *]). (SingI xs, SingI ys, SOrd s) => (NMap xs, NMap ys) -> NMap (Union xs ys) unionMap (xs, ys) = sortMap (sing @xs %++ sing @ys) (appendMap xs ys) @@ -97,7 +113,8 @@ let (a, b) = splitMap sxs sys xs in (NMapExt x a, b) -uninsertMap :: forall k v xs. Sing (k ':-> v) -> Sing xs -> NMap (Insert (k ':-> v) xs) -> (v, NMap xs) +uninsertMap :: forall s k v (xs :: [Mapping s *]). SOrd s + => Sing (k ':-> v) -> Sing xs -> NMap (Insert (k ':-> v) xs) -> (v, NMap xs) uninsertMap _ SNil (NMapExt v NMapEmpty) = (v, NMapEmpty) uninsertMap sx@(SMapping sk) (SCons (SMapping sk') sxs) (NMapExt v vs) = case sCompare sk sk' of SLT -> (v, vs) @@ -106,7 +123,8 @@ in (v', NMapExt v vs') uninsertMap _ (SCons _ _) NMapEmpty = error "unreachable" -unsortMap :: forall xs. Sing xs -> NMap (Sort xs) -> NMap xs +unsortMap :: forall s (xs :: [Mapping s *]). SOrd s + => Sing xs -> NMap (Sort xs) -> NMap xs unsortMap SNil NMapEmpty = NMapEmpty unsortMap (SCons sx@(SMapping _) sxs) vs = let (v', vs') = uninsertMap sx (sSort sxs) vs @@ -114,14 +132,15 @@ -- | Split a sorted 'NMap' into two arbitrary (and potentially -- unsorted) submaps. Conveniently select the submaps to split into --- using @-XTypeApplications@. +-- using @-XTypeApplications@. (Note the empty type argument for the +-- key kind). -- -- >>> m :: NMap '[ "a" ':-> Int, "b" ':-> Bool, "c" ':-> String ] -- >>> m = NMapExt 1 (NMapExt True (NMapExt "hello" NMapEmpty)) --- >>> ununionMap @'[ "b" ':-> Bool, "a" ':-> Int ] @'[ "c" ':-> String ] m +-- >>> ununionMap @_ @'[ "b" ':-> Bool, "a" ':-> Int ] @'[ "c" ':-> String ] m -- ({ b :-> True, a :-> 1 },{ c :-> "hello" }) -ununionMap :: forall xs ys. (SingI xs, SingI ys) => - NMap (Union xs ys) -> (NMap xs, NMap ys) +ununionMap :: forall s (xs :: [Mapping s *]) (ys :: [Mapping s *]). (SingI xs, SingI ys, SOrd s) + => NMap (Union xs ys) -> (NMap xs, NMap ys) ununionMap vs = splitMap sxs sys (unsortMap (sxs %++ sys) vs) where sxs = sing @xs diff --git a/src/Data/NamedSOP/Sum.hs b/src/Data/NamedSOP/Sum.hs --- a/src/Data/NamedSOP/Sum.hs +++ b/src/Data/NamedSOP/Sum.hs @@ -2,8 +2,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -32,8 +32,8 @@ -- -- > type A = NSum '[ "B" ':-> Int, "C" ':-> Bool ] -- > data A = B Int | C Bool -data NSum :: [Mapping Symbol Type] -> Type where - NSumThis :: v -> NSum ((k ':-> v) ': xs) +data NSum :: [Mapping s Type] -> Type where + NSumThis :: forall k v xs. v -> NSum ((k ':-> v) ': xs) NSumThat :: forall x xs. NSum xs -> NSum (x ': xs) instance {-# OVERLAPPABLE #-} Show (NSum '[]) where @@ -44,13 +44,31 @@ show (NSumThis v) = symbolVal (Proxy :: Proxy k) ++ " :-> " ++ show v show (NSumThat vs) = show vs +instance Eq (NSum '[]) where + _ == _ = True + +instance (Eq v, Eq (NSum xs)) => Eq (NSum ((k ':-> v) ': xs)) where + (NSumThis x ) == (NSumThis y ) = x == y + (NSumThat xs) == (NSumThat ys) = xs == ys + _ == _ = False + +instance Ord (NSum '[]) where + compare _ _ = EQ + +instance (Ord v, Ord (NSum xs)) => Ord (NSum ((k ':-> v) ': xs)) where + compare (NSumThis x ) (NSumThis y ) = compare x y + compare (NSumThat xs) (NSumThat ys) = compare xs ys + compare (NSumThis _ ) (NSumThat _ ) = GT + compare (NSumThat _ ) (NSumThis _ ) = LT + appendSum :: Sing xs -> Sing ys -> Either (NSum xs) (NSum ys) -> NSum (xs ++ ys) appendSum _ _ (Left (NSumThis x)) = NSumThis x appendSum (SCons _ sxs) sys (Left (NSumThat xs)) = NSumThat (appendSum sxs sys (Left xs)) appendSum SNil _ (Right ys) = ys appendSum (SCons (_ :: Sing x) sxs) sys (Right ys) = NSumThat @x (appendSum sxs sys (Right ys)) -insertSum :: Sing (k ':-> v) -> Sing xs -> Either v (NSum xs) -> NSum (Insert (k ':-> v) xs) +insertSum :: forall s k v (xs :: [Mapping s *]). SOrd s => + Sing (k ':-> v) -> Sing xs -> Either v (NSum xs) -> NSum (Insert (k ':-> v) xs) insertSum _ SNil (Left v) = NSumThis v insertSum sxk (SCons syk sys) (Left v) = case sCompare sxk syk of @@ -65,7 +83,7 @@ NSumThat v' -> NSumThat (insertSum sxk sys (Right v')) insertSum _ SNil (Right _) = error "unreachable" -sortSum :: Sing xs -> NSum xs -> NSum (Sort xs) +sortSum :: forall s (xs :: [Mapping s *]). SOrd s => Sing xs -> NSum xs -> NSum (Sort xs) sortSum SNil _ = error "unreachable" sortSum (SCons sx sxs) (NSumThis v) = insertSum sx (sSort sxs) (Left v) sortSum (SCons sx@(SMapping _) sxs) (NSumThat vs) = @@ -84,7 +102,7 @@ -- 'Data.NamedSOP.Map.NMapEmpty', and 'Data.NamedSOP.Map.unionMap', it -- is a semiring. unionSum :: - forall xs ys. (SingI xs, SingI ys) + forall s (xs :: [Mapping s *]) (ys :: [Mapping s *]). (SingI xs, SingI ys, SOrd s) => Either (NSum xs) (NSum ys) -> NSum (Union xs ys) unionSum xs = sortSum (sing @xs %++ sing @ys) (appendSum (sing @xs) (sing @ys) xs) @@ -99,7 +117,8 @@ Left x -> Left (NSumThat x) Right x -> Right x -uninsertSum :: forall k v xs. Sing (k ':-> v) -> Sing xs +uninsertSum :: forall s k v (xs :: [Mapping s *]). SOrd s + => Sing (k ':-> v) -> Sing xs -> NSum (Insert (k ':-> v) xs) -> Either v (NSum xs) uninsertSum _ SNil (NSumThis v) = Left v uninsertSum _ SNil (NSumThat v) = Right v @@ -114,7 +133,8 @@ Left x -> Left x Right x -> Right (NSumThat x) -unsortSum :: forall xs. Sing xs -> NSum (Sort xs) -> NSum xs +unsortSum :: forall s (xs :: [Mapping s *]). SOrd s + => Sing xs -> NSum (Sort xs) -> NSum xs unsortSum SNil _ = error "unreachable" unsortSum (SCons sx@(SMapping _) sxs) v = case uninsertSum sx (sSort sxs) v of @@ -126,10 +146,10 @@ -- -- >>> s :: NSum '[ "A" ':-> Int, "B" ':-> Bool, "C" ':-> String ] -- >>> s = NSumThat (NSumThis True) -- Select the "B" field. --- >>> ununionSum @'[ "B" ':-> Bool, "A" ':-> Int ] @'[ "C" ':-> String ] s +-- >>> ununionSum @_ @'[ "B" ':-> Bool, "A" ':-> Int ] @'[ "C" ':-> String ] s -- Left (B :-> True) -ununionSum :: forall xs ys. (SingI xs, SingI ys) => - NSum (Union xs ys) -> Either (NSum xs) (NSum ys) +ununionSum :: forall s (xs :: [Mapping s *]) (ys :: [Mapping s *]). (SingI xs, SingI ys, SOrd s) + => NSum (Union xs ys) -> Either (NSum xs) (NSum ys) ununionSum vs = splitSum sxs sys (unsortSum (sxs %++ sys) vs) where sxs = sing @xs diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE PolyKinds #-} + +import Control.Monad +import GHC.Generics +import Test.Tasty +import Test.Tasty.HUnit + +import Data.NamedSOP.Generic +import Data.NamedSOP.Map +import Data.NamedSOP.Sum + +main :: IO () +main = defaultMain tests + +testGenSpecProd :: ( Generic a + , GenProduct (Rep a) + , Eq a + , Eq (NMap (GProduct (Rep a))) + , Show a + , Show (NMap (GProduct (Rep a)))) => + [Char] -> a -> NMap (GProduct (Rep a)) -> [TestTree] +testGenSpecProd s a b = + [ testCase ("Generalize " ++ s) $ + genProduct a @?= b + , testCase ("Specialize " ++ s) $ + specProduct b @?= a + ] + + +testGenSpecSum :: ( Generic a + , GenSum (Rep a) + , Eq a + , Eq (NSum (GSum (Rep a))) + , Show a + , Show (NSum (GSum (Rep a)))) => + [Char] -> a -> NSum (GSum (Rep a)) -> [TestTree] +testGenSpecSum s a b = + [ testCase ("Generalize " ++ s) $ + genSum a @?= b + , testCase ("Specialize " ++ s) $ + specSum b @?= a + ] + +tests :: TestTree +tests = testGroup "Unit tests" [isoTests, unionTests] + +data EmptyP = EmptyP + deriving (Eq, Ord, Show, Generic) + +data UnaryP a = UnaryP a + deriving (Eq, Ord, Show, Generic) + +data Size2P a b = Size2P a b + deriving (Eq, Ord, Show, Generic) + +data RecordP = RecordP { recordPA :: Int, recordPB :: String } + deriving (Eq, Ord, Show, Generic) + +data EmptyS + deriving (Eq, Ord, Show, Generic) + +data UnaryS a = UnaryS a + deriving (Eq, Ord, Show, Generic) + +data Size2S a b = Size2SA a + | Size2SB b + deriving (Eq, Ord, Show, Generic) + +data RecordS = RecordSA { recordSAA :: Int } + | RecordSB { recordSBA :: Bool, recordSBB :: String } + deriving (Eq, Ord, Show, Generic) + +isoTests :: TestTree +isoTests = testGroup "Generic isomorphisms" $ join $ + [ testGenSpecProd "empty product" + EmptyP + NMapEmpty + , testGenSpecProd "unary product" + (UnaryP True) + (NMapExt @"_1" True NMapEmpty) + , testGenSpecProd "size-2 product" + (Size2P True "hello") + (NMapExt @"_1" True (NMapExt @"_2" "hello" NMapEmpty)) + , testGenSpecProd "record product" + (RecordP { recordPA = 1, recordPB = "hello" }) + (NMapExt @"recordPA" 1 (NMapExt @"recordPB" "hello" NMapEmpty)) + , testGenSpecSum "empty sum" + (undefined :: EmptyS) + (undefined :: NSum '[]) + , testGenSpecSum "unary sum" + (UnaryS True) + (NSumThis @"_UnaryS" (NMapExt @"_1" True NMapEmpty)) + , testGenSpecSum "size-2 sum, 1st branch" + (Size2SA True :: Size2S Bool String) + (NSumThis @"_Size2SA" (NMapExt @"_1" True NMapEmpty)) + , testGenSpecSum "size-2 sum, 2nd branch" + (Size2SB "hello" :: Size2S Bool String) + (NSumThat (NSumThis @"_Size2SB" (NMapExt @"_1" "hello" NMapEmpty))) + , testGenSpecSum "sum of records, 1st branch" + (RecordSA { recordSAA = 1 }) + (NSumThis @"_RecordSA" (NMapExt @"recordSAA" 1 NMapEmpty)) + , testGenSpecSum "sum of records, 2nd branch" + (RecordSB { recordSBA = True, recordSBB = "hello" }) + (NSumThat (NSumThis @"_RecordSB" + (NMapExt @"recordSBA" True + (NMapExt @"recordSBB" "hello" NMapEmpty)))) + ] + +unionTests :: TestTree +unionTests = testGroup "Union/ununion operations" + [ testCase "Union of products" $ + unionMap + ((NMapExt @"c" True (NMapExt @"a" "hello" NMapEmpty)), + (NMapExt @"b" "world" (NMapExt @"d" False NMapEmpty))) + @?= + (NMapExt @"a" "hello" + (NMapExt @"b" "world" + (NMapExt @"c" True + (NMapExt @"d" False NMapEmpty)))) + , testCase "Product ununion . union == id" $ + ununionMap + (unionMap + ((NMapExt @"c" True (NMapExt @"a" "hello" NMapEmpty)), + (NMapExt @"b" "world" (NMapExt @"d" False NMapEmpty)))) + @?= + ((NMapExt @"c" True (NMapExt @"a" "hello" NMapEmpty)), + (NMapExt @"b" "world" (NMapExt @"d" False NMapEmpty))) + , testCase "Union of sums, 1st branch" $ + unionSum @_ @'["b" ':-> Bool] @'["a" ':-> Int] + (Left (NSumThis @"b" True)) + @?= + (NSumThat (NSumThis @"b" True)) + , testCase "Union of sums, 2nd branch" $ + unionSum @_ @'["b" ':-> Bool] @'["a" ':-> Int] + (Right (NSumThis @"a" 1)) + @?= + (NSumThis @"a" 1) + , testCase "Sum ununion . union == id" $ + ununionSum @_ @'["b" ':-> Bool] @'["a" ':-> Int] + (unionSum @_ @'["b" ':-> Bool] @'["a" ':-> Int] + (Left (NSumThis @"b" True))) + @?= + (Left (NSumThis @"b" True)) + ]