diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -14,12 +14,18 @@ # Changelog +* 1.1.0.0 + - Added `CaseFunc` and `CaseFunc'` which replaces `CaseTypeable` (eg `CaseFunc @Typeable`) + + - Replaced `IsAll` constraint with `AllConstrained`. + * 1.0.0.1 - Added `CaseTypeable'` as an example of polymorphic `Case` that doesn't change the type. * 1.0.0.0 - The exposed api shouldn't break, but there are a lot of internal changes. - - Added `AFunctor` which can map over the types in the 'Many' . + - Added `AFunctor` which can map over the types in the 'Many' + . - Added friendlier type synomyns `Collect` and `CollectN` for `collect` and `collectN` - Expose type of 'Collector' and 'CollectorN' - Replace type parameter `r` from `Case` typeclass with `CaseResult` type family. @@ -28,7 +34,8 @@ - All `CaseXxxN` type variables now end with r n xs. * 0.11.0.0 - - Added `impossible` modelled after `Data.Void.absurd` + - Added `impossible` modelled after `Data.Void.absurd` + - Removed `zilch` so `Which '[]` is uninhabited like `Data.Void.Void`, making 'impossible' safe to use. - Removed `Monoid` and changed `Show`, `Read` and `Generic` instances for `Which '[]` to be partial just like Data.Void.Void. diff --git a/data-diverse.cabal b/data-diverse.cabal --- a/data-diverse.cabal +++ b/data-diverse.cabal @@ -1,5 +1,5 @@ name: data-diverse -version: 1.0.0.1 +version: 1.1.0.0 synopsis: Extensible records and polymorphic variants. description: "Data.Diverse.Many" is an extensible record for any size encoded efficiently as (Seq Any). "Data.Diverse.Which" is a polymorphic variant of possibilities encoded as (Int, Any). @@ -28,8 +28,8 @@ Data.Diverse.AFoldable Data.Diverse.AFunctor Data.Diverse.Case + Data.Diverse.CaseFunc Data.Diverse.Cases - Data.Diverse.CaseTypeable Data.Diverse.Many Data.Diverse.Many.Internal Data.Diverse.Reduce diff --git a/src/Data/Diverse.hs b/src/Data/Diverse.hs --- a/src/Data/Diverse.hs +++ b/src/Data/Diverse.hs @@ -3,7 +3,7 @@ , module Data.Diverse.AFunctor , module Data.Diverse.Case , module Data.Diverse.Cases - , module Data.Diverse.CaseTypeable + , module Data.Diverse.CaseFunc , module Data.Diverse.Many , module Data.Diverse.Reduce , module Data.Diverse.Reiterate @@ -15,7 +15,7 @@ import Data.Diverse.AFunctor import Data.Diverse.Case import Data.Diverse.Cases -import Data.Diverse.CaseTypeable +import Data.Diverse.CaseFunc import Data.Diverse.Many import Data.Diverse.Reduce import Data.Diverse.Reiterate diff --git a/src/Data/Diverse/Case.hs b/src/Data/Diverse/Case.hs --- a/src/Data/Diverse/Case.hs +++ b/src/Data/Diverse/Case.hs @@ -13,7 +13,7 @@ -- In conjunction with 'Data.Diverse.Reiterate.Reiterate', you can define handlers that can handle all -- the types in the @xs@ typelist. -- --- See "Data.Diverse.CaseTypeable" and "Data.Diverse.Cases". +-- See "Data.Diverse.CaseFunc" and "Data.Diverse.Cases". class Case c (xs :: [Type]) where -- | Return the handler/continuation when x is observed. case' :: c xs -> Head xs -> CaseResult c (Head xs) diff --git a/src/Data/Diverse/CaseFunc.hs b/src/Data/Diverse/CaseFunc.hs new file mode 100644 --- /dev/null +++ b/src/Data/Diverse/CaseFunc.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Diverse.CaseFunc where + +import Data.Diverse.Case +import Data.Diverse.Reiterate +import Data.Diverse.TypeLevel +import Data.Kind + +-- | This handler stores a polymorphic function that returns a different type. +-- +-- @ +-- let y = 'Data.Diverse.Which.pick' (5 :: Int) :: 'Data.Diverse.Which.Which' '[Int, Bool] +-- 'Data.Diverse.Which.switch' y ('CaseFunc' \@'Data.Typeable.Typeable' (show . typeRep . (pure \@Proxy))) \`shouldBe` "Int" +-- @ +-- +-- @ +-- let x = (5 :: Int) 'Data.Diverse.Many../' False 'Data.Diverse.Many../' \'X' 'Data.Diverse.Many../' Just \'O' 'Data.Diverse.Many../' (6 :: Int) 'Data.Diverse.Many../' Just \'A' 'Data.Diverse.Many../' 'Data.Diverse.Many.nul' +-- 'Data.Diverse.AFoldable.afoldr' (:) [] ('Data.Diverse.Many.forMany' ('CaseFunc' \@'Data.Typeable.Typeable' (show . typeRep . (pure @Proxy))) x) \`shouldBe` +-- [\"Int", \"Bool", \"Char", \"Maybe Char", \"Int", \"Maybe Char"] +-- @ +newtype CaseFunc (k :: Type -> Constraint) r (xs :: [Type]) = CaseFunc (forall x. k x => x -> r) +-- This was made possible by Syrak +-- https://www.reddit.com/r/haskell/comments/75zrci/help_how_to_pass_constraints_as_a_type_variable/ + +type instance CaseResult (CaseFunc k r) x = r + +instance Reiterate (CaseFunc k r) xs where + reiterate (CaseFunc f) = CaseFunc f + +instance k x => Case (CaseFunc k r) (x ': xs) where + case' (CaseFunc f) = f + +-- | This handler stores a polymorphic function that doesn't change the type. +-- +-- @ +-- let x = (5 :: Int) 'Data.Diverse.Many../' (6 :: Int8) 'Data.Diverse.Many../' (7 :: Int16) 'Data.Diverse.Many../' (8 :: Int32) 'Data.Diverse.Many../' 'Data.Diverse.Many.nil' +-- y = (15 :: Int) 'Data.Diverse.Many../' (16 :: Int8) 'Data.Diverse.Many../' (17 :: Int16) 'Data.Diverse.Many../' (18 :: Int32) 'Data.Diverse.Many../' 'Data.Diverse.Many.nil' +-- 'Data.Diverse.AFunctor.afmap' ('CaseFunc'' \@'Num' (+10)) x \`shouldBe` y +-- @ +newtype CaseFunc' (k :: Type -> Constraint) (xs :: [Type]) = CaseFunc' (forall x. k x => x -> x) + +type instance CaseResult (CaseFunc' k) x = x + +instance Reiterate (CaseFunc' k) xs where + reiterate (CaseFunc' f) = CaseFunc' f + +instance k x => Case (CaseFunc' k) (x ': xs) where + case' (CaseFunc' f) = f diff --git a/src/Data/Diverse/CaseTypeable.hs b/src/Data/Diverse/CaseTypeable.hs deleted file mode 100644 --- a/src/Data/Diverse/CaseTypeable.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} - -module Data.Diverse.CaseTypeable where - -import Data.Diverse.Case -import Data.Diverse.Reiterate -import Data.Diverse.TypeLevel -import Data.Kind -import Data.Typeable - --- | This handler stores a polymorphic function for all Typeables. --- This is an example of how to define and instance of 'Case' for --- polymorphic function into a specified result type. --- --- @ --- let y = 'Data.Diverse.Which.pick' (5 :: Int) :: 'Data.Diverse.Which.Which' '[Int, Bool] --- 'Data.Diverse.Which.switch' y ('CaseTypeable' (show . typeRep . (pure \@Proxy))) \`shouldBe` "Int" --- @ --- --- @ --- let x = (5 :: Int) 'Data.Diverse.Many../' False 'Data.Diverse.Many../' \'X' 'Data.Diverse.Many../' Just \'O' 'Data.Diverse.Many../' (6 :: Int) 'Data.Diverse.Many../' Just \'A' 'Data.Diverse.Many../' 'Data.Diverse.Many.nul' --- 'Data.Diverse.AFoldable.afoldr' (:) [] ('Data.Diverse.Many.forMany' ('CaseTypeable' (show . typeRep . (pure @Proxy))) x) \`shouldBe` --- [\"Int", \"Bool", \"Char", \"Maybe Char", \"Int", \"Maybe Char"] --- @ -newtype CaseTypeable r (xs :: [Type]) = CaseTypeable (forall x. Typeable x => x -> r) - -type instance CaseResult (CaseTypeable r) x = r - -instance Reiterate (CaseTypeable r) xs where - reiterate (CaseTypeable f) = CaseTypeable f - -instance Typeable x => Case (CaseTypeable r) (x ': xs) where - case' (CaseTypeable f) = f - - --- | This handler stores a polymorphic function for all Typeables. --- This is an example of how to define and instance of 'Case' for --- polymorphic function that doesn't change the type -newtype CaseTypeable' (xs :: [Type]) = CaseTypeable' (forall x. Typeable x => x -> x) - -type instance CaseResult CaseTypeable' x = x - -instance Reiterate CaseTypeable' xs where - reiterate (CaseTypeable' f) = CaseTypeable' f - -instance Typeable x => Case CaseTypeable' (x ': xs) where - case' (CaseTypeable' f) = f diff --git a/src/Data/Diverse/Cases.hs b/src/Data/Diverse/Cases.hs --- a/src/Data/Diverse/Cases.hs +++ b/src/Data/Diverse/Cases.hs @@ -68,14 +68,14 @@ -- However, the 'Cases' constructor is still exported to allow creating a master-of-all-'Case'. cases :: forall r xs fs. - (IsAll r (CaseResults (Cases fs r) fs), SameLength fs (Nub xs)) + (AllConstrained ((~) r) (CaseResults (Cases fs r) fs), SameLength fs (Nub xs)) => Many fs -> Cases fs r xs cases = Cases -- | A variation of 'cases' without the @SameLength@ constraint to allow creating a master-of-all-'Case'. cases' :: forall r xs fs. - (IsAll r (CaseResults (Cases fs r) fs)) + (AllConstrained ((~) r) (CaseResults (Cases fs r) fs)) => Many fs -> Cases fs r xs cases' = Cases @@ -126,13 +126,13 @@ -- @ casesN :: forall r xs fs. - (IsAll r (CaseResults (CasesN fs r 0) fs), SameLength fs xs) + (AllConstrained ((~) r) (CaseResults (CasesN fs r 0) fs), SameLength fs xs) => Many fs -> CasesN fs r 0 xs casesN = CasesN -- | A variation of 'casesN' without the @SameLength@ constraint to allow creating a master-of-all-'Case'. casesN' :: forall r xs fs. - (IsAll r (CaseResults (CasesN fs r 0) fs)) + (AllConstrained ((~) r) (CaseResults (CasesN fs r 0) fs)) => Many fs -> CasesN fs r 0 xs casesN' = CasesN diff --git a/src/Data/Diverse/TypeLevel.hs b/src/Data/Diverse/TypeLevel.hs --- a/src/Data/Diverse/TypeLevel.hs +++ b/src/Data/Diverse/TypeLevel.hs @@ -164,12 +164,16 @@ -- | Takes two lists which must be the same length and returns a list of corresponding pairs. type Zip (xs :: [k]) (ys :: [k]) = ZipImpl xs ys xs ys --- | Tests if all the types in a typelist is all a specified type. -type IsAll (x :: k) (xs :: [k]) = IsAllImpl xs x xs - +-- | The result from evaluating a 'Case' with a type from a typelist. type family CaseResult (c ::[k1] -> k2) (x :: k1) :: k2 -- | Return a list of results from applying 'CaseResult' to every type in the @xs@ typelist. type family CaseResults (c ::[k1] -> k2) (xs :: [k1]) :: [k2] where CaseResults c '[] = '[] CaseResults c (x ': xs) = CaseResult c x ': CaseResults c xs + +-- | Tests if all the types in a typelist satisfy a constraint +type family AllConstrained (c :: k -> Constraint) (xs :: [k]) :: Constraint where + AllConstrained c '[] = () + AllConstrained c (x ': xs) = (c x, AllConstrained c xs) +-- https://hackage.haskell.org/package/vinyl-0.6.0/docs/Data-Vinyl-TypeLevel.html#t:AllConstrained diff --git a/src/Data/Diverse/TypeLevel/Internal.hs b/src/Data/Diverse/TypeLevel/Internal.hs --- a/src/Data/Diverse/TypeLevel/Internal.hs +++ b/src/Data/Diverse/TypeLevel/Internal.hs @@ -192,14 +192,3 @@ ':<>: 'Text "‘" ':<>: 'ShowType ys' ':<>: 'Text "’") - --- | Tests if all the types in a typelist is all a specified type. -type family IsAllImpl (ctx :: [k]) (x :: k) (xs :: [k]) :: Constraint where - IsAllImpl ctx x '[] = () - IsAllImpl ctx x (x ': xs) = IsAllImpl ctx x xs - IsAllImpl ctx x xs = TypeError ('Text "IsAll error: ‘" - ':<>: 'ShowType ctx - ':<>: 'Text "’" - ':<>: 'Text " must only contain ‘" - ':<>: 'ShowType x - ':<>: 'Text "’") diff --git a/src/Data/Diverse/Which/Internal.hs b/src/Data/Diverse/Which/Internal.hs --- a/src/Data/Diverse/Which/Internal.hs +++ b/src/Data/Diverse/Which/Internal.hs @@ -379,7 +379,7 @@ -- let y = 'pickOnly' (5 :: Tagged Bar Int) -- y' = 'diversifyL' \@'[Bar] Proxy y :: 'Which' '[Tagged Bar Int, Tagged Foo Bool] -- y'' = 'diversifyL' \@'[Bar, Foo] Proxy y' :: 'Which' '[Tagged Foo Bool, Tagged Bar Int] --- 'switch' y'' ('Data.Diverse.CaseTypeable.CaseTypeable' (show . typeRep . (pure \@Proxy))) \`shouldBe` \"Tagged * Bar Int" +-- 'switch' y'' ('Data.Diverse.CaseFunc.CaseFunc' \@'Data.Typeable.Typeable' (show . typeRep . (pure \@Proxy))) \`shouldBe` \"Tagged * Bar Int" -- @ diversifyL :: forall ls branch tree proxy. @@ -411,7 +411,7 @@ -- let y = 'pickOnly' (5 :: Int) -- y' = 'diversifyN' \@'[0] \@_ \@[Int, Bool] Proxy y -- y'' = 'diversifyN' \@[1,0] \@_ \@[Bool, Int] Proxy y' --- 'switch' y'' ('Data.Diverse.CaseTypeable.CaseTypeable' (show . typeRep . (pure \@Proxy))) \`shouldBe` \"Int" +-- 'switch' y'' ('Data.Diverse.CaseFunc.CaseFunc' \@'Data.Typeable.Typeable' (show . typeRep . (pure \@Proxy))) \`shouldBe` \"Int" -- @ diversifyN :: forall indices branch tree proxy. (DiversifyN indices branch tree) => proxy indices -> Which branch -> Which tree diversifyN _ = whichN (CaseDiversifyN @indices @_ @0 @branch) @@ -627,11 +627,11 @@ -- 'Data.Diverse.Many../' 'Data.Diverse.Many.nil')) \`shouldBe` "5" -- @ -- --- Or 'Data.Diverse.CaseTypeable.CaseTypeable' to apply a polymorphic function that work on all 'Typeables'. +-- Or 'Data.Diverse.CaseFunc.CaseFunc' \@'Data.Typeable.Typeable' to apply a polymorphic function that work on all 'Typeable's. -- -- @ -- let y = 'Data.Diverse.Which.pick' (5 :: Int) :: 'Data.Diverse.Which.Which' '[Int, Bool] --- 'Data.Diverse.Which.switch' y ('CaseTypeable' (show . typeRep . (pure \@Proxy))) \`shouldBe` "Int" +-- 'Data.Diverse.Which.switch' y ('Data.Diverse.CaseFunc.CaseFunc' \@'Data.Typeable.Typeable' (show . typeRep . (pure \@Proxy))) \`shouldBe` "Int" -- @ -- -- Or you may use your own custom instance of 'Case'. diff --git a/test/Data/Diverse/ManySpec.hs b/test/Data/Diverse/ManySpec.hs --- a/test/Data/Diverse/ManySpec.hs +++ b/test/Data/Diverse/ManySpec.hs @@ -12,7 +12,6 @@ import Data.Diverse import Data.Int -import Data.Kind import Data.Tagged import Data.Typeable import Test.Hspec @@ -25,32 +24,6 @@ -------------------------------- --- | Create an instance of 'Case' that can handle all 'Num' -newtype CaseNum' (xs :: [Type]) = CaseNum' (forall x. Num x => x -> x) - -type instance CaseResult CaseNum' x = x - -instance Reiterate CaseNum' (x ': xs) where - reiterate (CaseNum' f) = CaseNum' f - -instance Num x => Case CaseNum' (x ': xs) where - case' (CaseNum' f) = f - --------------------------------- - --- | Create an instance of 'Case' that can handle all 'Show' and convert to a specified type -newtype CaseShow r (xs :: [Type]) = CaseShow (forall x. Show x => x -> r) - -type instance CaseResult (CaseShow r) x = r - -instance Reiterate (CaseShow r) (x ': xs) where - reiterate (CaseShow f) = CaseShow f - -instance Show x => Case (CaseShow r) (x ': xs) where - case' (CaseShow f) = f - --------------------------------- - data Foo data Bar @@ -332,9 +305,9 @@ afoldr (:) [] (forMany (cases y) x) `shouldBe` ret afoldr (:) [] (forMany (cases y) x) `shouldBe` ret - it "can be folded with single 'CaseTypeable' handlers using 'forMany' or 'collect'" $ do + it "can be folded with polymorphic 'CaseFunc' handlers using 'forMany' or 'collect'" $ do let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil - afoldr (:) [] (forMany (CaseTypeable (show . typeRep . (pure @Proxy))) x) `shouldBe` ["Int", "Bool", "Char", "Maybe Char", "Int", "Maybe Char"] + afoldr (:) [] (forMany (CaseFunc @Typeable (show . typeRep . (pure @Proxy))) x) `shouldBe` ["Int", "Bool", "Char", "Maybe Char", "Int", "Maybe Char"] it "can be folded with 'Many' handlers in index order using 'forManyN' or 'collectN'" $ do let x = (5 :: Int) ./ False ./ 'X' ./ Just 'O' ./ (6 :: Int) ./ Just 'A' ./ nil @@ -347,5 +320,5 @@ let x = (5 :: Int) ./ (6 :: Int8) ./ (7 :: Int16) ./ (8 :: Int32) ./ nil y = (15 :: Int) ./ (16 :: Int8) ./ (17 :: Int16) ./ (18 :: Int32) ./ nil z = ("5" :: String) ./ ("6" :: String) ./ ("7" :: String) ./ ("8" :: String) ./ nil - afmap (CaseNum' (+10)) x `shouldBe` y - afmap (CaseShow show) x `shouldBe` z + afmap (CaseFunc' @Num (+10)) x `shouldBe` y + afmap (CaseFunc @Show @String show) x `shouldBe` z diff --git a/test/Data/Diverse/WhichSpec.hs b/test/Data/Diverse/WhichSpec.hs --- a/test/Data/Diverse/WhichSpec.hs +++ b/test/Data/Diverse/WhichSpec.hs @@ -133,19 +133,19 @@ let y = pickOnly (5 :: Int) y' = diversify @_ @[Int, Bool] y y'' = diversify @_ @[Bool, Int] y' - switch y'' (CaseTypeable (show . typeRep . (pure @Proxy))) `shouldBe` "Int" + switch y'' (CaseFunc @Typeable (show . typeRep . (pure @Proxy))) `shouldBe` "Int" it "can be extended and rearranged by type with 'diversify'" $ do let y = pickOnly (5 :: Tagged Bar Int) y' = diversifyL @'[Bar] Proxy y :: Which '[Tagged Bar Int, Tagged Foo Bool] y'' = diversifyL @'[Bar, Foo] Proxy y' :: Which '[Tagged Foo Bool, Tagged Bar Int] - switch y'' (CaseTypeable (show . typeRep . (pure @Proxy))) `shouldBe` "Tagged * Bar Int" + switch y'' (CaseFunc @Typeable (show . typeRep . (pure @Proxy))) `shouldBe` "Tagged * Bar Int" it "can be extended and rearranged by index with 'diversifyN'" $ do let y = pickOnly (5 :: Int) y' = diversifyN @'[0] @_ @[Int, Bool] Proxy y y'' = diversifyN @[1,0] @_ @[Bool, Int] Proxy y' - switch y'' (CaseTypeable (show . typeRep . (pure @Proxy))) `shouldBe` "Int" + switch y'' (CaseFunc @Typeable (show . typeRep . (pure @Proxy))) `shouldBe` "Int" it "the 'diversify'ed type can contain multiple fields if they aren't in the original 'Many'" $ do let y = pick @_ @[Int, Char] (5 :: Int) @@ -229,9 +229,9 @@ ./ show @Int ./ nil)) `shouldBe` "5" - it "can be switched with a single 'CaseTypeable' handler" $ do + it "can be switched with a polymorphic 'CaseFunc' handler" $ do let y = pick (5 :: Int) :: Which '[Int, Bool] - switch y (CaseTypeable (show . typeRep . (pure @Proxy))) `shouldBe` "Int" + switch y (CaseFunc @Typeable (show . typeRep . (pure @Proxy))) `shouldBe` "Int" #if __GLASGOW_HASKELL__ >= 802 let expected = "Which (': * Int (': * Bool ('[] *)))" #else