diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# 0.1.2 + +- Add Data.Bimatchable + # 0.1.1.1 - Initial release. diff --git a/matchable.cabal b/matchable.cabal --- a/matchable.cabal +++ b/matchable.cabal @@ -1,5 +1,5 @@ name: matchable -version: 0.1.1.1 +version: 0.1.2 synopsis: A type class for Matchable Functors. description: This package provides a type class @Matchable@, which represents @zipMatch@ operation which can zip two values if these two have @@ -21,6 +21,7 @@ library hs-source-dirs: src exposed-modules: Data.Matchable + , Data.Bimatchable build-depends: base >=4.10 && <5, containers >=0.5.10.2 && <0.7, tagged >=0.8 && <0.9, @@ -30,25 +31,11 @@ ghc-options: -Wall default-language: Haskell2010 -test-suite my-functors-doctest - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: doctest.hs - build-depends: base >4 && <5, - containers >=0.5.10.2 && <0.7, - tagged >=0.8 && <0.9, - hashable >=1.0.1.1 && <1.3, - unordered-containers >=0.2.6 && <0.3, - vector >=0.10.9.0 && <0.13, - Glob, doctest, doctest-discover - ghc-options: -Wall - default-language: Haskell2010 - test-suite examples type: exitcode-stdio-1.0 hs-source-dirs: test main-is: example.hs - build-depends: base, containers, matchable, hspec + build-depends: base, containers, matchable, hspec, doctest ghc-options: -Wall default-language: Haskell2010 diff --git a/src/Data/Bimatchable.hs b/src/Data/Bimatchable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bimatchable.hs @@ -0,0 +1,124 @@ +module Data.Bimatchable( + Bimatchable(..), + bimapRecovered, + eq2Default, + liftEq2Default +) where + +import Control.Applicative + +import Data.Bifunctor +import Data.Functor.Classes + +import Data.Tagged + +-- | Containers that allows exact structural matching of two containers. +-- +-- @Bimatchable@ is 'Bifunctor'-version of 'Matchable'. +-- It can compare and zip containers with two parameters. +class (Eq2 t, Bifunctor t) => Bimatchable t where + {- | + + 'bizipMatch' is to 'Data.Matchable.zipMatch' what 'bimap' is to 'fmap'. + + Decides if two structures match exactly. If they match, return zipped version of them. + + ==== Law + + Forall @x :: t a b@, @y :: t a' b'@, @z :: t (a,a') (b,b')@, + + > bizipMatch x y = Just z + + holds if and only if both of + + > x = bimap fst fst z + > y = bimap snd snd z + + holds. Otherwise, @bizipMatch x y = Nothing@. + + ==== Example + >>> bizipMatch (Left 1) (Left 'a') + Just (Left (1,'a')) + >>> bizipMatch (Right 1) (Right False) + Just (Right (1,False)) + >>> bizipMatch (Left 1) (Right False) + Nothing + -} + bizipMatch :: t a b -> t a' b' -> Maybe (t (a,a') (b,b')) + bizipMatch = bizipMatchWith (curry Just) (curry Just) + + + {-| + + 'bizipMatchWith' is to 'Data.Matchable.zipMatchWith' what 'bimap' is to 'fmap'. + + Match two structures. If they match, zip them with given functions + @(a -> a' -> Maybe a'')@ and @(b -> b -> Maybe b'')@. + Passed functions can make whole match failby returning @Nothing@. + + ==== Law + + For any + + > x :: t a b + > y :: t a' b' + > f :: a -> a' -> Maybe a'' + > g :: b -> b' -> Maybe b'' + + 'bizipMatchWith' must satisfy the following. + + - If there is a pair @(z :: t (a,a') (b,b'), w :: t a'' b'')@ such that + fulfills all of the following three conditions, then + @bizipMatchWith f g x y = Just w@. + + 1. @x = bimap fst fst z@ + 2. @y = bimap snd snd z@ + 3. @bimap (uncurry f) (uncurry g) z = bimap Just Just w@ + + - If there are no such pair, @bizipMatchWith f g x y = Nothing@. + + -} + bizipMatchWith :: (a -> a' -> Maybe a'') + -> (b -> b' -> Maybe b'') + -> t a b -> t a' b' -> Maybe (t a'' b'') + + {-# MINIMAL bizipMatchWith #-} + +instance Bimatchable Either where + bizipMatchWith u _ (Left a) (Left a') = Left <$> u a a' + bizipMatchWith _ v (Right b) (Right b') = Right <$> v b b' + bizipMatchWith _ _ _ _ = Nothing + +instance Bimatchable (,) where + bizipMatch (a, b) (a', b') = Just ((a, a'), (b, b')) + bizipMatchWith u v (a, b) (a', b') = (,) <$> u a a' <*> v b b' + +instance Bimatchable Const where + bizipMatch (Const a) (Const a') = Just (Const (a, a')) + bizipMatchWith u _ (Const a) (Const a') = Const <$> u a a' + +instance Bimatchable Tagged where + bizipMatch (Tagged b) (Tagged b') = Just (Tagged (b, b')) + bizipMatchWith _ v (Tagged b) (Tagged b') = Tagged <$> v b b' + +bimapRecovered :: (Bimatchable t) + => (a -> a') -> (b -> b') -> t a b -> t a' b' +bimapRecovered f g tab = + case bizipMatchWith (const (Just . f)) (const (Just . g)) tab tab of + Nothing -> error "bimapRecovered: Unlawful instance of Bimatchable" + Just r -> r + +eq2Default :: (Bimatchable t, Eq a, Eq b) + => t a b -> t a b -> Bool +eq2Default = liftEq2Default (==) (==) + +liftEq2Default :: (Bimatchable t) + => (a -> a' -> Bool) + -> (b -> b' -> Bool) + -> t a b -> t a' b' -> Bool +liftEq2Default pa pb tab tab' = + case bizipMatchWith u v tab tab' of + Nothing -> False + Just _ -> True + where u a a' = if pa a a' then Just () else Nothing + v b b' = if pb b b' then Just () else Nothing diff --git a/test/doctest.hs b/test/doctest.hs deleted file mode 100644 --- a/test/doctest.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Main where - -import System.FilePath.Glob (glob) -import Test.DocTest (doctest) - -main :: IO () -main = do - glob "src/**/*.hs" >>= doctest diff --git a/test/example.hs b/test/example.hs --- a/test/example.hs +++ b/test/example.hs @@ -2,14 +2,17 @@ {-# LANGUAGE DeriveGeneric #-} module Main(main) where +import Data.Bifunctor +import Data.Bimatchable +import Data.Functor.Classes import Data.Matchable -import qualified Data.Map as Map -import GHC.Generics(Generic1) -import Data.Functor.Classes +import qualified Data.Map as Map -import Test.Hspec +import GHC.Generics (Generic1) +import Test.Hspec + main :: IO () main = hspec $ do context "Matchable []" $ do @@ -38,6 +41,13 @@ zipMatch either3 either3 `shouldBe` Just (Left "foo") specify "zipMatch either3 either4 = Nothing" $ zipMatch either3 either4 `shouldBe` Nothing + context "Bimatchable Either" $ do + specify "bizipMatch either1 either2 = Just (Right (1,2))" $ + bizipMatch either1 either2 `shouldBe` Just (Right (1,2)) + specify "bizipMatch either1 either3 = Nothing" $ + bizipMatch either1 either3 `shouldBe` Nothing + specify "bizipMatch either3 either4 = Just (Left (\"foo\", \"bar\"))" $ + bizipMatch either3 either4 `shouldBe` Just (Left ("foo", "bar")) context "Matchable ((,) Char)" $ do runIO $ do p $ "pair1 = " ++ show pair1 @@ -50,6 +60,9 @@ zipMatch pair3 pair4 `shouldBe` Just ('b', (3,4)) specify "zipMatch pair1 pair3 = Nothing" $ zipMatch pair1 pair3 `shouldBe` Nothing + context "Bimatchable (,)" $ do + specify "bizipMatch pair1 pair3 = Just (('a','b'),(1,3))" $ + bizipMatch pair1 pair3 `shouldBe` Just (('a','b'),(1,3)) context "Matchable (Map Char)" $ do runIO $ do p $ "map1 = " ++ show map1 @@ -71,6 +84,11 @@ zipMatch myTree1 myTree3 `shouldBe` Nothing specify "zipMatch myTree1 myTree4 = Nothing" $ zipMatch myTree1 myTree4 `shouldBe` Nothing + context "Bimatchable MyTree" $ do + specify "bizipMatch myTree1 myTree3 = Just _" $ + bizipMatch myTree1 myTree3 `shouldBe` Just (Node (0,3) ("foo",True) Empty (Node (1,4) ("bar", False) Empty Empty)) + specify "bizipMatch myTree1 myTree4 = Nothing" $ + bizipMatch myTree1 myTree4 `shouldBe` Nothing where p = putStrLn list1, list2, list3, list4 :: [Int] @@ -116,3 +134,21 @@ myTree4 :: MyTree Int Char myTree4 = Node 0 'a' Empty Empty + + +instance Bifunctor MyTree where + bimap _ _ Empty = Empty + bimap f g (Node k a l r) = Node (f k) (g a) (bimap f g l) (bimap f g r) + +instance Eq2 MyTree where + liftEq2 = liftEq2Default + +instance Bimatchable MyTree where + bizipMatchWith _ _ Empty Empty = Just Empty + bizipMatchWith f g (Node k a l r) (Node k' a' l' r') = + Node <$> f k k' + <*> g a a' + <*> bizipMatchWith f g l l' + <*> bizipMatchWith f g r r' + bizipMatchWith _ _ _ _ = Nothing +