matchable 0.1.1.1 → 0.1.2
raw patch · 5 files changed
+171/−28 lines, 5 filesdep −Globdep −doctest-discoverdep ~basedep ~containersdep ~hashable
Dependencies removed: Glob, doctest-discover
Dependency ranges changed: base, containers, hashable
Files
- CHANGELOG.md +4/−0
- matchable.cabal +3/−16
- src/Data/Bimatchable.hs +124/−0
- test/doctest.hs +0/−8
- test/example.hs +40/−4
CHANGELOG.md view
@@ -1,3 +1,7 @@+# 0.1.2++- Add Data.Bimatchable+ # 0.1.1.1 - Initial release.
matchable.cabal view
@@ -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
+ src/Data/Bimatchable.hs view
@@ -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
− test/doctest.hs
@@ -1,8 +0,0 @@-module Main where--import System.FilePath.Glob (glob)-import Test.DocTest (doctest)--main :: IO ()-main = do- glob "src/**/*.hs" >>= doctest
test/example.hs view
@@ -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+