named-sop 0.1.0.1 → 0.2.0.0

raw patch · 6 files changed

+261/−30 lines, 6 filesdep +named-sopdep +tastydep +tasty-hunitdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: named-sop, tasty, tasty-hunit

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• named-sop.cabal +12/−1
• src/Data/NamedSOP/Generic.hs +26/−6
• src/Data/NamedSOP/Map.hs +31/−12
• src/Data/NamedSOP/Sum.hs +31/−11
• test/Tests.hs +151/−0

@@ -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

@@ -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                     

@@ -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 

@@ -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

@@ -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

@@ -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))+  ]