diff --git a/haskus-utils-variant.cabal b/haskus-utils-variant.cabal --- a/haskus-utils-variant.cabal +++ b/haskus-utils-variant.cabal @@ -1,6 +1,6 @@ cabal-version: 1.20 name: haskus-utils-variant -version: 2.1.1 +version: 2.2 license: BSD3 license-file: LICENSE copyright: Sylvain Henry 2018 @@ -32,10 +32,10 @@ default-language: Haskell2010 ghc-options: -Wall build-depends: - base >=4.9 && <4.12, - template-haskell >=2.13.0.0 && <2.14, - haskus-utils-types ==1.2.*, - haskus-utils-data ==1.1.* + base >=4.9 && <5.0, + template-haskell >=2.13.0.0, + haskus-utils-types >=1.2, + haskus-utils-data >=1.1 test-suite tests type: exitcode-stdio-1.0 @@ -46,7 +46,7 @@ default-language: Haskell2010 ghc-options: -Wall -threaded build-depends: - base >=4.11.1.0 && <4.12, + base >=4.11.1.0, haskus-utils-variant -any, - tasty >=0.11 && <1.2, - tasty-quickcheck >=0.8 && <0.11 + tasty >=0.11, + tasty-quickcheck >=0.8 diff --git a/src/lib/Haskus/Utils/Variant.hs b/src/lib/Haskus/Utils/Variant.hs --- a/src/lib/Haskus/Utils/Variant.hs +++ b/src/lib/Haskus/Utils/Variant.hs @@ -336,7 +336,7 @@ | otherwise -> Left (Variant t a) class SplitVariant as rs xs where - splitVariant' :: V xs -> Either (V as) (V (Complement rs as)) + splitVariant' :: V xs -> Either (V rs) (V as) instance SplitVariant as rs '[] where {-# INLINE splitVariant' #-} @@ -344,7 +344,7 @@ instance forall as rs xs x n m. ( n ~ MaybeIndexOf x as - , m ~ IndexOf x rs + , m ~ MaybeIndexOf x rs , SplitVariant as rs xs , KnownNat m , KnownNat n @@ -353,16 +353,18 @@ {-# INLINE splitVariant' #-} splitVariant' (Variant 0 v) = case natValue' @n of - 0 -> Right (Variant (natValue' @m) v) - t -> Left (Variant (t-1) v) + -- we assume that if `x` isn't in `as`, it is in `rs` + -- hence we don't test if `m == 0` + 0 -> Left (Variant (natValue' @m - 1) v) + t -> Right (Variant (t-1) v) splitVariant' (Variant t v) = splitVariant' @as @rs (Variant (t-1) v :: V xs) -- | Split a variant in two splitVariant :: forall as xs. - ( SplitVariant as xs xs - ) => V xs -> Either (V as) (V (Complement xs as)) -splitVariant = splitVariant' @as @xs + ( SplitVariant as (Complement xs as) xs + ) => V xs -> Either (V (Complement xs as)) (V as) +splitVariant = splitVariant' @as @(Complement xs as) @xs -- | A value of type "x" can be extracted from (V xs) type (:<) x xs = diff --git a/src/lib/Haskus/Utils/VariantF.hs b/src/lib/Haskus/Utils/VariantF.hs --- a/src/lib/Haskus/Utils/VariantF.hs +++ b/src/lib/Haskus/Utils/VariantF.hs @@ -221,14 +221,14 @@ type SplitVariantF as xs e = ( Complement (ApplyAll e xs) (ApplyAll e as) ~ ApplyAll e (Complement xs as) - , SplitVariant (ApplyAll e as) (ApplyAll e xs) (ApplyAll e xs) + , SplitVariant (ApplyAll e as) (ApplyAll e (Complement xs as)) (ApplyAll e xs) ) -- | Split a VariantF in two splitVariantF :: forall as xs e. ( SplitVariantF as xs e ) => VariantF xs e - -> Either (VariantF as e) (VariantF (Complement xs as) e) + -> Either (VariantF (Complement xs as) e) (VariantF as e) splitVariantF (VariantF v) = bimap VariantF VariantF (splitVariant v) -- | Convert a VariantF into a multi-continuation diff --git a/src/tests/Variant.hs b/src/tests/Variant.hs --- a/src/tests/Variant.hs +++ b/src/tests/Variant.hs @@ -5,6 +5,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} module Variant ( testsVariant @@ -45,84 +46,62 @@ testsVariant :: TestTree testsVariant = testGroup "Variant" $ - [ testProperty "set/get by index (match)" - (fromVariantAt @1 b == Just B) - , testProperty "set/get by index (dont' match)" - (fromVariantAt @0 b == Nothing) - , testProperty "set/get by type (match)" - (fromVariant (toVariant B :: ABC) == Just B) - , testProperty "set/get by type (don't match)" - (fromVariant @C (toVariant B :: ABC) == Nothing) - - , testProperty "variant equality (match)" - (b == b) - , testProperty "variant equality (don't match)" - (b /= toVariant C) - - , testProperty "update by index (match)" - (mapVariantAt @1 (const D) b == toVariantAt @1 D) - , testProperty "update by index (don't match)" - (mapVariantAt @0 (const F) b == toVariantAt @1 B) - , testProperty "update by type (match)" - (mapVariantFirst b2d b == toVariantAt @1 D) - , testProperty "update by type (don't match)" - (mapVariantFirst c2d b == toVariant B) - , testProperty "update/fold by index (match)" - (foldMapVariantAt @1 b2def b == toVariant E) - , testProperty "update/fold by index (don't match)" - (foldMapVariantAt @2 c2def b == toVariant B) - - , testProperty "Convert into tuple" - (variantToTuple b == (Nothing, Just B, Nothing)) - , testProperty "Convert single variant" - (variantToValue (toVariant A :: V '[A]) == A) - - , testProperty "Lift Either: Left" - (variantFromEither (Left A :: Either A B) == toVariant A) - , testProperty "Lift Either: Right" - (variantFromEither (Right B :: Either A B) == toVariant B) - - , testProperty "To Either: Left" - (variantToEither (toVariant B :: V '[A,B]) == Left B) - , testProperty "To Either: Right" - (variantToEither (toVariant A :: V '[A,B]) == Right A) - - , testProperty "popVariantHead (match)" - (popVariantHead (toVariant A :: ABC) == Right A) - , testProperty "popVariantHead (don't match)" - (isLeft (popVariantHead b)) - - , testProperty "popVariantAt (match)" - (popVariantAt @1 b == Right B) - , testProperty "popVariantAt (don't match)" - (isLeft (popVariantAt @2 b)) - - , testProperty "popVariant (match)" - (popVariant @D (toVariantAt @4 D :: V '[A,B,C,B,D,E,D]) == Right D) - , testProperty "popVariant (match)" - (popVariant @D (toVariantAt @6 D :: V '[A,B,C,B,D,E,D]) == Right D) - , testProperty "popVariant (don't match)" - (popVariant @B (toVariantAt @4 D :: V '[A,B,C,B,D,E,D]) == Left (toVariantAt @2 D)) + [ testProperty "get by index (match)" $ fromVariantAt @1 b == Just B + , testProperty "get by index (dont' match)" $ fromVariantAt @0 b == Nothing + , testProperty "pattern V: set" $ (V A :: ABC) == (toVariant A :: ABC) + , testProperty "pattern V: match" $ case (V A :: ABC) of + V (x :: A) -> x == A + V (_ :: B) -> False + V (_ :: C) -> False + _ -> undefined + , testProperty "pattern V: match2" $ case (V B :: ABC) of + V (_ :: A) -> False + V (x :: B) -> x == B + V (_ :: C) -> False + _ -> undefined + , testProperty "pattern V: type application" $ (V @Float 1.0 :: V '[Int,Float,String]) == toVariantAt @1 1.0 + , testProperty "get by type (match)" $ fromVariant (V B :: ABC) == Just B + , testProperty "get by type (don't match)" $ fromVariant @C (V B :: ABC) == Nothing + , testProperty "variant equality (match)" $ b == b + , testProperty "variant equality (don't match)" $ b /= V C + , testProperty "update by index (match)" $ mapVariantAt @1 (const D) b == toVariantAt @1 D + , testProperty "update by index (don't match)" $ mapVariantAt @0 (const F) b == toVariantAt @1 B + , testProperty "update by type (match)" $ mapVariantFirst b2d b == toVariantAt @1 D + , testProperty "update by type (don't match)" $ mapVariantFirst c2d b == V B + , testProperty "update/fold by index (match)" $ foldMapVariantAt @1 b2def b == V E + , testProperty "update/fold by index (don't match)"$ foldMapVariantAt @2 c2def b == V B + , testProperty "Convert into tuple" $ variantToTuple b == (Nothing, Just B, Nothing) + , testProperty "Convert single variant" $ variantToValue (V A :: V '[A]) == A + , testProperty "Lift Either: Left" $ variantFromEither (Left A :: Either A B) == V A + , testProperty "Lift Either: Right" $ variantFromEither (Right B :: Either A B) == V B + , testProperty "To Either: Left" $ variantToEither (V B :: V '[A,B]) == Left B + , testProperty "To Either: Right" $ variantToEither (V A :: V '[A,B]) == Right A + , testProperty "popVariantHead (match)" $ popVariantHead (V A :: ABC) == Right A + , testProperty "popVariantHead (don't match)" $ isLeft (popVariantHead b) + , testProperty "popVariantAt (match)" $ popVariantAt @1 b == Right B + , testProperty "popVariantAt (don't match)" $ isLeft (popVariantAt @2 b) - , testProperty "prependVariant" - (fromVariantAt @4 (prependVariant @'[D,E,F] b) == Just B) - , testProperty "appendVariant" - (fromVariantAt @1 (appendVariant @'[D,E,F] b) == Just B) + , testProperty "popVariant (match)" $ popVariant @D (toVariantAt @4 D :: V '[A,B,C,B,D,E,D]) == Right D + , testProperty "popVariant (match)" $ popVariant @D (toVariantAt @6 D :: V '[A,B,C,B,D,E,D]) == Right D + , testProperty "popVariant (don't match)" $ popVariant @B (toVariantAt @4 D :: V '[A,B,C,B,D,E,D]) == Left (toVariantAt @2 D) - , testProperty "alterVariant" - (alterVariant @Num (+1) (toVariant (1.0 :: Float) :: V '[Int,Float]) == toVariant (2.0 :: Float)) - , testProperty "alterVariant" - (alterVariant @Num (+1) (toVariant (1.0 :: Float) :: V '[Float,Int]) == toVariant (2.0 :: Float)) + , testProperty "prependVariant" $ fromVariantAt @4 (prependVariant @'[D,E,F] b) == Just B + , testProperty "appendVariant" $ fromVariantAt @1 (appendVariant @'[D,E,F] b) == Just B - , testProperty "traverseVariant" - (traverseVariant @OrdNum (\x -> if x > 1 then Just x else Nothing) - (toVariant (2.0 :: Float) :: V '[Float,Int]) == Just (toVariant (2.0 :: Float))) - , testProperty "traverseVariant" - (traverseVariant @OrdNum (\x -> if x > 1 then Just x else Nothing) - (toVariant (0.5 :: Float) :: V '[Float,Int]) == Nothing) + , testProperty "alterVariant" $ alterVariant @Num (+1) (V @Float 1.0 :: V '[Int,Float]) == V @Float 2.0 + , testProperty "alterVariant" $ alterVariant @Num (+1) (V @Float 1.0 :: V '[Float,Int]) == V @Float 2.0 - , testProperty "liftVariant" - (fromVariant (liftVariant b :: V '[D,A,E,B,F,C]) == Just B) + , testProperty "traverseVariant" $ traverseVariant @OrdNum (\x -> if x > 1 then Just x else Nothing) + (V @Float 2.0 :: V '[Float,Int]) == Just (V @Float 2.0) + , testProperty "traverseVariant" $ traverseVariant @OrdNum (\x -> if x > 1 then Just x else Nothing) + (V @Float 0.5 :: V '[Float,Int]) == Nothing + , testProperty "liftVariant" $ fromVariant (liftVariant b :: V '[D,A,E,B,F,C]) == Just B + , testProperty "splitVariant" $ case splitVariant @'[A,C,D] (V A :: V '[A,B,C,D,E,F]) of + Right (x :: V '[A,C,D]) -> x == V A + Left (_ :: V '[B,E,F]) -> True + , testProperty "splitVariant2" $ case splitVariant @'[A,C,D] (V E :: V '[A,B,C,D,E,F]) of + Right (_ :: V '[A,C,D]) -> True + Left (y :: V '[B,E,F]) -> y == V E ] class (Ord a, Num a) => OrdNum a